Commit 0dc78832 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre
Browse files

no more prelude theory for programs

parent 2899d9b7
...@@ -51,7 +51,18 @@ and type_var = { ...@@ -51,7 +51,18 @@ and type_var = {
} }
let tyvar v = Tyvar v let tyvar v = Tyvar v
let tyapp (s, tyl) = Tyapp (s, tyl)
let rec type_inst s ty = match ty.ty_node with
| Ty.Tyvar n -> Mtv.find n s
| Ty.Tyapp (ts, tyl) -> Tyapp (ts, List.map (type_inst s) tyl)
let tyapp ts tyl = match ts.ts_def with
| None ->
Tyapp (ts, tyl)
| Some ty ->
let add m v t = Mtv.add v t m in
let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
type_inst s ty
type dty = dty_view type dty = dty_view
......
...@@ -32,7 +32,7 @@ val create_ty_decl_var : ?loc:Ptree.loc -> user:bool -> tvsymbol -> type_var ...@@ -32,7 +32,7 @@ val create_ty_decl_var : ?loc:Ptree.loc -> user:bool -> tvsymbol -> type_var
type dty type dty
val tyvar : type_var -> dty val tyvar : type_var -> dty
val tyapp : tysymbol * dty list -> dty val tyapp : tysymbol -> dty list -> dty
type dty_view = type dty_view =
| Tyvar of type_var | Tyvar of type_var
......
...@@ -198,10 +198,6 @@ let add_ind_decls = with_tuples ~reset:true add_ind_decl ...@@ -198,10 +198,6 @@ let add_ind_decls = with_tuples ~reset:true add_ind_decl
let add_prop_decl = with_tuples ~reset:true add_prop_decl let add_prop_decl = with_tuples ~reset:true add_prop_decl
let rec type_inst s ty = match ty.ty_node with
| Ty.Tyvar n -> Mtv.find n s
| Ty.Tyapp (ts, tyl) -> tyapp (ts, List.map (type_inst s) tyl)
let rec dty uc env = function let rec dty uc env = function
| PPTtyvar {id=x} -> | PPTtyvar {id=x} ->
tyvar (find_user_type_var x env) tyvar (find_user_type_var x env)
...@@ -211,17 +207,10 @@ let rec dty uc env = function ...@@ -211,17 +207,10 @@ let rec dty uc env = function
let np = List.length p in let np = List.length p in
if np <> a then error ~loc (TypeArity (x, a, np)); if np <> a then error ~loc (TypeArity (x, a, np));
let tyl = List.map (dty uc env) p in let tyl = List.map (dty uc env) p in
begin match ts.ts_def with tyapp ts tyl
| None ->
tyapp (ts, tyl)
| Some ty ->
let add m v t = Mtv.add v t m in
let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
type_inst s ty
end
| PPTtuple tyl -> | PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in let ts = ts_tuple (List.length tyl) in
tyapp (ts, List.map (dty uc env) tyl) tyapp ts (List.map (dty uc env) tyl)
let find_ns find p ns = let find_ns find p ns =
let loc = qloc p in let loc = qloc p in
...@@ -407,7 +396,7 @@ and dpat_node loc uc env = function ...@@ -407,7 +396,7 @@ and dpat_node loc uc env = function
let s = fs_tuple n in let s = fs_tuple n in
let tyl = List.map (fun _ -> fresh_type_var loc) pl in let tyl = List.map (fun _ -> fresh_type_var loc) pl in
let env, pl = dpat_args s.ls_name loc uc env tyl pl in let env, pl = dpat_args s.ls_name loc uc env tyl pl in
let ty = tyapp (ts_tuple n, tyl) in let ty = tyapp (ts_tuple n) tyl in
env, Papp (s, pl), ty env, Papp (s, pl), ty
| PPpas (p, x) -> | PPpas (p, x) ->
let env, p = dpat uc env p in let env, p = dpat uc env p in
...@@ -493,16 +482,16 @@ and dterm_node ~localize loc uc env = function ...@@ -493,16 +482,16 @@ and dterm_node ~localize loc uc env = function
let s = fs_tuple n in let s = fs_tuple n in
let tyl = List.map (fun _ -> fresh_type_var loc) tl in let tyl = List.map (fun _ -> fresh_type_var loc) tl in
let tl = dtype_args s.ls_name loc uc env tyl tl in let tl = dtype_args s.ls_name loc uc env tyl tl in
let ty = tyapp (ts_tuple n, tyl) in let ty = tyapp (ts_tuple n) tyl in
Tapp (s, tl), ty Tapp (s, tl), ty
| PPinfix (e1, x, e2) -> | PPinfix (e1, x, e2) ->
let s, tyl, ty = specialize_fsymbol (Qident x) uc in let s, tyl, ty = specialize_fsymbol (Qident x) uc in
let tl = dtype_args s.ls_name loc uc env tyl [e1; e2] in let tl = dtype_args s.ls_name loc uc env tyl [e1; e2] in
Tapp (s, tl), ty Tapp (s, tl), ty
| PPconst (ConstInt _ as c) -> | PPconst (ConstInt _ as c) ->
Tconst c, tyapp (Ty.ts_int, []) Tconst c, tyapp Ty.ts_int []
| PPconst (ConstReal _ as c) -> | PPconst (ConstReal _ as c) ->
Tconst c, tyapp (Ty.ts_real, []) Tconst c, tyapp Ty.ts_real []
| PPlet (x, e1, e2) -> | PPlet (x, e1, e2) ->
let e1 = dterm ~localize uc env e1 in let e1 = dterm ~localize uc env e1 in
let ty = e1.dt_ty in let ty = e1.dt_ty in
...@@ -574,7 +563,7 @@ and dterm_node ~localize loc uc env = function ...@@ -574,7 +563,7 @@ and dterm_node ~localize loc uc env = function
| TRterm t -> | TRterm t ->
let id = { id = "fc"; id_lab = []; id_loc = loc } in let id = { id = "fc"; id_lab = []; id_loc = loc } in
let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) -> let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) ->
let nty = tyapp (ts_func, [uty;ty]) in ty :: tyl, nty) let nty = tyapp ts_func [uty;ty] in ty :: tyl, nty)
uqu ([],t.dt_ty) uqu ([],t.dt_ty)
in in
let h = { dt_node = Tvar id.id ; dt_ty = ty } in let h = { dt_node = Tvar id.id ; dt_ty = ty } in
...@@ -591,8 +580,8 @@ and dterm_node ~localize loc uc env = function ...@@ -591,8 +580,8 @@ and dterm_node ~localize loc uc env = function
| [] -> assert false | [] -> assert false
in in
let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) -> let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) ->
let nty = tyapp (ts_func, [uty;ty]) in ty :: tyl, nty) let nty = tyapp ts_func [uty;ty] in ty :: tyl, nty)
uqu ([],tyapp (ts_pred, [uty])) uqu ([], tyapp ts_pred [uty])
in in
let h = { dt_node = Tvar id.id ; dt_ty = ty } in let h = { dt_node = Tvar id.id ; dt_ty = ty } in
let h = List.fold_left2 (fun h (uid,uty) ty -> let h = List.fold_left2 (fun h (uid,uty) ty ->
......
...@@ -59,8 +59,6 @@ val create_denv : unit -> denv ...@@ -59,8 +59,6 @@ val create_denv : unit -> denv
val create_user_type_var : string -> Denv.type_var val create_user_type_var : string -> Denv.type_var
val find_user_type_var : string -> denv -> Denv.type_var val find_user_type_var : string -> denv -> Denv.type_var
val type_inst : Denv.dty Ty.Mtv.t -> Ty.ty -> Denv.dty
val mem_var : string -> denv -> bool val mem_var : string -> denv -> bool
val find_var : string -> denv -> Denv.dty val find_var : string -> denv -> Denv.dty
val add_var : string -> Denv.dty -> denv -> denv val add_var : string -> Denv.dty -> denv -> denv
......
...@@ -39,10 +39,10 @@ let add_module ?(type_only=false) env penv (ltm, lmod) m = ...@@ -39,10 +39,10 @@ let add_module ?(type_only=false) env penv (ltm, lmod) m =
if Mnm.mem id.id lmod then raise (Loc.Located (loc, ClashModule id.id)); if Mnm.mem id.id lmod then raise (Loc.Located (loc, ClashModule id.id));
let wp = not type_only in let wp = not type_only in
let uc = create_module (Ident.id_user id.id loc) in let uc = create_module (Ident.id_user id.id loc) in
let prelude = Env.find_theory env ["programs"] "Prelude" in let prelude = Env.find_theory env ["bool"] "Bool" in
let uc = use_export_theory uc prelude in let uc = use_export_theory uc prelude in
let uc = let uc =
List.fold_left (Pgm_typing.decl ~wp env penv ltm lmod) uc m.mod_decl List.fold_left (Pgm_typing.decl ~wp env penv ltm lmod) uc m.mod_decl
in in
let m = close_module uc in let m = close_module uc in
Mnm.add id.id m.m_pure ltm, Mnm.add id.id m.m_pure ltm,
...@@ -57,17 +57,17 @@ let retrieve penv file c = ...@@ -57,17 +57,17 @@ let retrieve penv file c =
else else
let type_only = Debug.test_flag Typing.debug_type_only in let type_only = Debug.test_flag Typing.debug_type_only in
let env = Pgm_env.get_env penv in let env = Pgm_env.get_env penv in
List.fold_left (add_module ~type_only env penv) List.fold_left (add_module ~type_only env penv)
(Mnm.empty, Mnm.empty) ml (Mnm.empty, Mnm.empty) ml
let pgm_env_of_env = let pgm_env_of_env =
let h = Env.Wenv.create 17 in let h = Env.Wenv.create 17 in
fun env -> fun env ->
try try
Env.Wenv.find h env Env.Wenv.find h env
with Not_found -> with Not_found ->
let penv = Pgm_env.create env retrieve in let penv = Pgm_env.create env retrieve in
Env.Wenv.set h env penv; Env.Wenv.set h env penv;
penv penv
let read_channel env file c = let read_channel env file c =
......
...@@ -20,6 +20,8 @@ ...@@ -20,6 +20,8 @@
open Why open Why
open Util open Util
open Ident open Ident
open Ty
open Decl
open Theory open Theory
open Term open Term
...@@ -93,8 +95,8 @@ let pure_uc uc = uc.uc_pure ...@@ -93,8 +95,8 @@ let pure_uc uc = uc.uc_pure
let add_pervasives uc = let add_pervasives uc =
(* type unit = () *) (* type unit = () *)
let ts = let ts =
Ty.create_tysymbol Ty.create_tysymbol
(id_fresh "unit") [] (Some (Ty.ty_app (Ty.ts_tuple 0) [])) (id_fresh "unit") [] (Some (Ty.ty_app (Ty.ts_tuple 0) []))
in in
add_ty_decl uc [ts, Decl.Tabstract] add_ty_decl uc [ts, Decl.Tabstract]
...@@ -162,15 +164,41 @@ let add_psymbol ps uc = ...@@ -162,15 +164,41 @@ let add_psymbol ps uc =
let ls_Exit = create_lsymbol (id_fresh "%Exit") [] (Some ty_exn) let ls_Exit = create_lsymbol (id_fresh "%Exit") [] (Some ty_exn)
let create_module n = (* type unit = () *)
let m = { let ty_unit = ty_tuple []
let ts_unit = create_tysymbol (id_fresh "unit") [] (Some ty_unit)
(* logic ignore 'a : () *)
let ts_label = create_tysymbol (id_fresh "label") [] None
let ty_label = ty_app ts_label []
let fs_at =
let ty = ty_var (create_tvsymbol (id_fresh "a")) in
create_lsymbol (id_fresh "at") [ty; ty_label] (Some ty)
let fs_old =
let ty = ty_var (create_tvsymbol (id_fresh "a")) in
create_lsymbol (id_fresh "old") [ty] (Some ty)
let th_prelude =
let uc = create_theory (id_fresh "Prelude") in
let uc = use_export uc (tuple_theory 0) in
let uc = add_ty_decl uc [ts_unit, Tabstract] in
let uc = add_ty_decl uc [ts_label, Tabstract] in
let uc = add_logic_decl uc [fs_at, None] in
let uc = add_logic_decl uc [fs_old, None] in
close_theory uc
let empty_module n =
let m = {
uc_name = id_register n; uc_name = id_register n;
uc_impure = Theory.create_theory n; uc_impure = Theory.create_theory n;
uc_effect = Theory.create_theory n; uc_effect = Theory.create_theory n;
uc_pure = Theory.create_theory n; uc_pure = Theory.create_theory n;
uc_decls = []; uc_decls = [];
uc_import = [empty_ns]; uc_import = [empty_ns];
uc_export = [empty_ns]; } uc_export = [empty_ns]; }
in in
(* pervasives *) (* pervasives *)
let m = add_esymbol ls_Exit m in let m = add_esymbol ls_Exit m in
...@@ -199,9 +227,9 @@ let close_module uc = match uc.uc_export with ...@@ -199,9 +227,9 @@ let close_module uc = match uc.uc_export with
{ m_name = uc.uc_name; { m_name = uc.uc_name;
m_decls = List.rev uc.uc_decls; m_decls = List.rev uc.uc_decls;
m_export = e; m_export = e;
m_impure = close_theory uc.uc_impure; m_impure = close_theory uc.uc_impure;
m_effect = close_theory uc.uc_effect; m_effect = close_theory uc.uc_effect;
m_pure = close_theory uc.uc_pure; m_pure = close_theory uc.uc_pure;
} }
| _ -> | _ ->
raise CloseModule raise CloseModule
...@@ -213,21 +241,21 @@ let use_export uc m = ...@@ -213,21 +241,21 @@ let use_export uc m =
| i0 :: sti, e0 :: ste -> { uc with | i0 :: sti, e0 :: ste -> { uc with
uc_import = merge_ns false m.m_export i0 :: sti; uc_import = merge_ns false m.m_export i0 :: sti;
uc_export = merge_ns true m.m_export e0 :: ste; uc_export = merge_ns true m.m_export e0 :: ste;
uc_impure = Theory.use_export uc.uc_impure m.m_impure; uc_impure = Theory.use_export uc.uc_impure m.m_impure;
uc_effect = Theory.use_export uc.uc_effect m.m_effect; uc_effect = Theory.use_export uc.uc_effect m.m_effect;
uc_pure = Theory.use_export uc.uc_pure m.m_pure; } uc_pure = Theory.use_export uc.uc_pure m.m_pure; }
| _ -> assert false | _ -> assert false
let use_export_theory uc th = let use_export_theory uc th =
let uc = let uc =
{ uc with { uc with
uc_impure = Theory.use_export uc.uc_impure th; uc_impure = Theory.use_export uc.uc_impure th;
uc_effect = Theory.use_export uc.uc_effect th; uc_effect = Theory.use_export uc.uc_effect th;
uc_pure = Theory.use_export uc.uc_pure th; } uc_pure = Theory.use_export uc.uc_pure th; }
in in
(* all type symbols from th are added as (pure) mtsymbols *) (* all type symbols from th are added as (pure) mtsymbols *)
let add_ts _ ts = let add_ts _ ts =
ignore ignore
(create_mtsymbol ~impure:ts ~effect:ts ~pure:ts ~singleton:false) (create_mtsymbol ~impure:ts ~effect:ts ~pure:ts ~singleton:false)
in in
let rec add_ns ns uc = let rec add_ns ns uc =
...@@ -236,6 +264,10 @@ let use_export_theory uc th = ...@@ -236,6 +264,10 @@ let use_export_theory uc th =
in in
add_ns th.th_export uc add_ns th.th_export uc
let create_module id =
let uc = empty_module id in
use_export_theory uc th_prelude
let add_impure_pdecl env ltm d uc = let add_impure_pdecl env ltm d uc =
{ uc with uc_impure = Typing.add_decl env ltm uc.uc_impure d } { uc with uc_impure = Typing.add_decl env ltm uc.uc_impure d }
...@@ -246,14 +278,14 @@ let add_pure_pdecl env ltm d uc = ...@@ -246,14 +278,14 @@ let add_pure_pdecl env ltm d uc =
{ uc with uc_pure = Typing.add_decl env ltm uc.uc_pure d; } { uc with uc_pure = Typing.add_decl env ltm uc.uc_pure d; }
let add_pdecl env ltm d uc = let add_pdecl env ltm d uc =
{ uc with { uc with
uc_impure = Typing.add_decl env ltm uc.uc_impure d; uc_impure = Typing.add_decl env ltm uc.uc_impure d;
uc_effect = Typing.add_decl env ltm uc.uc_effect d; uc_effect = Typing.add_decl env ltm uc.uc_effect d;
uc_pure = Typing.add_decl env ltm uc.uc_pure d; } uc_pure = Typing.add_decl env ltm uc.uc_pure d; }
(* (*
Local Variables: Local Variables:
compile-command: "unset LANG; make -C ../.. testl" compile-command: "unset LANG; make -C ../.. testl"
End: End:
*) *)
...@@ -19,6 +19,7 @@ ...@@ -19,6 +19,7 @@
open Why open Why
open Ident open Ident
open Ty
open Term open Term
open Theory open Theory
open Pgm_types open Pgm_types
...@@ -72,17 +73,30 @@ val add_impure_decl : Decl.decl -> uc -> uc ...@@ -72,17 +73,30 @@ val add_impure_decl : Decl.decl -> uc -> uc
val add_effect_decl : Decl.decl -> uc -> uc val add_effect_decl : Decl.decl -> uc -> uc
val add_pure_decl : Decl.decl -> uc -> uc val add_pure_decl : Decl.decl -> uc -> uc
val add_impure_pdecl : val add_impure_pdecl :
Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc
val add_effect_pdecl : val add_effect_pdecl :
Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc
val add_pure_pdecl : val add_pure_pdecl :
Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc
val add_pdecl : val add_pdecl :
Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc
(** add in impure, effect and pure *) (** add in impure, effect and pure *)
(** builtins *)
val ts_label : tysymbol
val ty_label : ty
val ts_unit : tysymbol
val ty_unit : ty
val fs_old : lsymbol
val fs_at : lsymbol
val th_prelude : theory
(** exceptions *) (** exceptions *)
exception CloseModule exception CloseModule
...@@ -80,18 +80,16 @@ let is_mutable_field ts i = ...@@ -80,18 +80,16 @@ let is_mutable_field ts i =
(* phase 1: typing programs (using destructive type inference) **************) (* phase 1: typing programs (using destructive type inference) **************)
let dty_app (ts, tyl) = assert (ts.ts_def = None); tyapp (ts, tyl)
let find_ts ~pure uc s = let find_ts ~pure uc s =
ns_find_ts (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s] ns_find_ts (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s]
let find_ls ~pure uc s = let find_ls ~pure uc s =
ns_find_ls (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s] ns_find_ls (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s]
(* TODO: improve efficiency *) (* TODO: improve efficiency *)
let dty_bool uc = dty_app (find_ts ~pure:true uc "bool", []) let dty_bool uc = tyapp (find_ts ~pure:true uc "bool") []
let dty_int _uc = dty_app (Ty.ts_int, []) let dty_int _uc = tyapp Ty.ts_int []
let dty_unit _uc = dty_app (ts_tuple 0, []) let dty_unit _uc = tyapp (ts_tuple 0) []
let dty_label uc = dty_app (find_ts ~pure:true uc "label_", []) let dty_label _uc = tyapp ts_label []
(* note: local variables are simultaneously in locals (to type programs) (* note: local variables are simultaneously in locals (to type programs)
and in denv (to type logic elements) *) and in denv (to type logic elements) *)
...@@ -111,7 +109,7 @@ let loc_of_id id = Util.of_option id.Ident.id_loc ...@@ -111,7 +109,7 @@ let loc_of_id id = Util.of_option id.Ident.id_loc
let loc_of_ls ls = ls.ls_name.Ident.id_loc let loc_of_ls ls = ls.ls_name.Ident.id_loc
let dcurrying tyl ty = let dcurrying tyl ty =
let make_arrow_type ty1 ty2 = dty_app (ts_arrow, [ty1; ty2]) in let make_arrow_type ty1 ty2 = tyapp ts_arrow [ty1; ty2] in
List.fold_right make_arrow_type tyl ty List.fold_right make_arrow_type tyl ty
type region_policy = Region_var | Region_ret | Region_glob type region_policy = Region_var | Region_ret | Region_glob
...@@ -176,7 +174,7 @@ let rec specialize_ty ?(policy=Region_var) ~loc htv ty = match ty.ty_node with ...@@ -176,7 +174,7 @@ let rec specialize_ty ?(policy=Region_var) ~loc htv ty = match ty.ty_node with
in in
let regions = List.map mk_region (Util.prefix n tl) in let regions = List.map mk_region (Util.prefix n tl) in
let tl = List.map (specialize_ty ~policy ~loc htv) (Util.chop n tl) in let tl = List.map (specialize_ty ~policy ~loc htv) (Util.chop n tl) in
tyapp (ts, regions @ tl) tyapp ts (regions @ tl)
let rec specialize_type_v ?(policy=Region_var) ~loc htv = function let rec specialize_type_v ?(policy=Region_var) ~loc htv = function
| Tpure ty -> | Tpure ty ->
...@@ -245,7 +243,7 @@ let dexception uc qid = ...@@ -245,7 +243,7 @@ let dexception uc qid =
let sl = Typing.string_list_of_qualid [] qid in let sl = Typing.string_list_of_qualid [] qid in
let loc = Typing.qloc qid in let loc = Typing.qloc qid in
let _, _, ty as r = specialize_exception loc sl uc in let _, _, ty as r = specialize_exception loc sl uc in
let ty_exn = dty_app (ts_exn, []) in let ty_exn = tyapp ts_exn [] in
if not (Denv.unify ty ty_exn) then if not (Denv.unify ty ty_exn) then
errorm ~loc errorm ~loc
"@[this expression has type %a,@ but is expected to be an exception@]" "@[this expression has type %a,@ but is expected to be an exception@]"
...@@ -291,17 +289,10 @@ let rec dtype ~user env = function ...@@ -291,17 +289,10 @@ let rec dtype ~user env = function
print_qualid x (a - mt.mt_regions) np; print_qualid x (a - mt.mt_regions) np;
let tyl = List.map (dtype ~user env) p in let tyl = List.map (dtype ~user env) p in
let tyl = create_regions ~user mt.mt_regions @ tyl in let tyl = create_regions ~user mt.mt_regions @ tyl in
begin match ts.ts_def with tyapp ts tyl
| None ->
tyapp (ts, tyl)
| Some ty ->
let add m v t = Mtv.add v t m in
let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
Typing.type_inst s ty
end
| PPTtuple tyl -> | PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in let ts = ts_tuple (List.length tyl) in
tyapp (ts, List.map (dtype ~user env) tyl) tyapp ts (List.map (dtype ~user env) tyl)
let rec dutype_v env = function let rec dutype_v env = function
| Ptree.Tpure pt -> | Ptree.Tpure pt ->
...@@ -389,9 +380,9 @@ let rec dexpr ~ghost env e = ...@@ -389,9 +380,9 @@ let rec dexpr ~ghost env e =
and dexpr_desc ~ghost env loc = function and dexpr_desc ~ghost env loc = function
| Ptree.Econstant (ConstInt _ as c) -> | Ptree.Econstant (ConstInt _ as c) ->
DEconstant c, dty_app (Ty.ts_int, []) DEconstant c, tyapp Ty.ts_int []
| Ptree.Econstant (ConstReal _ as c) -> | Ptree.Econstant (ConstReal _ as c) ->
DEconstant c, dty_app (Ty.ts_real, []) DEconstant c, tyapp Ty.ts_real []
| Ptree.Eident (Qident {id=x}) when Mstr.mem x env.locals -> | Ptree.Eident (Qident {id=x}) when Mstr.mem x env.locals ->
(* local variable *) (* local variable *)
let tyv = Mstr.find x env.locals in let tyv = Mstr.find x env.locals in
...@@ -437,7 +428,7 @@ and dexpr_desc ~ghost env loc = function ...@@ -437,7 +428,7 @@ and dexpr_desc ~ghost env loc = function
let ghost = ghost (* || is_ps_ghost e1 *) in let ghost = ghost (* || is_ps_ghost e1 *) in
let e2 = dexpr ~ghost env e2 in let e2 = dexpr ~ghost env e2 in
let ty2 = create_type_var loc and ty = create_type_var loc in let ty2 = create_type_var loc and ty = create_type_var loc in
if not (Denv.unify e1.dexpr_type (dty_app (ts_arrow, [ty2; ty]))) then if not (Denv.unify e1.dexpr_type (tyapp ts_arrow [ty2; ty])) then
errorm ~loc:e1.dexpr_loc "this expression is not a function"; errorm ~loc:e1.dexpr_loc "this expression is not a function";
expected_type e2 ty2; expected_type e2 ty2;
DEapply (e1, e2), ty DEapply (e1, e2), ty
...@@ -461,13 +452,13 @@ and dexpr_desc ~ghost env loc = function ...@@ -461,13 +452,13 @@ and dexpr_desc ~ghost env loc = function
let n = List.length el in let n = List.length el in
let s = Typing.fs_tuple n in let s = Typing.fs_tuple n in
let tyl = List.map (fun _ -> create_type_var loc) el in let tyl = List.map (fun _ -> create_type_var loc) el in
let ty = dty_app (Typing.ts_tuple n, tyl) in let ty = tyapp (Typing.ts_tuple n) tyl in
let create d ty