Commit dd3aac24 authored by Andrei Paskevich's avatar Andrei Paskevich

Reworking tags and transformations, stage 3:

- everything is converted to the new shiny way of doing things.
  Well, everything except Gappa, which seems very unifinished anyway,
  and Encoding_instantiate, which is too complex and would like to 
  update it with François.

Also, I commented a little piece of exception reporting in manager/,
will see it with Claude.

THIS IS STILL A WORK IN PROGRESS!
Please inform me about any bugs, ugly APIs, and proposed corrections.

All the non-implemented things, mentioned in the previous commit
message are still in the TODO list and will be done soon.
parent 5c650119
......@@ -100,7 +100,7 @@ LIB_CORE = ident ty term pattern decl theory task pretty env printer trans
LIB_PARSER = ptree parser lexer denv typing
LIB_DRIVER = call_provers driver_ast driver_parser driver_lexer driver \
register prover whyconf
whyconf
LIB_TRANSFORM = simplify_recursive_definition simplify_formula inlining \
split_conjunction encoding_decorate encoding_decorate_mono \
......
......@@ -3,7 +3,8 @@
prelude "# this is a prelude for Gappa"
printer "gappa"
(* printer "gappa" *)
printer "why3"
filename "%f-%t-%g.gappa"
valid 0
......
......@@ -5,7 +5,7 @@ DIR=drivers/
for prover in z3 cvc3; do
for what in "" _goal _mono _def; do
for complete in "" _nbp; do
cat ${DIR}${prover}.drv |sed -e "s/transformation \"encoding_decorate\"/transformation \"encoding_instantiate$what$complete\"/" > ${DIR}${prover}_inst${what}${complete}.drv
cat ${DIR}${prover}.drv |sed -e "s/transformation \"encoding_decorate\"/(* transformation \"encoding_instantiate$what$complete\" *)/" > ${DIR}${prover}_inst${what}${complete}.drv
done
done
done
......@@ -30,10 +30,11 @@ open Task
type prelude = string list
type prelude_map = prelude Mid.t
type syntax_map = string Mid.t
type 'a pp = formatter -> 'a -> unit
type printer = prelude -> prelude_map -> task pp
type printer = prelude -> prelude_map -> syntax_map -> task pp
let printers : (string, printer) Hashtbl.t = Hashtbl.create 17
......@@ -118,32 +119,32 @@ let print_th_prelude task fmt pm =
let prel = try Mid.find th.th_name pm with Not_found -> [] in
print_prelude fmt prel) th_used
exception KnownTypeSyntax of tysymbol
exception KnownLogicSyntax of lsymbol
let add_ts_syntax ts s sm =
check_syntax s (List.length ts.ts_args);
if Mid.mem ts.ts_name sm then raise (KnownTypeSyntax ts);
Mid.add ts.ts_name s sm
let add_ls_syntax ls s sm =
check_syntax s (List.length ls.ls_args);
if Mid.mem ls.ls_name sm then raise (KnownLogicSyntax ls);
Mid.add ls.ls_name s sm
let meta_remove_type = "remove_type"
let meta_remove_logic = "remove_logic"
let meta_remove_prop = "remove_prop"
let meta_syntax_type = "syntax_type"
let meta_syntax_logic = "syntax_logic"
let () =
register_meta meta_remove_type [MTtysymbol];
register_meta meta_remove_logic [MTlsymbol];
register_meta meta_remove_prop [MTprsymbol];
register_meta meta_syntax_type [MTtysymbol; MTstring];
register_meta meta_syntax_logic [MTlsymbol; MTstring]
register_meta meta_remove_prop [MTprsymbol]
let remove_type ts = create_meta meta_remove_type [MAts ts]
let remove_logic ls = create_meta meta_remove_logic [MAls ls]
let remove_prop pr = create_meta meta_remove_prop [MApr pr]
let syntax_type ts s =
check_syntax s (List.length ts.ts_args);
create_meta meta_syntax_type [MAts ts; MAstr s]
let syntax_logic ls s =
check_syntax s (List.length ls.ls_args);
create_meta meta_syntax_logic [MAls ls; MAstr s]
let get_remove_set task =
let add td s = match td.td_node with
| Meta (_,[MARid id]) -> Sid.add id s
......@@ -155,16 +156,6 @@ let get_remove_set task =
let s = Stdecl.fold add (find_meta task meta_remove_prop).tds_set s in
s
let get_syntax_map task =
let add td m = match td.td_node with
| Meta (_,[MARid id; MARstr s]) -> Mid.add id s m
| _ -> assert false
in
let m = Mid.empty in
let m = Stdecl.fold add (find_meta task meta_syntax_type).tds_set m in
let m = Stdecl.fold add (find_meta task meta_syntax_logic).tds_set m in
m
(** {2 exceptions to use in transformations and printers} *)
exception UnsupportedType of ty * string
......@@ -203,6 +194,12 @@ let () = Exn_printer.register (fun fmt exn -> match exn with
fprintf fmt "Printer '%s' is already registered" s
| UnknownPrinter s ->
fprintf fmt "Unknown printer '%s'" s
| KnownTypeSyntax ts ->
fprintf fmt "Syntax for type symbol %a is already defined"
Pretty.print_ts ts
| KnownLogicSyntax ls ->
fprintf fmt "Syntax for logical symbol %a is already defined"
Pretty.print_ls ls
| BadSyntaxIndex i ->
fprintf fmt "Bad argument index %d, must start with 1" i
| BadSyntaxArity (i1,i2) ->
......
......@@ -29,9 +29,11 @@ open Task
type prelude = string list
type prelude_map = prelude Mid.t
type syntax_map = string Mid.t
type 'a pp = Format.formatter -> 'a -> unit
type printer = prelude -> prelude_map -> task pp
type printer = prelude -> prelude_map -> syntax_map -> task pp
val register_printer : string -> printer -> unit
......@@ -48,18 +50,14 @@ val meta_remove_type : string
val meta_remove_logic : string
val meta_remove_prop : string
val meta_syntax_type : string
val meta_syntax_logic : string
val remove_type : tysymbol -> tdecl
val remove_logic : lsymbol -> tdecl
val remove_prop : prsymbol -> tdecl
val syntax_type : tysymbol -> string -> tdecl
val syntax_logic : lsymbol -> string -> tdecl
val get_remove_set : task -> Sid.t
val get_syntax_map : task -> string Mid.t
val add_ts_syntax : tysymbol -> string -> syntax_map -> syntax_map
val add_ls_syntax : lsymbol -> string -> syntax_map -> syntax_map
val syntax_arguments : string -> 'a pp -> 'a list pp
(** (syntax_arguments templ print_arg fmt l) prints in the formatter fmt
......@@ -72,12 +70,12 @@ exception UnsupportedExpr of expr * string
exception UnsupportedDecl of decl * string
exception NotImplemented of string
val unsupportedType : ty -> string -> unit
val unsupportedTerm : term -> string -> unit
val unsupportedFmla : fmla -> string -> unit
val unsupportedExpr : expr -> string -> unit
val unsupportedDecl : decl -> string -> unit
val notImplemented : string -> unit
val unsupportedType : ty -> string -> 'a
val unsupportedTerm : term -> string -> 'a
val unsupportedFmla : fmla -> string -> 'a
val unsupportedExpr : expr -> string -> 'a
val unsupportedDecl : decl -> string -> 'a
val notImplemented : string -> 'a
(** {3 functions that catch inner error} *)
......@@ -85,7 +83,7 @@ exception Unsupported of string
(** This exception must be raised only inside a call
of one of the catch_* functions below *)
val unsupported : string -> unit
val unsupported : string -> 'a
val catch_unsupportedType : (ty -> 'a) -> (ty -> 'a)
(** [catch_unsupportedType f] return a function which applied on [arg]:
......
......@@ -47,7 +47,9 @@ type clone_map = tdecl_set Mid.t
type meta_map = tdecl_set Mstr.t
let cm_find cm th = try Mid.find th.th_name cm with Not_found -> empty_tds
let mm_find mm t = try Mstr.find t mm with Not_found -> empty_tds
let mm_find mm t =
try Mstr.find t mm with Not_found -> ignore (lookup_meta t); empty_tds
let cm_add cm th td = Mid.add th.th_name (tds_add td (cm_find cm th)) cm
let mm_add mm t td = Mstr.add t (tds_add td (mm_find mm t)) mm
......@@ -202,40 +204,27 @@ let task_tdecls = task_fold (fun acc td -> td::acc) []
let task_decls = task_fold (fun acc td ->
match td.td_node with Decl d -> d::acc | _ -> acc) []
(* TO BE REMOVED *)
let old_task_clone task =
Mid.fold (fun _ x -> Stdecl.fold (function
| { td_node = Clone (_,cl) } ->
Mid.fold (fun id id' m ->
let s = try Mid.find id' m with Not_found -> Sid.empty in
Mid.add id' (Sid.add id s) m) cl
| _ -> assert false) x.tds_set) (task_clone task) Mid.empty
let old_task_use task =
Mid.fold (fun _ x -> Stdecl.fold (function
| { td_node = Clone (th,cl) } -> (fun m ->
if Mid.is_empty cl then Mid.add th.th_name th m else m)
| _ -> assert false) x.tds_set) (task_clone task) Mid.empty
(* special selector for metaproperties of a single ident *)
let rec last_use task = match task with
| Some {task_decl={td_node=Clone(_,cl)}} when Mid.is_empty cl -> task
| Some {task_prev=task} -> last_use task
| None -> None
exception NotTaggingMeta of string
let rec last_clone task = match task with
| Some {task_decl={td_node=Clone _}} -> task
| Some {task_prev=task} -> last_clone task
| None -> None
let find_meta_ids t tds acc =
begin match lookup_meta t with
| [MTtysymbol|MTlsymbol|MTprsymbol] -> ()
| _ -> raise (NotTaggingMeta t)
end;
Stdecl.fold (fun td acc -> match td.td_node with
| Meta (s, [MARid id]) when s = t -> Sid.add id acc
| _ -> assert false) tds.tds_set acc
(* Exception reporting *)
let () = Exn_printer.register
begin fun fmt exn -> match exn with
let () = Exn_printer.register (fun fmt exn -> match exn with
| LemmaFound -> Format.fprintf fmt "Task cannot contain a lemma"
| SkipFound -> Format.fprintf fmt "Task cannot contain a skip"
| GoalFound -> Format.fprintf fmt "The task already ends with a goal"
| GoalNotFound -> Format.fprintf fmt "The task does not end with a goal"
| _ -> raise exn
end
| NotTaggingMeta s ->
Format.fprintf fmt "Metaproperty '%s' is not a symbol tag" s
| _ -> raise exn)
......@@ -93,12 +93,11 @@ val task_decls : task -> decl list
val task_goal : task -> prsymbol
(* TO BE REMOVED *)
(* special selector for metaproperties of a single ident *)
val old_task_clone : task -> Sid.t Mid.t
val old_task_use : task -> theory Mid.t
val last_clone : task -> task
val last_use : task -> task
exception NotTaggingMeta of string
val find_meta_ids : string -> tdecl_set -> Sid.t -> Sid.t
(* exceptions *)
......
......@@ -74,6 +74,9 @@ val on_theories_metas : theory list -> string list ->
(** {2 Registration} *)
exception UnknownTrans of string
exception KnownTrans of string
val register_transform : string -> (Env.env -> task trans) -> unit
val register_transform_l : string -> (Env.env -> task tlist) -> unit
......
......@@ -25,115 +25,33 @@ open Term
open Decl
open Theory
open Task
open Printer
open Trans
open Driver_ast
open Call_provers
(** error handling *)
type error = string
exception Error of error
let report = pp_print_string
let () = Exn_printer.register
(fun fmt exn -> match exn with
| Error error -> report fmt error
| _ -> raise exn)
let error ?loc e = match loc with
| None -> raise (Error e)
| Some loc -> raise (Loc.Located (loc, Error e))
let errorm ?loc f =
let buf = Buffer.create 512 in
let fmt = formatter_of_buffer buf in
kfprintf
(fun _ ->
pp_print_flush fmt ();
let s = Buffer.contents buf in
Buffer.clear buf;
error ?loc s)
fmt f
(** syntax substitutions *)
let opt_search_forward re s pos =
try Some (Str.search_forward re s pos) with Not_found -> None
let global_substitute_fmt expr repl_fun text fmt =
let rec replace start last_was_empty =
let startpos = if last_was_empty then start + 1 else start in
if startpos > String.length text then
pp_print_string fmt (Str.string_after text start)
else
match opt_search_forward expr text startpos with
| None ->
pp_print_string fmt (Str.string_after text start)
| Some pos ->
let end_pos = Str.match_end () in
pp_print_string fmt (String.sub text start (pos - start));
repl_fun text fmt;
replace end_pos (end_pos = pos)
in
replace 0 false
let iter_group expr iter_fun text =
let rec iter start last_was_empty =
let startpos = if last_was_empty then start + 1 else start in
if startpos < String.length text then
match opt_search_forward expr text startpos with
| None -> ()
| Some pos ->
let end_pos = Str.match_end () in
iter_fun text;
iter end_pos (end_pos = pos)
in
iter 0 false
let regexp_arg_pos = Str.regexp "%\\([0-9]+\\)"
let check_syntax loc s len =
let arg s =
let i = int_of_string (Str.matched_group 1 s) in
if i = 0 then errorm ~loc "bad index '%%0': start with '%%1'";
if i > len then
errorm ~loc "bad index '%%%i': the symbol has %i arguments" i len
in
iter_group regexp_arg_pos arg s
let syntax_arguments s print fmt l =
let args = Array.of_list l in
let repl_fun s fmt =
let i = int_of_string (Str.matched_group 1 s) in
print fmt args.(i-1) in
global_substitute_fmt regexp_arg_pos repl_fun s fmt
(** drivers *)
type driver = {
drv_env : Env.env;
drv_printer : string option;
drv_prelude : string list;
drv_filename : string option;
drv_transform : string list;
drv_thprelude : string list Mid.t;
drv_tags : Sstr.t Mid.t;
drv_tags_cl : Sstr.t Mid.t;
drv_syntax : string Mid.t;
drv_remove : Sid.t;
drv_remove_cl : Sid.t;
drv_meta : Stdecl.t Mid.t; (* the same as clone_map *)
drv_meta_cl : Stdecl.t Mid.t;
drv_regexps : (Str.regexp * Call_provers.prover_answer) list;
drv_exitcodes : (int * Call_provers.prover_answer) list;
drv_tag : int
drv_prelude : prelude;
drv_thprelude : prelude_map;
drv_syntax : syntax_map;
drv_meta : (theory * Stdecl.t) Mid.t;
drv_meta_cl : (theory * Stdecl.t) Mid.t;
drv_regexps : (Str.regexp * prover_answer) list;
drv_exitcodes : (int * prover_answer) list;
}
(** parse a driver file *)
exception NoPlugins
let load_plugin dir (byte,nat) =
if not Config.why_plugins then errorm "Plugins not supported";
if not Config.why_plugins then raise NoPlugins;
let file = if Config.Dynlink.is_native then nat else byte in
let file = Filename.concat dir file in
Config.Dynlink.loadfile_private file
......@@ -146,8 +64,10 @@ let load_file file =
close_in c;
f
let string_of_qualid thl idl =
String.concat "." thl ^ "." ^ String.concat "." idl
exception Duplicate of string
exception UnknownType of (string list * string list)
exception UnknownLogic of (string list * string list)
exception UnknownProp of (string list * string list)
let load_driver = let driver_tag = ref (-1) in fun env file ->
let prelude = ref [] in
......@@ -158,7 +78,7 @@ let load_driver = let driver_tag = ref (-1) in fun env file ->
let transform = ref [] in
let set_or_raise loc r v error = match !r with
| Some _ -> errorm ~loc "duplicate %s" error
| Some _ -> raise (Loc.Located (loc, Duplicate error))
| None -> r := Some v
in
let add_to_list r v = (r := v :: !r) in
......@@ -183,75 +103,51 @@ let load_driver = let driver_tag = ref (-1) in fun env file ->
List.iter add_global f.f_global;
let thprelude = ref Mid.empty in
let tags = ref Mid.empty in
let tags_cl = ref Mid.empty in
let syntax = ref Mid.empty in
let remove = ref Sid.empty in
let remove_cl = ref Sid.empty in
let meta = ref Mid.empty in
let meta_cl = ref Mid.empty in
let qualid = ref [] in
let find_pr th (loc,q) = try ns_find_pr th.th_export q with Not_found ->
errorm ~loc "unknown proposition %s" (string_of_qualid !qualid q)
let find_pr th (loc,q) = try ns_find_pr th.th_export q
with Not_found -> raise (Loc.Located (loc, UnknownProp (!qualid,q)))
in
let find_ls th (loc,q) = try ns_find_ls th.th_export q with Not_found ->
errorm ~loc "unknown logic symbol %s" (string_of_qualid !qualid q)
let find_ls th (loc,q) = try ns_find_ls th.th_export q
with Not_found -> raise (Loc.Located (loc, UnknownLogic (!qualid,q)))
in
let find_ts th (loc,q) = try ns_find_ts th.th_export q with Not_found ->
errorm ~loc "unknown type symbol %s" (string_of_qualid !qualid q)
let find_ts th (loc,q) = try ns_find_ts th.th_export q
with Not_found -> raise (Loc.Located (loc, UnknownType (!qualid,q)))
in
let add_meta th td m =
let s = try Mid.find th.th_name !m with Not_found -> Stdecl.empty in
m := Mid.add th.th_name (Stdecl.add td s) !m
in
let add_syntax loc k (_,q) id n s =
check_syntax loc s n;
if Mid.mem id !syntax then
errorm ~loc "duplicate syntax rule for %s symbol %s"
k (string_of_qualid !qualid q);
syntax := Mid.add id s !syntax;
remove := Sid.add id !remove
in
let add_tag c id s =
let mr = if c then tags_cl else tags in
let im = try Mid.find id !mr with Not_found -> Sstr.empty in
mr := Mid.add id (Sstr.add s im) !mr
let s = try snd (Mid.find th.th_name !m) with Not_found -> Stdecl.empty in
m := Mid.add th.th_name (th, Stdecl.add td s) !m
in
let add_local th (loc,rule) = match rule with
let add_local th = function
| Rprelude s ->
let l = try Mid.find th.th_name !thprelude with Not_found -> [] in
thprelude := Mid.add th.th_name (l @ [s]) !thprelude
| Rsyntaxls (q,s) ->
let ls = find_ls th q in
add_meta th (Printer.remove_logic ls) meta;
add_meta th (Printer.syntax_logic ls s) meta;
add_syntax loc "logic" q ls.ls_name (List.length ls.ls_args) s
add_meta th (remove_logic ls) meta;
syntax := add_ls_syntax ls s !syntax
| Rsyntaxts (q,s) ->
let ts = find_ts th q in
add_meta th (Printer.remove_type ts) meta;
add_meta th (Printer.syntax_type ts s) meta;
add_syntax loc "type" q ts.ts_name (List.length ts.ts_args) s
add_meta th (remove_type ts) meta;
syntax := add_ts_syntax ts s !syntax
| Rremovepr (c,q) ->
let td = Printer.remove_prop (find_pr th q) in
add_meta th td (if c then meta_cl else meta);
let sr = if c then remove_cl else remove in
sr := Sid.add (find_pr th q).pr_name !sr
let td = remove_prop (find_pr th q) in
add_meta th td (if c then meta_cl else meta)
| Rtagts (c,q,s) ->
let td = create_meta s [MAts (find_ts th q)] in
add_meta th td (if c then meta_cl else meta);
add_tag c (find_ts th q).ts_name s
add_meta th td (if c then meta_cl else meta)
| Rtagls (c,q,s) ->
let td = create_meta s [MAls (find_ls th q)] in
add_meta th td (if c then meta_cl else meta);
add_tag c (find_ls th q).ls_name s
add_meta th td (if c then meta_cl else meta)
| Rtagpr (c,q,s) ->
let td = create_meta s [MApr (find_pr th q)] in
add_meta th td (if c then meta_cl else meta);
add_tag c (find_pr th q).pr_name s
add_meta th td (if c then meta_cl else meta)
in
let add_local th (loc,rule) =
try add_local th (loc,rule) with e -> raise (Loc.Located (loc,e))
let add_local th (loc,rule) =
try add_local th rule with e -> raise (Loc.Located (loc,e))
in
let add_theory { thr_name = (loc,q); thr_rules = trl } =
let f,id = let l = List.rev q in List.rev (List.tl l),List.hd l in
......@@ -271,119 +167,16 @@ let load_driver = let driver_tag = ref (-1) in fun env file ->
drv_filename = !filename;
drv_transform = !transform;
drv_thprelude = !thprelude;
drv_tags = !tags;
drv_tags_cl = !tags_cl;
drv_syntax = !syntax;
drv_remove = !remove;
drv_remove_cl = !remove_cl;
drv_meta = !meta;
drv_meta_cl = !meta_cl;
drv_regexps = !regexps;
drv_exitcodes = !exitcodes;
drv_tag = !driver_tag;
}
(** query drivers *)
type driver_query = {
query_syntax : ident -> string option;
query_remove : ident -> bool;
query_tags : ident -> Sstr.t;
query_driver : driver;
query_lclone : task;
query_tag : int;
}
module Hsdq = Hashcons.Make (struct
type t = driver_query
let equal q1 q2 = q1.query_driver == q2.query_driver &&
task_equal q1.query_lclone q2.query_lclone
let hash q = Hashcons.combine q.query_driver.drv_tag
(option_apply 0 (fun t -> 1 + t.task_tag) q.query_lclone)
let tag n q = { q with query_tag = n }
end)
module Dq = StructMake (struct
type t = driver_query
let tag q = q.query_tag
end)
module Sdq = Dq.S
module Mdq = Dq.M
module Hdq = Dq.H
let get_tags map id = try Mid.find id map with Not_found -> Sstr.empty
let add_tags drv id acc = Sstr.union (get_tags drv.drv_tags_cl id) acc
let add_remove drv id acc = acc || Sid.mem id drv.drv_remove_cl
let driver_query drv task =
let clone = old_task_clone task in
let htags = Hid.create 7 in
let query_tags id = try Hid.find htags id with Not_found ->
let r = try Mid.find id clone with Not_found -> Sid.empty in
let s = Sid.fold (add_tags drv) r (get_tags drv.drv_tags id) in
Hid.replace htags id s; s
in
let hremove = Hid.create 7 in