Skip to content

GitLab

why3
why3
Commit 811ab575 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files
Options

whyml: ghost variables, functions, and expressions

parent 57635caf
Hide whitespace changes
Inline Side-by-side
Showing with 184 additions and 108 deletions
src/parser/parser.mly
View file @ 811ab575
......@@ -167,6 +167,13 @@ end
let empty_effect = { pe_reads = []; pe_writes = []; pe_raises = [] }
let effect_union e1 e2 =
let { pe_reads = r1; pe_writes = w1; pe_raises = x1 } = e1 in
let { pe_reads = r2; pe_writes = w2; pe_raises = x2 } = e2 in
{ pe_reads = r1 @ r2; pe_writes = w1 @ w2; pe_raises = x1 @ x2 }
let effect_exprs ghost l = List.map (fun x -> (ghost, x)) l
let type_c p ty ef q =
{ pc_result_type = ty;
pc_effect = ef;
......@@ -245,7 +252,7 @@ end
%nonassoc IN
%right SEMICOLON
%nonassoc prec_no_else
%nonassoc DOT ELSE
%nonassoc DOT ELSE GHOST
%nonassoc prec_named
%nonassoc COLON
......@@ -1053,17 +1060,16 @@ program_decl:
{ Dlogic $1 }
| use_clone
{ Duseclone $1 }
| LET lident_rich_pgm labels list1_type_v_binder opt_cast EQUAL triple
{ Dlet (add_lab $2 $3, mk_expr_i 7 (Efun ($4, cast_body $5 $7))) }
| LET lident_rich_pgm labels EQUAL FUN list1_type_v_binder ARROW triple
{ Dlet (add_lab $2 $3, mk_expr_i 8 (Efun ($6, $8))) }
| LET ghost lident_rich_pgm labels list1_type_v_binder opt_cast EQUAL triple
{ Dlet (add_lab $3 $4, $2, mk_expr_i 8 (Efun ($5, cast_body $6 $8))) }
| LET ghost lident_rich_pgm labels EQUAL FUN list1_type_v_binder ARROW triple
{ Dlet (add_lab $3 $4, $2, mk_expr_i 9 (Efun ($7, $9))) }
| LET REC list1_recfun_sep_and
{ Dletrec $3 }
| VAL lident_rich_pgm labels COLON type_v
{ Dparam (add_lab $2 $3, $5) }
| VAL lident_rich_pgm labels list1_type_v_param COLON type_c
{ let tv = Tarrow ($4, $6) in
Dparam (add_lab $2 $3, tv) }
| VAL ghost lident_rich_pgm labels COLON type_v
{ Dparam (add_lab $3 $4, $2, $6) }
| VAL ghost lident_rich_pgm labels list1_type_v_param COLON type_c
{ Dparam (add_lab $3 $4, $2, Tarrow ($5, $7)) }
| EXCEPTION uident labels
{ Dexn (add_lab $2 $3, None) }
| EXCEPTION uident labels primitive_type
......@@ -1099,8 +1105,9 @@ list1_recfun_sep_and:
;
recfun:
| lident_rich_pgm labels list1_type_v_binder opt_cast opt_variant EQUAL triple
{ add_lab $1 $2, $3, $5, cast_body $4 $7 }
| ghost lident_rich_pgm labels list1_type_v_binder
opt_cast opt_variant EQUAL triple
{ add_lab $2 $3, $1, $4, $6, cast_body $5 $8 }
;
expr:
......@@ -1152,10 +1159,16 @@ expr:
{ mk_expr (Elazy (LazyOr, $1, $3)) }
| LET pattern EQUAL expr IN expr
{ match $2.pat_desc with
| PPpvar id -> mk_expr (Elet (id, $4, $6))
| _ -> mk_expr (Ematch ($4, [$2, $6])) }
| PPpvar id -> mk_expr (Elet (id, false, $4, $6))
| _ -> mk_expr (Ematch ($4, [$2, $6])) }
| LET GHOST pattern EQUAL expr IN expr
{ match $3.pat_desc with
| PPpvar id -> mk_expr (Elet (id, true, $5, $7))
| _ -> Loc.errorm ~loc:(floc_i 3) "`ghost' cannot come before a pattern" }
| LET lident labels list1_type_v_binder EQUAL triple IN expr
{ mk_expr (Elet (add_lab $2 $3, mk_expr_i 6 (Efun ($4, $6)), $8)) }
{ mk_expr (Elet (add_lab $2 $3, false, mk_expr_i 6 (Efun ($4, $6)), $8)) }
| LET GHOST lident labels list1_type_v_binder EQUAL triple IN expr
{ mk_expr (Elet (add_lab $3 $4, true, mk_expr_i 7 (Efun ($5, $7)), $9)) }
| LET REC list1_recfun_sep_and IN expr
{ mk_expr (Eletrec ($3, $5)) }
| FUN list1_type_v_binder ARROW triple
......@@ -1190,6 +1203,8 @@ expr:
{ mk_expr (Etry ($2, $5)) }
| ANY simple_type_c
{ mk_expr (Eany $2) }
| GHOST expr
{ mk_expr (Eghost $2) }
| ABSTRACT expr post
{ mk_expr (Eabstract($2, $3)) }
| label expr %prec prec_named
......@@ -1309,17 +1324,17 @@ list1_type_v_param:
;
type_v_binder:
| lident labels
{ [add_lab $1 $2, None] }
| ghost lident labels
{ [add_lab $2 $3, $1, None] }
| type_v_param
{ $1 }
;
type_v_param:
| LEFTPAR RIGHTPAR
{ [id_anonymous (), Some (ty_unit ())] }
| LEFTPAR lidents_lab COLON primitive_type RIGHTPAR
{ List.map (fun i -> (i, Some $4)) $2 }
{ [id_anonymous (), false, Some (ty_unit ())] }
| LEFTPAR ghost lidents_lab COLON primitive_type RIGHTPAR
{ List.map (fun i -> (i, $2, Some $5)) $3 }
;
lidents_lab:
......@@ -1335,9 +1350,13 @@ type_v:
arrow_type_v:
| primitive_type ARROW type_c
{ Tarrow ([id_anonymous (), Some $1], $3) }
{ Tarrow ([id_anonymous (), false, Some $1], $3) }
| GHOST primitive_type ARROW type_c
{ Tarrow ([id_anonymous (), true, Some $2], $4) }
| lident labels COLON primitive_type ARROW type_c
{ Tarrow ([add_lab $1 $2, Some $4], $6) }
{ Tarrow ([add_lab $1 $2, false, Some $4], $6) }
| GHOST lident labels COLON primitive_type ARROW type_c
{ Tarrow ([add_lab $2 $3, true, Some $5], $7) }
/* TODO: we could alllow lidents instead, e.g. x y : int -> ... */
/*{ Tarrow (List.map (fun x -> x, Some $3) $1, $5) }*/
;
......@@ -1392,23 +1411,23 @@ post_exn:
;
effects:
| opt_reads opt_writes opt_raises
{ { pe_reads = $1; pe_writes = $2; pe_raises = $3 } }
| /* epsilon */ { empty_effect }
| effect effects { effect_union $1 $2 }
;
opt_reads:
| /* epsilon */ { [] }
| READS list1_lexpr_arg { $2 }
;
opt_writes:
| /* epsilon */ { [] }
| WRITES list1_lexpr_arg { $2 }
;
opt_raises:
| /* epsilon */ { [] }
| RAISES list1_uqualid { $2 }
effect:
| READS list1_lexpr_arg
{ { pe_reads = effect_exprs false $2; pe_writes = []; pe_raises = [] } }
| WRITES list1_lexpr_arg
{ { pe_writes = effect_exprs false $2; pe_reads = []; pe_raises = [] } }
| RAISES list1_uqualid
{ { pe_raises = effect_exprs false $2; pe_writes = []; pe_reads = [] } }
| GHOST READS list1_lexpr_arg
{ { pe_reads = effect_exprs true $3; pe_writes = []; pe_raises = [] } }
| GHOST WRITES list1_lexpr_arg
{ { pe_writes = effect_exprs true $3; pe_reads = []; pe_raises = [] } }
| GHOST RAISES list1_uqualid
{ { pe_raises = effect_exprs true $3; pe_writes = []; pe_reads = [] } }
;
opt_variant:
......@@ -1427,6 +1446,11 @@ list1_uqualid:
| uqualid list1_uqualid { $1 :: $2 }
;
ghost:
| /* epsilon */ { false }
| GHOST { true }
;
/*
Local Variables:
compile-command: "unset LANG; make -C ../.."
......
src/parser/ptree.ml
View file @ 811ab575
......@@ -186,17 +186,19 @@ type loop_annotation = {
type for_direction = To | Downto
type ghost = bool
type effect = {
pe_reads : lexpr list;
pe_writes : lexpr list;
pe_raises : qualid list;
pe_reads : (ghost * lexpr) list;
pe_writes : (ghost * lexpr) list;
pe_raises : (ghost * qualid) list;
}
type pre = lexpr
type post = lexpr * (qualid * lexpr) list
type binder = ident * pty option
type binder = ident * ghost * pty option
type type_v =
| Tpure of pty
......@@ -219,8 +221,9 @@ and expr_desc =
| Eident of qualid
| Eapply of expr * expr
| Efun of binder list * triple
| Elet of ident * expr * expr
| Eletrec of (ident * binder list * variant option * triple) list * expr
| Elet of ident * ghost * expr * expr
| Eletrec of
(ident * ghost * binder list * variant option * triple) list * expr
| Etuple of expr list
| Erecord of (qualid * expr) list
| Eupdate of expr * (qualid * expr) list
......@@ -241,19 +244,18 @@ and expr_desc =
| Emark of ident * expr
| Ecast of expr * pty
| Eany of type_c
| Eghost of expr
| Eabstract of expr * post
| Enamed of label * expr
(* TODO: ghost *)
and triple = pre * expr * post
type program_decl =
| Dlet of ident * expr
| Dletrec of (ident * binder list * variant option * triple) list
| Dlet of ident * ghost * expr
| Dletrec of (ident * ghost * binder list * variant option * triple) list
| Dlogic of decl
| Duseclone of use_clone
| Dparam of ident * type_v
| Dparam of ident * ghost * type_v
| Dexn of ident * pty option
(* modules *)
| Duse of qualid * bool option * (*as:*) string option
......
src/programs/pgm_typing.ml
View file @ 811ab575
......@@ -248,12 +248,17 @@ let dexception uc qid =
print_dty ty;
r
let no_ghost gh =
if gh then errorm "ghost types are not supported in this version of WhyML"
let eff_no_ghost l = List.map (fun (gh,x) -> no_ghost gh; x) l
let dueffect env e =
{ du_reads = e.Ptree.pe_reads;
du_writes = e.Ptree.pe_writes;
{ du_reads = eff_no_ghost e.Ptree.pe_reads;
du_writes = eff_no_ghost e.Ptree.pe_writes;
du_raises =
List.map (fun id -> let ls,_,_ = dexception env.uc id in ls)
e.Ptree.pe_raises; }
(eff_no_ghost e.Ptree.pe_raises); }
let dpost uc (q, ql) =
let dexn (id, l) = let s, _, _ = dexception uc id in s, l in
......@@ -309,7 +314,8 @@ and dutype_c env c =
duc_post = dpost env.uc c.Ptree.pc_post;
}
and dubinder env ({id=x; id_loc=loc} as id, v) =
and dubinder env ({id=x; id_loc=loc} as id, gh, v) =
no_ghost gh;
let ty = match v with
| Some v -> dtype ~user:true env v
| None -> create_type_var loc
......@@ -480,7 +486,8 @@ and dexpr_desc ~ghost ~userloc env loc = function
let tyl = List.map (fun (_,ty) -> ty) bl in
let ty = dcurrying tyl e.dexpr_type in
DEfun (bl, t), ty
| Ptree.Elet (x, e1, e2) ->
| Ptree.Elet (x, gh, e1, e2) ->
no_ghost gh;
let e1 = dexpr ~ghost ~userloc env e1 in
let ty1 = e1.dexpr_type in
let env = add_local env x.id ty1 in
......@@ -716,12 +723,16 @@ and dexpr_desc ~ghost ~userloc env loc = function
let e1 = dexpr ~ghost ~userloc env e1 in
let q = dpost env.uc q in
DEabstract(e1, q), e1.dexpr_type
| Ptree.Eghost _ ->
no_ghost true;
assert false
| Ptree.Enamed _ ->
assert false
and dletrec ~ghost ~userloc env dl =
(* add all functions into environment *)
let add_one env (id, bl, var, t) =
let add_one env (id, gh, bl, var, t) =
no_ghost gh;
let ty = create_type_var id.id_loc in
let env = add_local_top env id.id ty in
env, ((id, ty), bl, var, t)
......@@ -1560,7 +1571,7 @@ let rec is_pure_expr e =
| Elocal _ | Elogic _ -> true
| Eif (e1, e2, e3) -> is_pure_expr e1 && is_pure_expr e2 && is_pure_expr e3
| Elet (_, e1, e2) -> is_pure_expr e1 && is_pure_expr e2
| Eabstract (e1, _)
| Eabstract (e1, _)
| Emark (_, e1) -> is_pure_expr e1
| Eany c -> E.no_side_effect c.c_effect
| Eassert _ | Etry _ | Efor _ | Eraise _ | Ematch _
......@@ -2295,7 +2306,8 @@ let find_module penv lmod q id = match q with
(* env = to retrieve theories and modules from the loadpath
lmod = local modules *)
let rec decl ~wp env ltm lmod uc = function
| Ptree.Dlet (id, e) ->
| Ptree.Dlet (id, gh, e) ->
no_ghost gh;
let denv = create_denv uc in
let e = dexpr ~ghost:false ~userloc:None denv e in
let e = iexpr (create_ienv denv) e in
......@@ -2334,7 +2346,8 @@ let rec decl ~wp env ltm lmod uc = function
let d = Dletrec dl in
let uc = add_decl d uc in
if wp then Pgm_wp.decl uc d else uc
| Ptree.Dparam (id, tyv) ->
| Ptree.Dparam (id, gh, tyv) ->
no_ghost gh;
let loc = id.id_loc in
let denv = create_denv uc in
let tyv = dutype_v denv tyv in
......
src/whyml/mlw_dtree.ml
View file @ 811ab575
......@@ -75,7 +75,7 @@ and dexpr_desc =
| DEglobal_ls of Term.lsymbol
| DEapply of dexpr * dexpr list
| DEfun of dlambda
| DElet of ident * dexpr * dexpr
| DElet of ident * ghost * dexpr * dexpr
| DEletrec of drecfun list * dexpr
| DEassign of dexpr * dexpr
| DEif of dexpr * dexpr * dexpr
......@@ -92,6 +92,6 @@ and dexpr_desc =
| DEghost of dexpr
| DEany of dtype_c
and drecfun = ident * dity * dlambda
and drecfun = ident * ghost * dity * dlambda
and dlambda = dbinder list * dvariant list * dpre * dexpr * dpost * dxpost
src/whyml/mlw_ty.ml
View file @ 811ab575
......@@ -668,6 +668,10 @@ let vtv_unmut vtv =
if vtv.vtv_mut = None then vtv else
vty_value ~ghost:vtv.vtv_ghost vtv.vtv_ity
let vty_ghost = function
| VTvalue vtv -> vtv.vtv_ghost
| VTarrow vta -> vta.vta_ghost
let vty_arrow vtv ?(effect=eff_empty) ?(ghost=false) vty =
(* mutable arguments are rejected outright *)
if vtv.vtv_mut <> None then
......@@ -681,14 +685,10 @@ let vty_arrow vtv ?(effect=eff_empty) ?(ghost=false) vty =
vta_arg = vtv;
vta_result = vty;
vta_effect = effect;
vta_ghost = ghost;
vta_ghost = ghost || vty_ghost vty;
vta_vars = vty_vars vtv.vtv_vars vty;
}
let vty_ghost = function
| VTvalue vtv -> vtv.vtv_ghost
| VTarrow vta -> vta.vta_ghost
let vtv_ghostify vtv = { vtv with vtv_ghost = true }
let vta_ghostify vta = { vta with vta_ghost = true }
......
src/whyml/mlw_typing.ml
View file @ 811ab575
......@@ -219,7 +219,7 @@ let mk_let ~loc ~uloc e (desc,dity) =
if test_var e then desc, dity else
let loc = def_option loc uloc in
let e1 = mk_dexpr desc dity loc Slab.empty in
DElet (mk_id "q" loc, e, e1), dity
DElet (mk_id "q" loc, false, e, e1), dity
(* patterns *)
......@@ -321,18 +321,18 @@ and dpat_app denv ({ de_loc = loc } as de) ppl =
(* specifications *)
let dbinders denv bl =
let dbinder (id,pty) (denv,bl,tyl) =
let dbinder (id,gh,pty) (denv,bl,tyl) =
let dity = match pty with
| Some pty -> dity_of_pty ~user:true denv pty
| None -> create_type_variable () in
add_var id dity denv, (id,false,dity)::bl, dity::tyl
add_var id dity denv, (id,gh,dity)::bl, dity::tyl
in
List.fold_right dbinder bl (denv,[],[])
let deff_of_peff uc pe =
{ deff_reads = List.map (fun le -> false, le) pe.pe_reads;
deff_writes = List.map (fun le -> false, le) pe.pe_writes;
deff_raises = List.map (fun q -> false, find_xsymbol uc q) pe.pe_raises; }
{ deff_reads = pe.pe_reads;
deff_writes = pe.pe_writes;
deff_raises = List.map (fun (gh,q) -> gh, find_xsymbol uc q) pe.pe_raises; }
let dxpost uc ql = List.map (fun (q,f) -> find_xsymbol uc q, f) ql
......@@ -392,7 +392,7 @@ and de_desc denv loc = function
let e, el = decompose_app [e2] e1 in
let el = List.map (dexpr denv) el in
de_app (dexpr denv e) el
| Ptree.Elet (id, e1, e2) ->
| Ptree.Elet (id, gh, e1, e2) ->
let e1 = dexpr denv e1 in
let dity = e1.de_type in
let tvars = match e1.de_desc with
......@@ -401,10 +401,10 @@ and de_desc denv loc = function
let locals = Mstr.add id.id (tvars, dity) denv.locals in
let denv = { denv with locals = locals; tvars = tvars } in
let e2 = dexpr denv e2 in
DElet (id, e1, e2), e2.de_type
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, _) =
let add_one denv ({ id = id }, _, dity, _) =
{ denv with locals = Mstr.add id (denv.tvars, dity) denv.locals } in
let denv = List.fold_left add_one denv rdl in
let e1 = dexpr denv e1 in
......@@ -422,7 +422,7 @@ and de_desc denv loc = function
let e1 = dexpr denv e1 in
expected_type e1 dity_unit;
let e2 = dexpr denv e2 in
DElet (mk_id "_" loc, e1, e2), e2.de_type
DElet (mk_id "_" loc, false, e1, e2), e2.de_type
| Ptree.Eif (e1, e2, e3) ->
let e1 = dexpr denv e1 in
expected_type e1 dity_bool;
......@@ -537,6 +537,9 @@ and de_desc denv loc = function
| Ptree.Eany tyc ->
let tyc, dity = dtype_c denv tyc in
DEany tyc, dity
| Ptree.Eghost e1 ->
let e1 = dexpr denv e1 in
DEghost e1, e1.de_type
| Ptree.Eloop ({ loop_invariant = inv; loop_variant = var }, e1) ->
let e1 = dexpr denv e1 in
let var = dvariant denv.uc var in
......@@ -556,15 +559,15 @@ and de_desc denv loc = function
and dletrec denv rdl =
(* add all functions into environment *)
let add_one denv (id, bl, var, tr) =
let add_one denv (id, gh, bl, var, tr) =
let res = create_type_variable () in
add_var id res denv, (id, res, bl, var, tr) in
add_var id res denv, (id, gh, res, bl, var, tr) in
let denv, rdl = Util.map_fold_left add_one denv rdl in
(* then type-check all of them and unify *)
let type_one (id, res, bl, var, tr) =
let type_one (id, gh, res, bl, var, tr) =
let lam, dity = dlambda denv bl var tr in
Loc.try2 id.id_loc unify dity res;
id, dity, lam in
id, gh, dity, lam in
List.map type_one rdl
and dlambda denv bl var (p, e, (q, xq)) =
......@@ -707,8 +710,8 @@ let eff_of_deff lenv deff =
let eff = List.fold_left add_raise eff deff.deff_raises in
eff
let rec type_c lenv vars dtyc =
let result = type_v lenv vars dtyc.dc_result in
let rec type_c lenv gh vars dtyc =
let result = type_v lenv gh vars dtyc.dc_result in
let ty = match result with
| SpecV v -> ty_of_ity v.vtv_ity
| SpecA _ -> ty_unit in
......@@ -727,17 +730,24 @@ let rec type_c lenv vars dtyc =
c_post = create_post lenv "result" ty dtyc.dc_post;
c_xpost = xpost lenv dtyc.dc_xpost; }
and type_v lenv vars = function
and type_v lenv gh vars = function
| DSpecV (ghost,v) ->
let ghost = ghost || gh in
SpecV (vty_value ~ghost (ity_of_dity v))
| DSpecA (bl,tyc) ->
let lenv, pvl = binders lenv bl in
let add_pv s pv = vars_union s pv.pv_vtv.vtv_vars in
let vars = List.fold_left add_pv vars pvl in
SpecA (pvl, type_c lenv vars tyc)
SpecA (pvl, type_c lenv gh vars tyc)
(* expressions *)
let vty_ghostify gh vty =
if gh && not (vty_ghost vty) then vty_ghostify vty else vty
let e_ghostify gh e =
if gh && not (vty_ghost e.e_vty) then e_ghost e else e
let rec expr lenv de =
let loc = de.de_loc in
let e = Loc.try3 loc expr_desc lenv loc de in
......@@ -750,18 +760,29 @@ and expr_desc lenv loc de = match de.de_desc with
| LetV pv -> e_value pv
| LetA ps -> e_cast ps (vty_of_dity de.de_type)
end
| DElet (x, { de_desc = DEfun lam }, de2) ->
let def = expr_fun lenv x lam in
| DElet (x, gh, { de_desc = DEfun lam }, de2) ->
let def = expr_fun lenv x gh lam in
let lenv = add_local x.id (LetA def.rec_ps) lenv in
let e2 = expr lenv de2 in
e_rec [def] e2
| DEfun lam ->
let x = mk_id "fn" loc in
let def = expr_fun lenv x lam in
let def = expr_fun lenv x false lam in
let e2 = e_cast def.rec_ps (VTarrow def.rec_ps.ps_vta) in
e_rec [def] e2
| DElet (x, de1, de2) ->
let e1 = expr lenv de1 in
(* FIXME? (ghost "lab" fun x -> ...) loses the label "lab" *)
| DEghost { de_desc = DEfun lam } ->
let x = mk_id "fn" loc in
let def = expr_fun lenv x true lam in
let e2 = e_cast def.rec_ps (VTarrow def.rec_ps.ps_vta) in
e_rec [def] e2
| DElet (x, gh, de1, de2) ->
let e1 = e_ghostify gh (expr lenv de1) in
begin match e1.e_vty with
| VTarrow { vta_ghost = true } when not gh ->
errorm ~loc "%s must be a ghost function" x.id
| _ -> ()
end;
let def1 = create_let_defn (Denv.create_user_id x) e1 in
let lenv = add_local x.id def1.let_var lenv in
let e2 = expr lenv de2 in
......@@ -826,14 +847,19 @@ and expr_desc lenv loc de = match de.de_desc with
let lenv = add_local id.id (LetV pv) lenv in
xs, pv, expr lenv de in
e_try e1 (List.map branch bl)
(* We push ghost down in order to safely capture even non-ghost
raises of the inner expression in "ghost try e1 with ..." *)
| DEghost ({ de_desc = DEtry (de2, bl) } as de1) ->
let de2 = { de1 with de_desc = DEghost de2 } in
expr lenv { de1 with de_desc = DEtry (de2, bl) }
| DEmark (x, de1) ->
let ld = create_let_defn (Denv.create_user_id x) e_setmark in
let lenv = add_local x.id ld.let_var lenv in
e_let ld (expr lenv de1)
| DEany dtyc ->
e_any (type_c lenv vars_empty dtyc)
e_any (type_c lenv false vars_empty dtyc)
| DEghost de1 ->
e_ghost (expr lenv de1)
e_ghostify true (expr lenv de1)
| DEloop (var,inv,de1) ->
let inv = match inv with
| Some inv -> create_pre lenv inv
......@@ -855,23 +881,25 @@ 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 (id, dity, lam) =
let vta = match vty_of_dity dity with
let step1 lenv (id, gh, dity, lam) =
let vta = match vty_ghostify gh (vty_of_dity dity) with
| VTarrow vta -> vta
| VTvalue _ -> assert false in
let ps = create_psymbol (Denv.create_user_id id) vta vars_empty in
add_local id.id (LetA ps) lenv, (ps, lam) in
add_local id.id (LetA ps) lenv, (ps, gh, lam) 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, gh, lam) = ps, expr_lam lenv gh lam in
create_rec_defn (List.map step2 rdl)
and expr_fun lenv x lam =
let lam = expr_lam lenv lam in
and expr_fun lenv x gh lam =
let lam = expr_lam lenv gh lam in
create_fun_defn (Denv.create_user_id x) lam
and expr_lam lenv (bl, var, p, e, q, xq) =
and expr_lam lenv gh (bl, var, p, de, q, xq) =
let lenv, pvl = binders lenv bl in
let e = expr lenv e in
let e = e_ghostify gh (expr lenv de) in
if not gh && vty_ghost e.e_vty then
errorm ~loc:de.de_loc "ghost body in a non-ghost function";
let ty = match e.e_vty with
| VTarrow _ -> ty_unit
| VTvalue vtv -> ty_of_ity vtv.vtv_ity
......@@ -1343,14 +1371,16 @@ let add_module lib path mm mt m =
let uc = open_namespace uc in
let uc = List.fold_left add_decl uc dl in
Loc.try3 loc close_namespace uc import name
| Dlet (id, e) ->
| Dlet (id, gh, e) ->
let e = dexpr (create_denv uc) e in
let pd = match e.de_desc with
| DEfun lam ->
let def = expr_fun (create_lenv uc) id lam in
let def = expr_fun (create_lenv uc) id gh lam in
create_rec_decl [def]
| _ ->
let e = expr (create_lenv uc) e in
let e = e_ghostify gh (expr (create_lenv uc) e) in
if not gh && vty_ghost e.e_vty then
errorm ~loc "%s must be a ghost variable" id.id;
let def = create_let_defn (Denv.create_user_id id) e in
create_let_decl def
in
......@@ -1368,10 +1398,17 @@ let add_module lib path mm mt m =
let xs = create_xsymbol (Denv.create_user_id id) ity in
let pd = create_exn_decl xs in
Loc.try2 loc add_pdecl_with_tuples uc pd