Commit 8e33e369 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

whyml: letrec bodies must be first-order values

parent 08c5987e
...@@ -61,7 +61,7 @@ type dinvariant = Ptree.lexpr option ...@@ -61,7 +61,7 @@ type dinvariant = Ptree.lexpr option
type dexpr = { type dexpr = {
de_desc : dexpr_desc; de_desc : dexpr_desc;
de_type : dity; de_type : dvty;
de_lab : Ident.Slab.t; de_lab : Ident.Slab.t;
de_loc : loc; de_loc : loc;
} }
...@@ -93,6 +93,6 @@ and dexpr_desc = ...@@ -93,6 +93,6 @@ and dexpr_desc =
| DEghost of dexpr | DEghost of dexpr
| DEany of dtype_c | 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 and dlambda = dbinder list * dvariant list * dpre * dexpr * dpost * dxpost
...@@ -192,58 +192,25 @@ and unify_reg r1 r2 = ...@@ -192,58 +192,25 @@ and unify_reg r1 r2 =
| Rreg (reg1,_), Rreg (reg2,_) when reg_equal reg1 reg2 -> () | Rreg (reg1,_), Rreg (reg2,_) when reg_equal reg1 reg2 -> ()
| _ -> raise Exit | _ -> raise Exit
let unify ?(weak=false) d1 d2 = let unify ~weak d1 d2 =
try unify ~weak d1 d2 try unify ~weak d1 d2
with Exit -> raise (TypeMismatch (ity_of_dity d1, ity_of_dity d2)) with Exit -> raise (TypeMismatch (ity_of_dity d1, ity_of_dity d2))
let ts_arrow = let unify_weak d1 d2 = unify ~weak:true d1 d2
let v = List.map (fun s -> create_tvsymbol (Ident.id_fresh s)) ["a"; "b"] in let unify d1 d2 = unify ~weak:false d1 d2
Ty.create_tysymbol (Ident.id_fresh "arrow") v None
let make_arrow_type tyl ty = type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
let arrow ty1 ty2 = ts_app_real ts_arrow [ty1;ty2] in
List.fold_right arrow tyl ty
let rec unify_list d1 el res = let vty_of_dvty (argl,res) =
let rec check_val loc = function let add a v = VTarrow (vty_arrow (vty_value (ity_of_dity a)) v) in
| Dts (ts, _) when ts_equal ts ts_arrow -> List.fold_right add argl (VTvalue (vty_value (ity_of_dity res)))
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))
type tvars = dity list type tvars = dity list
let empty_tvars = [] 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 = let tv_in_tvars tv tvs =
try List.iter (occur_check tv) tvs; false with Exit -> true try List.iter (occur_check tv) tvs; false with Exit -> true
...@@ -251,7 +218,7 @@ let tv_in_tvars tv tvs = ...@@ -251,7 +218,7 @@ let tv_in_tvars tv tvs =
let reg_in_tvars tv tvs = let reg_in_tvars tv tvs =
try List.iter (occur_check_reg tv) tvs; false with Exit -> true 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 htvs = Htv.create 17 in
let hreg = Htv.create 17 in let hreg = Htv.create 17 in
let rec specialize = function let rec specialize = function
...@@ -277,7 +244,7 @@ let specialize_scheme tvs dity = ...@@ -277,7 +244,7 @@ let specialize_scheme tvs dity =
end end
| Rreg _ as r -> r | Rreg _ as r -> r
in in
specialize dity List.map specialize argl, specialize res
(* Specialization of symbols *) (* Specialization of symbols *)
...@@ -320,11 +287,11 @@ let specialize_vtarrow vars vta = ...@@ -320,11 +287,11 @@ let specialize_vtarrow vars vta =
let conv vtv = dity_of_vtv htv hreg vars vtv in let conv vtv = dity_of_vtv htv hreg vars vtv in
let rec specialize a = let rec specialize a =
let arg = conv a.vta_arg in let arg = conv a.vta_arg in
let res = match a.vta_result with let argl,res = match a.vta_result with
| VTvalue v -> conv v | VTvalue v -> [], conv v
| VTarrow a -> specialize a | VTarrow a -> specialize a
in in
make_arrow_type [arg] res arg::argl, res
in in
specialize vta specialize vta
...@@ -334,7 +301,7 @@ let specialize_psymbol ps = ...@@ -334,7 +301,7 @@ let specialize_psymbol ps =
let specialize_plsymbol pls = let specialize_plsymbol pls =
let htv = Htv.create 3 and hreg = Hreg.create 3 in let htv = Htv.create 3 and hreg = Hreg.create 3 in
let conv vtv = dity_of_vtv htv hreg vars_empty vtv 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 = let dity_of_ty htv hreg vars ty =
dity_of_ity htv hreg vars (ity_of_ty ty) dity_of_ity htv hreg vars (ity_of_ty ty)
...@@ -343,4 +310,4 @@ let specialize_lsymbol ls = ...@@ -343,4 +310,4 @@ let specialize_lsymbol ls =
let htv = Htv.create 3 and hreg = Hreg.create 3 in let htv = Htv.create 3 and hreg = Hreg.create 3 in
let conv ty = dity_of_ty htv hreg vars_empty ty in let conv ty = dity_of_ty htv hreg vars_empty ty in
let ty = Util.def_option ty_bool ls.ls_value 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
...@@ -31,31 +31,29 @@ open Mlw_module ...@@ -31,31 +31,29 @@ open Mlw_module
type dreg type dreg
type dity type dity
type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
type tvars (* a set of type variables *) type tvars (* a set of type variables *)
val empty_tvars: tvars 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_type_variable: unit -> dity
val create_user_type_variable: Ptree.ident -> dity
val its_app: user:bool -> itysymbol -> dity list -> dity val its_app: user:bool -> itysymbol -> dity list -> dity
val ts_app: tysymbol -> dity list -> dity val ts_app: tysymbol -> dity list -> dity
val make_arrow_type: dity list -> dity -> dity val unify: dity -> dity -> unit
val unify_weak: dity -> dity -> unit (* don't unify regions *)
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 ity_of_dity: dity -> ity 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 *) (** 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_pvsymbol: pvsymbol -> dity
val specialize_psymbol: psymbol -> dity val specialize_psymbol: psymbol -> dvty
val specialize_plsymbol: plsymbol -> dity val specialize_plsymbol: plsymbol -> dvty
val specialize_xsymbol: xsymbol -> dity val specialize_xsymbol: xsymbol -> dity
...@@ -91,7 +91,7 @@ let () = Exn_printer.register (fun fmt e -> match e with ...@@ -91,7 +91,7 @@ let () = Exn_printer.register (fun fmt e -> match e with
type denv = { type denv = {
uc : module_uc; uc : module_uc;
locals : (tvars * dity) Mstr.t; locals : (tvars * dvty) Mstr.t;
tvars : tvars; tvars : tvars;
uloc : Ptree.loc option; uloc : Ptree.loc option;
} }
...@@ -167,16 +167,19 @@ let dity_bool = ts_app ts_bool [] ...@@ -167,16 +167,19 @@ let dity_bool = ts_app ts_bool []
let dity_unit = ts_app ts_unit [] let dity_unit = ts_app ts_unit []
let dity_mark = ts_app ts_mark [] let dity_mark = ts_app ts_mark []
let unify_loc loc fn_unify x1 x2 = let unify_loc unify_fn loc x1 x2 = try unify_fn x1 x2 with
try fn_unify x1 x2 with | TypeMismatch (ity1,ity2) -> errorm ~loc
| TypeMismatch (ity1,ity2) -> "This expression has type %a, but is expected to have type %a"
errorm ~loc "This expression has type %a, \ Mlw_pretty.print_ity ity2 Mlw_pretty.print_ity ity1
but is expected to have type %a" | exn -> error ~loc exn
Mlw_pretty.print_ity ity2 Mlw_pretty.print_ity ity1
| exn -> error ~loc exn
let expected_type ?(weak=false) e dity = let expected_type { de_loc = loc ; de_type = (argl,res) } dity =
unify_loc e.de_loc (unify ~weak) dity e.de_type 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 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 | Ptree.Enamed (Ptree.Lstr s, e) -> extract_labels (Slab.add s labs) loc e
...@@ -244,24 +247,24 @@ let mk_var e = ...@@ -244,24 +247,24 @@ let mk_var e =
let mk_id s loc = let mk_id s loc =
{ id = s; id_loc = loc; id_lab = [] } { id = s; id_loc = loc; id_lab = [] }
let mk_dexpr desc dity loc labs = let mk_dexpr desc dvty loc labs =
{ de_desc = desc; de_type = dity; de_loc = loc; de_lab = labs } { de_desc = desc; de_type = dvty; de_loc = loc; de_lab = labs }
let mk_let ~loc ~uloc e (desc,dity) = let mk_let ~loc ~uloc e (desc,dvty) =
if test_var e then desc, dity else if test_var e then desc, dvty else
let loc = def_option loc uloc in let loc = def_option loc uloc in
let e1 = mk_dexpr desc dity loc Slab.empty in let e1 = mk_dexpr desc dvty loc Slab.empty in
DElet (mk_id "q" loc, false, e, e1), dity DElet (mk_id "q" loc, false, e, e1), dvty
(* patterns *) (* patterns *)
let add_var id dity denv = let add_var id dity denv =
let tvars = add_tvars denv.tvars dity in let tvars = add_dity denv.tvars dity in
let locals = Mstr.add id.id (tvars,dity) denv.locals in let locals = Mstr.add id.id (tvars,([],dity)) denv.locals in
{ denv with locals = locals; tvars = tvars } { denv with locals = locals; tvars = tvars }
let specialize_qualid uc p = match uc_find_ps uc p with 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 | PS ps -> DEglobal_ps ps, specialize_psymbol ps
| PL pl -> DEglobal_pl pl, specialize_plsymbol pl | PL pl -> DEglobal_pl pl, specialize_plsymbol pl
| LS ls -> DEglobal_ls ls, specialize_lsymbol ls | 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 ...@@ -287,8 +290,8 @@ let rec dpattern denv ({ pat_loc = loc } as pp) = match pp.pat_desc with
let dity = create_type_variable () in let dity = create_type_variable () in
PPvar (Denv.create_user_id id), dity, add_var id dity denv PPvar (Denv.create_user_id id), dity, add_var id dity denv
| Ptree.PPpapp (q,ppl) -> | Ptree.PPpapp (q,ppl) ->
let sym, dity = specialize_qualid denv.uc q in let sym, dvty = specialize_qualid denv.uc q in
dpat_app denv loc (mk_dexpr sym dity loc Slab.empty) ppl dpat_app denv loc (mk_dexpr sym dvty loc Slab.empty) ppl
| Ptree.PPprec fl when is_pure_record denv.uc fl -> | Ptree.PPprec fl when is_pure_record denv.uc fl ->
let kn = Theory.get_known (get_theory denv.uc) in let kn = Theory.get_known (get_theory denv.uc) in
let fl = List.map (find_pure_field denv.uc) fl 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 ...@@ -308,7 +311,7 @@ let rec dpattern denv ({ pat_loc = loc } as pp) = match pp.pat_desc with
| Ptree.PPpor (lpp1, lpp2) -> | Ptree.PPpor (lpp1, lpp2) ->
let pp1, dity1, denv = dpattern denv lpp1 in let pp1, dity1, denv = dpattern denv lpp1 in
let pp2, dity2, denv = dpattern denv lpp2 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 PPor (pp1, pp2), dity1, denv
| Ptree.PPpas (pp, id) -> | Ptree.PPpas (pp, id) ->
let pp, dity, denv = dpattern denv pp in let pp, dity, denv = dpattern denv pp in
...@@ -319,15 +322,18 @@ and dpat_app denv gloc ({ de_loc = loc } as de) ppl = ...@@ -319,15 +322,18 @@ and dpat_app denv gloc ({ de_loc = loc } as de) ppl =
let pp, ty, denv = dpattern denv lp in let pp, ty, denv = dpattern denv lp in
pp::ppl, (lp.pat_loc,ty)::tyl, denv in pp::ppl, (lp.pat_loc,ty)::tyl, denv in
let ppl, tyl, denv = List.fold_right add_pp ppl ([],[],denv) in let ppl, tyl, denv = List.fold_right add_pp ppl ([],[],denv) in
let pp = match de.de_desc with let pp, ls = match de.de_desc with
| DEglobal_pl pl -> Mlw_expr.PPpapp (pl, ppl) | DEglobal_pl pl -> Mlw_expr.PPpapp (pl, ppl), pl.pl_ls
| DEglobal_ls ls -> PPlapp (ls, ppl) | DEglobal_ls ls -> Mlw_expr.PPlapp (ls, ppl), ls
| DEglobal_pv pv -> errorm ~loc "%a is not a constructor" print_pv pv | 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 | DEglobal_ps ps -> errorm ~loc "%a is not a constructor" print_ps ps
| _ -> assert false | _ -> assert false
in in
let res = create_type_variable () in let argl, res = de.de_type in
Loc.try2 gloc unify_list de.de_type tyl res; 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 pp, res, denv
(* specifications *) (* specifications *)
...@@ -352,22 +358,22 @@ let deff_of_peff uc pe = ...@@ -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 dxpost uc ql = List.map (fun (q,f) -> find_xsymbol uc q, f) ql
let rec dtype_c denv tyc = 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_result = tyv;
dc_effect = deff_of_peff denv.uc tyc.pc_effect; dc_effect = deff_of_peff denv.uc tyc.pc_effect;
dc_pre = tyc.pc_pre; dc_pre = tyc.pc_pre;
dc_post = fst tyc.pc_post; dc_post = fst tyc.pc_post;
dc_xpost = dxpost denv.uc (snd tyc.pc_post); }, dc_xpost = dxpost denv.uc (snd tyc.pc_post); },
dity dvty
and dtype_v denv = function and dtype_v denv = function
| Tpure pty -> | Tpure pty ->
let dity = dity_of_pty ~user:true denv pty in let dity = dity_of_pty ~user:true denv pty in
DSpecV (false,dity), dity DSpecV (false,dity), ([],dity)
| Tarrow (bl,tyc) -> | Tarrow (bl,tyc) ->
let denv,bl,tyl = dbinders denv bl in let denv,bl,tyl = dbinders denv bl in
let tyc,dity = dtype_c denv tyc in let tyc,(argl,res) = dtype_c denv tyc in
DSpecA (bl,tyc), make_arrow_type tyl dity DSpecA (bl,tyc), (tyl @ argl,res)
let dvariant uc = function let dvariant uc = function
| Some (le, Some q) -> [le, Some (find_variant_ls uc q)] | Some (le, Some q) -> [le, Some (find_variant_ls uc q)]
...@@ -381,11 +387,20 @@ let dvariant uc = function ...@@ -381,11 +387,20 @@ let dvariant uc = function
let de_unit ~loc = hidden_ls ~loc (Term.fs_tuple 0) let de_unit ~loc = hidden_ls ~loc (Term.fs_tuple 0)
let de_app loc e el = let de_app _loc e el =
let res = create_type_variable () in let argl, res = e.de_type in
let tyl = List.map (fun a -> (a.de_loc, a.de_type)) el in let rec unify_list argl el = match argl, el with
Loc.try2 loc unify_list e.de_type tyl res; | arg::argl, e::el when Loc.equal e.de_loc Loc.dummy_position ->
DEapply (e, el), res 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 rec dexpr denv e =
let loc = e.Ptree.expr_loc in let loc = e.Ptree.expr_loc in
...@@ -398,9 +413,9 @@ let rec dexpr denv e = ...@@ -398,9 +413,9 @@ let rec dexpr denv e =
and de_desc denv loc = function and de_desc denv loc = function
| Ptree.Eident (Qident {id=x}) when Mstr.mem x denv.locals -> | Ptree.Eident (Qident {id=x}) when Mstr.mem x denv.locals ->
(* local variable *) (* local variable *)
let tvs, dity = Mstr.find x denv.locals in let tvs, dvty = Mstr.find x denv.locals in
let dity = specialize_scheme tvs dity in let dvty = specialize_scheme tvs dvty in
DElocal x, dity DElocal x, dvty
| Ptree.Eident p -> | Ptree.Eident p ->
specialize_qualid denv.uc p specialize_qualid denv.uc p
| Ptree.Eapply (e1, e2) -> | Ptree.Eapply (e1, e2) ->
...@@ -409,24 +424,25 @@ and de_desc denv loc = function ...@@ -409,24 +424,25 @@ and de_desc denv loc = function
de_app loc (dexpr denv e) el de_app loc (dexpr denv e) el
| Ptree.Elet (id, gh, e1, e2) -> | Ptree.Elet (id, gh, e1, e2) ->
let e1 = dexpr denv e1 in 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 let tvars = match e1.de_desc with
| DEfun _ -> denv.tvars | DEfun _ -> denv.tvars
| _ -> add_tvars denv.tvars dity in | _ -> add_dvty denv.tvars dvty in
let locals = Mstr.add id.id (tvars, dity) denv.locals in let locals = Mstr.add id.id (tvars, dvty) denv.locals in
let denv = { denv with locals = locals; tvars = tvars } in let denv = { denv with locals = locals; tvars = tvars } in
let e2 = dexpr denv e2 in let e2 = dexpr denv e2 in
DElet (id, gh, e1, e2), e2.de_type DElet (id, gh, e1, e2), e2.de_type
| Ptree.Eletrec (rdl, e1) -> | Ptree.Eletrec (rdl, e1) ->
let rdl = dletrec denv rdl in let rdl = dletrec denv rdl in
let add_one denv (_, { id = id }, _, dity, _) = let add_one denv (_, { id = id }, _, dvty, _) =
{ denv with locals = Mstr.add id (denv.tvars, dity) denv.locals } in { denv with locals = Mstr.add id (denv.tvars, dvty) denv.locals } in
let denv = List.fold_left add_one denv rdl in let denv = List.fold_left add_one denv rdl in
let e1 = dexpr denv e1 in let e1 = dexpr denv e1 in
DEletrec (rdl, e1), e1.de_type DEletrec (rdl, e1), e1.de_type
| Ptree.Efun (bl, tr) -> | Ptree.Efun (bl, tr) ->
let lam, dity = dlambda denv bl None tr in let denv, bl, tyl = dbinders denv bl in
DEfun lam, dity let lam, (argl, res) = dlambda denv bl None tr in
DEfun lam, (tyl @ argl, res)
| Ptree.Ecast (e1, pty) -> | Ptree.Ecast (e1, pty) ->
let e1 = dexpr denv e1 in let e1 = dexpr denv e1 in
expected_type e1 (dity_of_pty ~user:false denv pty); expected_type e1 (dity_of_pty ~user:false denv pty);
...@@ -443,7 +459,9 @@ and de_desc denv loc = function ...@@ -443,7 +459,9 @@ and de_desc denv loc = function
expected_type e1 dity_bool; expected_type e1 dity_bool;
let e2 = dexpr denv e2 in let e2 = dexpr denv e2 in
let e3 = dexpr denv e3 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 DEif (e1, e2, e3), e2.de_type
| Ptree.Etuple el -> | Ptree.Etuple el ->
let ls = fs_tuple (List.length el) in let ls = fs_tuple (List.length el) in
...@@ -474,8 +492,8 @@ and de_desc denv loc = function ...@@ -474,8 +492,8 @@ and de_desc denv loc = function
| Some e -> dexpr denv e | Some e -> dexpr denv e
| None -> | None ->
let loc = Loc.dummy_position in let loc = Loc.dummy_position in
let d, dity = de_app loc (hidden_ls ~loc pj) [e0] in let d, dvty = de_app loc (hidden_ls ~loc pj) [e0] in
mk_dexpr d dity loc Slab.empty in mk_dexpr d dvty loc Slab.empty in
let res = de_app loc (hidden_ls ~loc cs) (List.map get_val pjl) in let res = de_app loc (hidden_ls ~loc cs) (List.map get_val pjl) in
mk_let ~loc ~uloc:denv.uloc e1 res mk_let ~loc ~uloc:denv.uloc e1 res
| Ptree.Eupdate (e1, fl) -> | Ptree.Eupdate (e1, fl) ->
...@@ -487,8 +505,8 @@ and de_desc denv loc = function ...@@ -487,8 +505,8 @@ and de_desc denv loc = function
| Some e -> dexpr denv e | Some e -> dexpr denv e
| None -> | None ->
let loc = Loc.dummy_position in let loc = Loc.dummy_position in
let d, dity = de_app loc (hidden_pl ~loc pj) [e0] in let d, dvty = de_app loc (hidden_pl ~loc pj) [e0] in
mk_dexpr d dity loc Slab.empty in mk_dexpr d dvty loc Slab.empty in
let res = de_app loc (hidden_pl ~loc cs) (List.map get_val pjl) in let res = de_app loc (hidden_pl ~loc cs) (List.map get_val pjl) in
mk_let ~loc ~uloc:denv.uloc e1 res mk_let ~loc ~uloc:denv.uloc e1 res
| Ptree.Eassign (e1, q, e2) -> | Ptree.Eassign (e1, q, e2) ->
...@@ -496,34 +514,37 @@ and de_desc denv loc = function ...@@ -496,34 +514,37 @@ and de_desc denv loc = function
let e1 = { expr_desc = Eapply (fl,e1); expr_loc = loc } in let e1 = { expr_desc = Eapply (fl,e1); expr_loc = loc } in
let e1 = dexpr denv e1 in let e1 = dexpr denv e1 in
let e2 = dexpr denv e2 in let e2 = dexpr denv e2 in
expected_type ~weak:true e2 e1.de_type; let res = create_type_variable () in
DEassign (e1, e2), dity_unit expected_type e1 res;
expected_type_weak e2 res;
DEassign (e1, e2), ([], dity_unit)
| Ptree.Econstant (ConstInt _ as c) -> | Ptree.Econstant (ConstInt _ as c) ->
DEconstant c, dity_int DEconstant c, ([], dity_int)
| Ptree.Econstant (ConstReal _ as c) -> | Ptree.Econstant (ConstReal _ as c) ->
DEconstant c, dity_real DEconstant c, ([], dity_real)
| Ptree.Enot e1 -> | Ptree.Enot e1 ->
let e1 = dexpr denv e1 in let e1 = dexpr denv e1 in
expected_type e1 dity_bool; expected_type e1 dity_bool;
DEnot e1, dity_bool DEnot e1, ([], dity_bool)
| Ptree.Elazy (op, e1, e2) -> | Ptree.Elazy (op, e1, e2) ->
let e1 = dexpr denv e1 in let e1 = dexpr denv e1 in
let e2 = dexpr denv e2 in let e2 = dexpr denv e2 in