Commit 457c720b authored by Andrei Paskevich's avatar Andrei Paskevich

use the spec structure in ASTs

parent 3dcca8d3
......@@ -89,15 +89,20 @@ end
let () = Exn_printer.register
(fun fmt exn -> match exn with
| Parsing.Parse_error -> Format.fprintf fmt "syntax error"
| _ -> raise exn
)
| _ -> raise exn)
let mk_expr d = { expr_loc = floc (); expr_desc = d }
let mk_expr_i i d = { expr_loc = floc_i i; expr_desc = d }
let cast_body c ((p,e,q) as t) = match c with
let cast_body c ((e,sp) as t) = match c with
| None -> t
| Some pt -> p, { e with expr_desc = Ecast (e, pt) }, q
| Some pt -> { e with expr_desc = Ecast (e, pt) }, sp
let add_variant vl ((e,sp) as t) = match vl with
| [] -> t
| _ when sp.sp_variant <> [] ->
Loc.errorm "variant is specified twice"
| vl -> e, { sp with sp_variant = vl }
let rec mk_apply f = function
| [] ->
......@@ -109,10 +114,7 @@ end
mk_apply { expr_loc = loc; expr_desc = Eapply (f, a) } l
let mk_apply_id id =
let e =
{ expr_desc = Eident (Qident id); expr_loc = id.id_loc }
in
mk_apply e
mk_apply { expr_desc = Eident (Qident id); expr_loc = id.id_loc }
let mk_mixfix2 op e1 e2 =
let id = mk_id (mixfix op) (floc_i 2) in
......@@ -147,11 +149,13 @@ end
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;
pc_pre = p;
pc_post = q; }
let spec p (q,xq) ef vl = {
sp_pre = p;
sp_post = q;
sp_xpost = xq;
sp_effect = ef;
sp_variant = vl;
}
(* dead code
let add_init_mark e =
......@@ -1043,7 +1047,7 @@ list1_recfun_sep_and:
recfun:
| ghost lident_rich_pgm labels list1_type_v_binder
opt_cast opt_variant EQUAL triple
{ floc (), add_lab $2 $3, $1, $4, $6, cast_body $5 $8 }
{ floc (), add_lab $2 $3, $1, $4, add_variant $6 (cast_body $5 $8) }
;
expr:
......@@ -1142,16 +1146,17 @@ expr:
| GHOST expr
{ mk_expr (Eghost $2) }
| ABSTRACT expr post
{ mk_expr (Eabstract($2, $3)) }
{ mk_expr (Eabstract($2, spec (mk_pp PPtrue) $3 empty_effect [])) }
| label expr %prec prec_named
{ mk_expr (Enamed ($1, $2)) }
;
triple:
| pre expr post
{ $1, (* add_init_label *) $2, $3 }
{ (* add_init_label *) $2, spec $1 $3 empty_effect [] }
| expr %prec prec_triple
{ mk_pp PPtrue, (* add_init_label *) $1, (mk_pp PPtrue, []) }
{ (* add_init_label *) $1,
spec (mk_pp PPtrue) (mk_pp PPtrue, []) empty_effect [] }
;
expr_arg:
......@@ -1306,17 +1311,17 @@ simple_type_v:
type_c:
| type_v
{ type_c (mk_pp PPtrue) $1 empty_effect (mk_pp PPtrue, []) }
{ $1, spec (mk_pp PPtrue) (mk_pp PPtrue, []) empty_effect [] }
| pre type_v effects post
{ type_c $1 $2 $3 $4 }
{ $2, spec $1 $4 $3 [] }
;
/* for ANY */
simple_type_c:
| simple_type_v
{ type_c (mk_pp PPtrue) $1 empty_effect (mk_pp PPtrue, []) }
{ $1, spec (mk_pp PPtrue) (mk_pp PPtrue, []) empty_effect [] }
| pre type_v effects post
{ type_c $1 $2 $3 $4 }
{ $2, spec $1 $4 $3 [] }
;
annotation:
......
......@@ -197,8 +197,16 @@ type effect = {
}
type pre = lexpr
type post = lexpr * (qualid * lexpr) list
type post = lexpr
type xpost = (qualid * post) list
type spec = {
sp_pre : pre;
sp_post : post;
sp_xpost : xpost;
sp_effect : effect;
sp_variant : variant list;
}
type binder = ident * ghost * pty option
......@@ -206,12 +214,7 @@ type type_v =
| Tpure of pty
| Tarrow of binder list * type_c
and type_c = {
pc_result_type : type_v;
pc_effect : effect;
pc_pre : pre;
pc_post : post;
}
and type_c = type_v * spec
type expr = {
expr_desc : expr_desc;
......@@ -247,12 +250,12 @@ and expr_desc =
| Ecast of expr * pty
| Eany of type_c
| Eghost of expr
| Eabstract of expr * post
| Eabstract of triple
| Enamed of label * expr
and letrec = loc * ident * ghost * binder list * variant list * triple
and letrec = loc * ident * ghost * binder list * triple
and triple = pre * expr * post
and triple = expr * spec
type pdecl =
| Dlet of ident * ghost * expr
......
......@@ -315,12 +315,11 @@ let rec dutype_v env = function
let c = dutype_c env c in
DUTarrow (bl, c)
and dutype_c env c =
let ty = dutype_v env c.Ptree.pc_result_type in
{ duc_result_type = ty;
duc_effect = dueffect env c.Ptree.pc_effect;
duc_pre = c.Ptree.pc_pre;
duc_post = dpost env.uc c.Ptree.pc_post;
and dutype_c env (ty,sp) =
{ duc_result_type = dutype_v env ty;
duc_effect = dueffect env sp.Ptree.sp_effect;
duc_pre = sp.Ptree.sp_pre;
duc_post = dpost env.uc (sp.Ptree.sp_post, sp.Ptree.sp_xpost);
}
and dubinder env ({id=x; id_loc=loc} as id, gh, v) =
......@@ -496,7 +495,7 @@ and dexpr_desc ~ghost ~userloc env loc = function
DEapply (e1, e2), ty
| Ptree.Efun (bl, t) ->
let env, bl = map_fold_left dubinder env bl in
let (_,e,_) as t = dtriple ~ghost ~userloc env t in
let _, ((_,e,_) as t) = dtriple ~ghost ~userloc env t in
let tyl = List.map (fun (_,ty) -> ty) bl in
let ty = dcurrying tyl e.dexpr_type in
DEfun (bl, t), ty
......@@ -735,7 +734,7 @@ and dexpr_desc ~ghost ~userloc env loc = function
DEany c, dpurify_utype_v c.duc_result_type
| Ptree.Eabstract(e1,q) ->
let e1 = dexpr ~ghost ~userloc env e1 in
let q = dpost env.uc q in
let q = dpost env.uc (q.sp_post, q.sp_xpost) in
DEabstract(e1, q), e1.dexpr_type
| Ptree.Eghost _ ->
no_ghost true;
......@@ -745,18 +744,17 @@ and dexpr_desc ~ghost ~userloc env loc = function
and dletrec ~ghost ~userloc env dl =
(* add all functions into environment *)
let add_one env (_loc, id, gh, bl, var, t) =
let add_one env (_loc, id, gh, bl, 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)
env, ((id, ty), bl, t)
in
let env, dl = map_fold_left add_one env dl in
(* then type-check all of them and unify *)
let type_one ((id, tyres), bl, v, t) =
let type_one ((id, tyres), bl, t) =
let env, bl = map_fold_left dubinder env bl in
let v = dvariants env v in
let (_,e,_) as t = dtriple ~ghost ~userloc env t in
let v, ((_,e,_) as t) = dtriple ~ghost ~userloc env t in
let tyl = List.map (fun (_,ty) -> ty) bl in
let ty = dcurrying tyl e.dexpr_type in
if not (Denv.unify ty tyres) then
......@@ -767,10 +765,11 @@ and dletrec ~ghost ~userloc env dl =
in
env, List.map type_one dl
and dtriple ~ghost ~userloc env (p, e, q) =
and dtriple ~ghost ~userloc env (e, sp) =
let v = dvariants env sp.sp_variant in
let e = dexpr ~ghost ~userloc env e in
let q = dpost env.uc q in
(p, e, q)
let q = dpost env.uc (sp.sp_post, sp.sp_xpost) in
v, (sp.sp_pre, e, q)
(*** regions tables ********************************************************)
......
......@@ -29,8 +29,9 @@ type ident = Ptree.ident
type ghost = bool
type dpre = Ptree.pre
type dpost = Ptree.pre
type dxpost = (xsymbol * dpost) list
type dbinder = ident * ghost * dity
type dxpost = dpost Mexn.t
type dinvariant = Ptree.lexpr option
type dvariant = Ptree.lexpr * Term.lsymbol option
type deffect = {
deff_reads : (ghost * Ptree.lexpr) list;
......@@ -38,21 +39,21 @@ type deffect = {
deff_raises : (ghost * xsymbol) list;
}
type dspec = {
ds_pre : dpre;
ds_post : dpost;
ds_xpost : dxpost;
ds_effect : deffect;
ds_variant : dvariant list;
}
type dbinder = ident * ghost * dity
type dtype_v =
| DSpecV of ghost * dity
| DSpecA of dbinder list * dtype_c
and dtype_c = {
dc_result : dtype_v;
dc_effect : deffect;
dc_pre : dpre;
dc_post : dpost;
dc_xpost : dxpost;
}
type dvariant = Ptree.lexpr * Term.lsymbol option
type dinvariant = Ptree.lexpr option
and dtype_c = dtype_v * dspec
type dexpr = {
de_desc : dexpr_desc;
......@@ -83,10 +84,10 @@ and dexpr_desc =
| DEtry of dexpr * (xsymbol * ident * dexpr) list
| DEfor of ident * dexpr * Ptree.for_direction * dexpr * dinvariant * dexpr
| DEassert of Ptree.assertion_kind * Ptree.lexpr
| DEabstract of dexpr * dpost * dxpost
| DEabstract of dtriple
| DEmark of ident * dexpr
| DEghost of dexpr
| DEany of dtype_c
and drecfun = ident * ghost * dvty * dbinder list * dtriple
and dtriple = dvariant list * dpre * dexpr * dpost * dxpost
and dtriple = dexpr * dspec
This diff is collapsed.
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