let rec expr =
function
| Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->
mkexp loc
(Pexp_apply ((mkexp loc (Pexp_ident (Lident "!"))),
[ ("", (expr x)) ]))
| (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as
e) ->
let (e, l) =
(match sep_expr_acc [] e with
| (loc, ml, Ast.ExId (_, (Ast.IdUid (_, s)))) :: l ->
let ca = constructors_arity ()
in
((mkexp loc
(Pexp_construct ((mkli (conv_con s) ml), None,
ca))),
l)
| (loc, ml, Ast.ExId (_, (Ast.IdLid (_, s)))) :: l ->
((mkexp loc (Pexp_ident (mkli s ml))), l)
| (_, [], e) :: l -> ((expr e), l)
| _ -> error loc "bad ast in expression") in
let (_, e) =
List.fold_left
(fun (loc_bp, e1) (loc_ep, ml, e2) ->
match e2 with
| Ast.ExId (_, (Ast.IdLid (_, s))) ->
let loc = Loc.merge loc_bp loc_ep
in
(loc,
(mkexp loc
(Pexp_field (e1, (mkli (conv_lab s) ml)))))
| _ ->
error (loc_of_expr e2)
"lowercase identifier expected")
(loc, e) l
in e
| ExAnt (loc, _) -> error loc "antiquotation not allowed here"
| (ExApp (loc, _, _) as f) ->
let (f, al) = expr_fa [] f in
let al = List.map label_expr al
in
(match (expr f).pexp_desc with
| Pexp_construct (li, None, _) ->
let al = List.map snd al
in
if constructors_arity ()
then
mkexp loc
(Pexp_construct (li,
(Some (mkexp loc (Pexp_tuple al))), true))
else
(let a =
match al with
| [ a ] -> a
| _ -> mkexp loc (Pexp_tuple al)
in
mkexp loc
(Pexp_construct (li, (Some a), false)))
| Pexp_variant (s, None) ->
let al = List.map snd al in
let a =
if constructors_arity ()
then mkexp loc (Pexp_tuple al)
else
(match al with
| [ a ] -> a
| _ -> mkexp loc (Pexp_tuple al))
in mkexp loc (Pexp_variant (s, (Some a)))
| _ -> mkexp loc (Pexp_apply ((expr f), al)))
| ExAre (loc, e1, e2) ->
mkexp loc
(Pexp_apply
((mkexp loc
(Pexp_ident (array_function "Array" "get"))),
[ ("", (expr e1)); ("", (expr e2)) ]))
| ExArr (loc, e) ->
mkexp loc (Pexp_array (List.map expr (list_of_expr e [])))
| ExAsf loc -> mkexp loc Pexp_assertfalse
| ExAss (loc, e, v) ->
let e =
(match e with
| Ast.ExAcc (loc, x,
(Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->
Pexp_apply ((mkexp loc (Pexp_ident (Lident ":="))),
[ ("", (expr x)); ("", (expr v)) ])
| ExAcc (loc, _, _) ->
(match (expr e).pexp_desc with
| Pexp_field (e, lab) ->
Pexp_setfield (e, lab, (expr v))
| _ -> error loc "bad record access")
| ExAre (_, e1, e2) ->
Pexp_apply
((mkexp loc
(Pexp_ident (array_function "Array" "set"))),
[ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ])
| Ast.ExId (_, (Ast.IdLid (_, lab))) ->
Pexp_setinstvar (lab, (expr v))
| ExSte (_, e1, e2) ->
Pexp_apply
((mkexp loc
(Pexp_ident (array_function "String" "set"))),
[ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ])
| _ -> error loc "bad left part of assignment")
in mkexp loc e
| ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e))
| ExChr (loc, s) ->
mkexp loc
(Pexp_constant (Const_char (char_of_char_token loc s)))
| ExCoe (loc, e, t1, t2) ->
let t1 =
(match t1 with | Ast.TyNil _ -> None | t -> Some (ctyp t))
in
mkexp loc
(Pexp_constraint ((expr e), t1, (Some (ctyp t2))))
| ExFlo (loc, s) ->
mkexp loc
(Pexp_constant (Const_float (remove_underscores s)))
| ExFor (loc, i, e1, e2, df, el) ->
let e3 = ExSeq (loc, el)
in
mkexp loc
(Pexp_for (i, (expr e1), (expr e2), (mkdirection df),
(expr e3)))
| Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e)))
->
mkexp loc
(Pexp_function (lab, None,
[ ((patt_of_lab loc lab po), (when_expr e w)) ]))
| Ast.ExFun (loc,
(Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) ->
let lab = paolab lab p
in
mkexp loc
(Pexp_function (("?" ^ lab), (Some (expr e1)),
[ ((patt p), (when_expr e2 w)) ]))
| Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e)))
->
let lab = paolab lab p
in
mkexp loc
(Pexp_function (("?" ^ lab), None,
[ ((patt_of_lab loc lab p), (when_expr e w)) ]))
| ExFun (loc, a) ->
mkexp loc (Pexp_function ("", None, (match_case a [])))
| ExIfe (loc, e1, e2, e3) ->
mkexp loc
(Pexp_ifthenelse ((expr e1), (expr e2), (Some (expr e3))))
| ExInt (loc, s) ->
let i =
(try int_of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int")
in mkexp loc (Pexp_constant (Const_int i))
| ExInt32 (loc, s) ->
let i32 =
(try Int32.of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int32")
in mkexp loc (Pexp_constant (Const_int32 i32))
| ExInt64 (loc, s) ->
let i64 =
(try Int64.of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int64")
in mkexp loc (Pexp_constant (Const_int64 i64))
| ExNativeInt (loc, s) ->
let nati =
(try Nativeint.of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type nativeint")
in mkexp loc (Pexp_constant (Const_nativeint nati))
| ExLab (loc, _, _) ->
error loc "labeled expression not allowed here"
| ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e))
| ExLet (loc, rf, bi, e) ->
mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e)))
| ExLmd (loc, i, me, e) ->
mkexp loc (Pexp_letmodule (i, (module_expr me), (expr e)))
| ExMat (loc, e, a) ->
mkexp loc (Pexp_match ((expr e), (match_case a [])))
| ExNew (loc, id) -> mkexp loc (Pexp_new (long_type_ident id))
| ExObj (loc, po, cfl) ->
let p =
(match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in
let cil = class_str_item cfl []
in mkexp loc (Pexp_object (((patt p), cil)))
| ExOlb (loc, _, _) ->
error loc "labeled expression not allowed here"
| ExOvr (loc, iel) ->
mkexp loc (Pexp_override (mkideexp iel []))
| ExRec (loc, lel, eo) ->
(match lel with
| Ast.RbNil _ -> error loc "empty record"
| _ ->
let eo =
(match eo with
| Ast.ExNil _ -> None
| e -> Some (expr e))
in mkexp loc (Pexp_record ((mklabexp lel []), eo)))
| ExSeq (_loc, e) ->
let rec loop =
(function
| [] -> expr (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))
| [ e ] -> expr e
| e :: el ->
let _loc = Loc.merge (loc_of_expr e) _loc
in mkexp _loc (Pexp_sequence ((expr e), (loop el))))
in loop (list_of_expr e [])
| ExSnd (loc, e, s) -> mkexp loc (Pexp_send ((expr e), s))
| ExSte (loc, e1, e2) ->
mkexp loc
(Pexp_apply
((mkexp loc
(Pexp_ident (array_function "String" "get"))),
[ ("", (expr e1)); ("", (expr e2)) ]))
| ExStr (loc, s) ->
mkexp loc
(Pexp_constant
(Const_string (string_of_string_token loc s)))
| ExTry (loc, e, a) ->
mkexp loc (Pexp_try ((expr e), (match_case a [])))
| Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) ->
mkexp loc
(Pexp_tuple
(List.map expr (list_of_expr e1 (list_of_expr e2 []))))
| Ast.ExTup (loc, _) -> error loc "singleton tuple"
| ExTyc (loc, e, t) ->
mkexp loc
(Pexp_constraint ((expr e), (Some (ctyp t)), None))
| Ast.ExId (loc, (Ast.IdUid (_, "()"))) ->
mkexp loc (Pexp_construct ((lident "()"), None, true))
| Ast.ExId (loc, (Ast.IdLid (_, s))) ->
mkexp loc (Pexp_ident (lident s))
| Ast.ExId (loc, (Ast.IdUid (_, s))) ->
mkexp loc
(Pexp_construct ((lident (conv_con s)), None, true))
| ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None))
| ExWhi (loc, e1, el) ->
let e2 = ExSeq (loc, el)
in mkexp loc (Pexp_while ((expr e1), (expr e2)))
| Ast.ExOpI (loc, i, e) ->
mkexp loc (Pexp_open ((long_uident i), (expr e)))
| Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) ->
mkexp loc (Pexp_pack ((module_expr me), (package_type pt)))
| Ast.ExPkg (loc, _) ->
error loc "(module_expr : package_type) expected here"
| ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e)))
| Ast.ExCom (loc, _, _) ->
error loc "expr, expr: not allowed here"
| Ast.ExSem (loc, _, _) ->
error loc
"expr; expr: not allowed here, use do {...} or [|...|] to surround them"
| (ExId (_, _) | ExNil _ as e) ->
error (loc_of_expr e) "invalid expr"
and patt_of_lab _loc lab =
function
| Ast.PaNil _ ->
patt (Ast.PaId (_loc, (Ast.IdLid (_loc, lab))))
| p -> patt p
and expr_of_lab _loc lab =
function
| Ast.ExNil _ ->
expr (Ast.ExId (_loc, (Ast.IdLid (_loc, lab))))
| e -> expr e
and label_expr =
function
| ExLab (loc, lab, eo) -> (lab, (expr_of_lab loc lab eo))
| ExOlb (loc, lab, eo) ->
(("?" ^ lab), (expr_of_lab loc lab eo))
| e -> ("", (expr e))
and binding x acc =
match x with
| Ast.BiAnd (_, x, y) -> binding x (binding y acc)
| Ast.BiEq (_loc, p,
(Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) ->
((patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))))),
(expr e)) :: acc
| Ast.BiEq (_, p, e) -> ((patt p), (expr e)) :: acc
| Ast.BiNil _ -> acc
| _ -> assert false
and match_case x acc =
match x with
| Ast.McOr (_, x, y) -> match_case x (match_case y acc)
| Ast.McArr (_, p, w, e) -> ((patt p), (when_expr e w)) :: acc
| Ast.McNil _ -> acc
| _ -> assert false
and when_expr e w =
match w with
| Ast.ExNil _ -> expr e
| w -> mkexp (loc_of_expr w) (Pexp_when ((expr w), (expr e)))
and mklabexp x acc =
match x with
| Ast.RbSem (_, x, y) -> mklabexp x (mklabexp y acc)
| Ast.RbEq (_, i, e) ->
((ident ~conv_lid: conv_lab i), (expr e)) :: acc
| _ -> assert false
and mkideexp x acc =
match x with
| Ast.RbNil _ -> acc
| Ast.RbSem (_, x, y) -> mkideexp x (mkideexp y acc)
| Ast.RbEq (_, (Ast.IdLid (_, s)), e) -> (s, (expr e)) :: acc
| _ -> assert false
and mktype_decl x acc =
match x with
| Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc)
| Ast.TyDcl (_, c, tl, td, cl) ->
let cl =
List.map
(fun (t1, t2) ->
let loc =
Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2)
in ((ctyp t1), (ctyp t2), (mkloc loc)))
cl
in
(c,
(type_decl (List.fold_right type_parameters tl []) cl td)) ::
acc
| _ -> assert false
and module_type =
function
| Ast.MtNil loc ->
error loc "abstract/nil module type not allowed here"
| Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i))
| Ast.MtFun (loc, n, nt, mt) ->
mkmty loc
(Pmty_functor (n, (module_type nt), (module_type mt)))
| Ast.MtQuo (loc, _) ->
error loc "module type variable not allowed here"
| Ast.MtSig (loc, sl) ->
mkmty loc (Pmty_signature (sig_item sl []))
| Ast.MtWit (loc, mt, wc) ->
mkmty loc (Pmty_with ((module_type mt), (mkwithc wc [])))
| Ast.MtAnt (_, _) -> assert false
and sig_item s l =
match s with
| Ast.SgNil _ -> l
| SgCls (loc, cd) ->
(mksig loc
(Psig_class
(List.map class_info_class_type
(list_of_class_type cd [])))) ::
l
| SgClt (loc, ctd) ->
(mksig loc
(Psig_class_type
(List.map class_info_class_type
(list_of_class_type ctd [])))) ::
l
| Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l)
| SgDir (_, _, _) -> l
| Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) ->
(mksig loc (Psig_exception ((conv_con s), []))) :: l
| Ast.SgExc (loc,
(Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) ->
(mksig loc
(Psig_exception ((conv_con s),
(List.map ctyp (list_of_ctyp t []))))) ::
l
| SgExc (_, _) -> assert false
| SgExt (loc, n, t, sl) ->
(mksig loc
(Psig_value (n, (mkvalue_desc t (list_of_meta_list sl))))) ::
l
| SgInc (loc, mt) ->
(mksig loc (Psig_include (module_type mt))) :: l
| SgMod (loc, n, mt) ->
(mksig loc (Psig_module (n, (module_type mt)))) :: l
| SgRecMod (loc, mb) ->
(mksig loc (Psig_recmodule (module_sig_binding mb []))) ::
l
| SgMty (loc, n, mt) ->
let si =
(match mt with
| MtQuo (_, _) -> Pmodtype_abstract
| _ -> Pmodtype_manifest (module_type mt))
in (mksig loc (Psig_modtype (n, si))) :: l
| SgOpn (loc, id) ->
(mksig loc (Psig_open (long_uident id))) :: l
| SgTyp (loc, tdl) ->
(mksig loc (Psig_type (mktype_decl tdl []))) :: l
| SgVal (loc, n, t) ->
(mksig loc (Psig_value (n, (mkvalue_desc t [])))) :: l
| Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item"
and module_sig_binding x acc =
match x with
| Ast.MbAnd (_, x, y) ->
module_sig_binding x (module_sig_binding y acc)
| Ast.MbCol (_, s, mt) -> (s, (module_type mt)) :: acc
| _ -> assert false
and module_str_binding x acc =
match x with
| Ast.MbAnd (_, x, y) ->
module_str_binding x (module_str_binding y acc)
| Ast.MbColEq (_, s, mt, me) ->
(s, (module_type mt), (module_expr me)) :: acc
| _ -> assert false
and module_expr =
function
| Ast.MeNil loc -> error loc "nil module expression"
| Ast.MeId (loc, i) -> mkmod loc (Pmod_ident (long_uident i))
| Ast.MeApp (loc, me1, me2) ->
mkmod loc
(Pmod_apply ((module_expr me1), (module_expr me2)))
| Ast.MeFun (loc, n, mt, me) ->
mkmod loc
(Pmod_functor (n, (module_type mt), (module_expr me)))
| Ast.MeStr (loc, sl) ->
mkmod loc (Pmod_structure (str_item sl []))
| Ast.MeTyc (loc, me, mt) ->
mkmod loc
(Pmod_constraint ((module_expr me), (module_type mt)))
| Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) ->
mkmod loc (Pmod_unpack ((expr e), (package_type pt)))
| Ast.MePkg (loc, _) ->
error loc "(value expr) not supported yet"
| Ast.MeAnt (loc, _) ->
error loc "antiquotation in module_expr"
and str_item s l =
match s with
| Ast.StNil _ -> l
| StCls (loc, cd) ->
(mkstr loc
(Pstr_class
(List.map class_info_class_expr
(list_of_class_expr cd [])))) ::
l
| StClt (loc, ctd) ->
(mkstr loc
(Pstr_class_type
(List.map class_info_class_type
(list_of_class_type ctd [])))) ::
l
| Ast.StSem (_, st1, st2) -> str_item st1 (str_item st2 l)
| StDir (_, _, _) -> l
| Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast.
ONone) ->
(mkstr loc (Pstr_exception ((conv_con s), []))) :: l
| Ast.StExc (loc,
(Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast.
ONone) ->
(mkstr loc
(Pstr_exception ((conv_con s),
(List.map ctyp (list_of_ctyp t []))))) ::
l
| Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))),
(Ast.OSome i)) ->
(mkstr loc (Pstr_exn_rebind ((conv_con s), (ident i)))) ::
l
| StExc (_, _, _) -> assert false
| StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l
| StExt (loc, n, t, sl) ->
(mkstr loc
(Pstr_primitive (n,
(mkvalue_desc t (list_of_meta_list sl))))) ::
l
| StInc (loc, me) ->
(mkstr loc (Pstr_include (module_expr me))) :: l
| StMod (loc, n, me) ->
(mkstr loc (Pstr_module (n, (module_expr me)))) :: l
| StRecMod (loc, mb) ->
(mkstr loc (Pstr_recmodule (module_str_binding mb []))) ::
l
| StMty (loc, n, mt) ->
(mkstr loc (Pstr_modtype (n, (module_type mt)))) :: l
| StOpn (loc, id) ->
(mkstr loc (Pstr_open (long_uident id))) :: l
| StTyp (loc, tdl) ->
(mkstr loc (Pstr_type (mktype_decl tdl []))) :: l
| StVal (loc, rf, bi) ->
(mkstr loc (Pstr_value ((mkrf rf), (binding bi [])))) :: l
| Ast.StAnt (loc, _) -> error loc "antiquotation in str_item"
and class_type =
function
| CtCon (loc, ViNil, id, tl) ->
mkcty loc
(Pcty_constr ((long_class_ident id),
(List.map ctyp (list_of_opt_ctyp tl []))))
| CtFun (loc, (TyLab (_, lab, t)), ct) ->
mkcty loc (Pcty_fun (lab, (ctyp t), (class_type ct)))
| CtFun (loc, (TyOlb (loc1, lab, t)), ct) ->
let t =
TyApp (loc1,
(Ast.TyId (loc1, (Ast.IdLid (loc1, "option")))), t)
in
mkcty loc
(Pcty_fun (("?" ^ lab), (ctyp t), (class_type ct)))
| CtFun (loc, t, ct) ->
mkcty loc (Pcty_fun ("", (ctyp t), (class_type ct)))
| CtSig (loc, t_o, ctfl) ->
let t =
(match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in
let cil = class_sig_item ctfl []
in mkcty loc (Pcty_signature (((ctyp t), cil)))
| CtCon (loc, _, _, _) ->
error loc "invalid virtual class inside a class type"
| CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) |
CtAnd (_, _, _) | CtNil _ -> assert false
and class_info_class_expr ci =
match ci with
| CeEq (_, (CeCon (loc, vir, (IdLid (_, name)), params)), ce)
->
let (loc_params, (params, variance)) =
(match params with
| Ast.TyNil _ -> (loc, ([], []))
| t ->
((loc_of_ctyp t),
(List.split (class_parameters t []))))
in
{
pci_virt = mkvirtual vir;
pci_params = (params, (mkloc loc_params));
pci_name = name;
pci_expr = class_expr ce;
pci_loc = mkloc loc;
pci_variance = variance;
}
| ce -> error (loc_of_class_expr ce) "bad class definition"
and class_info_class_type ci =
match ci with
| CtEq (_, (CtCon (loc, vir, (IdLid (_, name)), params)), ct) |
CtCol (_, (CtCon (loc, vir, (IdLid (_, name)), params)),
ct)
->
let (loc_params, (params, variance)) =
(match params with
| Ast.TyNil _ -> (loc, ([], []))
| t ->
((loc_of_ctyp t),
(List.split (class_parameters t []))))
in
{
pci_virt = mkvirtual vir;
pci_params = (params, (mkloc loc_params));
pci_name = name;
pci_expr = class_type ct;
pci_loc = mkloc loc;
pci_variance = variance;
}
| ct ->
error (loc_of_class_type ct)
"bad class/class type declaration/definition"
and class_sig_item c l =
match c with
| Ast.CgNil _ -> l
| CgCtr (loc, t1, t2) ->
(Pctf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l
| Ast.CgSem (_, csg1, csg2) ->
class_sig_item csg1 (class_sig_item csg2 l)
| CgInh (_, ct) -> (Pctf_inher (class_type ct)) :: l
| CgMth (loc, s, pf, t) ->
(Pctf_meth
((s, (mkprivate pf), (mkpolytype (ctyp t)), (mkloc loc)))) ::
l
| CgVal (loc, s, b, v, t) ->
(Pctf_val
((s, (mkmutable b), (mkvirtual v), (ctyp t),
(mkloc loc)))) ::
l
| CgVir (loc, s, b, t) ->
(Pctf_virt
((s, (mkprivate b), (mkpolytype (ctyp t)), (mkloc loc)))) ::
l
| CgAnt (_, _) -> assert false
and class_expr =
function
| (CeApp (loc, _, _) as c) ->
let (ce, el) = class_expr_fa [] c in
let el = List.map label_expr el
in mkpcl loc (Pcl_apply ((class_expr ce), el))
| CeCon (loc, ViNil, id, tl) ->
mkpcl loc
(Pcl_constr ((long_class_ident id),
(List.map ctyp (list_of_opt_ctyp tl []))))
| CeFun (loc, (PaLab (_, lab, po)), ce) ->
mkpcl loc
(Pcl_fun (lab, None, (patt_of_lab loc lab po),
(class_expr ce)))
| CeFun (loc, (PaOlbi (_, lab, p, e)), ce) ->
let lab = paolab lab p
in
mkpcl loc
(Pcl_fun (("?" ^ lab), (Some (expr e)), (patt p),
(class_expr ce)))
| CeFun (loc, (PaOlb (_, lab, p)), ce) ->
let lab = paolab lab p
in
mkpcl loc
(Pcl_fun (("?" ^ lab), None, (patt_of_lab loc lab p),
(class_expr ce)))
| CeFun (loc, p, ce) ->
mkpcl loc (Pcl_fun ("", None, (patt p), (class_expr ce)))
| CeLet (loc, rf, bi, ce) ->
mkpcl loc
(Pcl_let ((mkrf rf), (binding bi []), (class_expr ce)))
| CeStr (loc, po, cfl) ->
let p =
(match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in
let cil = class_str_item cfl []
in mkpcl loc (Pcl_structure (((patt p), cil)))
| CeTyc (loc, ce, ct) ->
mkpcl loc
(Pcl_constraint ((class_expr ce), (class_type ct)))
| CeCon (loc, _, _, _) ->
error loc "invalid virtual class inside a class expression"
| CeAnt (_, _) | CeEq (_, _, _) | CeAnd (_, _, _) | CeNil _ ->
assert false
and class_str_item c l =
match c with
| CrNil _ -> l
| CrCtr (loc, t1, t2) ->
(Pcf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l
| Ast.CrSem (_, cst1, cst2) ->
class_str_item cst1 (class_str_item cst2 l)
| CrInh (loc, ov, ce, pb) ->
let opb = if pb = "" then None else Some pb
in
(Pcf_inher ((override_flag loc ov), (class_expr ce), opb)) ::
l
| CrIni (_, e) -> (Pcf_init (expr e)) :: l
| CrMth (loc, s, ov, pf, e, t) ->
let t =
(match t with
| Ast.TyNil _ -> None
| t -> Some (mkpolytype (ctyp t))) in
let e = mkexp loc (Pexp_poly ((expr e), t))
in
(Pcf_meth
((s, (mkprivate pf), (override_flag loc ov), e,
(mkloc loc)))) ::
l
| CrVal (loc, s, ov, mf, e) ->
(Pcf_val
((s, (mkmutable mf), (override_flag loc ov), (expr e),
(mkloc loc)))) ::
l
| CrVir (loc, s, pf, t) ->
(Pcf_virt
((s, (mkprivate pf), (mkpolytype (ctyp t)), (mkloc loc)))) ::
l
| CrVvr (loc, s, mf, t) ->
(Pcf_valvirt ((s, (mkmutable mf), (ctyp t), (mkloc loc)))) ::
l
| CrAnt (_, _) -> assert false