use the spec structure in ASTs

src/parser/parser.mly

@@ -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:

src/parser/ptree.ml

@@ -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

src/programs/pgm_typing.ml

@@ -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 ********************************************************)
 

src/whyml/mlw_dtree.ml

@@ -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