Commit 59fd421a authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

whyml: specification typing, part 1

parent f118cf52
...@@ -44,7 +44,7 @@ type deffect = { ...@@ -44,7 +44,7 @@ type deffect = {
} }
type dtype_v = type dtype_v =
| DSpecV of dity | DSpecV of ghost * dity
| DSpecA of dbinder list * dtype_c | DSpecA of dbinder list * dtype_c
and dtype_c = { and dtype_c = {
......
...@@ -215,7 +215,7 @@ and build_v vars = function ...@@ -215,7 +215,7 @@ and build_v vars = function
let vty = build_c (List.fold_left add_arg vars pvl) tyc in let vty = build_c (List.fold_left add_arg vars pvl) tyc in
VTarrow (spec_arrow pvl tyc.c_effect vty) VTarrow (spec_arrow pvl tyc.c_effect vty)
let create_val_decl id tyv = let create_val id tyv =
let varm = check_v tyv in let varm = check_v tyv in
let vars = varmap_join varm vars_empty in let vars = varmap_join varm vars_empty in
let name = match build_v vars tyv with let name = match build_v vars tyv with
......
...@@ -114,7 +114,7 @@ type val_decl = private { ...@@ -114,7 +114,7 @@ type val_decl = private {
val_vars : varset Mid.t; val_vars : varset Mid.t;
} }
val create_val_decl : Ident.preid -> type_v -> val_decl val create_val : Ident.preid -> type_v -> val_decl
(** patterns *) (** patterns *)
......
...@@ -313,13 +313,14 @@ and dpat_app denv ({ de_loc = loc } as de) ppl = ...@@ -313,13 +313,14 @@ and dpat_app denv ({ de_loc = loc } as de) ppl =
(* specifications *) (* specifications *)
let dbinder (id,pty) (denv,bl,tyl) = let dbinders denv bl =
let dity = match pty with let dbinder (id,pty) (denv,bl,tyl) =
| Some pty -> dity_of_pty ~user:true denv pty let dity = match pty with
| None -> create_type_variable () in | Some pty -> dity_of_pty ~user:true denv pty
add_var id dity denv, (id,false,dity)::bl, dity::tyl | None -> create_type_variable () in
add_var id dity denv, (id,false,dity)::bl, dity::tyl
let dbinders denv bl = List.fold_right dbinder bl (denv,[],[]) in
List.fold_right dbinder bl (denv,[],[])
let deff_of_peff uc pe = let deff_of_peff uc pe =
{ deff_reads = List.map (fun le -> false, le) pe.pe_reads; { deff_reads = List.map (fun le -> false, le) pe.pe_reads;
...@@ -340,7 +341,7 @@ let rec dtype_c denv tyc = ...@@ -340,7 +341,7 @@ let rec dtype_c denv tyc =
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 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,dity = dtype_c denv tyc in
...@@ -554,7 +555,7 @@ and dlambda denv bl var (p, e, (q, xq)) = ...@@ -554,7 +555,7 @@ and dlambda denv bl var (p, e, (q, xq)) =
*) *)
(bl, var, p, e, q, dxpost denv.uc xq), make_arrow_type tyl e.de_type (bl, var, p, e, q, dxpost denv.uc xq), make_arrow_type tyl e.de_type
(* second stage *) (** stage 2 *)
type lenv = { type lenv = {
mod_uc : module_uc; mod_uc : module_uc;
...@@ -600,6 +601,41 @@ let add_local x lv lenv = match lv with ...@@ -600,6 +601,41 @@ let add_local x lv lenv = match lv with
exception DuplicateException of xsymbol exception DuplicateException of xsymbol
let binders lenv bl =
let binder lenv (id, ghost, dity) =
let vtv = vty_value ~ghost (ity_of_dity dity) in
let pv = create_pvsymbol (Denv.create_user_id id) vtv in
add_local id.id (LetV pv) lenv, pv in
Util.map_fold_left binder lenv bl
let xpost lenv xq =
let add_exn m (xs,f) =
let f = create_post lenv "result" (ty_of_ity xs.xs_ity) f in
Mexn.add_new (DuplicateException xs) xs f m in
List.fold_left add_exn Mexn.empty xq
let eff_of_deff _lenv _deff = eff_empty (* TODO *)
let rec type_c lenv dtyc =
let result = type_v lenv dtyc.dc_result in
let ty = match result with
| SpecV v -> ty_of_ity v.vtv_ity
| SpecA _ -> ty_unit in
{ c_pre = create_pre lenv dtyc.dc_pre;
c_effect = eff_of_deff lenv dtyc.dc_effect;
c_result = result;
c_post = create_post lenv "result" ty dtyc.dc_post;
c_xpost = xpost lenv dtyc.dc_xpost; }
and type_v lenv = function
| DSpecV (ghost,v) ->
SpecV (vty_value ~ghost (ity_of_dity v))
| DSpecA (bl,tyc) ->
let lenv, pvl = binders lenv bl in
SpecA (pvl, type_c lenv tyc)
(* expressions *)
let rec expr lenv de = match de.de_desc with let rec expr lenv de = match de.de_desc with
| DElocal x -> | DElocal x ->
assert (Mstr.mem x lenv.let_vars); assert (Mstr.mem x lenv.let_vars);
...@@ -687,14 +723,8 @@ let rec expr lenv de = match de.de_desc with ...@@ -687,14 +723,8 @@ let rec expr lenv de = match de.de_desc with
let ld = create_let_defn (Denv.create_user_id x) e_setmark in let ld = create_let_defn (Denv.create_user_id x) e_setmark in
let lenv = add_local x.id ld.let_var lenv in let lenv = add_local x.id ld.let_var lenv in
e_let ld (expr lenv de1) e_let ld (expr lenv de1)
(* | DEany dtyc ->
| DEany deff -> e_any (type_c lenv dtyc)
let aeff = {
aeff_reads = List.map (expr lenv) deff.deff_reads;
aeff_writes = List.map (expr lenv) deff.deff_writes;
aeff_raises = deff.deff_raises } in
e_any aeff (ity_of_dity de.de_type)
*)
| DEghost de1 -> | DEghost de1 ->
e_ghost (expr lenv de1) e_ghost (expr lenv de1)
| _ -> | _ ->
...@@ -706,8 +736,7 @@ and expr_rec lenv rdl = ...@@ -706,8 +736,7 @@ and expr_rec lenv rdl =
| VTarrow vta -> vta | VTarrow vta -> vta
| VTvalue _ -> assert false in | VTvalue _ -> assert false in
let ps = create_psymbol (Denv.create_user_id id) vta vars_empty in let ps = create_psymbol (Denv.create_user_id id) vta vars_empty in
add_local id.id (LetA ps) lenv, (ps, lam) add_local id.id (LetA ps) lenv, (ps, lam) in
in
let lenv, rdl = Util.map_fold_left step1 lenv rdl in let lenv, rdl = Util.map_fold_left step1 lenv rdl in
let step2 (ps, lam) = ps, expr_lam lenv lam in let step2 (ps, lam) = ps, expr_lam lenv lam in
create_rec_defn (List.map step2 rdl) create_rec_defn (List.map step2 rdl)
...@@ -717,27 +746,18 @@ and expr_fun lenv x lam = ...@@ -717,27 +746,18 @@ and expr_fun lenv x lam =
create_fun_defn (Denv.create_user_id x) lam create_fun_defn (Denv.create_user_id x) lam
and expr_lam lenv (bl, var, p, e, q, xq) = and expr_lam lenv (bl, var, p, e, q, xq) =
let binder (id, ghost, dity) = let lenv, pvl = binders lenv bl in
let vtv = vty_value ~ghost (ity_of_dity dity) in
create_pvsymbol (Denv.create_user_id id) vtv in
let pvl = List.map binder bl in
let add_binder pv = add_local pv.pv_vs.vs_name.id_string (LetV pv) in
let lenv = List.fold_right add_binder pvl lenv in
let e = expr lenv e in let e = expr lenv e in
let ty = match e.e_vty with let ty = match e.e_vty with
| VTarrow _ -> ty_unit | VTarrow _ -> ty_unit
| VTvalue vtv -> ty_of_ity vtv.vtv_ity in | VTvalue vtv -> ty_of_ity vtv.vtv_ity in
let mk_variant (t,r) = { v_term = create_pre lenv t; v_rel = r } in let mk_variant (t,r) = { v_term = create_pre lenv t; v_rel = r } in
let add_exn m (xs,f) =
let f = create_post lenv "result" (ty_of_ity xs.xs_ity) f in
Mexn.add_new (DuplicateException xs) xs f m in
{ l_args = pvl; { l_args = pvl;
l_variant = List.map mk_variant var; l_variant = List.map mk_variant var;
l_pre = create_pre lenv p; l_pre = create_pre lenv p;
l_expr = e; l_expr = e;
l_post = create_post lenv "result" ty q; l_post = create_post lenv "result" ty q;
l_xpost = List.fold_left add_exn Mexn.empty xq; l_xpost = xpost lenv xq; }
}
(** Type declaration *) (** Type declaration *)
...@@ -1224,8 +1244,12 @@ let add_module lib path mm mt m = ...@@ -1224,8 +1244,12 @@ let add_module lib path mm mt m =
let xs = create_xsymbol (Denv.create_user_id id) ity in let xs = create_xsymbol (Denv.create_user_id id) ity in
let pd = create_exn_decl xs in let pd = create_exn_decl xs in
Loc.try2 loc add_pdecl_with_tuples uc pd Loc.try2 loc add_pdecl_with_tuples uc pd
| Dparam _ -> | Dparam (id, tyv) ->
assert false (*TODO*) let tyv, _ = dtype_v (create_denv uc) tyv in
let tyv = type_v (create_lenv uc) tyv in
let vd = create_val (Denv.create_user_id id) tyv in
let pd = create_val_decl vd in
Loc.try2 loc add_pdecl_with_tuples uc pd
| Duse _ -> | Duse _ ->
assert false (*TO BE REMOVED EVENTUALLY *) assert false (*TO BE REMOVED EVENTUALLY *)
in in
......
...@@ -29,6 +29,15 @@ module N ...@@ -29,6 +29,15 @@ module N
let create_dref i = {| dcontents = {| contents = i |} |} let create_dref i = {| dcontents = {| contents = i |} |}
let foo (x : ref int) (y : ref int) =
x.contents <- 1;
y.contents <- 2
val gr : ref int
let test () =
foo gr {| contents = 5 |}
let myfun r = { r = r } let myfun r = { r = r }
'L: 'L:
let rec on_tree t = { true } match t with let rec on_tree t = { true } match t with
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment