labels in programs

src/parser/denv.ml

@@ -228,7 +228,7 @@ let rec term env t = match t.dt_node with
       let rec collect p ll e = match e.dt_node with
         | Tnamed (Lstr l, e) -> collect p (l::ll) e
         | Tnamed (Lpos p, e) -> collect (Some p) ll e
-        | _ -> t_label ?loc:p ll (term env e)
+        | _ -> t_label ?loc:p (List.rev ll) (term env e)
       in
       collect None [] t
   | Teps (id, ty, e1) ->
@@ -277,7 +277,7 @@ and fmla env = function
       let rec collect p ll = function
         | Fnamed (Lstr l, e) -> collect p (l::ll) e
         | Fnamed (Lpos p, e) -> collect (Some p) ll e
-        | e -> t_label ?loc:p ll (fmla env e)
+        | e -> t_label ?loc:p (List.rev ll) (fmla env e)
       in
       collect None [] f
   | Fvar f ->

src/parser/parser.mly

@@ -1123,6 +1123,8 @@ expr:
    { mk_expr (Etry ($2, $5)) }
 | ANY simple_type_c
    { mk_expr (Eany $2) }
+| label expr %prec prec_named
+   { mk_expr (Enamed ($1, $2)) }
 ;
 
 triple:

src/parser/ptree.ml

@@ -230,6 +230,7 @@ and expr_desc =
   | Elabel of ident * expr
   | Ecast of expr * pty
   | Eany of type_c
+  | Enamed of label * expr
 
   (* TODO: ghost *)
 

src/programs/pgm_ttree.ml

@@ -18,6 +18,7 @@
 (**************************************************************************)
 
 open Why3
+open Ident
 open Denv
 open Ty
 open Pgm_types
@@ -38,32 +39,6 @@ type for_direction = Ptree.for_direction
 (*****************************************************************************)
 (* phase 1: introduction of destructive types *)
 
-(***
-type dregion = {
-  dr_tv : Denv.type_var;
-  dr_ty : Denv.dty;
-}
-
-type deffect = {
-  de_reads  : dregion list;
-  de_writes : dregion list;
-  de_raises : esymbol list;
-}
-
-type dtype_v =
-  | DTpure  of Denv.dty
-  | DTarrow of dbinder list * dtype_c
-
-and dtype_c =
-  { dc_result_type : dtype_v;
-    dc_effect      : deffect;
-    dc_pre         : Denv.dfmla;
-    dc_post        : (Denv.dty * Denv.dfmla) *
-                     (Term.lsymbol * (Denv.dty option * Denv.dfmla)) list; }
-
-and dbinder = ident * Denv.dty * dtype_v
-***)
-
 (* user type_v *)
 
 type dpre = Ptree.pre
@@ -126,6 +101,7 @@ and dexpr_desc =
   | DEassert of assertion_kind * Ptree.lexpr
   | DElabel of string * dexpr
   | DEany of dutype_c
+  | DEnamed of Ptree.label * dexpr
 
 and drecfun = (ident * Denv.dty) * dubinder list * dvariant option * dtriple
 
@@ -225,6 +201,7 @@ and iexpr_desc =
   | IEassert of assertion_kind * Term.term
   | IElabel of label * iexpr
   | IEany of itype_c
+  | IEnamed of Ptree.label * iexpr
 
 and irecfun = ivsymbol * ibinder list * irec_variant option * itriple
 
@@ -257,6 +234,7 @@ type expr = {
   expr_type  : ty;
   expr_type_v: type_v;
   expr_effect: E.t;
+  expr_lab   : Ident.label list;
   expr_loc   : loc;
 }
 

src/programs/pgm_wp.ml

@@ -413,9 +413,11 @@ let well_founded_rel = function
 
 (* Recursive computation of the weakest precondition *)
 
-let wp_label ?loc f =
-  if List.mem "WP" f.t_label then f
-  else t_label ?loc ("WP"::f.t_label) f
+let wp_label ?loc ?(lab=[]) f =
+  let loc = option_apply f.t_loc (fun x -> Some x) loc in
+  let lab = lab @ f.t_label in
+  let lab = if List.mem "WP" lab then lab else "WP" :: lab in
+  t_label ?loc lab f
 
 let t_True env =
   fs_app (find_ls ~pure:true env "True") []
@@ -436,7 +438,7 @@ let rec wp_expr env rm e q =
   let q = post_map (old_label lab) q in
   let f = wp_desc env rm e q in
   let f = erase_label lab f in
-  let f = wp_label ~loc:e.expr_loc f in
+  let f = wp_label ~loc:e.expr_loc ~lab:e.expr_lab f in
   if Debug.test_flag debug then begin
     eprintf "@[--------@\n@[<hov 2>e = %a@]@\n" Pgm_pretty.print_expr e;
     eprintf "@[<hov 2>q = %a@]@\n" Pretty.print_term (snd (fst q));
@@ -482,7 +484,6 @@ and wp_desc env rm e q = match e.expr_desc with
       let q1 = (* if result=True then w2 else w3 *)
         let res = v_result e1.expr_type in
         let test = t_equ (t_var res) (t_True env) in
-        let test = wp_label ~loc:e1.expr_loc test in
         let q1 = t_if test w2 w3 in
         saturate_post e1.expr_effect (res, q1) q
       in