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

use the spec structure in ASTs

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