Commit c6ac849f authored by Francois Bobot's avatar Francois Bobot

driver.ml is working and alt-ergo.ml is up to date

parent aeb454f9
......@@ -104,8 +104,7 @@ doc/version.tex src/version.ml: Version version.sh config.status
# why
#####
CORE_CMO := ident.cmo ty.cmo term.cmo theory.cmo \
pretty.cmo transform.cmo context_utils.cmo
CORE_CMO := ident.cmo ty.cmo term.cmo theory.cmo pretty.cmo context_utils.cmo
CORE_CMO := $(addprefix src/core/,$(CORE_CMO))
UTIL_CMO := pp.cmo loc.cmo util.cmo hashcons.cmo
......@@ -114,8 +113,8 @@ UTIL_CMO := $(addprefix src/util/,$(UTIL_CMO))
PARSER_CMO := parser.cmo lexer.cmo typing.cmo transform_utils.cmo
PARSER_CMO := $(addprefix src/parser/,$(PARSER_CMO))
TRANSFORM_CMO := simplify_recursive_definition.cmo inlining.cmo \
flatten.cmo
TRANSFORM_CMO := transform.cmo simplify_recursive_definition.cmo \
inlining.cmo flatten.cmo
TRANSFORM_CMO := $(addprefix src/transform/,$(TRANSFORM_CMO))
OUTPUT_CMO := driver_parser.cmo driver_lexer.cmo driver.cmo \
......
......@@ -30,6 +30,8 @@ end
theory algebra.AC
tag cloned op "AC"
remove cloned Comm
remove cloned Assoc
end
(*
......
......@@ -50,12 +50,14 @@ let () =
let in_emacs = Sys.getenv "TERM" = "dumb"
let transformation l =
let transformation env l =
let t1 = Simplify_recursive_definition.t env in
let t2 = Inlining.all env in
List.map (fun (t,c) ->
let c = if !simplify_recursive
then Transform.apply Simplify_recursive_definition.t c
then Transform.apply t1 c
else c in
let c = if !inlining then Transform.apply Inlining.all c
let c = if !inlining then Transform.apply t2 c
else c in
(t,c)) l
......@@ -91,14 +93,14 @@ let type_file env file =
end else
Typing.add_from_file env file
let extract_goals ctxt =
Transform.apply (Transform.split_goals ()) ctxt
let extract_goals env ctxt =
Transform.apply (Transform.split_goals env) ctxt
let transform env l =
let l = List.map
(fun t -> t, Context.use_export Context.init_context t)
(Typing.local_theories l) in
let l = transformation l in
let l = transformation env l in
if !print_stdout then
List.iter
(fun (t,ctxt) -> Pretty.print_named_context
......@@ -109,7 +111,7 @@ let transform env l =
| Some file ->
let drv = load_driver file env in
begin match l with
| (_,ctxt) :: _ -> begin match extract_goals ctxt with
| (_,ctxt) :: _ -> begin match extract_goals env ctxt with
| g :: _ ->
Driver.print_context drv std_formatter g
| [] ->
......
......@@ -127,10 +127,14 @@ open Transform_utils
let print_logic_decl drv ctxt fmt = function
| Lfunction (ls, None) ->
let sac = match Driver.query_ident drv ls.ls_name with
| Driver.Remove -> assert false (*TODO message *)
| Driver.Syntax _ -> assert false (*TODO substitution *)
| Driver.Tag s -> if Snm.mem "AC" s then "ac " else "" in
let tyl = ls.ls_args in
let ty = match ls.ls_value with None -> assert false | Some ty -> ty in
fprintf fmt "@[<hov 2>logic %a : %a -> %a@]@\n"
(*(if cloned_from_ls env ctxt ac_th "op" ls then "ac " else "") *)
fprintf fmt "@[<hov 2>logic %s%a : %a -> %a@]@\n"
sac
print_ident ls.ls_name
(print_list comma print_type) tyl print_type ty
| Lfunction (ls, Some defn) ->
......@@ -154,11 +158,9 @@ let print_decl drv ctxt fmt d = match d.d_node with
print_list newline print_type_decl fmt dl
| Dlogic dl ->
print_list newline (print_logic_decl drv ctxt) fmt dl
| Dind _ ->
assert false
(* | Dprop (Paxiom, pr) when *)
(* (cloned_from_pr drv ctxt ac_th "Comm" pr *)
(* || cloned_from_pr env ctxt ac_th "Assoc" pr) -> () *)
| Dind _ -> assert false (* TODO *)
| Dprop (Paxiom, pr) when
Driver.query_ident drv pr.pr_name = Driver.Remove -> ()
| Dprop (Paxiom, pr) ->
fprintf fmt "@[<hov 2>axiom %a :@ %a@]@\n"
print_ident pr.pr_name print_fmla pr.pr_fmla
......
......@@ -18,8 +18,11 @@
(**************************************************************************)
open Format
open Ty
open Term
open Theory
open Driver_ast
open Ident
type error = string
......@@ -56,6 +59,24 @@ type theory_driver = {
thd_tsymbol : unit ;
}
type translation =
| Remove
| Syntax of string
| Tag of Snm.t
let translation_union t1 t2 =
match t1, t2 with
| Remove, _ | _, Remove -> Remove
| ((Syntax _ as s), _) | (_,(Syntax _ as s)) -> s
| Tag s1, Tag s2 -> Tag (Snm.union s1 s2)
let print_translation fmt = function
| Remove -> fprintf fmt "remove"
| Syntax s -> fprintf fmt "syntax %s" s
| Tag s -> fprintf fmt "tag %a"
(Pp.print_iter1 Snm.iter Pp.comma Pp.string) s
type printer = driver -> formatter -> context -> unit
and driver = {
......@@ -65,10 +86,21 @@ and driver = {
drv_call_file : string option;
drv_regexps : (string * prover_answer) list;
drv_prelude : string option;
drv_rules : (string list, theory_rules) Hashtbl.t;
drv_theory : (string list, theory_driver) Hashtbl.t;
drv_thprelude : string 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_ctxt : translation Hid.t;
drv_env : Typing.env;
}
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 printers *)
let (printers : (string, printer) Hashtbl.t) = Hashtbl.create 17
......@@ -83,9 +115,78 @@ let load_file file =
close_in c;
f
let rec qualid_to_slist = function
| [] -> assert false
| [a] -> a,[]
| a::l -> let id,l = qualid_to_slist l in (id,a::l)
let string_of_qualid thl idl =
let thl = String.concat "." thl in
let idl = String.concat "." idl in
thl^"."^idl
let load_rules env driver {thr_name = loc,qualid; thr_rules = trl} =
let id,qfile = qualid_to_slist qualid in
let th = Typing.find_theory env qfile id in
let add_htheory cloned id t =
try
let t2,t3 = Hid.find driver.drv_theory id in
let t23 =
if cloned then (translation_union t t2),t3
else t2,(translation_union t t3) in
Hid.replace driver.drv_theory id t23
with Not_found ->
let t23 = if cloned then (Tag Snm.empty),t else t,(Tag Snm.empty) in
Hid.add driver.drv_theory id t23 in
let rec find_lident ns = function
| [] -> assert false
| [a] -> (Mnm.find a ns.ns_ls).ls_name
| a::l -> find_lident (Mnm.find a ns.ns_ns) l in
let rec find_tyident ns = function
| [] -> assert false
| [a] -> (Mnm.find a ns.ns_ts).ts_name
| a::l -> find_tyident (Mnm.find a ns.ns_ns) l in
let rec find_prident ns = function
| [] -> assert false
| [a] -> (Mnm.find a ns.ns_pr).pr_name
| a::l -> find_prident (Mnm.find a ns.ns_ns) l in
let add = function
| Rremove (c,(loc,q)) ->
begin
try
add_htheory c (find_prident th.th_export q) Remove
with Not_found -> errorm ~loc "Unknown axioms %s"
(string_of_qualid qualid q)
end
| Rsyntax ((loc,q),s) ->
begin
try
add_htheory false (find_lident th.th_export q) (Syntax s)
with Not_found -> errorm ~loc "Unknown logic %s"
(string_of_qualid qualid q)
end
| Rtag (c,(loc,q),s) ->
begin
try
add_htheory c (find_lident th.th_export q) (Tag (Snm.singleton s))
with Not_found -> errorm ~loc "Unknown logic %s"
(string_of_qualid qualid q)
end
| Rprelude (loc,s) -> if Hid.mem driver.drv_thprelude th.th_name
then errorm ~loc "duplicate prelude"
else Hid.add driver.drv_thprelude th.th_name s in
List.iter add trl
let load_driver file env =
let f = load_file file in
let printer = ref (None : printer option) in
let prelude = ref None in
let printer = ref None in
let call_stdin = ref None in
let call_file = 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
let add (loc, g) = match g with
| Printer _ when !printer <> None ->
errorm ~loc "duplicate printer"
......@@ -93,35 +194,51 @@ let load_driver file env =
printer := Some (Hashtbl.find printers s)
| Printer s ->
errorm ~loc "unknown printer %s" s
| _ ->
() (* TODO *)
| Prelude s -> set_or_raise loc 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
| RegexpUnknown (s1,s2) -> regexps:=(s1,Unknown s2)::!regexps
| RegexpFailure (s1,s2) -> regexps:=(s1,Failure s2)::!regexps
in
List.iter add f.f_global;
{ drv_printer = !printer;
drv_context = Context.init_context;
drv_call_stdin = None;
drv_call_file = None;
drv_regexps = [];
drv_prelude = None;
drv_rules = Hashtbl.create 17;
drv_theory = Hashtbl.create 17;
}
let driver = { drv_printer = !printer;
drv_context = Context.init_context;
drv_call_stdin = !call_stdin;
drv_call_file = !call_file;
drv_regexps = !regexps;
drv_prelude = !prelude;
drv_thprelude = Hid.create 16;
drv_theory = Hid.create 16;
drv_with_ctxt = Hid.create 16;
drv_env = env;
} in
List.iter (load_rules env driver) f.f_rules;
driver
(** querying drivers *)
type translation =
| Remove
| Syntax of string
| Tag of string list
let query_ident dr id =
assert false (*TODO*)
let query_ident drv id =
try
Hid.find drv.drv_with_ctxt id
with Not_found ->
let r = try
Mid.find id drv.drv_context.ctxt_cloned
with Not_found -> Sid.empty in
let tr = try fst (Hid.find drv.drv_theory id)
with Not_found -> Tag Snm.empty in
let tr = Sid.fold
(fun id acc -> try translation_union acc
(snd (Hid.find drv.drv_theory id))
with Not_found -> acc) r tr in
Hid.add drv.drv_with_ctxt id tr;
tr
(** using drivers *)
let print_context drv = match drv.drv_printer with
let print_context drv fmt ctxt = match drv.drv_printer with
| None -> errorm "no printer"
| Some f -> f drv
| Some f -> f {drv with drv_context = ctxt} fmt ctxt
let call_prover drv ctx = assert false (*TODO*)
let call_prover_on_file drv filename = assert false (*TODO*)
......
......@@ -32,7 +32,7 @@ val load_driver : string -> Typing.env -> driver
type translation =
| Remove
| Syntax of string
| Tag of string list
| Tag of Snm.t
val query_ident : driver -> ident -> translation
......
......@@ -27,11 +27,11 @@ type trule =
| Rremove of cloned * qualid
| Rsyntax of qualid * string
| Rtag of cloned * qualid * string
| Rprelude of string
| Rprelude of loc * string
type theory_rules = {
th_name : qualid;
th_rules : trule list;
thr_name : qualid;
thr_rules : trule list;
}
type global =
......
......@@ -66,7 +66,7 @@ list0_theory:
theory:
| THEORY qualid list0_trule END
{ { th_name = $2; th_rules = $3 } }
{ { thr_name = $2; thr_rules = $3 } }
;
list0_trule:
......@@ -75,7 +75,7 @@ list0_trule:
;
trule:
| PRELUDE STRING { Rprelude $2 }
| PRELUDE STRING { Rprelude (loc (),$2) }
| REMOVE cloned qualid { Rremove ($2, $3) }
| SYNTAX qualid STRING { Rsyntax ($2, $3) }
| TAG cloned qualid STRING { Rtag ($2, $3, $4) }
......
......@@ -21,15 +21,6 @@ open Ty
open Term
open Theory
let qualid_of_lstring s =
assert false (*TODO*)
(* let qualid_of_lstring = function *)
(* | [] -> invalid_arg "Transfrom_utils.qualid_of_lstring : empty list" *)
(* | a :: l -> *)
(* let id = Ptree.Qident {Ptree.id = a;id_loc = Loc.dummy_position} in *)
(* List.fold_left (fun acc x -> *)
(* Ptree.Qdot (acc,{Ptree.id = x;id_loc = Loc.dummy_position})) id l *)
let cloned_from_ts env ctxt l s ls1 =
assert false (*TODO*)
(* try *)
......
......@@ -17,13 +17,11 @@
(* *)
(**************************************************************************)
val qualid_of_lstring : string list -> Ptree.qualid
val cloned_from_ts : Typing.env -> Theory.context ->
string list -> string -> Ty.tysymbol -> bool
string list -> string list -> Ty.tysymbol -> bool
val cloned_from_ls : Typing.env -> Theory.context ->
string list -> string -> Term.lsymbol -> bool
string list -> string list -> Term.lsymbol -> bool
val cloned_from_pr : Typing.env -> Theory.context ->
string list -> string -> Theory.prop -> bool
string list -> string list -> Theory.prop -> bool
......@@ -31,4 +31,4 @@ let elt a =
r
let t = Transform.elt elt
let t env = Transform.elt (fun _ -> elt) env
......@@ -19,4 +19,4 @@
(* a list of decl_or_use to a list of decl *)
val t : Transform.ctxt_t
val t : Typing.env -> Transform.ctxt_t
......@@ -118,8 +118,8 @@ let fold isnotinlinedt isnotinlinedf ctxt0 (env, ctxt) =
(create_prop (id_dup pr.pr_name) (replacep env pr.pr_fmla)))
| Duse _ | Dclone _ -> env,add_decl ctxt d
let t ~isnotinlinedt ~isnotinlinedf =
Transform.fold_map (fold isnotinlinedt isnotinlinedf) empty_env
let t ~isnotinlinedt ~isnotinlinedf env =
Transform.fold_map (fun _ -> fold isnotinlinedt isnotinlinedf) empty_env env
let all = t ~isnotinlinedt:(fun _ -> false) ~isnotinlinedf:(fun _ -> false)
......
......@@ -23,17 +23,18 @@
val t :
isnotinlinedt:(Term.term -> bool) ->
isnotinlinedf:(Term.fmla -> bool) ->
Typing.env ->
Transform.ctxt_t
(* Inline them all *)
val all : Transform.ctxt_t
val all : Typing.env -> Transform.ctxt_t
(* Inline only the trivial definition :
logic c : t = a
logic f(x : t,...., ) : t = g(y : t2,...) *)
val trivial : Transform.ctxt_t
val trivial : Typing.env -> Transform.ctxt_t
(* Function to use in other transformations if inlining is needed *)
......
......@@ -140,9 +140,4 @@ let elt d =
| Dind _ -> [d] (* TODO *)
| Dprop _ | Dclone _ | Duse _ -> [d]
let elt d =
let r = elt d in
(* Format.printf "srd : %a -> %a@\n" Pretty.print_decl d Pretty.print_decl_list r;*)
r
let t = Transform.elt elt
let t env = Transform.elt (fun _ -> elt) env
......@@ -20,7 +20,7 @@
(* Simplify the recursive type and logic definition *)
val t : Transform.ctxt_t
val t : Typing.env -> Transform.ctxt_t
(* ungroup recursive definition *)
......
......@@ -20,21 +20,29 @@
open Ident
open Theory
open Context
open Typing
(* the memoisation is inside the function *)
type 'a t = { all : context -> 'a;
clear : unit -> unit;
env : env;
}
type ctxt_t = context t
let conv_res f c = {all = (fun x -> c (f.all x));
clear = f.clear}
clear = f.clear;
env = f.env}
let compose f g = {all = (fun x -> g.all (f.all x));
clear = (fun () -> f.clear (); g.clear ());
}
exception CompositionOfIncompatibleTranformation
let compose f g =
if g.env != f.env then raise CompositionOfIncompatibleTranformation;
{all = (fun x -> g.all (f.all x));
clear = (fun () -> f.clear (); g.clear ());
env = f.env
}
let apply f x = f.all x
......@@ -56,17 +64,18 @@ let memo f tag h = ymemo (fun _ -> f) tag h
let d_tag d = d.d_tag
let ctxt_tag c = c.ctxt_tag
let t ?(clear=(fun () -> ())) all clear_all =
let t all clear_all env =
{all = all;
clear = (fun () -> clear ();clear_all ())
clear = clear_all;
env = env;
}
let fold ?clear f_fold v_empty =
let fold f_fold v_empty tenv =
let memo_t = Hashtbl.create 64 in
let rewind env todo =
List.fold_left
(fun env ctxt ->
let env = f_fold ctxt env in
let env = f_fold tenv ctxt env in
Hashtbl.add memo_t ctxt.ctxt_tag env;
env) env todo in
let rec f todo ctxt =
......@@ -78,31 +87,31 @@ let fold ?clear f_fold v_empty =
rewind env (ctxt::todo)
with Not_found -> f (ctxt::todo) ctxt2
in
t ?clear (f []) (fun () -> Hashtbl.clear memo_t)
t (f []) (fun () -> Hashtbl.clear memo_t) tenv
let fold_map ?clear f_fold v_empty =
let fold_map f_fold v_empty env =
let v_empty = v_empty,init_context in
let f_fold ctxt env_ctxt2 = f_fold ctxt env_ctxt2 in
conv_res (fold ?clear f_fold v_empty) snd
let f_fold env ctxt env_ctxt2 = f_fold env ctxt env_ctxt2 in
conv_res (fold f_fold v_empty env) snd
let map ?clear f_map =
fold_map ?clear (fun ctxt1 ctxt2 -> (), f_map ctxt1 (snd ctxt2)) ()
let map f_map env =
fold_map (fun env ctxt1 ctxt2 -> (), f_map env ctxt1 (snd ctxt2)) () env
let map_concat ?clear f_elt =
let f_elt ctxt0 ctxt =
List.fold_left add_decl ctxt (f_elt ctxt0) in
map ?clear f_elt
let map_concat f_elt env =
let f_elt env ctxt0 ctxt =
List.fold_left add_decl ctxt (f_elt env ctxt0) in
map f_elt env
let elt ?clear f_elt =
let elt f_elt env =
let memo_elt = Hashtbl.create 64 in
let f_elt ctxt0 = memo f_elt d_tag memo_elt ctxt0.ctxt_decl in
let f = map_concat ?clear f_elt in
let f_elt env ctxt0 = memo (f_elt env) d_tag memo_elt ctxt0.ctxt_decl in
let f = map_concat f_elt env in
{f with clear = fun () -> Hashtbl.clear memo_elt; f.clear ()}
let register ?clear f =
let register f env =
let memo_t = Hashtbl.create 16 in
t ?clear (memo f ctxt_tag memo_t) (fun () -> Hashtbl.clear memo_t)
t (memo (f env) ctxt_tag memo_t) (fun () -> Hashtbl.clear memo_t) env
(* Utils *)
......@@ -126,8 +135,8 @@ let fold_context_of_decl f ctxt env ctxt_done d =
let env,decls = f ctxt env d in
env,List.fold_left add_decl ctxt_done decls
let split_goals () =
let f ctxt0 (ctxt,l) =
let split_goals env =
let f _ ctxt0 (ctxt,l) =
let decl = ctxt0.ctxt_decl in
match decl.d_node with
| Dprop (Pgoal,_) -> (ctxt,(add_decl ctxt decl)::l)
......@@ -137,11 +146,11 @@ let split_goals () =
(add_decl ctxt d1,
(add_decl ctxt d2)::l)
| _ -> (add_decl ctxt decl,l) in
let g = fold f (init_context,[]) in
let g = fold f (init_context,[]) env in
conv_res g snd
let extract_goals =
let f ctxt0 (ctxt,l) =
let extract_goals env =
let f env ctxt0 (ctxt,l) =
let decl = ctxt0.ctxt_decl in
match decl.d_node with
| Dprop (Pgoal,f) -> (ctxt,(f.pr_name,f.pr_fmla,ctxt)::l)
......@@ -150,11 +159,10 @@ let extract_goals =
(add_decl ctxt d,
(f.pr_name,f.pr_fmla,ctxt)::l)
| _ -> (add_decl ctxt decl,l) in
let g = fold f (init_context,[]) in
let g = fold f (init_context,[]) env in
conv_res g snd
let unit_tag () = 0
let identity = {all = (fun x -> x);
clear = (fun () -> ())}
let identity env = {all = (fun x -> x);
clear = (fun () -> ());
env = env}
......@@ -19,6 +19,7 @@
open Ident
open Theory
open Typing
(* Tranformation on context with some memoisations *)
......@@ -28,6 +29,7 @@ open Theory
type 'a t
type ctxt_t = context t
exception CompositionOfIncompatibleTranformation
(* compose two transformations, the underlying datastructures for
the memoisation are shared *)
val compose : context t -> 'a t -> 'a t
......@@ -35,41 +37,26 @@ val compose : context t -> 'a t -> 'a t
(* apply a transformation and memoise *)
val apply : 'a t -> context -> 'a
(* clear the datastructures used to store the memoisation *)
val clear : 'a t -> unit
(** General constructors *)
(* create a transformation with only one memoisation *)
val register :
?clear:(unit -> unit) ->
(context -> 'a) -> 'a t
val register : (env -> context -> 'a) -> env -> 'a t
(* Fold from the first declaration to the last with a memoisation at
each step *)
val fold :
?clear:(unit -> unit) ->
(context -> 'a -> 'a) -> 'a -> 'a t
val fold : (env -> context -> 'a -> 'a) -> 'a -> env -> 'a t
val fold_map :
?clear:(unit -> unit) ->
(context -> 'a * context -> 'a * context) -> 'a ->
context t
val fold_map : (env -> context -> 'a * context -> 'a * context) -> 'a ->
env -> context t
val map :
?clear:(unit -> unit) ->
(context -> context -> context) -> context t
val map : (env -> context -> context -> context) -> env -> context t
val map_concat :
?clear:(unit -> unit) ->
(context -> decl list) -> context t
val map_concat : (env -> context -> decl list) -> env -> context t
(* map the element of the list without an environnment.
A memoisation is performed at each step, and for each elements *)
val elt :
?clear:(unit -> unit) ->
(decl -> decl list) -> context t
val elt : (env -> decl -> decl list) -> env -> context t
(** Utils *)
......@@ -97,6 +84,6 @@ val fold_context_of_decl:
(* Utils *)
val split_goals : unit -> context list t
val split_goals : env -> context list t
val identity : context t
val identity : env -> context 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