setting up the command line for program extraction

note: program extraction IS NOT yet implemented
parent 12627ead
...@@ -364,7 +364,7 @@ install_no_local:: ...@@ -364,7 +364,7 @@ install_no_local::
######## ########
PGM_FILES = pgm_ttree pgm_types pgm_pretty \ PGM_FILES = pgm_ttree pgm_types pgm_pretty \
pgm_module pgm_wp pgm_typing pgm_ocaml pgm_main pgm_module pgm_wp pgm_typing pgm_main
PGMMODULES = $(addprefix src/programs/, $(PGM_FILES)) PGMMODULES = $(addprefix src/programs/, $(PGM_FILES))
...@@ -392,7 +392,7 @@ clean:: ...@@ -392,7 +392,7 @@ clean::
######## ########
MLW_FILES = mlw_ty mlw_expr mlw_decl mlw_pretty mlw_wp mlw_module \ MLW_FILES = mlw_ty mlw_expr mlw_decl mlw_pretty mlw_wp mlw_module \
mlw_dtree mlw_dty mlw_typing mlw_main mlw_dtree mlw_dty mlw_typing mlw_ocaml mlw_main
MLWMODULES = $(addprefix src/whyml/, $(MLW_FILES)) MLWMODULES = $(addprefix src/whyml/, $(MLW_FILES))
...@@ -422,6 +422,9 @@ clean:: ...@@ -422,6 +422,9 @@ clean::
src/main.cmo: src/why3.cma src/main.cmo: src/why3.cma
src/main.cmx: src/why3.cmxa src/main.cmx: src/why3.cmxa
src/main.cmo src/main.cmx: INCLUDES += -I src/whyml
src/main.dep: DEPFLAGS += -I src/whyml
byte: bin/why3.byte byte: bin/why3.byte
opt: bin/why3.opt opt: bin/why3.opt
...@@ -441,6 +444,12 @@ install_no_local:: ...@@ -441,6 +444,12 @@ install_no_local::
install_local: bin/why3 install_local: bin/why3
ifneq "$(MAKECMDGOALS)" "clean"
include src/main.dep
endif
depend: src/main.dep
clean:: clean::
rm -f src/main.cm[iox] src/main.annot src/main.o rm -f src/main.cm[iox] src/main.annot src/main.o
rm -f bin/why3.byte bin/why3.opt bin/why3 rm -f bin/why3.byte bin/why3.opt bin/why3
......
...@@ -103,6 +103,7 @@ let opt_memlimit = ref None ...@@ -103,6 +103,7 @@ let opt_memlimit = ref None
let opt_command = ref None let opt_command = ref None
let opt_task = ref None let opt_task = ref None
let opt_realize = ref false let opt_realize = ref false
let opt_extract = ref false
let opt_bisect = ref false let opt_bisect = ref false
let opt_print_libdir = ref false let opt_print_libdir = ref false
...@@ -178,6 +179,10 @@ let option_list = Arg.align [ ...@@ -178,6 +179,10 @@ let option_list = Arg.align [
" same as -o"; " same as -o";
"--realize", Arg.Set opt_realize, "--realize", Arg.Set opt_realize,
" Realize selected theories from the library"; " Realize selected theories from the library";
"-E", Arg.Set opt_extract,
" Generate OCaml code for selected theories/modules from the library";
"--extract", Arg.Set opt_extract,
" same as -E";
"--bisect", Arg.Set opt_bisect, "--bisect", Arg.Set opt_bisect,
" Reduce the set of needed axioms which prove a goal, \ " Reduce the set of needed axioms which prove a goal, \
and output the resulting task"; and output the resulting task";
...@@ -300,11 +305,14 @@ let () = try ...@@ -300,11 +305,14 @@ let () = try
exit 1 exit 1
end; end;
if !opt_output <> None
&& !opt_driver = None && !opt_prover = None && not !opt_extract then begin
eprintf
"Option '-o'/'--output' requires a prover, a driver, or option '-E'.@.";
exit 1
end;
if !opt_prover = None then begin if !opt_prover = None then begin
if !opt_driver = None && !opt_output <> None then begin
eprintf "Option '-o'/'--output' requires a prover or a driver.@.";
exit 1
end;
if !opt_timelimit <> None then begin if !opt_timelimit <> None then begin
eprintf "Option '-t'/'--timelimit' requires a prover.@."; eprintf "Option '-t'/'--timelimit' requires a prover.@.";
exit 1 exit 1
...@@ -321,6 +329,12 @@ let () = try ...@@ -321,6 +329,12 @@ let () = try
opt_print_theory := true opt_print_theory := true
end; end;
if !opt_extract && !opt_output = None then begin
eprintf
"Option '-E'/'--extract' require a directory to output the result.@.";
exit 1
end;
if !opt_bisect && !opt_output = None then begin if !opt_bisect && !opt_output = None then begin
eprintf "Option '--bisect' require a directory to output the result.@."; eprintf "Option '--bisect' require a directory to output the result.@.";
exit 1 exit 1
...@@ -505,12 +519,81 @@ let do_local_theory env drv fname m (tname,_,t,glist) = ...@@ -505,12 +519,81 @@ let do_local_theory env drv fname m (tname,_,t,glist) =
in in
do_theory env drv fname tname th glist do_theory env drv fname tname th glist
(* program extraction *)
let do_extract_theory _env tname th _glist =
printf "do_extract_theory: tname=%s th_path=%a@." tname
(Pp.print_list Pp.dot Format.pp_print_string) th.th_path
let do_extract_module _env tname m _glist =
printf "do_extract_module: tname=%s th_path=%a@." tname
(Pp.print_list Pp.dot Format.pp_print_string)
m.Mlw_module.mod_theory.th_path
let do_global_extract env (tname,p,t,glist) =
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
with Not_found ->
let th = Mstr.find t thm in
do_extract_theory env tname th glist
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
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 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 tname th glist
let do_extract_module_from env fname mm thm (tname,_,t,glist) =
try
let m = Mstr.find t mm in do_extract_module env tname m glist
with Not_found -> try
let th = Mstr.find t thm in do_extract_theory env tname th glist
with Not_found ->
eprintf "Theory/module '%s' not found in file '%s'.@." tname fname;
exit 1
let do_local_extract env fname cin tlist =
if !opt_parser = Some "whyml" || Filename.check_suffix fname ".mlw" then begin
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 t m glist; Mstr.remove t thm in
let thm = Mstr.fold do_m mm thm in
Mstr.iter (fun t th -> do_extract_theory env t th glist) 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 t th glist 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
end
let total_annot_tokens = ref 0 let total_annot_tokens = ref 0
let total_program_tokens = ref 0 let total_program_tokens = ref 0
let do_input env drv = function let do_input env drv = function
| None, _ when !opt_parse_only || !opt_type_only -> | None, _ when !opt_parse_only || !opt_type_only ->
() ()
| None, tlist when !opt_extract ->
Queue.iter (do_global_extract env) tlist
| None, tlist -> | None, tlist ->
Queue.iter (do_global_theory env drv) tlist Queue.iter (do_global_theory env drv) tlist
| Some f, tlist -> | Some f, tlist ->
...@@ -518,24 +601,24 @@ let do_input env drv = function ...@@ -518,24 +601,24 @@ let do_input env drv = function
| "-" -> "stdin", stdin | "-" -> "stdin", stdin
| f -> f, open_in f | f -> f, open_in f
in in
if !opt_token_count then if !opt_token_count then begin
let lb = Lexing.from_channel cin in let lb = Lexing.from_channel cin in
let a,p = Lexer.token_counter lb in let a,p = Lexer.token_counter lb in
close_in cin; close_in cin;
if a = 0 then if a = 0 then begin
begin (* hack: we assume it is a why file and not a mlw *)
(* hack: we assume it is a why file and not a mlw *) total_annot_tokens := !total_annot_tokens + p;
total_annot_tokens := !total_annot_tokens + p; Format.printf "File %s: %d tokens@." f p;
Format.printf "File %s: %d tokens@." f p; end else begin
end total_program_tokens := !total_program_tokens + p;
else total_annot_tokens := !total_annot_tokens + a;
begin Format.printf "File %s: %d tokens in annotations@." f a;
total_program_tokens := !total_program_tokens + p; Format.printf "File %s: %d tokens in programs@." f p
total_annot_tokens := !total_annot_tokens + a; end
Format.printf "File %s: %d tokens in annotations@." f a; end else if !opt_extract then begin
Format.printf "File %s: %d tokens in programs@." f p do_local_extract env fname cin tlist;
end close_in cin
else end else begin
let m = Env.read_channel ?format:!opt_parser env fname cin in let m = Env.read_channel ?format:!opt_parser env fname cin in
close_in cin; close_in cin;
if !opt_type_only then if !opt_type_only then
...@@ -548,6 +631,7 @@ let do_input env drv = function ...@@ -548,6 +631,7 @@ let do_input env drv = function
Ident.Mid.iter do_th (Mstr.fold add_th m Ident.Mid.empty) Ident.Mid.iter do_th (Mstr.fold add_th m Ident.Mid.empty)
else else
Queue.iter (do_local_theory env drv fname m) tlist Queue.iter (do_local_theory env drv fname m) tlist
end
let () = let () =
try try
......
...@@ -81,7 +81,6 @@ let add_module ?(type_only=false) env path (ltm, lmod) m = ...@@ -81,7 +81,6 @@ let add_module ?(type_only=false) env path (ltm, lmod) m =
let uc = use_export_theory uc prelude in let uc = use_export_theory uc prelude in
let uc = List.fold_left (Pgm_typing.decl ~wp env ltm lmod) uc m.mod_decl in let uc = List.fold_left (Pgm_typing.decl ~wp env ltm lmod) uc m.mod_decl in
let md = close_module uc in let md = close_module uc in
if Debug.test_flag debug_extraction then Pgm_ocaml.extract_module path md;
Mstr.add ("WP " ^ id.id) md.m_pure ltm, (* avoids a theory/module clash *) Mstr.add ("WP " ^ id.id) md.m_pure ltm, (* avoids a theory/module clash *)
Mstr.add id.id md lmod Mstr.add id.id md lmod
......
...@@ -27,9 +27,8 @@ open Ty ...@@ -27,9 +27,8 @@ open Ty
open Term open Term
open Decl open Decl
open Theory open Theory
open Pgm_types.T open Mlw_expr
open Pgm_ttree open Mlw_decl
open Pgm_module
(** Driver *) (** Driver *)
...@@ -434,9 +433,11 @@ let logic_tdecl fmt td = match td.td_node with ...@@ -434,9 +433,11 @@ let logic_tdecl fmt td = match td.td_node with
let extract_theory _path _th = let extract_theory _path _th =
assert false (*TODO*) assert false (*TODO*)
(** Program Expression *) (** Program expressions *)
let rec print_expr fmt e = match e.expr_desc with let rec print_expr _fmt e = match e.e_node with
| _ -> assert false (*TODO*)
(***
| Elogic t -> | Elogic t ->
print_term fmt t print_term fmt t
| Elocal v -> | Elocal v ->
...@@ -507,10 +508,13 @@ and print_branch fmt (p, e) = ...@@ -507,10 +508,13 @@ and print_branch fmt (p, e) =
and print_pattern fmt p = and print_pattern fmt p =
print_pat fmt p.ppat_pat print_pat fmt p.ppat_pat
***)
(** Program Declarations *) (** Program Declarations *)
let decl fmt = function let decl _fmt pd = match pd.pd_node with
| _ -> assert false (*TODO*)
(***
| Dlet (ps, e) -> | Dlet (ps, e) ->
fprintf fmt "@[<hov 2>let %a =@ %a@]" fprintf fmt "@[<hov 2>let %a =@ %a@]"
print_ls ps.ps_pure print_expr e print_ls ps.ps_pure print_expr e
...@@ -518,9 +522,11 @@ let decl fmt = function ...@@ -518,9 +522,11 @@ let decl fmt = function
fprintf fmt "(* pgm let rec *)" (* TODO *) fprintf fmt "(* pgm let rec *)" (* TODO *)
| Dparam ps -> | Dparam ps ->
print_param_decl fmt ps.ps_pure print_param_decl fmt ps.ps_pure
***)
(** Modules *) (** Modules *)
(***
let extract_module_to m fmt = let extract_module_to m fmt =
(* extract all logic decls first *) (* extract all logic decls first *)
print_list newline2 logic_tdecl fmt m.m_pure.th_decls; print_list newline2 logic_tdecl fmt m.m_pure.th_decls;
...@@ -540,6 +546,11 @@ let extract_module path m = ...@@ -540,6 +546,11 @@ let extract_module path m =
eprintf " to file %s@." file; eprintf " to file %s@." file;
print_in_file (extract_module_to m) file print_in_file (extract_module_to m) file
end end
***)
let extract_module _env _pr _thpr ?old _fmt _m =
ignore (old);
assert false (*TODO*)
(* (*
Local Variables: Local Variables:
......
...@@ -20,5 +20,9 @@ ...@@ -20,5 +20,9 @@
(* OCaml program extraction *) (* OCaml program extraction *)
val extract_module: string list -> Pgm_module.t -> unit open Why3
val extract_module:
Env.env -> Printer.prelude -> Printer.prelude_map ->
?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