program extraction (WIP)

TODO

@@ -119,6 +119,12 @@ tools
   - Maybe : make something generic for the dialog box with memory.
 
 
+OCaml extraction
+----------------
+
+  - allow other realizations for arithmetic, such as Zarith or GMP
+    (currently this is Num)
+
 provers
 -------
 

bench/bench

@@ -44,6 +44,7 @@ bads () {
 
 drivers () {
     for f in $1/*.drv; do
+        if [ $f = "drivers/ocaml.drv" ]; then continue; fi
 	echo -n "  "$f"... "
 	# running Why
 	if ! echo "theory Test goal G : 1=2 end" | $pgm -F why --driver $f - > /dev/null 2>&1; then

drivers/ocaml.drv

+
+filename "%f_%t.ml"
+
+theory BuiltIn
+  syntax type       int   "Num.num"
+  syntax predicate  (=)   "(%1 = %2)"
+end
+
+theory option.Option
+  syntax type     option "(%1 option)"
+  syntax function None   "None"
+  syntax function Some   "(Some %1)"
+end
+
+theory Bool
+  syntax type bool "bool"
+  syntax function True  "true"
+  syntax function False "false"
+end
+
+theory bool.Bool
+  syntax function andb  "(%1 && %2)"
+  syntax function orb   "(%1 || %2)"
+  (* syntax function xorb  "(xorb %1 %2)" *)
+  syntax function notb  "(not %1)"
+  (* syntax function implb "(implb %1)" *)
+end
+
+theory list.List
+  syntax type     list "%1 list"
+  syntax function Nil  "[]"
+  syntax function Cons "(%1 :: %2)"
+end
+
+theory int.Int
+  syntax function zero "(Num.num_of_int 0)"
+  syntax function one  "(Num.num_of_int 1)"
+
+  syntax function (+)  "(Num.add_num %1 %2)"
+  syntax function (-)  "(Num.sub_num %1 %2)"
+  syntax function (*)  "(Num.mult_num %1 %2)"
+  syntax function (-_) "(Num.minus_num %1)"
+
+  syntax predicate (<=) "(Num.le_num %1 %2)"
+  syntax predicate (<)  "(Num.lt_num %1 %2)"
+  syntax predicate (>=) "(Num.ge_num %1 %2)"
+  syntax predicate (>)  "(Num.gt_num %1 %2)"
+end
+
+theory int.Abs
+  syntax function abs "(Num.abs_num %1)"
+end
+
+theory int.MinMax
+  syntax function min "(Num.min_num %1 %2)"
+  syntax function max "(Num.max_num %1 %2)"
+end
+
+(* Note: documentation for Num says ``Euclidean division'' but this is
+   rather a computer division *)
+theory int.ComputerDivision
+  syntax function div "(Num.quo_num %1 %2)"
+  syntax function mod "(Num.mod_num %1 %2)"
+end
+

src/core/printer.ml

@@ -251,14 +251,11 @@ let get_syntax_map task =
   let sm = Task.on_meta meta_remove_prop sm_add_pr sm task in
   sm
 
-(*
-let get_syntax_map_of_theory theory =
-  let sm = Mid.empty in
-  let sm = Theory.on_meta meta_syntax_type sm_add_ts sm theory in
-  let sm = Theory.on_meta meta_syntax_logic sm_add_ls sm theory in
-  let sm = Theory.on_meta meta_remove_prop sm_add_pr sm theory in
-  sm
-*)
+let add_syntax_map td sm = match td.td_node with
+  | Meta (m, args) when meta_equal m meta_syntax_type  -> sm_add_ts sm args
+  | Meta (m, args) when meta_equal m meta_syntax_logic -> sm_add_ls sm args
+  | Meta (m, args) when meta_equal m meta_remove_prop  -> sm_add_pr sm args
+  | _ -> sm
 
 let query_syntax sm id = Mid.find_opt id sm
 

src/core/printer.mli

@@ -60,9 +60,8 @@ type syntax_map = string Mid.t
 (* [syntax_map] maps the idents of removed props to "" *)
 
 val get_syntax_map : task -> syntax_map
-(*
-val get_syntax_map_of_theory : theory -> syntax_map
-*)
+val add_syntax_map : tdecl -> syntax_map -> syntax_map
+  (* interprets a declaration as a syntax rule, if any *)
 
 val query_syntax : syntax_map -> ident -> string option
 

src/driver/driver.ml

@@ -199,6 +199,10 @@ let load_driver = let driver_tag = ref (-1) in fun env file extra_files ->
     drv_tag         = !driver_tag
   }
 
+let syntax_map drv =
+  let addth _ (_,tds) acc = Stdecl.fold Printer.add_syntax_map tds acc in
+  Mid.fold addth drv.drv_meta Mid.empty
+
 (** apply drivers *)
 
 exception UnknownSpec of string

src/driver/driver.mli

@@ -84,3 +84,7 @@ val prove_task_prepared :
   ?inplace   : bool ->
   driver -> Task.task -> Call_provers.pre_prover_call
 
+
+(** Traverse all metas from a driver *)
+
+val syntax_map: driver -> Printer.syntax_map

src/main.ml

@@ -523,15 +523,16 @@ let do_local_theory env drv fname m (tname,_,t,glist) =
 
 let extract_to ?fname th extract =
   let dir = match !opt_output with Some dir -> dir | None -> assert false in
-  let fname = match fname, th.th_path with
+  let _fname = match fname, th.th_path with
     | Some fname, _ ->
         let fname = Filename.basename fname in
         (try Filename.chop_extension fname with _ -> fname)
     | None, [] -> assert false
     | None, path -> List.hd (List.rev path)
   in
-  let mname = fname ^ "__" ^ th.th_name.Ident.id_string ^ ".ml" in
-  let mname = String.uncapitalize mname in
+  (* FIXME: use fname to forge the OCaml filename *)
+  let mname = (* fname ^ "__" ^ *) th.th_name.Ident.id_string ^ ".ml" in
+  (* let mname = String.uncapitalize mname in *)
   let file = Filename.concat dir mname in
   let old =
     if Sys.file_exists file then begin
@@ -543,48 +544,50 @@ let extract_to ?fname th extract =
   extract file ?old (formatter_of_out_channel cout);
   close_out cout
 
-let do_extract_theory _env ?fname tname th _glist =
-  let extract fname ?old _fmt = ignore (old);
-    Debug.dprintf Mlw_ocaml.debug "extract theory %s to file %s@." tname fname
+let do_extract_theory env ?fname tname th =
+  let extract fname ?old fmt = ignore (old);
+    Debug.dprintf Mlw_ocaml.debug "extract theory %s to file %s@." tname fname;
+    Mlw_ocaml.extract_theory env ?old fmt th
   in
   extract_to ?fname th extract
 
-let do_extract_module _env ?fname tname m _glist =
-  let extract fname ?old _fmt = ignore (old);
-    Debug.dprintf Mlw_ocaml.debug "extract module %s to file %s@." tname fname
+let do_extract_module env ?fname tname m =
+  let extract fname ?old fmt = ignore (old);
+    Debug.dprintf Mlw_ocaml.debug "extract module %s to file %s@." tname fname;
+    Mlw_ocaml.extract_module env ?old fmt m
   in
   extract_to ?fname m.Mlw_module.mod_theory extract
 
-let do_global_extract env (tname,p,t,glist) =
+let do_global_extract env (tname,p,t,_) =
   try
     let lib = Mlw_main.library_of_env env in
     let mm, thm = Env.read_lib_file lib p in
     try
       let m = Mstr.find t mm in
-      do_extract_module env tname m glist
+      do_extract_module env tname m
     with Not_found ->
       let th = Mstr.find t thm in
-      do_extract_theory env tname th glist
+      do_extract_theory env tname th
   with Env.LibFileNotFound _ | Not_found -> try
     let format = Util.def_option "why" !opt_parser in
     let th = Env.read_theory ~format env p t in
-    do_extract_theory env tname th glist
+    do_extract_theory env tname th
   with Env.LibFileNotFound _ | Env.TheoryNotFound _ ->
     eprintf "Theory/module '%s' not found.@." tname;
     exit 1
 
-let do_extract_theory_from env fname m (tname,_,t,glist) =
+let do_extract_theory_from env fname m (tname,_,t,_) =
   let th = try Mstr.find t m with Not_found ->
     eprintf "Theory '%s' not found in file '%s'.@." tname fname;
     exit 1
   in
-  do_extract_theory env ~fname tname th glist
+  do_extract_theory env ~fname tname th
 
-let do_extract_module_from env fname mm thm (tname,_,t,glist) =
+let do_extract_module_from env fname mm thm (tname,_,t,_) =
   try
-    let m = Mstr.find t mm in do_extract_module env ~fname tname m glist
+    let m = Mstr.find t mm in do_extract_module env ~fname tname m
   with Not_found -> try
-    let th = Mstr.find t thm in do_extract_theory env ~fname tname th glist
+    let th = Mstr.find t thm in do_extract_theory env ~fname tname th
   with Not_found ->
     eprintf "Theory/module '%s' not found in file '%s'.@." tname fname;
     exit 1
@@ -594,19 +597,17 @@ let do_local_extract env fname cin tlist =
     let lib = Mlw_main.library_of_env env in
     let mm, thm = Mlw_main.read_channel lib [] fname cin in
     if Queue.is_empty tlist then begin
-      let glist = Queue.create () in
       let do_m t m thm =
-        do_extract_module env ~fname t m glist; Mstr.remove t thm in
+        do_extract_module env ~fname t m; Mstr.remove t thm in
       let thm = Mstr.fold do_m mm thm in
-      Mstr.iter (fun t th -> do_extract_theory env ~fname t th glist) thm
+      Mstr.iter (fun t th -> do_extract_theory env ~fname t th) thm
     end else
       Queue.iter (do_extract_module_from env fname mm thm) tlist
   end else begin
     let m = Env.read_channel ?format:!opt_parser env fname cin in
     if Queue.is_empty tlist then
-      let glist = Queue.create () in
       let add_th t th mi = Ident.Mid.add th.th_name (t,th) mi in
-      let do_th _ (t,th) = do_extract_theory env ~fname t th glist in
+      let do_th _ (t,th) = do_extract_theory env ~fname t th in
       Ident.Mid.iter do_th (Mstr.fold add_th m Ident.Mid.empty)
     else
       Queue.iter (do_extract_theory_from env fname m) tlist

src/whyml/mlw_ocaml.mli

@@ -24,7 +24,11 @@ open Why3
 
 val debug: Debug.flag
 
+val extract_theory:
+  Env.env -> ?old:Pervasives.in_channel -> Format.formatter ->
+  Theory.theory -> unit
+
 val extract_module:
-  Env.env -> Printer.prelude -> Printer.prelude_map ->
-  ?old:Pervasives.in_channel -> Format.formatter -> Mlw_module.modul -> unit
+  Env.env -> ?old:Pervasives.in_channel -> Format.formatter ->
+  Mlw_module.modul -> unit