program extraction (WIP)

parent db97f181
......@@ -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
-------
......
......@@ -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
......
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
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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
......
This diff is collapsed.
......@@ -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
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