Commit 2d3b47ba authored by Andrei Paskevich's avatar Andrei Paskevich

"Please, don't shoot, I can explain everything" commit

- unify Lfunction and Lpredicate (mucho bettar)
- separation of prop and fmla
- making prop and tvsymbol private aliases of ident
parent a20e5f3a
...@@ -25,7 +25,7 @@ open Ty ...@@ -25,7 +25,7 @@ open Ty
open Term open Term
open Theory open Theory
let iprinter,tprinter,lprinter,cprinter,pprinter = let iprinter,tprinter,lprinter,pprinter =
let bl = ["theory"; "type"; "logic"; "inductive"; let bl = ["theory"; "type"; "logic"; "inductive";
"axiom"; "lemma"; "goal"; "use"; "clone"; "axiom"; "lemma"; "goal"; "use"; "clone";
"namespace"; "import"; "export"; "end"; "namespace"; "import"; "export"; "end";
...@@ -39,7 +39,6 @@ let iprinter,tprinter,lprinter,cprinter,pprinter = ...@@ -39,7 +39,6 @@ let iprinter,tprinter,lprinter,cprinter,pprinter =
create_ident_printer bl ~sanitizer:isanitize, create_ident_printer bl ~sanitizer:isanitize,
create_ident_printer bl ~sanitizer:lsanitize, create_ident_printer bl ~sanitizer:lsanitize,
create_ident_printer bl ~sanitizer:lsanitize, create_ident_printer bl ~sanitizer:lsanitize,
create_ident_printer bl ~sanitizer:usanitize,
create_ident_printer bl ~sanitizer:usanitize create_ident_printer bl ~sanitizer:usanitize
let thash = Hid.create 63 let thash = Hid.create 63
...@@ -50,7 +49,6 @@ let forget_all () = ...@@ -50,7 +49,6 @@ let forget_all () =
forget_all iprinter; forget_all iprinter;
forget_all tprinter; forget_all tprinter;
forget_all lprinter; forget_all lprinter;
forget_all cprinter;
forget_all pprinter; forget_all pprinter;
Hid.clear thash; Hid.clear thash;
Hid.clear lhash; Hid.clear lhash;
...@@ -60,9 +58,9 @@ let tv_set = ref Sid.empty ...@@ -60,9 +58,9 @@ let tv_set = ref Sid.empty
(* type variables always start with a quote *) (* type variables always start with a quote *)
let print_tv fmt tv = let print_tv fmt tv =
tv_set := Sid.add tv !tv_set; tv_set := Sid.add (tv_name tv) !tv_set;
let sanitize n = "'" ^ n in let sanitize n = "'" ^ n in
let n = id_unique iprinter ~sanitizer:sanitize tv in let n = id_unique iprinter ~sanitizer:sanitize (tv_name tv) in
fprintf fmt "%s" n fprintf fmt "%s" n
let forget_tvs () = let forget_tvs () =
...@@ -89,12 +87,15 @@ let print_ts fmt ts = ...@@ -89,12 +87,15 @@ let print_ts fmt ts =
let print_ls fmt ls = let print_ls fmt ls =
Hid.replace lhash ls.ls_name ls; Hid.replace lhash ls.ls_name ls;
if ls.ls_constr then fprintf fmt "%s" (id_unique cprinter ls.ls_name) let n = if ls.ls_constr
else fprintf fmt "%s" (id_unique lprinter ls.ls_name) then id_unique lprinter ~sanitizer:String.capitalize ls.ls_name
else id_unique lprinter ls.ls_name
in
fprintf fmt "%s" n
let print_pr fmt pr = let print_pr fmt pr =
Hid.replace phash pr.pr_name pr; Hid.replace phash (pr_name pr) pr;
fprintf fmt "%s" (id_unique pprinter pr.pr_name) fprintf fmt "%s" (id_unique pprinter (pr_name pr))
(** Types *) (** Types *)
...@@ -248,8 +249,8 @@ and print_tl fmt tl = ...@@ -248,8 +249,8 @@ and print_tl fmt tl =
(print_list alt (print_list comma print_tr)) tl (print_list alt (print_list comma print_tr)) tl
and print_tr fmt = function and print_tr fmt = function
| TrTerm t -> print_term fmt t | Term t -> print_term fmt t
| TrFmla f -> print_fmla fmt f | Fmla f -> print_fmla fmt f
(** Declarations *) (** Declarations *)
...@@ -278,37 +279,30 @@ let print_type_decl fmt (ts,def) = match def with ...@@ -278,37 +279,30 @@ let print_type_decl fmt (ts,def) = match def with
let print_type_decl fmt d = print_type_decl fmt d; forget_tvs () let print_type_decl fmt d = print_type_decl fmt d; forget_tvs ()
let print_logic_decl fmt = function let print_ld fmt ld =
| Lfunction (fs,None) -> let _,vl,e = open_ls_defn ld in
fprintf fmt "@[<hov 2>logic %a%a :@ %a@]" begin match e with
print_ls fs (print_paren_l print_ty) fs.ls_args | Term t -> print_term fmt t
print_ty (of_option fs.ls_value) | Fmla f -> print_fmla fmt f
| Lpredicate (ps,None) -> end;
fprintf fmt "@[<hov 2>logic %a%a@]" List.iter forget_var vl
print_ls ps (print_paren_l print_ty) ps.ls_args
| Lfunction (fs,Some fd) -> let print_ls_defn fmt = option_iter (fprintf fmt " =@ %a" print_ld)
let _,vl,t = open_fs_defn fd in let print_ls_type fmt = option_iter (fprintf fmt " :@ %a" print_ty)
fprintf fmt "@[<hov 2>logic %a%a :@ %a =@ %a@]"
print_ls fs (print_paren_l print_vsty) vl let print_logic_decl fmt (ls,ld) =
print_ty t.t_ty print_term t; fprintf fmt "@[<hov 2>logic %a%a%a%a@]"
List.iter forget_var vl print_ls ls (print_paren_l print_ty) ls.ls_args
| Lpredicate (ps,Some fd) -> print_ls_type ls.ls_value print_ls_defn ld;
let _,vl,f = open_ps_defn fd in forget_tvs ()
fprintf fmt "@[<hov 2>logic %a%a =@ %a@]"
print_ls ps (print_paren_l print_vsty) vl print_fmla f;
List.iter forget_var vl
let print_logic_decl fmt d = print_logic_decl fmt d; forget_tvs ()
let print_prop fmt pr =
fprintf fmt "%a : %a" print_pr pr print_fmla pr.pr_fmla
let print_ind fmt pr = fprintf fmt "@[<hov 4>| %a@]" print_prop pr let print_ind fmt (pr,f) =
fprintf fmt "@[<hov 4>| %a : %a@]" print_pr pr print_fmla f
let print_ind_decl fmt (ps,bl) = let print_ind_decl fmt (ps,bl) =
fprintf fmt "@[<hov 2>inductive %a%a =@ @[<hov>%a@]@]" fprintf fmt "@[<hov 2>inductive %a%a =@ @[<hov>%a@]@]"
print_ls ps (print_paren_l print_ty) ps.ls_args print_ls ps (print_paren_l print_ty) ps.ls_args
(print_list newline print_ind) bl; (print_list newline print_ind) bl;
forget_tvs () forget_tvs ()
let print_pkind fmt = function let print_pkind fmt = function
...@@ -316,6 +310,11 @@ let print_pkind fmt = function ...@@ -316,6 +310,11 @@ let print_pkind fmt = function
| Plemma -> fprintf fmt "lemma" | Plemma -> fprintf fmt "lemma"
| Pgoal -> fprintf fmt "goal" | Pgoal -> fprintf fmt "goal"
let print_prop_decl fmt (k,pr,f) =
fprintf fmt "@[<hov 2>%a %a : %a@]" print_pkind k
print_pr pr print_fmla f;
forget_tvs ()
let print_inst fmt (id1,id2) = let print_inst fmt (id1,id2) =
if Hid.mem thash id2 then if Hid.mem thash id2 then
let n = id_unique tprinter id1 in let n = id_unique tprinter id1 in
...@@ -332,9 +331,7 @@ let print_decl fmt d = match d.d_node with ...@@ -332,9 +331,7 @@ let print_decl fmt d = match d.d_node with
| Dtype tl -> print_list newline print_type_decl fmt tl | Dtype tl -> print_list newline print_type_decl fmt tl
| Dlogic ll -> print_list newline print_logic_decl fmt ll | Dlogic ll -> print_list newline print_logic_decl fmt ll
| Dind il -> print_list newline print_ind_decl fmt il | Dind il -> print_list newline print_ind_decl fmt il
| Dprop (k,pr) -> | Dprop p -> print_prop_decl fmt p
fprintf fmt "@[<hov 2>%a %a@]" print_pkind k print_prop pr;
forget_tvs ()
| Duse th -> | Duse th ->
fprintf fmt "@[<hov 2>(* use %a *)@]" print_th th fprintf fmt "@[<hov 2>(* use %a *)@]" print_th th
| Dclone (th,inst) -> | Dclone (th,inst) ->
......
...@@ -42,12 +42,12 @@ val print_pat : formatter -> pattern -> unit (* pattern *) ...@@ -42,12 +42,12 @@ val print_pat : formatter -> pattern -> unit (* pattern *)
val print_term : formatter -> term -> unit (* term *) val print_term : formatter -> term -> unit (* term *)
val print_fmla : formatter -> fmla -> unit (* formula *) val print_fmla : formatter -> fmla -> unit (* formula *)
val print_pkind : formatter -> prop_kind -> unit
val print_type_decl : formatter -> ty_decl -> unit val print_type_decl : formatter -> ty_decl -> unit
val print_logic_decl : formatter -> logic_decl -> unit val print_logic_decl : formatter -> logic_decl -> unit
val print_ind_decl : formatter -> ind_decl -> unit val print_ind_decl : formatter -> ind_decl -> unit
val print_prop_decl : formatter -> prop_decl -> unit
val print_pkind : formatter -> prop_kind -> unit
val print_prop : formatter -> prop -> unit
val print_decl : formatter -> decl -> unit val print_decl : formatter -> decl -> unit
val print_decls : formatter -> decl list -> unit val print_decls : formatter -> decl list -> unit
......
...@@ -164,7 +164,7 @@ exception PredicateSymbolExpected of lsymbol ...@@ -164,7 +164,7 @@ exception PredicateSymbolExpected of lsymbol
let pat_app fs pl ty = let pat_app fs pl ty =
if not fs.ls_constr then raise (ConstructorExpected fs); if not fs.ls_constr then raise (ConstructorExpected fs);
let s = match fs.ls_value with let s = match fs.ls_value with
| Some vty -> Ty.matching Mid.empty vty ty | Some vty -> Ty.matching Mtv.empty vty ty
| None -> raise (FunctionSymbolExpected fs) | None -> raise (FunctionSymbolExpected fs)
in in
let mtch s ty p = Ty.matching s ty p.pat_ty in let mtch s ty p = Ty.matching s ty p.pat_ty in
...@@ -260,20 +260,20 @@ and term_branch = pattern * int * term ...@@ -260,20 +260,20 @@ and term_branch = pattern * int * term
and fmla_branch = pattern * int * fmla and fmla_branch = pattern * int * fmla
and trigger_elt = and expr =
| TrTerm of term | Term of term
| TrFmla of fmla | Fmla of fmla
and trigger = trigger_elt list and trigger = expr list
(* trigger traversal *) (* trigger traversal *)
let tr_map fnT fnF = let tr_map fnT fnF =
let fn = function TrTerm t -> TrTerm (fnT t) | TrFmla f -> TrFmla (fnF f) in let fn = function Term t -> Term (fnT t) | Fmla f -> Fmla (fnF f) in
List.map (List.map fn) List.map (List.map fn)
let tr_fold fnT fnF = let tr_fold fnT fnF =
let fn acc = function TrTerm t -> fnT acc t | TrFmla f -> fnF acc f in let fn acc = function Term t -> fnT acc t | Fmla f -> fnF acc f in
List.fold_left (List.fold_left fn) List.fold_left (List.fold_left fn)
module T = struct module T = struct
...@@ -344,8 +344,8 @@ module F = struct ...@@ -344,8 +344,8 @@ module F = struct
let f_eq_bound (v1, f1) (v2, f2) = v1 == v2 && f1 == f2 let f_eq_bound (v1, f1) (v2, f2) = v1 == v2 && f1 == f2
let tr_eq tr1 tr2 = match tr1,tr2 with let tr_eq tr1 tr2 = match tr1,tr2 with
| TrTerm t1, TrTerm t2 -> t1 == t2 | Term t1, Term t2 -> t1 == t2
| TrFmla f1, TrFmla f2 -> f1 == f2 | Fmla f1, Fmla f2 -> f1 == f2
| _ -> false | _ -> false
let f_eq_quant (vl1, n1, tl1, f1) (vl2, n2, tl2, f2) = let f_eq_quant (vl1, n1, tl1, f1) (vl2, n2, tl2, f2) =
...@@ -391,7 +391,7 @@ module F = struct ...@@ -391,7 +391,7 @@ module F = struct
let f_hash_bound (v, f) = Hashcons.combine v.vs_name.id_tag f.f_tag let f_hash_bound (v, f) = Hashcons.combine v.vs_name.id_tag f.f_tag
let tr_hash = function TrTerm t -> t.t_tag | TrFmla f -> f.f_tag let tr_hash = function Term t -> t.t_tag | Fmla f -> f.f_tag
let f_hash_quant (vl, _, tl, f) = let f_hash_quant (vl, _, tl, f) =
let h = Hashcons.combine_list v_hash f.f_tag vl in let h = Hashcons.combine_list v_hash f.f_tag vl in
...@@ -560,7 +560,7 @@ let f_any_unsafe prT prF lvl f = ...@@ -560,7 +560,7 @@ let f_any_unsafe prT prF lvl f =
let t_app fs tl ty = let t_app fs tl ty =
let s = match fs.ls_value with let s = match fs.ls_value with
| Some vty -> Ty.matching Mid.empty vty ty | Some vty -> Ty.matching Mtv.empty vty ty
| _ -> raise (FunctionSymbolExpected fs) | _ -> raise (FunctionSymbolExpected fs)
in in
let mtch s ty t = Ty.matching s ty t.t_ty in let mtch s ty t = Ty.matching s ty t.t_ty in
...@@ -570,7 +570,7 @@ let t_app fs tl ty = ...@@ -570,7 +570,7 @@ let t_app fs tl ty =
let f_app ps tl = let f_app ps tl =
let s = match ps.ls_value with let s = match ps.ls_value with
| None -> Mid.empty | None -> Mtv.empty
| _ -> raise (PredicateSymbolExpected ps) | _ -> raise (PredicateSymbolExpected ps)
in in
let mtch s ty t = Ty.matching s ty t.t_ty in let mtch s ty t = Ty.matching s ty t.t_ty in
......
...@@ -152,11 +152,11 @@ and term_branch ...@@ -152,11 +152,11 @@ and term_branch
and fmla_branch and fmla_branch
and trigger_elt = and expr =
| TrTerm of term | Term of term
| TrFmla of fmla | Fmla of fmla
and trigger = trigger_elt list and trigger = expr list
module Mterm : Map.S with type key = term module Mterm : Map.S with type key = term
module Sterm : Set.S with type elt = term module Sterm : Set.S with type elt = term
......
This diff is collapsed.
...@@ -23,18 +23,14 @@ open Term ...@@ -23,18 +23,14 @@ open Term
(** Named propositions *) (** Named propositions *)
type prop = private { type prop
pr_name : ident;
pr_fmla : fmla;
}
module Spr : Set.S with type elt = prop module Spr : Set.S with type elt = prop
module Mpr : Map.S with type key = prop module Mpr : Map.S with type key = prop
module Hpr : Hashtbl.S with type key = prop module Hpr : Hashtbl.S with type key = prop
val create_prop : preid -> fmla -> prop val create_prop : preid -> prop
val pr_name : prop -> ident
val shortcut_for_discussion_dont_be_mad_andrei_please : ident -> fmla -> prop
(** Declarations *) (** Declarations *)
...@@ -48,25 +44,23 @@ type ty_decl = tysymbol * ty_def ...@@ -48,25 +44,23 @@ type ty_decl = tysymbol * ty_def
(* logic declaration *) (* logic declaration *)
type fs_defn type ls_defn
type ps_defn
type logic_decl = type logic_decl = lsymbol * ls_defn option
| Lfunction of lsymbol * fs_defn option
| Lpredicate of lsymbol * ps_defn option
val make_fs_defn : lsymbol -> vsymbol list -> term -> fs_defn val make_ls_defn : lsymbol -> vsymbol list -> expr -> ls_defn
val make_ps_defn : lsymbol -> vsymbol list -> fmla -> ps_defn val make_fs_defn : lsymbol -> vsymbol list -> term -> ls_defn
val make_ps_defn : lsymbol -> vsymbol list -> fmla -> ls_defn
val open_fs_defn : fs_defn -> lsymbol * vsymbol list * term val open_ls_defn : ls_defn -> lsymbol * vsymbol list * expr
val open_ps_defn : ps_defn -> lsymbol * vsymbol list * fmla val open_fs_defn : ls_defn -> lsymbol * vsymbol list * term
val open_ps_defn : ls_defn -> lsymbol * vsymbol list * fmla
val fs_defn_axiom : fs_defn -> fmla val ls_defn_axiom : ls_defn -> fmla
val ps_defn_axiom : ps_defn -> fmla
(* inductive predicate declaration *) (* inductive predicate declaration *)
type ind_decl = lsymbol * prop list type ind_decl = lsymbol * (prop * fmla) list
(* proposition declaration *) (* proposition declaration *)
...@@ -75,7 +69,7 @@ type prop_kind = ...@@ -75,7 +69,7 @@ type prop_kind =
| Plemma | Plemma
| Pgoal | Pgoal
type prop_decl = prop_kind * prop type prop_decl = prop_kind * prop * fmla
(** Context and Theory *) (** Context and Theory *)
...@@ -125,9 +119,7 @@ and decl_node = ...@@ -125,9 +119,7 @@ and decl_node =
val create_ty_decl : ty_decl list -> decl val create_ty_decl : ty_decl list -> decl
val create_logic_decl : logic_decl list -> decl val create_logic_decl : logic_decl list -> decl
val create_ind_decl : ind_decl list -> decl val create_ind_decl : ind_decl list -> decl
val create_prop_decl : prop_kind -> prop -> decl val create_prop_decl : prop_kind -> prop -> fmla -> decl
val prop_decl_of_fmla : prop_kind -> preid -> fmla -> decl
(* separate independent groups of declarations *) (* separate independent groups of declarations *)
...@@ -139,11 +131,11 @@ val create_ind_decls : ind_decl list -> decl list ...@@ -139,11 +131,11 @@ val create_ind_decls : ind_decl list -> decl list
exception ConstructorExpected of lsymbol exception ConstructorExpected of lsymbol
exception IllegalTypeAlias of tysymbol exception IllegalTypeAlias of tysymbol
exception UnboundTypeVar of ident exception UnboundTypeVar of tvsymbol
exception InvalidIndDecl of ident * ident exception InvalidIndDecl of lsymbol * prop
exception TooSpecificIndDecl of ident * ident * term exception TooSpecificIndDecl of lsymbol * prop * term
exception NonPositiveIndDecl of ident * ident * lsymbol exception NonPositiveIndDecl of lsymbol * prop * lsymbol
exception IllegalConstructor of lsymbol exception IllegalConstructor of lsymbol
exception BadLogicDecl of ident exception BadLogicDecl of ident
......
...@@ -24,6 +24,13 @@ open Ident ...@@ -24,6 +24,13 @@ open Ident
type tvsymbol = ident type tvsymbol = ident
module Stv = Sid
module Mtv = Mid
module Htv = Hid
let create_tvsymbol = id_register
let tv_name v = v
(* type symbols and types *) (* type symbols and types *)
type tysymbol = { type tysymbol = {
...@@ -58,7 +65,6 @@ let mk_ts name args def = { ...@@ -58,7 +65,6 @@ let mk_ts name args def = {
ts_def = def; ts_def = def;
} }
let create_tvsymbol = id_register
let create_tysymbol name args def = mk_ts (id_register name) args def let create_tysymbol name args def = mk_ts (id_register name) args def
module Ty = struct module Ty = struct
...@@ -107,15 +113,15 @@ exception NonLinear ...@@ -107,15 +113,15 @@ exception NonLinear
exception UnboundTypeVariable exception UnboundTypeVariable
let rec tv_known vs ty = match ty.ty_node with let rec tv_known vs ty = match ty.ty_node with
| Tyvar n -> Sid.mem n vs | Tyvar n -> Stv.mem n vs
| _ -> ty_all (tv_known vs) ty | _ -> ty_all (tv_known vs) ty
let create_tysymbol name args def = let create_tysymbol name args def =
let add s v = let add s v =
if Sid.mem v s then raise NonLinear; if Stv.mem v s then raise NonLinear;
Sid.add v s Stv.add v s
in in
let s = List.fold_left add Sid.empty args in let s = List.fold_left add Stv.empty args in
let _ = match def with let _ = match def with
| Some ty -> tv_known s ty || raise UnboundTypeVariable | Some ty -> tv_known s ty || raise UnboundTypeVariable
| _ -> true | _ -> true
...@@ -125,15 +131,15 @@ let create_tysymbol name args def = ...@@ -125,15 +131,15 @@ let create_tysymbol name args def =
exception BadTypeArity exception BadTypeArity
let rec tv_inst m ty = match ty.ty_node with let rec tv_inst m ty = match ty.ty_node with
| Tyvar n -> Mid.find n m | Tyvar n -> Mtv.find n m
| _ -> ty_map (tv_inst m) ty | _ -> ty_map (tv_inst m) ty
let ty_app s tl = let ty_app s tl =
if List.length tl != List.length s.ts_args then raise BadTypeArity; if List.length tl != List.length s.ts_args then raise BadTypeArity;
match s.ts_def with match s.ts_def with
| Some ty -> | Some ty ->
let add m v t = Mid.add v t m in let add m v t = Mtv.add v t m in
tv_inst (List.fold_left2 add Mid.empty s.ts_args tl) ty tv_inst (List.fold_left2 add Mtv.empty s.ts_args tl) ty
| _ -> | _ ->
ty_app s tl ty_app s tl
...@@ -161,8 +167,8 @@ let rec matching s ty1 ty2 = ...@@ -161,8 +167,8 @@ let rec matching s ty1 ty2 =
if ty1 == ty2 then s if ty1 == ty2 then s
else match ty1.ty_node, ty2.ty_node with else match ty1.ty_node, ty2.ty_node with
| Tyvar n1, _ -> | Tyvar n1, _ ->
(try if Mid.find n1 s == ty2 then s else raise TypeMismatch (try if Mtv.find n1 s == ty2 then s else raise TypeMismatch
with Not_found -> Mid.add n1 ty2 s) with Not_found -> Mtv.add n1 ty2 s)
| Tyapp (f1, l1), Tyapp (f2, l2) when f1 == f2 -> | Tyapp (f1, l1), Tyapp (f2, l2) when f1 == f2 ->
List.fold_left2 matching s l1 l2 List.fold_left2 matching s l1 l2
| _ -> | _ ->
......
...@@ -21,7 +21,14 @@ open Ident ...@@ -21,7 +21,14 @@ open Ident
(** Types *) (** Types *)
type tvsymbol = ident type tvsymbol
module Stv : Set.S with type elt = tvsymbol
module Mtv : Map.S with type key = tvsymbol
module Htv : Hashtbl.S with type key = tvsymbol
val create_tvsymbol : preid -> tvsymbol
val tv_name : tvsymbol -> ident
(* type symbols and types *) (* type symbols and types *)
...@@ -40,17 +47,15 @@ and ty_node = private ...@@ -40,17 +47,15 @@ and ty_node = private
| Tyvar of tvsymbol | Tyvar of tvsymbol
| Tyapp of tysymbol * ty list | Tyapp of tysymbol * ty list
exception NonLinear
exception UnboundTypeVariable
val create_tvsymbol : preid -> tvsymbol
val create_tysymbol : preid -> tvsymbol list -> ty option -> tysymbol
module Sts : Set.S with type elt = tysymbol module Sts : Set.S with type elt = tysymbol
module Mts : Map.S with type key = tysymbol module Mts : Map.S with type key = tysymbol
module Hts : Hashtbl.S with type key = tysymbol module Hts : Hashtbl.S with type key = tysymbol
exception BadTypeArity exception BadTypeArity
exception NonLinear
exception UnboundTypeVariable
val create_tysymbol : preid -> tvsymbol list -> ty option -> tysymbol
val ty_var : tvsymbol -> ty val ty_var : tvsymbol -> ty
val ty_app : tysymbol -> ty list -> ty val ty_app : tysymbol -> ty list -> ty
...@@ -67,8 +72,8 @@ val ty_s_any : (tysymbol -> bool) -> ty -> bool ...@@ -67,8 +72,8 @@ val ty_s_any : (tysymbol -> bool) -> ty -> bool
exception TypeMismatch exception TypeMismatch
val matching : ty Mid.t -> ty -> ty -> ty Mid.t val matching : ty Mtv.t -> ty -> ty -> ty Mtv.t
val ty_match : ty -> ty -> ty Mid.t -> ty Mid.t option val ty_match : ty -> ty -> ty Mtv.t -> ty Mtv.t option
(* built-in symbols *) (* built-in symbols *)
......
...@@ -188,8 +188,7 @@ let do_file env drv filename_printer file = ...@@ -188,8 +188,7 @@ let do_file env drv filename_printer file =
let goals = extract_goals env drv [] th in let goals = extract_goals env drv [] th in
List.filter (fun (_,ctxt) -> List.filter (fun (_,ctxt) ->
match ctxt.ctxt_decl.d_node with match ctxt.ctxt_decl.d_node with
| Dprop (_,{pr_name = pr_name}) -> | Dprop (_,pr',_) -> pr == pr'
Ident.id_derived_from pr_name pr.pr_name
| _ -> assert false) goals in | _ -> assert false) goals in
(* Apply transformations *) (* Apply transformations *)
let goals = List.map let goals = List.map
...@@ -202,7 +201,7 @@ let do_file env drv filename_printer file = ...@@ -202,7 +201,7 @@ let do_file env drv filename_printer file =
let res = Driver.call_prover ~debug:!debug ?timeout drv ctxt in let res = Driver.call_prover ~debug:!debug ?timeout drv ctxt in
printf "%s %s %s : %a@." printf "%s %s %s : %a@."
file th.th_name.Ident.id_short file th.th_name.Ident.id_short
(goal_of_ctxt ctxt).pr_name.Ident.id_long (pr_name (goal_of_ctxt ctxt)).Ident.id_long
Call_provers.print_prover_result res in Call_provers.print_prover_result res in
List.iter call goals List.iter call goals
| Some dir (* we are in the output mode *) -> | Some dir (* we are in the output mode *) ->
......
...@@ -36,7 +36,7 @@ let forget_var v = forget_id ident_printer v.vs_name ...@@ -36,7 +36,7 @@ let forget_var v = forget_id ident_printer v.vs_name
let rec print_type drv fmt ty = match ty.ty_node with let rec print_type drv fmt ty = match ty.ty_node with
| Tyvar id -> | Tyvar id ->
fprintf fmt "'%a" print_ident id fprintf fmt "'%a" print_ident (tv_name id)
| Tyapp (ts, tl) -> | Tyapp (ts, tl) ->
match Driver.query_ident drv ts.ts_name with match Driver.query_ident drv ts.ts_name with
| Driver.Remove -> assert false (* Mettre une erreur *) | Driver.Remove -> assert false (* Mettre une erreur *)
...@@ -129,8 +129,8 @@ let rec print_fmla drv fmt f = match f.f_node with ...@@ -129,8 +129,8 @@ let rec print_fmla drv fmt f = match f.f_node with
assert false assert false
and print_trigger drv fmt = function and print_trigger drv fmt = function
| TrTerm t -> (print_term drv) fmt t | Term t -> (print_term drv) fmt t
| TrFmla f -> (print_fmla drv) fmt f | Fmla f -> (print_fmla drv) fmt f
and print_triggers drv fmt tl = print_list comma (print_trigger drv) fmt tl and print_triggers drv fmt tl = print_list comma (print_trigger drv) fmt tl
...@@ -150,63 +150,68 @@ let print_type_decl drv fmt = function ...@@ -150,63 +150,68 @@ let print_type_decl drv fmt = function
let ac_th = ["algebra";"AC"] let ac_th = ["algebra";"AC"]
let print_logic_decl drv ctxt fmt = function
| Lfunction (ls, def) -> let print_ld drv fmt ld =
begin let _,vl,e = open_ls_defn ld in
match Driver.query_ident drv ls.ls_name with begin match e with
| Driver.Remove | Driver.Syntax _ -> false | Term t -> print_term drv fmt t
| Driver.Tag s -> | Fmla f -> print_fmla drv fmt f
end;
List.iter forget_var vl
let print_ls_defn drv fmt =