- make the interface to ls_defn more straightforward

- assure generation of new variables on create_ls_defn

src/core/pretty.ml

@@ -278,7 +278,7 @@ let print_type_decl fmt (ts,def) = match def with
 let print_type_decl fmt d = print_type_decl fmt d; forget_tvs ()
 
 let print_ls_defn fmt ld =
-  let _,vl,e = open_ls_defn ld in
+  let vl,e = open_ls_defn ld in
   fprintf fmt " =@ %a" print_expr e;
   List.iter forget_var vl
 

src/core/theory.ml

@@ -43,24 +43,6 @@ type logic_decl = lsymbol * ls_defn option
 exception UnboundVars of Svs.t
 exception IllegalConstructor of lsymbol
 
-let check_fvs f =
-  let fvs = f_freevars Svs.empty f in
-  if Svs.is_empty fvs then f else raise (UnboundVars fvs)
-
-let make_fs_defn fs vl t =
-  if fs.ls_constr then raise (IllegalConstructor fs);
-  let hd = t_app fs (List.map t_var vl) t.t_ty in
-  let fd = f_forall vl [] (f_equ hd t) in
-  fs, vl, Term t, check_fvs fd
-
-let make_ps_defn ps vl f =
-  let hd = f_app ps (List.map t_var vl) in
-  let pd = f_forall vl [] (f_iff hd f) in
-  ps, vl, Fmla f, check_fvs pd
-
-let make_ls_defn ls vl =
-  e_apply (make_fs_defn ls vl) (make_ps_defn ls vl)
-
 let extract_ls_defn f =
   let vl, ef = f_open_forall f in
   match ef.f_node with
@@ -76,15 +58,28 @@ let extract_ls_defn f =
         end
     | _ -> assert false
 
-let open_ls_defn (ls,vl,e,_) = (ls,vl,e)
+let check_fvs f =
+  let fvs = f_freevars Svs.empty f in
+  if Svs.is_empty fvs then f else raise (UnboundVars fvs)
+
+let make_fs_defn fs vl t =
+  if fs.ls_constr then raise (IllegalConstructor fs);
+  let hd = t_app fs (List.map t_var vl) t.t_ty in
+  let fd = f_forall vl [] (f_equ hd t) in
+  extract_ls_defn fd
+
+let make_ps_defn ps vl f =
+  let hd = f_app ps (List.map t_var vl) in
+  let pd = f_forall vl [] (f_iff hd f) in
+  extract_ls_defn pd
+
+let make_ls_defn ls vl = e_apply (make_fs_defn ls vl) (make_ps_defn ls vl)
+
+let open_fs_defn = function (_,vl,Term t,_) -> (vl,t) | _ -> assert false
 
-let open_fs_defn = function
-  | (fs,vl,Term t,_) -> (fs,vl,t)
-  | _ -> assert false
+let open_ps_defn = function (_,vl,Fmla f,_) -> (vl,f) | _ -> assert false
 
-let open_ps_defn = function
-  | (ps,vl,Fmla f,_) -> (ps,vl,f)
-  | _ -> assert false
+let open_ls_defn (_,vl,e,_) = (vl,e)
 
 let ls_defn_axiom (_,_,_,f) = f
 

src/core/theory.mli

@@ -35,17 +35,17 @@ type ty_decl = tysymbol * ty_def
 
 type ls_defn
 
-val make_ls_defn : lsymbol -> vsymbol list -> expr -> ls_defn
-val make_fs_defn : lsymbol -> vsymbol list -> term -> ls_defn
-val make_ps_defn : lsymbol -> vsymbol list -> fmla -> ls_defn
+type logic_decl = lsymbol * ls_defn option
 
-val open_ls_defn : ls_defn -> lsymbol * vsymbol list * expr
-val open_fs_defn : ls_defn -> lsymbol * vsymbol list * term
-val open_ps_defn : ls_defn -> lsymbol * vsymbol list * fmla
+val make_ls_defn : lsymbol -> vsymbol list -> expr -> logic_decl
+val make_fs_defn : lsymbol -> vsymbol list -> term -> logic_decl
+val make_ps_defn : lsymbol -> vsymbol list -> fmla -> logic_decl
 
-val ls_defn_axiom : ls_defn -> fmla
+val open_ls_defn : ls_defn -> vsymbol list * expr
+val open_fs_defn : ls_defn -> vsymbol list * term
+val open_ps_defn : ls_defn -> vsymbol list * fmla
 
-type logic_decl = lsymbol * ls_defn option
+val ls_defn_axiom : ls_defn -> fmla
 
 (* inductive predicate declaration *)
 

src/output/alt_ergo.ml

@@ -160,7 +160,7 @@ let print_logic_decl drv ctxt fmt (ls,ld) =
                 (print_list comma (print_type drv)) ls.ls_args 
                 (print_option_or_default "prop" (print_type drv)) ls.ls_value
           | Some ld ->
-              let _,vl,e = open_ls_defn ld in
+              let vl,e = open_ls_defn ld in
               begin match e with
                 | Term t ->
                     (* TODO AC? *)

src/output/why3.ml

@@ -292,7 +292,7 @@ let print_type_decl drv fmt d =
     | _ -> print_type_decl drv fmt d; forget_tvs ()
 
 let print_ls_defn drv fmt ld =
-  let _,vl,e = open_ls_defn ld in
+  let vl,e = open_ls_defn ld in
   fprintf fmt " =@ %a" (print_expr drv) e;
   List.iter forget_var vl
 

src/parser/typing.ml

@@ -870,8 +870,8 @@ let add_logics dl th =
     match d.ld_type with
     | None -> (* predicate *)
 	let ps = Hashtbl.find psymbols id in
-        let defn = match d.ld_def with
-	  | None -> None
+        begin match d.ld_def with
+	  | None -> ps,None
 	  | Some f -> 
 	      let f = dfmla denv f in
               let vl = match ps.ls_value with
@@ -879,13 +879,12 @@ let add_logics dl th =
                 | _ -> assert false
               in
 	      let env = env_of_vsymbol_list vl in
-              Some (make_ps_defn ps vl (fmla env f))
-        in
-        ps, defn
+              make_ps_defn ps vl (fmla env f)
+        end
     | Some ty -> (* function *)
 	let fs = Hashtbl.find fsymbols id in
-        let defn = match d.ld_def with
-	  | None -> None
+        begin match d.ld_def with
+	  | None -> fs,None
 	  | Some t -> 
 	      let loc = t.pp_loc in
 	      let t = dterm denv t in
@@ -894,15 +893,13 @@ let add_logics dl th =
                 | _ -> assert false
               in
 	      let env = env_of_vsymbol_list vl in
-              try Some (make_fs_defn fs vl (term env t))
+              try make_fs_defn fs vl (term env t)
 	      with _ -> term_expected_type ~loc t.dt_ty (dty denv ty)
-        in
-        fs, defn
+        end
   in
   let dl = List.map type_decl dl in
   List.fold_left add_decl th (create_logic_decls dl)
 
-
 let term env t =
   let denv = create_denv env in
   let t = dterm denv t in

src/transform/inlining.ml

@@ -75,19 +75,19 @@ let fold isnotinlinedt isnotinlinedf ctxt0 (env, ctxt) =
         match ld with
           | None -> env,add_decl ctxt d
           | Some ld ->
-              let _,vs,e = open_ls_defn ld in
+              let vs,e = open_ls_defn ld in
               match e with
                 | Term t ->
                     let t = replacet env t in
                     if t_s_any ffalse ((==) ls) t || isnotinlinedt t
                     then env, add_decl ctxt 
-                      (create_logic_decl [(ls, Some (make_fs_defn ls vs t))])
+                      (create_logic_decl [make_fs_defn ls vs t])
                     else {env with fs = Mls.add ls (vs,t) env.fs},ctxt
                 | Fmla f -> 
                     let f = replacep env f in
                     if f_s_any ffalse ((==) ls) f || isnotinlinedf f
                     then env, add_decl ctxt 
-                      (create_logic_decl [(ls,Some (make_ps_defn ls vs f))])
+                      (create_logic_decl [make_ps_defn ls vs f])
                     else {env with ps = Mls.add ls (vs,f) env.ps},ctxt
       end
     | Dind dl ->
@@ -97,10 +97,12 @@ let fold isnotinlinedt isnotinlinedf ctxt0 (env, ctxt) =
     | Dlogic dl -> 
         env,
         add_decl ctxt (create_logic_decl 
-           (List.map (fun (ls,ld) -> ls, Util.option_map (fun ld ->
-              let _,vs,e = open_ls_defn ld in
-              let e = e_map (replacet env) (replacep env) e in
-              make_ls_defn ls vs e) ld) dl))
+           (List.map (fun (ls,ld) -> match ld with 
+              | None -> ls, None
+              | Some ld ->
+                let vs,e = open_ls_defn ld in
+                let e = e_map (replacet env) (replacep env) e in
+                make_ls_defn ls vs e) dl))
     | Dtype dl -> env,add_decl ctxt d
     | Dprop (k,pr,f) -> 
         env,add_decl ctxt (create_prop_decl k pr (replacep env f))

src/transform/transform.ml

@@ -241,9 +241,9 @@ let rewrite_elt rt rf d =
     | Dlogic l -> [create_logic_decl (List.map 
         (function 
            | (ls,Some def) -> 
-               let (ls,vsl,expr) = open_ls_defn def in
+               let vsl,expr = open_ls_defn def in
                let expr = e_map rt rf expr in
-               (ls,Some (make_ls_defn ls vsl expr))
+               make_ls_defn ls vsl expr
            | l -> l) l)]
     | Dind indl -> [create_ind_decl 
         (List.map (fun (ls,pl) -> ls,