Commit fd402ea5 authored by Andrei Paskevich's avatar Andrei Paskevich

- rework Call_provers, remove calling primitives from Driver

- accept timeout regexps in drivers
- do not take command line from drivers
parent a3f4f927
......@@ -4,8 +4,7 @@
prelude "(* this is a prelude for Alt-Ergo*)"
printer "alt-ergo"
filename "%f-%t-%s.why"
call_on_file "alt-ergo %s"
filename "%f-%t-%g.why"
valid "Valid"
invalid "Invalid"
......
printer "coq"
filename "%f_%t_%s.v"
call_on_file "coqc %s"
filename "%f_%t_%g.v"
prelude "(* generated by Why3's Coq driver *)"
......
......@@ -4,8 +4,7 @@
prelude "(* this is a prelude for smtlib*)"
printer "smtv1"
filename "%f-%t-%s.smt"
call_on_stdin "cvc3 -lang smt"
filename "%f-%t-%g.smt"
valid "unsat"
unknown "\\bunknown\\b\\|\\bsat\\b" "Unknown"
......
printer "why3"
filename "%f-%t-%s.why"
filename "%f-%t-%g.why"
theory BuiltIn
syntax type int "int"
......
printer "why3"
filename "%f-%t-%s.why"
filename "%f-%t-%g.why"
transformations
"remove_logic_definition"
......
printer "why3"
filename "%f-%t-%s.why"
filename "%f-%t-%g.why"
(* À discuter *)
transformations
......
printer "why3"
filename "%f-%t-%s.why"
filename "%f-%t-%g.why"
(* À discuter *)
transformations
......
printer "why3"
filename "%f-%t-%s.why"
filename "%f-%t-%g.why"
transformations
"compile_match"
......
......@@ -4,9 +4,7 @@
prelude "(* this is a prelude for smtlib*)"
printer "smtv1"
filename "%f-%t-%s.smt"
call_on_file "z3 -smt %s"
call_on_stdin "z3 -smt -in"
filename "%f-%t-%g.smt"
valid "unsat"
unknown "unknown\\|sat|Fail" "Unknown"
......
......@@ -18,45 +18,111 @@
(**************************************************************************)
open Format
open Sysutil
type prover_answer =
| Valid
| Invalid
| Timeout
| Unknown of string
| Failure of string
| Timeout
| HighFailure
type prover_result = {
pr_answer : prover_answer;
pr_output : string;
pr_time : float;
}
type prover_regexp = Str.regexp * prover_answer
let print_prover_answer fmt = function
| Valid -> fprintf fmt "Valid"
| Invalid -> fprintf fmt "Invalid"
| Timeout -> fprintf fmt "Timeout"
| Unknown s -> pp_print_string fmt s
| Failure s -> pp_print_string fmt s
| Timeout -> fprintf fmt "Timeout"
| HighFailure -> fprintf fmt "HighFailure"
type prover_result =
{ pr_time : float;
pr_answer : prover_answer;
pr_stderr : string;
pr_stdout : string}
let print_prover_result fmt pr =
fprintf fmt "%a (%.2fs)" print_prover_answer pr.pr_answer pr.pr_time;
if pr.pr_answer == HighFailure
then fprintf fmt "@\nstdout-stderr : \"%s\"" pr.pr_stdout;
if pr.pr_answer == HighFailure then
fprintf fmt "@\n@stdout-stderr:@\n%s@." pr.pr_output
let rec grep out l = match l with
| [] -> HighFailure
| (re,pa)::l ->
begin try
ignore (Str.search_forward re out 0);
match pa with
| Valid | Invalid | Timeout -> pa
| Unknown s -> Unknown (Str.replace_matched s out)
| Failure s -> Failure (Str.replace_matched s out)
| HighFailure -> assert false
with Not_found -> grep out l end
type prover =
{ pr_call_stdin : string option; (* %f pour le nom du fichier *)
pr_call_file : string option;
pr_regexps : (Str.regexp * prover_answer) list;
(* \1,... sont remplacés *)
}
let call_prover debug command regexps opt_cout buffer =
let t0 = Unix.time () in
let (cin,cout) as p = Unix.open_process command in
let cout = match opt_cout with Some c -> c | _ -> cout in
Buffer.output_buffer cout buffer; close_out cout;
let out = channel_contents cin in
let ret = Unix.close_process p in
let t1 = Unix.time () in
if debug then Format.eprintf "Call_provers: Command output:@\n%s@." out;
let ans = match ret with
| Unix.WSTOPPED n ->
if debug then Format.eprintf "Call_provers: stopped on signal %d" n;
HighFailure
| Unix.WSIGNALED n ->
if debug then Format.eprintf "Call_provers: killed by signal %d" n;
HighFailure
| Unix.WEXITED n ->
if debug then Format.eprintf "Call_provers: exited with status %d" n;
grep out regexps
in
{ pr_answer = ans;
pr_output = out;
pr_time = t1 -. t0 }
let call_on_buffer ?(debug=false) ?(suffix=".dump")
~command ~timelimit ~memlimit ~regexps buffer () =
let on_stdin = ref false in
let cmd_regexp = Str.regexp "%\\(.\\)" in
let replace filename s = match Str.matched_group 1 s with
| "%" -> "%"
| "f" -> on_stdin := false; filename
| "t" -> string_of_int timelimit
| "m" -> string_of_int memlimit
| _ -> failwith "unknown format specifier, use %%f, %%t or %%m"
in
let cmd_stdin = Str.global_substitute cmd_regexp (replace "") command in
if !on_stdin then call_prover debug cmd_stdin regexps None buffer
else
let fout,cout = Filename.open_temp_file "why" suffix in
try
let cmd = Str.global_substitute cmd_regexp (replace fout) command in
let res = call_prover debug cmd regexps (Some cout) buffer in
if not debug then Sys.remove fout;
res
with e ->
close_out cout;
if not debug then Sys.remove fout;
raise e
let call_on_formatter ?debug ?suffix
~command ~timelimit ~memlimit ~regexps formatter =
let buffer = Buffer.create 1024 in
let fmt = formatter_of_buffer buffer in
formatter fmt; pp_print_flush fmt ();
call_on_buffer ?debug ?suffix ~command ~timelimit ~memlimit ~regexps buffer
exception CommandError
exception NoCommandlineProvided
let call_on_file ?debug ?suffix
~command ~timelimit ~memlimit ~regexps filename =
let buffer = file_contents_buf filename in
call_on_buffer ?debug ?suffix ~command ~timelimit ~memlimit ~regexps buffer
(*
let is_true_cygwin = Sys.os_type = "Cygwin"
(* this should be replaced by a proper use of fork/waitpid() *)
......@@ -249,3 +315,4 @@ let on_buffer ?debug ?timeout ?filename pr buffer =
(fun file cout ->
Buffer.output_buffer cout buffer;
on_file ?timeout ?debug pr file)
*)
......@@ -17,59 +17,52 @@
(* *)
(**************************************************************************)
open Format
type prover_answer =
| Valid
| Invalid
| Timeout
| Unknown of string
| Failure of string
| Timeout
| HighFailure
val print_prover_answer : formatter -> prover_answer -> unit
type prover_result =
{ pr_time : float;
type prover_result = {
pr_answer : prover_answer;
pr_stderr : string;
pr_stdout : string}
pr_output : string;
pr_time : float;
}
val print_prover_result : formatter -> prover_result -> unit
type prover_regexp = Str.regexp * prover_answer
type prover =
{ pr_call_stdin : string option; (* %f pour le nom du fichier *)
pr_call_file : string option;
pr_regexps : (Str.regexp * prover_answer) list;
(* \1,... sont remplacés *)
}
val print_prover_answer : Format.formatter -> prover_answer -> unit
val print_prover_result : Format.formatter -> prover_result -> unit
exception CommandError
exception NoCommandlineProvided
val call_on_buffer :
?debug : bool ->
?suffix : string ->
command : string ->
timelimit : int ->
memlimit : int ->
regexps : prover_regexp list ->
Buffer.t ->
(unit -> prover_result)
val cpulimit : string ref
val call_on_formatter :
?debug : bool ->
?suffix : string ->
command : string ->
timelimit : int ->
memlimit : int ->
regexps : prover_regexp list ->
(Format.formatter -> unit) ->
(unit -> prover_result)
val on_file :
?debug:bool ->
?timeout:int ->
prover ->
val call_on_file :
?debug : bool ->
?suffix : string ->
command : string ->
timelimit : int ->
memlimit : int ->
regexps : prover_regexp list ->
string ->
prover_result
val on_formatter :
?debug:bool ->
?timeout:int ->
?filename:string -> (* used as the suffix of a tempfile if the prover can't
deal with stdin *)
prover ->
(formatter -> unit) ->
prover_result
(unit -> prover_result)
val on_buffer :
?debug:bool ->
?timeout:int ->
?filename:string -> (* used as the suffix of a tempfile if the prover can't
deal with stdin *)
prover ->
Buffer.t ->
prover_result
......@@ -28,6 +28,7 @@ open Task
open Register
open Env
open Driver_ast
open Call_provers
(* Utils from Str *)
......@@ -91,28 +92,17 @@ let errorm ?loc f =
(** creating drivers *)
type prover_answer =
Call_provers.prover_answer =
| Valid
| Invalid
| Unknown of string
| Failure of string
| Timeout
| HighFailure
type theory_driver = {
thd_prelude : string list;
thd_tsymbol : unit ;
}
type translation =
| Remove
| Syntax of string
| Tag of Sstr.t
let translation_union t1 t2 =
match t1, t2 with
let translation_union t1 t2 = match t1, t2 with
| Remove, _ | _, Remove -> Remove
| ((Syntax _ as s), _) | (_,(Syntax _ as s)) -> s
| Tag s1, Tag s2 -> Tag (Sstr.union s1 s2)
......@@ -125,63 +115,30 @@ let print_translation fmt = function
type printer = (ident -> translation) -> formatter -> task -> unit
and driver = {
type driver = {
drv_env : env;
drv_printer : printer option;
drv_prover : Call_provers.prover;
drv_prelude : string list;
drv_filename : string option;
drv_transforms : task tlist_reg;
drv_thprelude : string list Mid.t;
drv_translations : (translation * translation) Mid.t
}
(*
and driver = {
drv_raw : raw_driver;
drv_clone : Theory.clone_map;
drv_used : Theory.use_map;
drv_env : env;
drv_thprelude : string list Hid.t;
(* the first is the translation only for this ident, the second is
also for representant *)
drv_theory : (translation * translation) Hid.t;
drv_with_task : translation Hid.t;
drv_translations : (translation * translation) Mid.t;
drv_regexps : Call_provers.prover_regexp list;
}
*)
(*
let print_driver fmt driver =
printf "drv_theory %a@\n"
(Pp.print_iter2 Hid.iter Pp.semi Pp.comma print_ident
(Pp.print_pair print_translation print_translation))
driver.drv_theory
*)
(** registering transformation *)
let (transforms : (string, task tlist_reg) Hashtbl.t)
= Hashtbl.create 17
let register_transform_l name transform =
Hashtbl.replace transforms name transform
let (transforms : (string, task tlist_reg) Hashtbl.t) = Hashtbl.create 17
let register_transform_l name trans = Hashtbl.replace transforms name trans
let register_transform name t = register_transform_l name (singleton t)
let list_transforms () = Hashtbl.fold (fun k _ acc -> k::acc) transforms []
(** registering printers *)
let (printers : (string, printer) Hashtbl.t) = Hashtbl.create 17
let register_printer name printer = Hashtbl.replace printers name printer
let list_printers () = Hashtbl.fold (fun k _ acc -> k::acc) printers []
(*
let () =
Dynlink.allow_only ["Theory";"Term";"Ident";"Transform";"Driver";
"Pervasives";"Format";"List";"Sys";"Unix"]
*)
let load_plugin dir (byte,nat) =
if not Config.why_plugins then errorm "Plugins not supported";
let file = if Config.Dynlink.is_native then nat else byte in
......@@ -220,7 +177,6 @@ let check_syntax loc s len =
"invalid indice of argument \"%%%i\" this logic has only %i argument"
i len) s
let load_rules env (premap,tmap) {thr_name = loc,qualid; thr_rules = trl} =
let id,qfile = qualid_to_slist qualid in
let th = try
......@@ -244,7 +200,7 @@ let load_rules env (premap,tmap) {thr_name = loc,qualid; thr_rules = trl} =
try
premap,add_htheory tmap c
(ns_find_pr th.th_export q).pr_name Remove
with Not_found -> errorm ~loc "Unknown axioms %s"
with Not_found -> errorm ~loc "Unknown proposition %s"
(string_of_qualid qualid q)
end
| Rsyntaxls ((loc,q),s) ->
......@@ -302,14 +258,13 @@ let load_driver file env =
let f = load_file file in
let prelude = ref [] in
let printer = ref None in
let call_stdin = ref None in
let call_file = ref None in
let filename = ref None in
let ltransforms = ref None in
let regexps = ref [] in
let set_or_raise loc r v error =
if !r <> None then errorm ~loc "duplicate %s" error
else r := Some v in
else r := Some v
in
let add (loc, g) = match g with
| Printer _ when !printer <> None ->
errorm ~loc "duplicate printer"
......@@ -318,10 +273,9 @@ let load_driver file env =
| Printer s ->
errorm ~loc "unknown printer %s" s
| Prelude s -> prelude := s :: !prelude
| CallStdin s -> set_or_raise loc call_stdin s "callstdin"
| CallFile s -> set_or_raise loc call_file s "callfile"
| RegexpValid s -> regexps:=(s,Valid)::!regexps
| RegexpInvalid s -> regexps:=(s,Invalid)::!regexps
| RegexpTimeout s -> regexps:=(s,Timeout)::!regexps
| RegexpUnknown (s1,s2) -> regexps:=(s1,Unknown s2)::!regexps
| RegexpFailure (s1,s2) -> regexps:=(s1,Failure s2)::!regexps
| Filename s -> set_or_raise loc filename s "filename"
......@@ -332,7 +286,9 @@ let load_driver file env =
let regexps = List.map (fun (s,a) -> (Str.regexp s,a)) !regexps in
let trans r =
let transformations = match !r with
| None -> [] | Some l -> l in
| Some l -> l
| None -> []
in
List.fold_left
(fun acc (loc,s) ->
let t =
......@@ -340,21 +296,21 @@ let load_driver file env =
with Not_found -> errorm ~loc "unknown transformation %s" s in
compose_l acc t
)
identity_l transformations in
identity_l transformations
in
let transforms = trans ltransforms in
let (premap,tmap) =
List.fold_left (load_rules env) (Mid.empty,Mid.empty) f.f_rules in
List.fold_left (load_rules env) (Mid.empty,Mid.empty) f.f_rules
in
{
drv_env = env;
drv_printer = !printer;
drv_prover = {Call_provers.pr_call_stdin = !call_stdin;
pr_call_file = !call_file;
pr_regexps = regexps};
drv_prelude = !prelude;
drv_filename = !filename;
drv_transforms = transforms;
drv_thprelude = premap;
drv_translations = tmap
drv_translations = tmap;
drv_regexps = regexps;
}
(** querying drivers *)
......@@ -384,6 +340,8 @@ let syntax_arguments s print fmt l =
print fmt args.(i-1) in
global_substitute_fmt regexp_arg_pos repl_fun s fmt
let get_regexps drv = drv.drv_regexps
(** using drivers *)
let apply_transforms drv =
......@@ -409,60 +367,26 @@ let print_prelude drv used fmt =
fprintf fmt "@."
let print_task drv fmt task = match drv.drv_printer with
| None -> errorm "no printer"
| None ->
errorm "no printer"
| Some f ->
print_prelude drv (task_used task) fmt;
f (query_ident drv (task_clone task)) fmt task
let regexp_filename = Str.regexp "%\\([a-z]\\)"
let filename_of_goal drv filename theory_name task =
match drv.drv_filename with
| None -> errorm "no filename syntax given"
| Some f ->
let pr_name = (task_goal task).pr_name in
let repl_fun s =
let i = matched_group 1 s in
match i with
| "f" -> filename
let file_of_task drv input_file theory_name task =
let filename_regexp = Str.regexp "%\\(.\\)" in
let replace s = match matched_group 1 s with
| "%" -> "%"
| "f" -> input_file
| "t" -> theory_name
| "s" -> pr_name.id_short
| _ -> errorm "substitution variable are only %%f %%t and %%s" in
global_substitute regexp_filename repl_fun f
let file_printer =
create_ident_printer ~sanitizer:(sanitizer char_to_alnumus char_to_alnumus)
[]
let call_prover_on_file ?debug ?timeout drv filename =
Call_provers.on_file ?debug ?timeout drv.drv_prover filename
let call_prover_on_formatter ?debug ?timeout ?filename drv ib =
Call_provers.on_formatter ?debug ?timeout ?filename drv.drv_prover ib
let call_prover_on_buffer ?debug ?timeout ?filename drv ib =
Call_provers.on_buffer ?debug ?timeout ?filename drv.drv_prover ib
let call_prover ?debug ?timeout drv task =
let filename =
match drv.drv_filename with
| None -> None
| Some _ -> Some (filename_of_goal drv "why" "call_prover" task) in
let formatter fmt = print_task drv fmt task in
call_prover_on_formatter ?debug ?timeout ?filename drv formatter
let call_prover_ext ?debug ?timeout drv task =
let filename =
match drv.drv_filename with
| None -> None
| Some _ -> Some (filename_of_goal drv "why" "call_prover" task) in
let formatter fmt = print_task drv fmt task in
let buf = Buffer.create 64 in
let fmt = formatter_of_buffer buf in
formatter fmt;
(fun () -> call_prover_on_buffer ?debug ?timeout ?filename drv buf)
| "g" -> (task_goal task).pr_name.id_short
| _ -> errorm "unknown format specifier, use %%f, %%t or %%g"
in
let file = match drv.drv_filename with
| Some f -> f
| None -> "%f_%t_%g.dump"
in
global_substitute filename_regexp replace file
(*
Local Variables:
......
......@@ -25,18 +25,17 @@ open Task
open Trans
open Env
(** {2 creating drivers} *)
(** {2 create a driver} *)
type driver
val load_driver : string -> env -> driver
(** loads a driver from a file
@param string driver file name
@param env TODO
*)
(** {2 querying drivers} *)
(** {2 query a driver} *)
type translation =
| Remove
......@@ -48,8 +47,10 @@ val syntax_arguments : string -> (formatter -> 'a -> unit) ->
(** (syntax_argument templ print_arg fmt l) prints in the formatter fmt
the list l using the template templ and the printer print_arg *)
val get_regexps : driver -> Call_provers.prover_regexp list
(** fetch the regular expressions to parse the prover's output *)
(** {2 registering printers} *)
(** {2 register printers and transformations} *)
type printer = (ident -> translation) -> formatter -> task -> unit
......@@ -61,7 +62,7 @@ val register_transform_l : string -> task Register.tlist_reg -> unit
val list_printers : unit -> string list
val list_transforms : unit -> string list