Commit 017deebd authored by Andrei Paskevich's avatar Andrei Paskevich

keep real symbols in Clone and Meta

parent 7209c060
......@@ -86,7 +86,7 @@ module Spr = Prop.S
module Mpr = Prop.M
module Hpr = Prop.H
let pr_equal pr1 pr2 = id_equal pr1.pr_name pr2.pr_name
let pr_equal = (==)
let create_prsymbol n = { pr_name = id_register n }
......
......@@ -43,18 +43,11 @@ let iprinter,tprinter,lprinter,pprinter =
create_ident_printer bl ~sanitizer:isanitize,
create_ident_printer bl ~sanitizer:usanitize
let thash = Hid.create 63
let lhash = Hid.create 63
let phash = Hid.create 63
let forget_all () =
forget_all iprinter;
forget_all tprinter;
forget_all lprinter;
forget_all pprinter;
Hid.clear thash;
Hid.clear lhash;
Hid.clear phash
forget_all pprinter
let tv_set = ref Sid.empty
......@@ -81,20 +74,16 @@ let print_th fmt th =
fprintf fmt "%s" (id_unique iprinter ~sanitizer th.th_name)
let print_ts fmt ts =
Hid.replace thash ts.ts_name ts;
fprintf fmt "%s" (id_unique tprinter ts.ts_name)
let print_ls fmt ls =
Hid.replace lhash ls.ls_name ls;
fprintf fmt "%s" (id_unique lprinter ls.ls_name)
let print_cs fmt ls =
Hid.replace lhash ls.ls_name ls;
let sanitizer = String.capitalize in
fprintf fmt "%s" (id_unique lprinter ~sanitizer ls.ls_name)
let print_pr fmt pr =
Hid.replace phash pr.pr_name pr;
fprintf fmt "%s" (id_unique pprinter pr.pr_name)
(** Types *)
......@@ -328,41 +317,35 @@ let print_decl fmt d = match d.d_node with
| Dind il -> print_list newline print_ind_decl fmt il
| Dprop p -> print_prop_decl fmt p
let print_inst fmt (id1,id2) =
if Hid.mem thash id2 then
let n = id_unique tprinter id1 in
fprintf fmt "type %s = %a" n print_ts (Hid.find thash id2)
else if Hid.mem lhash id2 then
let n = id_unique lprinter id1 in
fprintf fmt "logic %s = %a" n print_ls (Hid.find lhash id2)
else if Hid.mem phash id2 then
let n = id_unique pprinter id1 in
fprintf fmt "prop %s = %a" n print_pr (Hid.find phash id2)
else
fprintf fmt "ident %s = %s" id1.id_string id2.id_string
let print_inst_ts fmt (ts1,ts2) =
fprintf fmt "type %a = %a" print_ts ts1 print_ts ts2
let print_inst_ls fmt (ls1,ls2) =
fprintf fmt "logic %a = %a" print_ls ls1 print_ls ls2
let print_inst_pr fmt (pr1,pr2) =
fprintf fmt "prop %a = %a" print_pr pr1 print_pr pr2
let print_meta_arg fmt = function
| MARid id ->
if Hid.mem thash id then
fprintf fmt "type %a" print_ts (Hid.find thash id)
else if Hid.mem lhash id then
fprintf fmt "logic %a" print_ls (Hid.find lhash id)
else if Hid.mem phash id then
fprintf fmt "prop %a" print_pr (Hid.find phash id)
else
fprintf fmt "ident %s" id.id_string
| MARstr s -> fprintf fmt "\"%s\"" s
| MARint i -> fprintf fmt "%d" i
| MAts ts -> fprintf fmt "type %a" print_ts ts
| MAls ls -> fprintf fmt "logic %a" print_ls ls
| MApr pr -> fprintf fmt "prop %a" print_pr pr
| MAstr s -> fprintf fmt "\"%s\"" s
| MAint i -> fprintf fmt "%d" i
let print_tdecl fmt td = match td.td_node with
| Decl d ->
print_decl fmt d
| Use th ->
fprintf fmt "@[<hov 2>(* use %a *)@]" print_th th
| Clone (th,inst) ->
let inst = Mid.fold (fun x y a -> (x,y)::a) inst [] in
fprintf fmt "@[<hov 2>(* clone %a with %a *)@]"
print_th th (print_list comma print_inst) inst
| Clone (th,tm,lm,pm) ->
let tm = Mts.fold (fun x y a -> (x,y)::a) tm [] in
let lm = Mls.fold (fun x y a -> (x,y)::a) lm [] in
let pm = Mpr.fold (fun x y a -> (x,y)::a) pm [] in
fprintf fmt "@[<hov 2>(* clone %a with %a,%a,%a *)@]"
print_th th (print_list comma print_inst_ts) tm
(print_list comma print_inst_ls) lm
(print_list comma print_inst_pr) pm
| Meta (t,al) ->
fprintf fmt "@[<hov 2>(* meta %s %a *)@]"
t (print_list space print_meta_arg) al
......@@ -386,7 +369,7 @@ module NsTree = struct
let contents ns kn =
let add_ns s ns acc = Namespace (s, ns, kn) :: acc in
let add_pr s p acc =
let add_pr s p acc =
let k, _ = find_prop_decl kn p in
Leaf (sprint_pkind k ^ " " ^ s) :: acc in
let add_ls s ls acc =
......@@ -411,7 +394,7 @@ end
let print_namespace fmt name th =
let module P = Print_tree.Make(NsTree) in
fprintf fmt "@[<hov>%a@]@." P.print
fprintf fmt "@[<hov>%a@]@." P.print
(NsTree.Namespace (name, th.th_export, th.th_known))
(* Exception reporting *)
......
......@@ -47,7 +47,7 @@ val print_fmla : formatter -> fmla -> unit (* formula *)
val print_expr : formatter -> expr -> unit (* term or formula *)
val print_pkind : formatter -> prop_kind -> unit
val print_meta_arg : formatter -> meta_arg_real -> unit
val print_meta_arg : formatter -> meta_arg -> unit
val print_type_decl : formatter -> ty_decl -> unit
val print_logic_decl : formatter -> logic_decl -> unit
......
......@@ -113,7 +113,8 @@ let print_prelude fmt pl =
let print_th_prelude task fmt pm =
let th_used = task_fold (fun acc -> function
| { td_node = Clone (th,cl) } when Mid.is_empty cl -> th::acc
| { td_node = Clone (th,tm,lm,pm) }
when Mts.is_empty tm && Mls.is_empty lm && Mpr.is_empty pm -> th::acc
| _ -> acc) [] task
in
List.iter (fun th ->
......@@ -140,19 +141,27 @@ let meta_remove_type = register_meta "remove_type" [MTtysymbol]
let meta_remove_logic = register_meta "remove_logic" [MTlsymbol]
let meta_remove_prop = register_meta "remove_prop" [MTprsymbol]
let remove_type ts = create_meta meta_remove_type [MAts ts]
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 remove_prop pr = create_meta meta_remove_prop [MApr pr]
let get_remove_set task =
let add td s = match td.td_node with
| Meta (_,[MARid id]) -> Sid.add id s
let add_ts td s = match td.td_node with
| Meta (_,[MAts ts]) -> Sid.add ts.ts_name s
| _ -> assert false
in
let add_ls td s = match td.td_node with
| Meta (_,[MAls ls]) -> Sid.add ls.ls_name s
| _ -> assert false
in
let add_pr td s = match td.td_node with
| Meta (_,[MApr pr]) -> Sid.add pr.pr_name s
| _ -> assert false
in
let s = Sid.empty in
let s = Stdecl.fold add (find_meta task meta_remove_type).tds_set s in
let s = Stdecl.fold add (find_meta task meta_remove_logic).tds_set s in
let s = Stdecl.fold add (find_meta task meta_remove_prop).tds_set s in
let s = Stdecl.fold add_ts (find_meta task meta_remove_type).tds_set s in
let s = Stdecl.fold add_ls (find_meta task meta_remove_logic).tds_set s in
let s = Stdecl.fold add_pr (find_meta task meta_remove_prop).tds_set s in
s
(** {2 exceptions to use in transformations and printers} *)
......
......@@ -165,7 +165,7 @@ let add_ind_decls tk dl = List.fold_left add_decl tk (create_ind_decls dl)
let rec add_tdecl task td = match td.td_node with
| Decl d -> new_decl task d td
| Use th -> use_export task th
| Clone (th,_) -> add_clone task th td
| Clone (th,_,_,_) -> add_clone task th td
| Meta (t,_) -> add_meta task t td
and flat_tdecl task td = match td.td_node with
......@@ -215,13 +215,31 @@ let task_decls = task_fold (fun acc td ->
exception NotTaggingMeta of string
let find_tagged t tds acc =
let find_tagged_ts t tds acc =
begin match lookup_meta t with
| [MTtysymbol|MTlsymbol|MTprsymbol] -> ()
| [MTtysymbol] -> ()
| _ -> 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
| Meta (s, [MAts ts]) when s = t -> Sts.add ts acc
| _ -> assert false) tds.tds_set acc
let find_tagged_ls t tds acc =
begin match lookup_meta t with
| [MTlsymbol] -> ()
| _ -> raise (NotTaggingMeta t)
end;
Stdecl.fold (fun td acc -> match td.td_node with
| Meta (s, [MAls ls]) when s = t -> Sls.add ls acc
| _ -> assert false) tds.tds_set acc
let find_tagged_pr t tds acc =
begin match lookup_meta t with
| [MTprsymbol] -> ()
| _ -> raise (NotTaggingMeta t)
end;
Stdecl.fold (fun td acc -> match td.td_node with
| Meta (s, [MApr pr]) when s = t -> Spr.add pr acc
| _ -> assert false) tds.tds_set acc
exception NotExclusiveMeta of string
......
......@@ -99,7 +99,9 @@ val task_goal : task -> prsymbol
exception NotTaggingMeta of string
val find_tagged : string -> tdecl_set -> Sid.t -> Sid.t
val find_tagged_ts : string -> tdecl_set -> Sts.t -> Sts.t
val find_tagged_ls : string -> tdecl_set -> Sls.t -> Sls.t
val find_tagged_pr : string -> tdecl_set -> Spr.t -> Spr.t
(* special selector for exclusive metaproperties *)
......
......@@ -96,11 +96,6 @@ type meta_arg =
| MAstr of string
| MAint of int
type meta_arg_real =
| MARid of ident
| MARstr of string
| MARint of int
exception KnownMeta of string
exception UnknownMeta of string
exception BadMetaArity of string * int * int
......@@ -148,8 +143,8 @@ and tdecl = {
and tdecl_node =
| Decl of decl
| Use of theory
| Clone of theory * ident Mid.t
| Meta of string * meta_arg_real list
| Clone of theory * tysymbol Mts.t * lsymbol Mls.t * prsymbol Mpr.t
| Meta of string * meta_arg list
(** Theory declarations *)
......@@ -158,32 +153,42 @@ module Hstdecl = Hashcons.Make (struct
type t = tdecl
let eq_marg a1 a2 = match a1,a2 with
| MARid id1, MARid id2 -> id_equal id1 id2
| MARstr s1, MARstr s2 -> s1 = s2
| MARint i1, MARint i2 -> i1 = i2
| MAts ts1, MAts ts2 -> ts_equal ts1 ts2
| MAls ls1, MAls ls2 -> ls_equal ls1 ls2
| MApr pr1, MApr pr2 -> pr_equal pr1 pr2
| MAstr s1, MAstr s2 -> s1 = s2
| MAint i1, MAint i2 -> i1 = i2
| _,_ -> false
let equal td1 td2 = match td1.td_node, td2.td_node with
| Decl d1, Decl d2 -> d_equal d1 d2
| Use th1, Use th2 -> id_equal th1.th_name th2.th_name
| Clone (th1,cl1), Clone (th2,cl2) ->
| Clone (th1,tm1,lm1,pm1), Clone (th2,tm2,lm2,pm2) ->
id_equal th1.th_name th2.th_name &&
Mid.equal id_equal cl1 cl2
Mts.equal ts_equal tm1 tm2 &&
Mls.equal ls_equal lm1 lm2 &&
Mpr.equal pr_equal pm1 pm2
| Meta (t1,al1), Meta (t2,al2) ->
t1 = t2 && list_all2 eq_marg al1 al2
| _,_ -> false
let hs_cl _ id acc = Hashcons.combine acc id.id_tag
let hs_cl_ts _ ts acc = Hashcons.combine acc ts.ts_name.id_tag
let hs_cl_ls _ ls acc = Hashcons.combine acc ls.ls_name.id_tag
let hs_cl_pr _ pr acc = Hashcons.combine acc pr.pr_name.id_tag
let hs_ta = function
| MARid id -> id.id_tag
| MARstr s -> Hashtbl.hash s
| MARint i -> Hashtbl.hash i
| MAts ts -> ts.ts_name.id_tag
| MAls ls -> ls.ls_name.id_tag
| MApr pr -> pr.pr_name.id_tag
| MAstr s -> Hashtbl.hash s
| MAint i -> Hashtbl.hash i
let hash td = match td.td_node with
| Decl d -> d.d_tag
| Use th -> th.th_name.id_tag
| Clone (th,cl) -> Mid.fold hs_cl cl th.th_name.id_tag
| Clone (th,tm,lm,pm) ->
Mts.fold hs_cl_ts tm (Mls.fold hs_cl_ls lm
(Mpr.fold hs_cl_pr pm th.th_name.id_tag))
| Meta (t,al) -> Hashcons.combine_list hs_ta (Hashtbl.hash t) al
let tag n td = { td with td_tag = n }
......@@ -261,12 +266,16 @@ let close_namespace uc import s =
(* Base constructors *)
let known_clone kn cl =
Mid.iter (fun _ id -> known_id kn id) cl
let known_clone kn tm lm pm =
Mts.iter (fun _ ts -> known_id kn ts.ts_name) tm;
Mls.iter (fun _ ls -> known_id kn ls.ls_name) lm;
Mpr.iter (fun _ pr -> known_id kn pr.pr_name) pm
let known_meta kn al =
let check = function
| MARid id -> known_id kn id
| MAts ts -> known_id kn ts.ts_name
| MAls ls -> known_id kn ls.ls_name
| MApr pr -> known_id kn pr.pr_name
| _ -> ()
in
List.iter check al
......@@ -281,7 +290,7 @@ let add_tdecl uc td = match td.td_node with
uc_decls = td :: uc.uc_decls;
uc_known = merge_known uc.uc_known th.th_known;
uc_used = Sid.union uc.uc_used (Sid.add th.th_name th.th_used) }
| Clone (_,cl) -> known_clone uc.uc_known cl;
| Clone (_,tm,lm,pm) -> known_clone uc.uc_known tm lm pm;
{ uc with uc_decls = td :: uc.uc_decls }
| Meta (_,al) -> known_meta uc.uc_known al;
{ uc with uc_decls = td :: uc.uc_decls }
......@@ -373,72 +382,54 @@ exception CannotInstantiate of ident
type clones = {
cl_local : Sid.t;
ts_table : tysymbol Hts.t;
ls_table : lsymbol Hls.t;
pr_table : prsymbol Hpr.t;
mutable id_table : ident Mid.t;
mutable id_local : Sid.t;
mutable ts_table : tysymbol Mts.t;
mutable ls_table : lsymbol Mls.t;
mutable pr_table : prsymbol Mpr.t;
}
let empty_clones s = {
cl_local = s;
ts_table = Hts.create 17;
ls_table = Hls.create 17;
pr_table = Hpr.create 17;
id_table = Mid.empty;
id_local = Sid.empty;
ts_table = Mts.empty;
ls_table = Mls.empty;
pr_table = Mpr.empty;
}
let cl_add_ts cl ts ts' =
cl.id_table <- Mid.add ts.ts_name ts'.ts_name cl.id_table;
Hts.replace cl.ts_table ts ts'
let cl_add_ls cl ls ls' =
cl.id_table <- Mid.add ls.ls_name ls'.ls_name cl.id_table;
Hls.replace cl.ls_table ls ls'
let cl_add_pr cl pr pr' =
cl.id_table <- Mid.add pr.pr_name pr'.pr_name cl.id_table;
Hpr.replace cl.pr_table pr pr'
(* populate the clone structure *)
let cl_find_id cl id =
if not (Sid.mem id cl.cl_local) then id
else Mid.find id cl.id_table
let rec cl_find_ts cl ts =
if not (Sid.mem ts.ts_name cl.cl_local) then ts
else try Hts.find cl.ts_table ts
else try Mts.find ts cl.ts_table
with Not_found ->
let td' = option_map (cl_trans_ty cl) ts.ts_def in
let ts' = create_tysymbol (id_dup ts.ts_name) ts.ts_args td' in
cl.id_local <- Sid.add ts'.ts_name cl.id_local;
cl_add_ts cl ts ts';
cl.ts_table <- Mts.add ts ts' cl.ts_table;
ts'
and cl_trans_ty cl ty = ty_s_map (cl_find_ts cl) ty
let cl_find_ls cl ls =
if not (Sid.mem ls.ls_name cl.cl_local) then ls
else try Hls.find cl.ls_table ls
else try Mls.find ls cl.ls_table
with Not_found ->
let ta' = List.map (cl_trans_ty cl) ls.ls_args in
let vt' = option_map (cl_trans_ty cl) ls.ls_value in
let ls' = create_lsymbol (id_dup ls.ls_name) ta' vt' in
cl.id_local <- Sid.add ls'.ls_name cl.id_local;
cl_add_ls cl ls ls';
cl.ls_table <- Mls.add ls ls' cl.ls_table;
ls'
let cl_trans_fmla cl f = f_s_map (cl_find_ts cl) (cl_find_ls cl) f
let cl_find_pr cl pr =
if not (Sid.mem pr.pr_name cl.cl_local) then assert false
else try ignore (Hpr.find cl.pr_table pr); assert false
if not (Sid.mem pr.pr_name cl.cl_local) then pr
else try Mpr.find pr cl.pr_table
with Not_found ->
let pr' = create_prsymbol (id_dup pr.pr_name) in
cl.id_local <- Sid.add pr'.pr_name cl.id_local;
cl_add_pr cl pr pr';
cl.pr_table <- Mpr.add pr pr' cl.pr_table;
pr'
(* initialize the clone structure *)
......@@ -451,7 +442,7 @@ let cl_init_ts cl ts ts' =
if not (Sid.mem id cl.cl_local) then raise (NonLocal id);
if List.length ts.ts_args <> List.length ts'.ts_args
then raise (BadInstance (id, ts'.ts_name));
cl_add_ts cl ts ts'
cl.ts_table <- Mts.add ts ts' cl.ts_table
let cl_init_ls cl ls ls' =
let id = ls.ls_name in
......@@ -467,7 +458,7 @@ let cl_init_ls cl ls ls' =
in
ignore (try List.fold_left2 mtch sb ls.ls_args ls'.ls_args
with Invalid_argument _ -> raise (BadInstance (id, ls'.ls_name)));
cl_add_ls cl ls ls'
cl.ls_table <- Mls.add ls ls' cl.ls_table
let cl_init_pr cl pr =
let id = pr.pr_name in
......@@ -564,13 +555,16 @@ let cl_decl cl inst d = match d.d_node with
| Dprop p -> cl_prop cl inst p
let cl_marg cl = function
| MARid id -> MARid (cl_find_id cl id)
| MAts ts -> MAts (cl_find_ts cl ts)
| MAls ls -> MAls (cl_find_ls cl ls)
| MApr pr -> MApr (cl_find_pr cl pr)
| a -> a
let cl_tdecl cl inst td = match td.td_node with
| Decl d -> Decl (cl_decl cl inst d)
| Use th -> Use th
| Clone (th,i) -> Clone (th, Mid.map (cl_find_id cl) i)
| Clone (th,tm,lm,pm) -> Clone (th, Mts.map (cl_find_ts cl) tm,
Mls.map (cl_find_ls cl) lm, Mpr.map (cl_find_pr cl) pm)
| Meta (id,al) -> Meta (id, List.map (cl_marg cl) al)
let clone_theory cl add_td acc th inst =
......@@ -582,7 +576,7 @@ let clone_theory cl add_td acc th inst =
option_apply acc (add_td acc) td
in
let acc = List.fold_left add acc th.th_decls in
add_td acc (mk_tdecl (Clone (th, cl.id_table)))
add_td acc (mk_tdecl (Clone (th, cl.ts_table, cl.ls_table, cl.pr_table)))
let clone_export uc th inst =
let cl = cl_init th inst in
......@@ -593,21 +587,21 @@ let clone_export uc th inst =
let f_ts n ts ns =
if Sid.mem ts.ts_name th.th_local then
let ts' = Hts.find cl.ts_table ts in
let ts' = Mts.find ts cl.ts_table in
if Sid.mem ts'.ts_name cl.id_local
then add_ts true n ts' ns else ns
else add_ts true n ts ns in
let f_ls n ls ns =
if Sid.mem ls.ls_name th.th_local then
let ls' = Hls.find cl.ls_table ls in
let ls' = Mls.find ls cl.ls_table in
if Sid.mem ls'.ls_name cl.id_local
then add_ls true n ls' ns else ns
else add_ls true n ls ns in
let f_pr n pr ns =
if Sid.mem pr.pr_name th.th_local then
let pr' = Hpr.find cl.pr_table pr in
let pr' = Mpr.find pr cl.pr_table in
if Sid.mem pr'.pr_name cl.id_local
then add_pr true n pr' ns else ns
else add_pr true n pr ns in
......@@ -633,7 +627,8 @@ let clone_theory add_td acc th inst =
let create_clone = clone_theory (fun tdl td -> td :: tdl)
let create_null_clone th = mk_tdecl (Clone (th,Mid.empty))
let create_null_clone th =
mk_tdecl (Clone (th, Mts.empty, Mls.empty, Mpr.empty))
(** Meta properties *)
......@@ -649,15 +644,11 @@ let create_meta s al =
let atl = try Hashtbl.find meta_table s
with Not_found -> raise (UnknownMeta s)
in
let get_meta_arg_real at a = match at, a with
| MTtysymbol, MAts ts -> MARid ts.ts_name
| MTlsymbol, MAls ls -> MARid ls.ls_name
| MTprsymbol, MApr pr -> MARid pr.pr_name
| MTstring, MAstr s -> MARstr s
| MTint, MAint i -> MARint i
| _,_ -> raise (MetaTypeMismatch (s, at, get_meta_arg_type a))
let get_meta_arg at a =
let mt = get_meta_arg_type a in
if at = mt then a else raise (MetaTypeMismatch (s,at,mt))
in
let al = try List.map2 get_meta_arg_real atl al
let al = try List.map2 get_meta_arg atl al
with Invalid_argument _ ->
raise (BadMetaArity (s, List.length atl, List.length al))
in
......@@ -666,9 +657,16 @@ let create_meta s al =
let add_meta uc s al = add_tdecl uc (create_meta s al)
let clone_meta tdt th tdc = match tdt.td_node, tdc.td_node with
| Meta (t,al), Clone (th',cl) when id_equal th.th_name th'.th_name ->
let find_id id = try Mid.find id cl with Not_found -> id in
let cl_marg = function MARid id -> MARid (find_id id) | a -> a in
| Meta (t,al), Clone (th',tm,lm,pm) when id_equal th.th_name th'.th_name ->
let find_ts ts = try Mts.find ts tm with Not_found -> ts in
let find_ls ls = try Mls.find ls lm with Not_found -> ls in
let find_pr pr = try Mpr.find pr pm with Not_found -> pr in
let cl_marg = function
| MAts ts -> MAts (find_ts ts)
| MAls ls -> MAls (find_ls ls)
| MApr pr -> MApr (find_pr pr)
| a -> a
in
mk_tdecl (Meta (t, List.map cl_marg al))
| _,_ -> invalid_arg "clone_meta"
......
......@@ -54,11 +54,6 @@ type meta_arg =
| MAstr of string
| MAint of int
type meta_arg_real =
| MARid of ident
| MARstr of string
| MARint of int
val register_meta : string -> meta_arg_type list -> string
val register_meta_exc : string -> meta_arg_type list -> string
......@@ -86,8 +81,8 @@ and tdecl = private {
and tdecl_node = private
| Decl of decl
| Use of theory
| Clone of theory * ident Mid.t
| Meta of string * meta_arg_real list
| Clone of theory * tysymbol Mts.t * lsymbol Mls.t * prsymbol Mpr.t
| Meta of string * meta_arg list
module Stdecl : Set.S with type elt = tdecl
module Mtdecl : Map.S with type key = tdecl
......
......@@ -224,9 +224,10 @@ let print_task ?(debug=false) drv fmt task =
Mid.fold (fun _ (th,s) task ->
let cs = (find_clone task th).tds_set in
Stdecl.fold (fun td task -> match td.td_node with
| Clone (_,cl) when Mid.is_empty cl ->
| Clone (_,tm,lm,pm)
when Mts.is_empty tm && Mls.is_empty lm && Mpr.is_empty pm ->
Stdecl.fold (fun td task -> add_tdecl task td) s task
| _ -> assert false (* impossible *)
| _ -> task
) cs task
) drv.drv_meta task
in
......
......@@ -53,7 +53,7 @@ let forget_var v = forget_id ident_printer v.vs_name
type info = {
info_syn : syntax_map;
info_rem : Sid.t;
info_ac : Sid.t;
info_ac : Sls.t;
}
let rec print_type info fmt ty = match ty.ty_node with
......@@ -167,7 +167,7 @@ let ac_th = ["algebra";"AC"]
let print_logic_decl info fmt (ls,ld) =
match ld with
| None ->
let sac = if Sid.mem ls.ls_name info.info_ac then "ac " else "" in
let sac = if Sls.mem ls info.info_ac then "ac " else "" in
fprintf fmt "@[<hov 2>logic %s%a : %a%s%a@]@\n"
sac print_ident ls.ls_name
(print_list comma (print_type info)) ls.ls_args
......@@ -220,7 +220,8 @@ let print_task pr thpr syn fmt task =
let info = {
info_syn = syn;
info_rem = get_remove_set task;
info_ac = Task.find_tagged meta_ac (find_meta task meta_ac) Sid.empty }
info_ac =
Task.find_tagged_ls meta_ac (find_meta task meta_ac) Sls.empty }
in
let decls = Task.task_decls task in
ignore (print_list_opt (add_flush newline2) (print_decl info) fmt decls)
......
......@@ -68,6 +68,11 @@ let print_vs fmt vs =
let forget_var vs = forget_id iprinter vs.vs_name
(* theory names always start with an upper case letter *)
let print_th fmt th =
let sanitizer = String.capitalize in
fprintf fmt "%s" (id_unique iprinter ~sanitizer th.th_name)
let print_ts fmt ts =
fprintf fmt "%s" (id_unique tprinter ts.ts_name)
......@@ -336,22 +341,34 @@ let print_decl info fmt d = match d.d_node with
let print_decls info fmt dl =
fprintf fmt "@[<hov>%a@\n@]" (print_list nothing (print_decl info)) dl
let print_inst fmt (id1,id2) =
fprintf fmt "ident %s = %s" id1.id_string id2.id_string
let print_inst_ts fmt (ts1,ts2) =
fprintf fmt "type %a = %a" print_ts ts1 print_ts ts2
let print_inst_ls fmt (ls1,ls2) =
fprintf fmt "logic %a = %a" print_ls ls1 print_ls ls2
let print_inst_pr fmt (pr1,pr2) =
fprintf fmt "prop %a = %a" print_pr pr1 print_pr pr2
let print_meta_arg fmt = function
| MARid id -> fprintf fmt "ident %s" id.id_string
| MARstr s -> fprintf fmt "\"%s\"" s
| MARint i -> fprintf fmt "%d" i
| MAts ts -> fprintf fmt "type %a" print_ts ts
| MAls ls -> fprintf fmt "logic %a" print_ls ls
| MApr pr -> fprintf fmt "prop %a" print_pr pr
| MAstr s -> fprintf fmt "\"%s\"" s
| MAint i -> fprintf fmt "%d" i
let print_tdecl info fmt td = match td.td_node with
| Decl d -> print_decl info fmt d
| Use th ->
fprintf fmt "@[<hov 2>(* use %s *)@]@\n" th.th_name.id_string
| Clone (th,inst) ->
let inst = Mid.fold (fun x y a -> (x,y)::a) inst [] in
fprintf fmt "@[<hov 2>(* clone %s with %a *)@]@\n"
th.th_name.id_string (print_list comma print_inst) inst
fprintf fmt "@[<hov 2>(* use %a *)@]@\n" print_th th
| Clone (th,tm,lm,pm) ->
let tm = Mts.fold (fun x y a -> (x,y)::a) tm [] in
let lm = Mls.fold (fun x y a -> (x,y)::a) lm [] in
let pm = Mpr.fold (fun x y a -> (x,y)::a) pm [] in
fprintf fmt "@[<hov 2>(* clone %a with %a,%a,%a *)@]"
print_th th (print_list comma print_inst_ts) tm
(print_list comma print_inst_ls) lm
(print_list comma print_inst_pr) pm
| Meta (t,al) ->
fprintf fmt "@[<hov 2>(* meta %s %a *)@]@\n"
t (print_list space print_meta_arg) al
......
......@@ -25,11 +25,11 @@ open Decl
(** Discard definitions of built-in symbols *)
let add_ld q = function
| ls, Some _ when Sid.mem ls.ls_name q -> (ls, None)
| ls, Some _ when Sls.mem ls q -> (ls, None)
| d -> d
let add_id q (ld,id) = function
| ls, _ when Sid.mem ls.ls_name q -> (ls, None)::ld, id
| ls, _ when Sls.mem ls q -> (ls, None)::ld, id
| d -> ld, d::id
let elim q d = match d.d_node with
......@@ -40,13 +40,9 @@ let elim q d = match d.d_node with
create_logic_decls (List.rev ld) @ create_ind_decls (List.rev id)
| _ -> [d]
let eliminate_builtin =
Trans.on_metas
[ Printer.meta_remove_type;
Printer.meta_remove_logic;
Printer.meta_remove_prop ]
(fun mm ->
Trans.decl (elim (Mstr.fold Task.find_tagged mm Sid.empty)) None)
let eliminate_builtin = Trans.on_meta Printer.meta_remove_logic (fun tds ->
let rem_ls = Task.find_tag