diff --git a/src/whyml/mlw_dtree.ml b/src/whyml/mlw_dtree.ml
index e948e22f0bd6f93744cf0adaa92e07e29a1d4708..e615319e0428af4fbed8211db8cce386257b6d2b 100644
--- a/src/whyml/mlw_dtree.ml
+++ b/src/whyml/mlw_dtree.ml
@@ -61,7 +61,7 @@ type dinvariant = Ptree.lexpr option
type dexpr = {
de_desc : dexpr_desc;
- de_type : dity;
+ de_type : dvty;
de_lab : Ident.Slab.t;
de_loc : loc;
}
@@ -93,6 +93,6 @@ and dexpr_desc =
| DEghost of dexpr
| DEany of dtype_c
-and drecfun = loc * ident * ghost * dity * dlambda
+and drecfun = loc * ident * ghost * dvty * dlambda
and dlambda = dbinder list * dvariant list * dpre * dexpr * dpost * dxpost
diff --git a/src/whyml/mlw_dty.ml b/src/whyml/mlw_dty.ml
index a3e1f16cd76e446d2f9e54dbc679fc1d6f4116ae..d1f2d13e53dedbcb0654ca0962d214382b902a71 100644
--- a/src/whyml/mlw_dty.ml
+++ b/src/whyml/mlw_dty.ml
@@ -192,58 +192,25 @@ and unify_reg r1 r2 =
| Rreg (reg1,_), Rreg (reg2,_) when reg_equal reg1 reg2 -> ()
| _ -> raise Exit
-let unify ?(weak=false) d1 d2 =
+let unify ~weak d1 d2 =
try unify ~weak d1 d2
with Exit -> raise (TypeMismatch (ity_of_dity d1, ity_of_dity d2))
-let ts_arrow =
- let v = List.map (fun s -> create_tvsymbol (Ident.id_fresh s)) ["a"; "b"] in
- Ty.create_tysymbol (Ident.id_fresh "arrow") v None
+let unify_weak d1 d2 = unify ~weak:true d1 d2
+let unify d1 d2 = unify ~weak:false d1 d2
-let make_arrow_type tyl ty =
- let arrow ty1 ty2 = ts_app_real ts_arrow [ty1;ty2] in
- List.fold_right arrow tyl ty
+type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
-let rec unify_list d1 el res =
- let rec check_val loc = function
- | Dts (ts, _) when ts_equal ts ts_arrow ->
- Loc.errorm ~loc "This expression is not a first-order value"
- | Dvar { contents = Dval d } -> check_val loc d
- | _ -> ()
- in
- let unify_loc loc d1 d2 =
- check_val loc d2;
- try unify d1 d2 with
- | TypeMismatch (ity1, ity2) ->
- Loc.errorm ~loc "This expression has type %a, \
- but is expected to have type %a"
- Mlw_pretty.print_ity ity2 Mlw_pretty.print_ity ity1
- | exn -> Loc.error ~loc exn
- in
- match d1, el with
- | Dts (ts, [d1;d2]), ((loc,dity)::el) when ts_equal ts ts_arrow ->
- (* this is an ugly and overcomplicated way to treat
- implicit fields in record update expressions *)
- if Loc.equal loc Loc.dummy_position
- then (unify_loc loc d1 dity; unify_list d2 el res)
- else (unify_list d2 el res; unify_loc loc d1 dity)
- | Dvar { contents = Dval d1 }, _ ->
- unify_list d1 el res
- | _ ->
- unify d1 (make_arrow_type (List.map snd el) res)
-
-let rec vty_of_dity = function
- | Dvar { contents = Dval d } ->
- vty_of_dity d
- | Dts (ts, [d1; d2]) when ts_equal ts ts_arrow ->
- VTarrow (vty_arrow (vty_value (ity_of_dity d1)) (vty_of_dity d2))
- | dity ->
- VTvalue (vty_value (ity_of_dity dity))
+let vty_of_dvty (argl,res) =
+ let add a v = VTarrow (vty_arrow (vty_value (ity_of_dity a)) v) in
+ List.fold_right add argl (VTvalue (vty_value (ity_of_dity res)))
type tvars = dity list
+
let empty_tvars = []
-let add_tvars tvs dity = dity :: tvs
+let add_dity tvs dity = dity :: tvs
+let add_dvty tvs (argl,res) = res :: List.rev_append argl tvs
let tv_in_tvars tv tvs =
try List.iter (occur_check tv) tvs; false with Exit -> true
@@ -251,7 +218,7 @@ let tv_in_tvars tv tvs =
let reg_in_tvars tv tvs =
try List.iter (occur_check_reg tv) tvs; false with Exit -> true
-let specialize_scheme tvs dity =
+let specialize_scheme tvs (argl,res) =
let htvs = Htv.create 17 in
let hreg = Htv.create 17 in
let rec specialize = function
@@ -277,7 +244,7 @@ let specialize_scheme tvs dity =
end
| Rreg _ as r -> r
in
- specialize dity
+ List.map specialize argl, specialize res
(* Specialization of symbols *)
@@ -320,11 +287,11 @@ let specialize_vtarrow vars vta =
let conv vtv = dity_of_vtv htv hreg vars vtv in
let rec specialize a =
let arg = conv a.vta_arg in
- let res = match a.vta_result with
- | VTvalue v -> conv v
+ let argl,res = match a.vta_result with
+ | VTvalue v -> [], conv v
| VTarrow a -> specialize a
in
- make_arrow_type [arg] res
+ arg::argl, res
in
specialize vta
@@ -334,7 +301,7 @@ let specialize_psymbol ps =
let specialize_plsymbol pls =
let htv = Htv.create 3 and hreg = Hreg.create 3 in
let conv vtv = dity_of_vtv htv hreg vars_empty vtv in
- make_arrow_type (List.map conv pls.pl_args) (conv pls.pl_value)
+ List.map conv pls.pl_args, conv pls.pl_value
let dity_of_ty htv hreg vars ty =
dity_of_ity htv hreg vars (ity_of_ty ty)
@@ -343,4 +310,4 @@ let specialize_lsymbol ls =
let htv = Htv.create 3 and hreg = Hreg.create 3 in
let conv ty = dity_of_ty htv hreg vars_empty ty in
let ty = Util.def_option ty_bool ls.ls_value in
- make_arrow_type (List.map conv ls.ls_args) (conv ty)
+ List.map conv ls.ls_args, conv ty
diff --git a/src/whyml/mlw_dty.mli b/src/whyml/mlw_dty.mli
index 573533e3d272d0bd8c640ccb8802909d4ad8f344..e3cadf3af7c81f8e0d9b6b741fd4b548edf0bfa2 100644
--- a/src/whyml/mlw_dty.mli
+++ b/src/whyml/mlw_dty.mli
@@ -31,31 +31,29 @@ open Mlw_module
type dreg
type dity
+type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
type tvars (* a set of type variables *)
val empty_tvars: tvars
-val add_tvars: tvars -> dity -> tvars
+val add_dity: tvars -> dity -> tvars
+val add_dvty: tvars -> dvty -> tvars
-val create_user_type_variable: Ptree.ident -> dity
val create_type_variable: unit -> dity
+val create_user_type_variable: Ptree.ident -> dity
val its_app: user:bool -> itysymbol -> dity list -> dity
val ts_app: tysymbol -> dity list -> dity
-val make_arrow_type: dity list -> dity -> dity
-
-val unify: ?weak:bool -> dity -> dity -> unit
- (** destructive unification, with or without region unification *)
-
-val unify_list: dity -> (Loc.position * dity) list -> dity -> unit
+val unify: dity -> dity -> unit
+val unify_weak: dity -> dity -> unit (* don't unify regions *)
val ity_of_dity: dity -> ity
-val vty_of_dity: dity -> vty
+val vty_of_dvty: dvty -> vty
(** use with care, only once unification is done *)
-val specialize_scheme: tvars -> dity -> dity
+val specialize_scheme: tvars -> dvty -> dvty
-val specialize_lsymbol: lsymbol -> dity
+val specialize_lsymbol: lsymbol -> dvty
val specialize_pvsymbol: pvsymbol -> dity
-val specialize_psymbol: psymbol -> dity
-val specialize_plsymbol: plsymbol -> dity
+val specialize_psymbol: psymbol -> dvty
+val specialize_plsymbol: plsymbol -> dvty
val specialize_xsymbol: xsymbol -> dity
diff --git a/src/whyml/mlw_typing.ml b/src/whyml/mlw_typing.ml
index ee4c96f324b5ddfffb041756afa5aa7cf27ab0ad..3849ee2e0d0a95eeb110e92f90f386e9155ff71d 100644
--- a/src/whyml/mlw_typing.ml
+++ b/src/whyml/mlw_typing.ml
@@ -91,7 +91,7 @@ let () = Exn_printer.register (fun fmt e -> match e with
type denv = {
uc : module_uc;
- locals : (tvars * dity) Mstr.t;
+ locals : (tvars * dvty) Mstr.t;
tvars : tvars;
uloc : Ptree.loc option;
}
@@ -167,16 +167,19 @@ let dity_bool = ts_app ts_bool []
let dity_unit = ts_app ts_unit []
let dity_mark = ts_app ts_mark []
-let unify_loc loc fn_unify x1 x2 =
- try fn_unify x1 x2 with
- | TypeMismatch (ity1,ity2) ->
- errorm ~loc "This expression has type %a, \
- but is expected to have type %a"
- Mlw_pretty.print_ity ity2 Mlw_pretty.print_ity ity1
- | exn -> error ~loc exn
+let unify_loc unify_fn loc x1 x2 = try unify_fn x1 x2 with
+ | TypeMismatch (ity1,ity2) -> errorm ~loc
+ "This expression has type %a, but is expected to have type %a"
+ Mlw_pretty.print_ity ity2 Mlw_pretty.print_ity ity1
+ | exn -> error ~loc exn
-let expected_type ?(weak=false) e dity =
- unify_loc e.de_loc (unify ~weak) dity e.de_type
+let expected_type { de_loc = loc ; de_type = (argl,res) } dity =
+ if argl <> [] then errorm ~loc "This expression is not a first-order value";
+ unify_loc unify loc dity res
+
+let expected_type_weak { de_loc = loc ; de_type = (argl,res) } dity =
+ if argl <> [] then errorm ~loc "This expression is not a first-order value";
+ unify_loc unify_weak loc dity res
let rec extract_labels labs loc e = match e.Ptree.expr_desc with
| Ptree.Enamed (Ptree.Lstr s, e) -> extract_labels (Slab.add s labs) loc e
@@ -244,24 +247,24 @@ let mk_var e =
let mk_id s loc =
{ id = s; id_loc = loc; id_lab = [] }
-let mk_dexpr desc dity loc labs =
- { de_desc = desc; de_type = dity; de_loc = loc; de_lab = labs }
+let mk_dexpr desc dvty loc labs =
+ { de_desc = desc; de_type = dvty; de_loc = loc; de_lab = labs }
-let mk_let ~loc ~uloc e (desc,dity) =
- if test_var e then desc, dity else
+let mk_let ~loc ~uloc e (desc,dvty) =
+ if test_var e then desc, dvty else
let loc = def_option loc uloc in
- let e1 = mk_dexpr desc dity loc Slab.empty in
- DElet (mk_id "q" loc, false, e, e1), dity
+ let e1 = mk_dexpr desc dvty loc Slab.empty in
+ DElet (mk_id "q" loc, false, e, e1), dvty
(* patterns *)
let add_var id dity denv =
- let tvars = add_tvars denv.tvars dity in
- let locals = Mstr.add id.id (tvars,dity) denv.locals in
+ let tvars = add_dity denv.tvars dity in
+ let locals = Mstr.add id.id (tvars,([],dity)) denv.locals in
{ denv with locals = locals; tvars = tvars }
let specialize_qualid uc p = match uc_find_ps uc p with
- | PV pv -> DEglobal_pv pv, specialize_pvsymbol pv
+ | PV pv -> DEglobal_pv pv, ([],specialize_pvsymbol pv)
| PS ps -> DEglobal_ps ps, specialize_psymbol ps
| PL pl -> DEglobal_pl pl, specialize_plsymbol pl
| LS ls -> DEglobal_ls ls, specialize_lsymbol ls
@@ -287,8 +290,8 @@ let rec dpattern denv ({ pat_loc = loc } as pp) = match pp.pat_desc with
let dity = create_type_variable () in
PPvar (Denv.create_user_id id), dity, add_var id dity denv
| Ptree.PPpapp (q,ppl) ->
- let sym, dity = specialize_qualid denv.uc q in
- dpat_app denv loc (mk_dexpr sym dity loc Slab.empty) ppl
+ let sym, dvty = specialize_qualid denv.uc q in
+ dpat_app denv loc (mk_dexpr sym dvty loc Slab.empty) ppl
| Ptree.PPprec fl when is_pure_record denv.uc fl ->
let kn = Theory.get_known (get_theory denv.uc) in
let fl = List.map (find_pure_field denv.uc) fl in
@@ -308,7 +311,7 @@ let rec dpattern denv ({ pat_loc = loc } as pp) = match pp.pat_desc with
| Ptree.PPpor (lpp1, lpp2) ->
let pp1, dity1, denv = dpattern denv lpp1 in
let pp2, dity2, denv = dpattern denv lpp2 in
- unify_loc lpp2.pat_loc unify dity1 dity2;
+ unify_loc unify lpp2.pat_loc dity1 dity2;
PPor (pp1, pp2), dity1, denv
| Ptree.PPpas (pp, id) ->
let pp, dity, denv = dpattern denv pp in
@@ -319,15 +322,18 @@ and dpat_app denv gloc ({ de_loc = loc } as de) ppl =
let pp, ty, denv = dpattern denv lp in
pp::ppl, (lp.pat_loc,ty)::tyl, denv in
let ppl, tyl, denv = List.fold_right add_pp ppl ([],[],denv) in
- let pp = match de.de_desc with
- | DEglobal_pl pl -> Mlw_expr.PPpapp (pl, ppl)
- | DEglobal_ls ls -> PPlapp (ls, ppl)
+ let pp, ls = match de.de_desc with
+ | DEglobal_pl pl -> Mlw_expr.PPpapp (pl, ppl), pl.pl_ls
+ | DEglobal_ls ls -> Mlw_expr.PPlapp (ls, ppl), ls
| DEglobal_pv pv -> errorm ~loc "%a is not a constructor" print_pv pv
| DEglobal_ps ps -> errorm ~loc "%a is not a constructor" print_ps ps
| _ -> assert false
in
- let res = create_type_variable () in
- Loc.try2 gloc unify_list de.de_type tyl res;
+ let argl, res = de.de_type in
+ if List.length argl <> List.length ppl then error ~loc:gloc
+ (Term.BadArity (ls, List.length argl, List.length ppl));
+ let unify_arg ta (loc,tv) = unify_loc unify loc ta tv in
+ List.iter2 unify_arg argl tyl;
pp, res, denv
(* specifications *)
@@ -352,22 +358,22 @@ let deff_of_peff uc pe =
let dxpost uc ql = List.map (fun (q,f) -> find_xsymbol uc q, f) ql
let rec dtype_c denv tyc =
- let tyv, dity = dtype_v denv tyc.pc_result_type in
+ let tyv, dvty = dtype_v denv tyc.pc_result_type in
{ dc_result = tyv;
dc_effect = deff_of_peff denv.uc tyc.pc_effect;
dc_pre = tyc.pc_pre;
dc_post = fst tyc.pc_post;
dc_xpost = dxpost denv.uc (snd tyc.pc_post); },
- dity
+ dvty
and dtype_v denv = function
| Tpure pty ->
let dity = dity_of_pty ~user:true denv pty in
- DSpecV (false,dity), dity
+ DSpecV (false,dity), ([],dity)
| Tarrow (bl,tyc) ->
let denv,bl,tyl = dbinders denv bl in
- let tyc,dity = dtype_c denv tyc in
- DSpecA (bl,tyc), make_arrow_type tyl dity
+ let tyc,(argl,res) = dtype_c denv tyc in
+ DSpecA (bl,tyc), (tyl @ argl,res)
let dvariant uc = function
| Some (le, Some q) -> [le, Some (find_variant_ls uc q)]
@@ -381,11 +387,20 @@ let dvariant uc = function
let de_unit ~loc = hidden_ls ~loc (Term.fs_tuple 0)
-let de_app loc e el =
- let res = create_type_variable () in
- let tyl = List.map (fun a -> (a.de_loc, a.de_type)) el in
- Loc.try2 loc unify_list e.de_type tyl res;
- DEapply (e, el), res
+let de_app _loc e el =
+ let argl, res = e.de_type in
+ let rec unify_list argl el = match argl, el with
+ | arg::argl, e::el when Loc.equal e.de_loc Loc.dummy_position ->
+ expected_type e arg; unify_list argl el
+ | arg::argl, e::el ->
+ let res = unify_list argl el in expected_type e arg; res
+ | argl, [] -> argl, res
+ | [], _ when fst e.de_type = [] -> errorm ~loc:e.de_loc
+ "This expression is not a function and cannot be applied"
+ | [], _ -> errorm ~loc:e.de_loc
+ "This function is applied to too many arguments"
+ in
+ DEapply (e, el), unify_list argl el
let rec dexpr denv e =
let loc = e.Ptree.expr_loc in
@@ -398,9 +413,9 @@ let rec dexpr denv e =
and de_desc denv loc = function
| Ptree.Eident (Qident {id=x}) when Mstr.mem x denv.locals ->
(* local variable *)
- let tvs, dity = Mstr.find x denv.locals in
- let dity = specialize_scheme tvs dity in
- DElocal x, dity
+ let tvs, dvty = Mstr.find x denv.locals in
+ let dvty = specialize_scheme tvs dvty in
+ DElocal x, dvty
| Ptree.Eident p ->
specialize_qualid denv.uc p
| Ptree.Eapply (e1, e2) ->
@@ -409,24 +424,25 @@ and de_desc denv loc = function
de_app loc (dexpr denv e) el
| Ptree.Elet (id, gh, e1, e2) ->
let e1 = dexpr denv e1 in
- let dity = e1.de_type in
+ let dvty = e1.de_type in
let tvars = match e1.de_desc with
| DEfun _ -> denv.tvars
- | _ -> add_tvars denv.tvars dity in
- let locals = Mstr.add id.id (tvars, dity) denv.locals in
+ | _ -> add_dvty denv.tvars dvty in
+ let locals = Mstr.add id.id (tvars, dvty) denv.locals in
let denv = { denv with locals = locals; tvars = tvars } in
let e2 = dexpr denv e2 in
DElet (id, gh, e1, e2), e2.de_type
| Ptree.Eletrec (rdl, e1) ->
let rdl = dletrec denv rdl in
- let add_one denv (_, { id = id }, _, dity, _) =
- { denv with locals = Mstr.add id (denv.tvars, dity) denv.locals } in
+ let add_one denv (_, { id = id }, _, dvty, _) =
+ { denv with locals = Mstr.add id (denv.tvars, dvty) denv.locals } in
let denv = List.fold_left add_one denv rdl in
let e1 = dexpr denv e1 in
DEletrec (rdl, e1), e1.de_type
| Ptree.Efun (bl, tr) ->
- let lam, dity = dlambda denv bl None tr in
- DEfun lam, dity
+ let denv, bl, tyl = dbinders denv bl in
+ let lam, (argl, res) = dlambda denv bl None tr in
+ DEfun lam, (tyl @ argl, res)
| Ptree.Ecast (e1, pty) ->
let e1 = dexpr denv e1 in
expected_type e1 (dity_of_pty ~user:false denv pty);
@@ -443,7 +459,9 @@ and de_desc denv loc = function
expected_type e1 dity_bool;
let e2 = dexpr denv e2 in
let e3 = dexpr denv e3 in
- expected_type e3 e2.de_type;
+ let res = create_type_variable () in
+ expected_type e2 res;
+ expected_type e3 res;
DEif (e1, e2, e3), e2.de_type
| Ptree.Etuple el ->
let ls = fs_tuple (List.length el) in
@@ -474,8 +492,8 @@ and de_desc denv loc = function
| Some e -> dexpr denv e
| None ->
let loc = Loc.dummy_position in
- let d, dity = de_app loc (hidden_ls ~loc pj) [e0] in
- mk_dexpr d dity loc Slab.empty in
+ let d, dvty = de_app loc (hidden_ls ~loc pj) [e0] in
+ mk_dexpr d dvty loc Slab.empty in
let res = de_app loc (hidden_ls ~loc cs) (List.map get_val pjl) in
mk_let ~loc ~uloc:denv.uloc e1 res
| Ptree.Eupdate (e1, fl) ->
@@ -487,8 +505,8 @@ and de_desc denv loc = function
| Some e -> dexpr denv e
| None ->
let loc = Loc.dummy_position in
- let d, dity = de_app loc (hidden_pl ~loc pj) [e0] in
- mk_dexpr d dity loc Slab.empty in
+ let d, dvty = de_app loc (hidden_pl ~loc pj) [e0] in
+ mk_dexpr d dvty loc Slab.empty in
let res = de_app loc (hidden_pl ~loc cs) (List.map get_val pjl) in
mk_let ~loc ~uloc:denv.uloc e1 res
| Ptree.Eassign (e1, q, e2) ->
@@ -496,34 +514,37 @@ and de_desc denv loc = function
let e1 = { expr_desc = Eapply (fl,e1); expr_loc = loc } in
let e1 = dexpr denv e1 in
let e2 = dexpr denv e2 in
- expected_type ~weak:true e2 e1.de_type;
- DEassign (e1, e2), dity_unit
+ let res = create_type_variable () in
+ expected_type e1 res;
+ expected_type_weak e2 res;
+ DEassign (e1, e2), ([], dity_unit)
| Ptree.Econstant (ConstInt _ as c) ->
- DEconstant c, dity_int
+ DEconstant c, ([], dity_int)
| Ptree.Econstant (ConstReal _ as c) ->
- DEconstant c, dity_real
+ DEconstant c, ([], dity_real)
| Ptree.Enot e1 ->
let e1 = dexpr denv e1 in
expected_type e1 dity_bool;
- DEnot e1, dity_bool
+ DEnot e1, ([], dity_bool)
| Ptree.Elazy (op, e1, e2) ->
let e1 = dexpr denv e1 in
let e2 = dexpr denv e2 in
expected_type e1 dity_bool;
expected_type e2 dity_bool;
- DElazy (op, e1, e2), dity_bool
+ DElazy (op, e1, e2), ([], dity_bool)
| Ptree.Ematch (e1, bl) ->
let e1 = dexpr denv e1 in
+ let ety = create_type_variable () in
let res = create_type_variable () in
+ expected_type e1 ety;
let branch (pp,e) =
let ppat, dity, denv = dpattern denv pp in
- unify_loc pp.pat_loc unify e1.de_type dity;
+ unify_loc unify pp.pat_loc ety dity;
let e = dexpr denv e in
expected_type e res;
ppat, e in
- DEmatch (e1, List.map branch bl), res
+ DEmatch (e1, List.map branch bl), ([], res)
| Ptree.Eraise (q, e1) ->
- let res = create_type_variable () in
let xs = find_xsymbol denv.uc q in
let dity = specialize_xsymbol xs in
let e1 = match e1 with
@@ -531,9 +552,11 @@ and de_desc denv loc = function
| None when ity_equal xs.xs_ity ity_unit -> de_unit ~loc
| _ -> errorm ~loc "exception argument expected" in
expected_type e1 dity;
- DEraise (xs, e1), res
+ DEraise (xs, e1), ([], create_type_variable ())
| Ptree.Etry (e1, cl) ->
+ let res = create_type_variable () in
let e1 = dexpr denv e1 in
+ expected_type e1 res;
let branch (q, id, e) =
let xs = find_xsymbol denv.uc q in
let dity = specialize_xsymbol xs in
@@ -541,21 +564,21 @@ and de_desc denv loc = function
| Some id -> id, add_var id dity denv
| None -> mk_id "void" loc, denv in
let e = dexpr denv e in
- expected_type e e1.de_type;
+ expected_type e res;
xs, id, e
in
let cl = List.map branch cl in
DEtry (e1, cl), e1.de_type
| Ptree.Eabsurd ->
- DEabsurd, create_type_variable ()
+ DEabsurd, ([], create_type_variable ())
| Ptree.Eassert (ak, lexpr) ->
- DEassert (ak, lexpr), dity_unit
+ DEassert (ak, lexpr), ([], dity_unit)
| Ptree.Emark (id, e1) ->
let e1 = dexpr denv e1 in
DEmark (id, e1), e1.de_type
| Ptree.Eany tyc ->
- let tyc, dity = dtype_c denv tyc in
- DEany tyc, dity
+ let tyc, dvty = dtype_c denv tyc in
+ DEany tyc, dvty
| Ptree.Eghost e1 ->
let e1 = dexpr denv e1 in
DEghost e1, e1.de_type
@@ -579,24 +602,34 @@ and de_desc denv loc = function
DEfor (id,efrom,dir,eto,inv,e1), e1.de_type
and dletrec denv rdl =
- (* add all functions into environment *)
- let add_one denv (_,id,_,_,_,_) =
- let res = create_type_variable () in
- add_var id res denv, res in
- let denv, tyl = Util.map_fold_left add_one denv rdl in
- (* then type-check all of them and unify *)
- let type_one (loc, id, gh, bl, var, tr) res =
- let lam, dity = dlambda denv bl var tr in
- Loc.try2 id.id_loc unify dity res;
- loc, id, gh, dity, lam in
- List.map2 type_one rdl tyl
+ (* add all functions into the environment *)
+ let add_one denv (_,id,_,bl,_,_) =
+ let argl = List.map (fun _ -> create_type_variable ()) bl in
+ let dvty = argl, create_type_variable () in
+ let tvars = add_dvty denv.tvars dvty in
+ let locals = Mstr.add id.id (tvars, dvty) denv.locals in
+ { denv with locals = locals; tvars = tvars }, dvty in
+ let denv, dvtyl = Util.map_fold_left add_one denv rdl in
+ (* then unify the binders *)
+ let bind_one (_,_,_,bl,_,_) (argl,res) =
+ let denv,bl,tyl = dbinders denv bl in
+ List.iter2 unify argl tyl;
+ denv,bl,tyl,res in
+ let denvl = List.map2 bind_one rdl dvtyl in
+ (* then type-check the bodies *)
+ let type_one (loc, id, gh, _, var, tr) (denv,bl,tyl,tyv) =
+ let lam, (argl, res) = dlambda denv bl var tr in
+ if argl <> [] then errorm ~loc
+ "The body of a recursive function must be a first-order value";
+ unify_loc unify loc tyv res;
+ loc, id, gh, (tyl, tyv), lam in
+ List.map2 type_one rdl denvl
and dlambda denv bl var (p, e, (q, xq)) =
- let denv,bl,tyl = dbinders denv bl in
let e = dexpr denv e in
let var = dvariant denv.uc var in
let xq = dxpost denv.uc xq in
- (bl, var, p, e, q, xq), make_arrow_type tyl e.de_type
+ (bl, var, p, e, q, xq), e.de_type
(** stage 2 *)
@@ -704,7 +737,7 @@ let rec get_eff_expr lenv { pp_desc = d; pp_loc = loc } = match d with
let itya, vtvv =
try Mls.find (uc_find_ls lenv.mod_uc p) pjm with Not_found ->
errorm ~loc:(qloc p) "'%a' must be a field name" print_qualid p in
- let sbs = unify_loc loc (ity_match ity_subst_empty) itya vtv.vtv_ity in
+ let sbs = unify_loc (ity_match ity_subst_empty) loc itya vtv.vtv_ity in
let mut = Util.option_map (reg_full_inst sbs) vtvv.vtv_mut in
let ghost = vtv.vtv_ghost || vtvv.vtv_ghost in
vty_value ~ghost ?mut (ity_full_inst sbs vtvv.vtv_ity)
@@ -790,7 +823,7 @@ and expr_desc lenv loc de = match de.de_desc with
assert (Mstr.mem x lenv.let_vars);
begin match Mstr.find x lenv.let_vars with
| LetV pv -> e_value pv
- | LetA ps -> e_cast ps (vty_of_dity de.de_type)
+ | LetA ps -> e_cast ps (vty_of_dvty de.de_type)
end
| DElet (x, gh, { de_desc = DEfun lam }, de2) ->
let def = expr_fun lenv x gh lam in
@@ -827,18 +860,18 @@ and expr_desc lenv loc de = match de.de_desc with
| DEapply (de1, del) ->
let el = List.map (expr lenv) del in
begin match de1.de_desc with
- | DEglobal_pl pls -> e_plapp pls el (ity_of_dity de.de_type)
- | DEglobal_ls ls -> e_lapp ls el (ity_of_dity de.de_type)
+ | DEglobal_pl pls -> e_plapp pls el (ity_of_dity (snd de.de_type))
+ | DEglobal_ls ls -> e_lapp ls el (ity_of_dity (snd de.de_type))
| _ -> e_app (expr lenv de1) el
end
| DEglobal_pv pv ->
e_value pv
| DEglobal_ps ps ->
- e_cast ps (vty_of_dity de.de_type)
+ e_cast ps (vty_of_dvty de.de_type)
| DEglobal_pl pl ->
- e_plapp pl [] (ity_of_dity de.de_type)
+ e_plapp pl [] (ity_of_dity (snd de.de_type))
| DEglobal_ls ls ->
- e_lapp ls [] (ity_of_dity de.de_type)
+ e_lapp ls [] (ity_of_dity (snd de.de_type))
| DEif (de1, de2, de3) ->
e_if (expr lenv de1) (expr lenv de2) (expr lenv de3)
| DEassign (de1, de2) ->
@@ -873,9 +906,9 @@ and expr_desc lenv loc de = match de.de_desc with
| Ptree.Acheck -> Acheck in
e_assert ak (create_pre lenv f)
| DEabsurd ->
- e_absurd (ity_of_dity de.de_type)
+ e_absurd (ity_of_dity (snd de.de_type))
| DEraise (xs, de1) ->
- e_raise xs (expr lenv de1) (ity_of_dity de.de_type)
+ e_raise xs (expr lenv de1) (ity_of_dity (snd de.de_type))
| DEtry (de1, bl) ->
let e1 = expr lenv de1 in
let branch (xs,id,de) =
@@ -918,8 +951,8 @@ and expr_desc lenv loc de = match de.de_desc with
e_for pv efrom dir eto inv e1
and expr_rec lenv rdl =
- let step1 lenv (_loc, id, gh, dity, lam) =
- let vta = match vty_ghostify gh (vty_of_dity dity) with
+ let step1 lenv (_loc, id, gh, dvty, lam) =
+ let vta = match vty_ghostify gh (vty_of_dvty dvty) with
| VTarrow vta -> vta
| VTvalue _ -> assert false in
let ps = create_psymbol (Denv.create_user_id id) vta vars_empty in
diff --git a/tests/test-pgm-jcf.mlx b/tests/test-pgm-jcf.mlx
index c00787e098b4551fa3402ae95d8aa4118641312c..3e5c416c271677748b847adcfd446353436cd2c3 100644
--- a/tests/test-pgm-jcf.mlx
+++ b/tests/test-pgm-jcf.mlx
@@ -5,7 +5,7 @@ module TestWP
let rec f (x:int) = {} g x {}
with g (x:int) = {} f x {}
in
- f x x
+ f x
end
(***