Attention une mise à jour du serveur va être effectuée le lundi 17 mai entre 13h et 13h30. Cette mise à jour va générer une interruption du service de quelques minutes.

Commit bffd338a authored by David Hauzar's avatar David Hauzar

Passing traceability information from printer to the parser of the output of the solver.

Conflicts:
	src/driver/call_provers.ml
	src/printer/smtv2.ml
	src/session/session_scheduler.ml
parent 8178fc7e
......@@ -12,7 +12,7 @@
open Stdlib
type model_parser = string -> (string * string) list
type model_parser = string -> Printer.printer_mapping -> (string * string) list
type reg_model_parser = Pp.formatted * model_parser
......@@ -34,4 +34,4 @@ let list_model_parsers () =
let () = register_model_parser
~desc:"Model@ parser@ with@ no@ output@ (used@ if@ the@ solver@ does@ not@ support@ models." "no_model"
(fun _ -> [])
(fun _ _ -> [])
......@@ -9,7 +9,7 @@
(* *)
(********************************************************************)
type model_parser = string -> (string * string) list
type model_parser = string -> Printer.printer_mapping -> (string * string) list
val register_model_parser : desc:Pp.formatted -> string -> model_parser -> unit
......
......@@ -28,11 +28,17 @@ type blacklist = string list
type 'a pp = Pp.formatter -> 'a -> unit
type printer_mapping = {
lsymbol_m : string -> Term.lsymbol;
queried_terms : Term.term list;
}
type printer_args = {
env : Env.env;
prelude : prelude;
th_prelude : prelude_map;
blacklist : blacklist;
mutable printer_mapping : printer_mapping;
}
type printer = printer_args -> ?old:in_channel -> task pp
......@@ -44,6 +50,11 @@ let printers : reg_printer Hstr.t = Hstr.create 17
exception KnownPrinter of string
exception UnknownPrinter of string
let get_default_printer_mapping = {
lsymbol_m = (function _ -> raise Not_found);
queried_terms = [];
}
let register_printer ~desc s p =
if Hstr.mem printers s then raise (KnownPrinter s);
Hstr.replace printers s (desc, p)
......
......@@ -24,15 +24,25 @@ type blacklist = string list
type 'a pp = Format.formatter -> 'a -> unit
(* Makes it possible to estabilish traceability from names
in the output of the printer to elements of AST in its input. *)
type printer_mapping = {
lsymbol_m : string -> Term.lsymbol;
queried_terms : Term.term list;
}
type printer_args = {
env : Env.env;
prelude : prelude;
th_prelude : prelude_map;
blacklist : blacklist;
mutable printer_mapping : printer_mapping;
}
type printer = printer_args -> ?old:in_channel -> task pp
val get_default_printer_mapping : printer_mapping
val register_printer : desc:Pp.formatted -> string -> printer -> unit
val lookup_printer : string -> printer
......
......@@ -185,7 +185,6 @@ let parse_prover_run res_parser time out ret on_timelimit timelimit ~printer_map
| _ -> ans
in
let model = res_parser.prp_model_parser out printer_mapping in
(* let out_with_model = add_model (out^"\nModel:\n") model in *)
Debug.dprintf debug "Call_provers: model:@.";
debug_print_model model;
{ pr_answer = ans;
......
......@@ -94,6 +94,7 @@ val call_on_file :
?memlimit : int ->
?stepslimit : int ->
res_parser : prover_result_parser ->
printer_mapping : Printer.printer_mapping ->
?cleanup : bool ->
?inplace : bool ->
?redirect : bool ->
......@@ -106,6 +107,7 @@ val call_on_buffer :
?stepslimit : int ->
res_parser : prover_result_parser ->
filename : string ->
printer_mapping : Printer.printer_mapping ->
?inplace : bool ->
Buffer.t -> pre_prover_call
(** Call a prover on the task printed in the {!type: Buffer.t} given.
......
......@@ -240,10 +240,10 @@ let file_of_task drv input_file theory_name task =
let file_of_theory drv input_file th =
get_filename drv input_file th.th_name.Ident.id_string "null"
let call_on_buffer ~command ?timelimit ?memlimit ?stepslimit ?inplace ~filename drv buffer =
let call_on_buffer ~command ?timelimit ?memlimit ?stepslimit ?inplace ~filename ~printer_mapping drv buffer =
Call_provers.call_on_buffer
~command ?timelimit ?memlimit ?stepslimit ~res_parser:drv.drv_res_parser
~filename ?inplace buffer
~filename ~printer_mapping ?inplace buffer
(** print'n'prove *)
......@@ -283,16 +283,20 @@ let print_task_prepared ?old drv fmt task =
| None -> raise NoPrinter
| Some p -> p
in
let printer = lookup_printer p
{ Printer.env = drv.drv_env;
let printer_args = { Printer.env = drv.drv_env;
prelude = drv.drv_prelude;
th_prelude = drv.drv_thprelude;
blacklist = drv.drv_blacklist } in
fprintf fmt "@[%a@]@?" (printer ?old) task
blacklist = drv.drv_blacklist;
printer_mapping = get_default_printer_mapping;
} in
let printer = lookup_printer p printer_args in
fprintf fmt "@[%a@]@?" (printer ?old) task;
printer_args.printer_mapping
let print_task ?old drv fmt task =
let task = prepare_task drv task in
print_task_prepared ?old drv fmt task
print_task_prepared ?old drv fmt task;
()
let print_theory ?old drv fmt th =
let task = Task.use_export None th in
......@@ -303,7 +307,8 @@ let prove_task_prepared
let buf = Buffer.create 1024 in
let fmt = formatter_of_buffer buf in
let old_channel = Opt.map open_in old in
print_task_prepared ?old:old_channel drv fmt task; pp_print_flush fmt ();
let printer_mapping = print_task_prepared ?old:old_channel drv fmt task in
pp_print_flush fmt ();
Opt.iter close_in old_channel;
let filename = match old, inplace with
| Some fn, Some true -> fn
......@@ -316,7 +321,7 @@ let prove_task_prepared
get_filename drv fn "T" pr.pr_name.id_string
in
let res =
call_on_buffer ~command ?timelimit ?memlimit ?stepslimit ?inplace ~filename drv buf in
call_on_buffer ~command ?timelimit ?memlimit ?stepslimit ?inplace ~filename ~printer_mapping drv buf in
Buffer.reset buf;
res
......
......@@ -41,6 +41,7 @@ val call_on_buffer :
?stepslimit : int ->
?inplace : bool ->
filename : string ->
printer_mapping : Printer.printer_mapping ->
driver -> Buffer.t -> Call_provers.pre_prover_call
......@@ -67,7 +68,7 @@ val prepare_task : driver -> Task.task -> Task.task
val print_task_prepared :
?old : in_channel ->
driver -> Format.formatter -> Task.task -> unit
driver -> Format.formatter -> Task.task -> Printer.printer_mapping
val prove_task_prepared :
command : string ->
......
......@@ -11,6 +11,10 @@
(* Parses the model returned by CVC4 and Z3. *)
open Printer
open Ident
open Term
exception EndOfStringExc;;
let add_chr str chr num_opened =
......@@ -103,18 +107,48 @@ let rec parse_pairs str pos list =
let _ = parse_pairs "((s(s)) 1) (x 1))" 0 []
let _ = parse_pairs "((= (+ (+ (+ (+ (+ (+ (+ x1 x2) x3) x4) x5) x6) x7) x8) 2) false))" 0 []
let rec extract_term_string labels raw_string regexp =
match labels with
| [] -> raw_string
| label::labels_tail ->
let l_string = label.lab_string in
begin
try
ignore(Str.search_forward regexp l_string 0);
let end_pos = Str.match_end () in
String.sub l_string end_pos ((String.length l_string) - end_pos)
with Not_found -> extract_term_string labels_tail raw_string regexp
end
let get_term_string term raw_string =
let labels = Slab.elements term.t_label in
let regexp = Str.regexp "model_trace:" in
extract_term_string labels raw_string regexp
let rec get_terms_values_strings raw_strings terms collected_strings =
match raw_strings with
| [] -> collected_strings
| (raw_term_string, value)::raw_strings_tail ->
let (term_string, terms_tail) = match terms with
| [] -> (raw_term_string, [])
| term::t_tail -> ((get_term_string term raw_term_string), t_tail) in
get_terms_values_strings raw_strings_tail terms_tail (collected_strings @ [(term_string, value)])
(* Parses the model returned by CVC4 or Z3.
Assumes that the model has the following form "model: (pairs)"
Returns the list of pairs term - value *)
let parse model =
let parse model printer_mapping =
try
let r = Str.regexp "unknown\\|sat" in
let start_m = Str.search_forward r model 0 in
let start = find_first_open_bracket model start_m in
snd(parse_pairs model (start+1) []);
let raw_terms_values_strings = snd(parse_pairs model (start+1) []) in
get_terms_values_strings raw_terms_values_strings printer_mapping.queried_terms []
with Not_found -> []
let _ = parse "dasfdfd dafsd ( dasfdf ) dfa unknown ((x 1))"
let _ = parse "dasfdfd dafsd ( dasfdf ) dfa unknown ((x 1))" Printer.get_default_printer_mapping
let () = Model_parser.register_model_parser "cvc4_z3" parse
~desc:"Parser@ for@ the@ model@ of@ cv4@ and@ z3."
......@@ -287,7 +287,7 @@ let print_logic_decl info fmt (ls,def) =
(print_expr info) expr;
List.iter forget_var vsl
let print_prop_decl info fmt k pr f = match k with
let print_prop_decl args info fmt k pr f = match k with
| Paxiom ->
fprintf fmt "@[<hov 2>;; %s@\n(assert@ %a)@]@\n@\n"
pr.pr_name.id_string (* FIXME? collisions *)
......@@ -314,10 +314,13 @@ let print_prop_decl info fmt k pr f = match k with
fprintf fmt "@\n;; %s@\n%s" s s;
) model_list;
fprintf fmt "))@]@\n";
end
end;
args.printer_mapping <- { lsymbol_m = args.printer_mapping.lsymbol_m;
queried_terms = info.info_model; }
| Plemma| Pskip -> assert false
let print_decl info fmt d = match d.d_node with
let print_decl args info fmt d = match d.d_node with
| Dtype ts ->
print_type_decl info fmt ts
| Ddata _ -> unsupportedDecl d
......@@ -331,27 +334,18 @@ let print_decl info fmt d = match d.d_node with
"smtv2 : inductive definition are not supported"
| Dprop (k,pr,f) ->
if Mid.mem pr.pr_name info.info_syn then () else
print_prop_decl info fmt k pr f
print_prop_decl args info fmt k pr f
let print_decls =
let print_decls args =
let print_decl (sm, cm, model) fmt d =
try let info = {info_syn = sm; info_converters = cm; info_model = model} in
print_decl info fmt d; (sm, cm, info.info_model), []
print_decl args info fmt d; (sm, cm, info.info_model), []
with Unsupported s -> raise (UnsupportedDecl (d,s)) in
let print_decl = Printer.sprint_decl print_decl in
let print_decl task acc = print_decl task.Task.task_decl acc in
Discriminate.on_syntax_map (fun sm ->
Printer.on_converter_map (fun cm ->
Trans.fold print_decl ((sm, cm, []),[])))
(*
let print_decl (sm,model) fmt d =
try let info = {info_syn = sm; info_model = model} in
print_decl info fmt d; (sm, info.info_model), []
with Unsupported s -> raise (UnsupportedDecl (d,s)) in
let print_decl = Printer.sprint_decl print_decl in
let print_decl task acc = print_decl task.Task.task_decl acc in
Discriminate.on_syntax_map (fun sm -> Trans.fold print_decl ((sm,[]),[]))
Preliminary support for model from CVC4 *)
let print_task args ?old:_ fmt task =
(* In trans-based p-printing [forget_all] is a no-no *)
......@@ -361,7 +355,7 @@ let print_task args ?old:_ fmt task =
let rec print = function
| x :: r -> print r; Pp.string fmt x
| [] -> () in
print (snd (Trans.apply print_decls task));
print (snd (Trans.apply (print_decls args) task));
pp_print_flush fmt ()
let () = register_printer "smtv2" print_task
......
......@@ -294,10 +294,10 @@ let schedule_edition t command filename callback =
Call_provers.prp_regexps = [];
Call_provers.prp_timeregexps = [];
Call_provers.prp_stepsregexp = [];
Call_provers.prp_model_parser = fun _ -> []
Call_provers.prp_model_parser = fun _ _ -> []
} in
let precall =
Call_provers.call_on_file ~command ~res_parser ~redirect:false filename in
Call_provers.call_on_file ~command ~res_parser ~redirect:false filename ~printer_mapping:Printer.get_default_printer_mapping in
callback Running;
t.running_proofs <- (Check_prover(callback, precall ())) :: t.running_proofs;
run_timeout_handler t
......
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