Commit b3e92d1d authored by Andrei Paskevich's avatar Andrei Paskevich

stock "definition axiom" in logic_decl

also, rewrite application of "<>" into "not ( = )"
parent b408a39e
...@@ -1237,3 +1237,20 @@ let f_s_exists prT prF prP f = ...@@ -1237,3 +1237,20 @@ let f_s_exists prT prF prP f =
try f_s_fold (exists_fn prT) (exists_fn prF) (exists_fn prP) false f try f_s_fold (exists_fn prT) (exists_fn prF) (exists_fn prP) false f
with FoldSkip -> true with FoldSkip -> true
(* built-in symbols *)
let ps_equ =
let v = ty_var (create_tvsymbol (id_fresh "a")) in
create_psymbol (id_fresh "=") [v; v]
let ps_neq =
let v = ty_var (create_tvsymbol (id_fresh "a")) in
create_psymbol (id_fresh "<>") [v; v]
(* FIXME: is it right to do so? *)
let f_app p tl =
if p == ps_neq then f_not (f_app ps_equ tl) else f_app p tl
let f_equ t1 t2 = f_app ps_equ [t1; t2]
let f_neq t1 t2 = f_app ps_neq [t1; t2]
...@@ -121,7 +121,7 @@ type binop = ...@@ -121,7 +121,7 @@ type binop =
| Fimplies | Fimplies
| Fiff | Fiff
type real_constant = type real_constant =
| RConstDecimal of string * string * string option (* int / frac / exp *) | RConstDecimal of string * string * string option (* int / frac / exp *)
| RConstHexa of string * string * string | RConstHexa of string * string * string
...@@ -349,3 +349,11 @@ val f_subst_fmla_alpha : fmla -> fmla -> fmla -> fmla ...@@ -349,3 +349,11 @@ val f_subst_fmla_alpha : fmla -> fmla -> fmla -> fmla
val t_match : term -> term -> term Mvs.t -> term Mvs.t option val t_match : term -> term -> term Mvs.t -> term Mvs.t option
val f_match : fmla -> fmla -> term Mvs.t -> term Mvs.t option val f_match : fmla -> fmla -> term Mvs.t -> term Mvs.t option
(* built-in symbols *)
val ps_equ : psymbol
val ps_neq : psymbol
val f_equ : term -> term -> fmla
val f_neq : term -> term -> fmla
...@@ -36,8 +36,8 @@ type ty_decl = tysymbol * ty_def ...@@ -36,8 +36,8 @@ type ty_decl = tysymbol * ty_def
(* logic declaration *) (* logic declaration *)
type logic_decl = type logic_decl =
| Lfunction of fsymbol * (vsymbol list * term) option (* FIXME: binders *) | Lfunction of fsymbol * fmla option
| Lpredicate of psymbol * (vsymbol list * fmla) option (* FIXME: binders *) | Lpredicate of psymbol * fmla option
| Linductive of psymbol * (ident * fmla) list | Linductive of psymbol * (ident * fmla) list
(* proposition declaration *) (* proposition declaration *)
...@@ -73,16 +73,16 @@ module D = struct ...@@ -73,16 +73,16 @@ module D = struct
| Talgebraic l1, Talgebraic l2 -> for_all2 (==) l1 l2 | Talgebraic l1, Talgebraic l2 -> for_all2 (==) l1 l2
| _ -> false | _ -> false
let eq_fd fs1 fs2 fd1 fd2 = fs1 == fs2 && match fd1,fd2 with let eq_fd fs1 fd1 fs2 fd2 = fs1 == fs2 && match fd1,fd2 with
| Some fd1, Some fd2 -> fd1 == fd2
| None, None -> true | None, None -> true
| Some (l1,t1), Some (l2,t2) -> t1 == t2 && for_all2 (==) l1 l2
| _ -> false | _ -> false
let eq_ld ld1 ld2 = match ld1,ld2 with let eq_ld ld1 ld2 = match ld1,ld2 with
| Lfunction (fs1,fd1), Lfunction (fs2,fd2) -> eq_fd fs1 fs2 fd1 fd2 | Lfunction (fs1,fd1), Lfunction (fs2,fd2) -> eq_fd fs1 fd1 fs2 fd2
| Lpredicate (ps1,pd1), Lpredicate (ps2,pd2) -> eq_fd ps1 ps2 pd1 pd2 | Lpredicate (ps1,pd1), Lpredicate (ps2,pd2) -> eq_fd ps1 pd1 ps2 pd2
| Linductive (ps1,l1), Linductive (ps2,l2) -> ps1 == ps2 && | Linductive (ps1,al1), Linductive (ps2,al2) -> ps1 == ps2 &&
for_all2 (fun (i1,f1) (i2,f2) -> i1 == i2 && f1 == f2) l1 l2 for_all2 (fun (i1,f1) (i2,f2) -> i1 == i2 && f1 == f2) al1 al2
| _ -> false | _ -> false
let equal d1 d2 = match d1.d_node, d2.d_node with let equal d1 d2 = match d1.d_node, d2.d_node with
...@@ -97,15 +97,11 @@ module D = struct ...@@ -97,15 +97,11 @@ module D = struct
let tag fs = fs.fs_name.id_tag in let tag fs = fs.fs_name.id_tag in
1 + Hashcons.combine_list tag ts.ts_name.id_tag l 1 + Hashcons.combine_list tag ts.ts_name.id_tag l
let hs_fd fd = Hashcons.combine_option (fun f -> f.f_tag) fd
let hs_ld ld = match ld with let hs_ld ld = match ld with
| Lfunction (fs,fd) -> | Lfunction (fs,fd) -> Hashcons.combine fs.fs_name.id_tag (hs_fd fd)
let tag vs = vs.vs_name.id_tag in | Lpredicate (ps,pd) -> Hashcons.combine ps.ps_name.id_tag (hs_fd pd)
let hsh (l,t) = Hashcons.combine_list tag t.t_tag l in
Hashcons.combine fs.fs_name.id_tag (Hashcons.combine_option hsh fd)
| Lpredicate (ps,pd) ->
let tag vs = vs.vs_name.id_tag in
let hsh (l,f) = Hashcons.combine_list tag f.f_tag l in
Hashcons.combine ps.ps_name.id_tag (Hashcons.combine_option hsh pd)
| Linductive (ps,l) -> | Linductive (ps,l) ->
let hs_pair (i,f) = Hashcons.combine i.id_tag f.f_tag in let hs_pair (i,f) = Hashcons.combine i.id_tag f.f_tag in
Hashcons.combine_list hs_pair ps.ps_name.id_tag l Hashcons.combine_list hs_pair ps.ps_name.id_tag l
...@@ -137,11 +133,19 @@ let create_prop k i f = Hdecl.hashcons (mk_decl (Dprop (k, id_register i, f))) ...@@ -137,11 +133,19 @@ let create_prop k i f = Hdecl.hashcons (mk_decl (Dprop (k, id_register i, f)))
(* error reporting *) (* error reporting *)
exception NotAConstructor of fsymbol exception NotAConstructor of fsymbol
exception MalformedDefinition of fmla
exception IllegalTypeAlias of tysymbol exception IllegalTypeAlias of tysymbol
exception DuplicateVariable of vsymbol
exception UnboundTypeVar of ident exception UnboundTypeVar of ident
exception UnboundVars of Svs.t exception UnboundVars of Svs.t
let make_fdef fs vl t =
let hd = t_app fs (List.map t_var vl) t.t_ty in
Lfunction (fs, Some (f_forall vl [] (f_equ hd t)))
let make_pdef ps vl f =
let hd = f_app ps (List.map t_var vl) in
Lpredicate (ps, Some (f_forall vl [] (f_iff hd f)))
let create_type tdl = let create_type tdl =
let check_constructor ty fs = let check_constructor ty fs =
if not fs.fs_constr then raise (NotAConstructor fs); if not fs.fs_constr then raise (NotAConstructor fs);
...@@ -169,34 +173,41 @@ let create_type tdl = ...@@ -169,34 +173,41 @@ let create_type tdl =
create_type tdl create_type tdl
let create_logic ldl = let create_logic ldl =
let add s v = let check_fv f =
if Svs.mem v s then raise (DuplicateVariable v); let fvs = f_freevars Svs.empty f in
Svs.add v s if not (Svs.is_empty fvs) then raise (UnboundVars fvs);
in in
let check_vs vs vl = let check_def fd =
let vs2 = List.fold_left add Svs.empty vl in check_fv fd;
if not (Svs.subset vs vs2) then raise (UnboundVars vs) match fd.f_node with
| Fquant (Fforall, fq) -> f_open_quant fq
| _ -> raise (MalformedDefinition fd)
in in
let check_ax (_,f) = let check_ax (_,f) =
let fvs = f_freevars Svs.empty f in check_fv f;
if not (Svs.is_empty fvs) then raise (UnboundVars fvs);
assert false (* TODO *) assert false (* TODO *)
in in
let lmatch sbs ty v = Ty.matching sbs ty v.vs_ty in
let rmatch sbs v ty = Ty.matching sbs v.vs_ty ty in
let check_decl = function let check_decl = function
| Lfunction (fs, Some (vl, t)) -> | Lfunction (fs, Some fd) ->
let lty,rty = fs.fs_scheme in let (vl,_,f) = check_def fd in
let lsubst = Ty.matching Mid.empty rty t.t_ty in let hd = match f.f_node with
let rsubst = Ty.matching Mid.empty t.t_ty rty in | Fapp (ps, [hd; _]) when ps == ps_equ -> hd
ignore (List.fold_left2 lmatch lsubst lty vl); | _ -> raise (MalformedDefinition fd)
ignore (List.fold_left2 rmatch rsubst vl lty); in
check_vs (t_freevars Svs.empty t) vl let t = try t_app fs (List.map t_var vl) hd.t_ty with
| Lpredicate (ps, Some (vl, f)) -> | _ -> raise (MalformedDefinition fd)
let lty = ps.ps_scheme in in
ignore (List.fold_left2 lmatch Mid.empty lty vl); if t != hd then raise (MalformedDefinition fd)
ignore (List.fold_left2 rmatch Mid.empty vl lty); | Lpredicate (ps, Some pd) ->
check_vs (f_freevars Svs.empty f) vl let (vl,_,f) = check_def pd in
let hd = match f.f_node with
| Fbinop (Fiff, hd, _) -> hd
| _ -> raise (MalformedDefinition pd)
in
let f = try f_app ps (List.map t_var vl) with
| _ -> raise (MalformedDefinition pd)
in
if f != hd then raise (MalformedDefinition pd)
| Linductive (ps,la) -> | Linductive (ps,la) ->
List.iter check_ax la List.iter check_ax la
| _ -> () | _ -> ()
...@@ -324,37 +335,27 @@ let add_symbol add id v uc = ...@@ -324,37 +335,27 @@ let add_symbol add id v uc =
let get_namespace uc = List.hd uc.uc_import let get_namespace uc = List.hd uc.uc_import
(** Builtin symbols *) (** Built-in symbols *)
let t_int = create_tysymbol (id_fresh "int") [] None
let t_real = create_tysymbol (id_fresh "real") [] None
let eq = let builtin_ts = [ts_int; ts_real]
let v = ty_var (create_tvsymbol (id_fresh "a")) in let builtin_ps = [ps_equ; ps_neq]
create_psymbol (id_fresh "=") [v; v;]
let neq =
let v = ty_var (create_tvsymbol (id_fresh "a")) in
create_psymbol (id_fresh "<>") [v; v;]
let builtin_tysymbols = [t_int; t_real]
let builtin_psymbols = [eq; neq]
let ts_name x = x.ts_name let ts_name x = x.ts_name
let ps_name x = x.ps_name let ps_name x = x.ps_name
let builtin_ns = let builtin_ns =
let add adder name = List.fold_right (fun s -> adder (name s).id_short s) in let add adder name = List.fold_right (fun s -> adder (name s).id_short s) in
let ns = add add_ts ts_name builtin_tysymbols empty_ns in let ns = add add_ts ts_name builtin_ts empty_ns in
let ns = add add_ps ps_name builtin_psymbols ns in let ns = add add_ps ps_name builtin_ps ns in
ns ns
let builtin_th = id_register (id_fresh "Builtin") let builtin_th = id_register (id_fresh "Builtin")
let builtin_known = let builtin_known =
let add name = List.fold_right (fun s -> Mid.add (name s) builtin_th) in let add name = List.fold_right (fun s -> Mid.add (name s) builtin_th) in
let kn = Mid.add builtin_th builtin_th Mid.empty in let kn = Mid.add builtin_th builtin_th Mid.empty in
let kn = add ts_name builtin_tysymbols kn in let kn = add ts_name builtin_ts kn in
let kn = add ps_name builtin_psymbols kn in let kn = add ps_name builtin_ps kn in
kn kn
...@@ -455,13 +456,13 @@ let check_logic kn = function ...@@ -455,13 +456,13 @@ let check_logic kn = function
known_ty kn (snd fs.fs_scheme); known_ty kn (snd fs.fs_scheme);
List.iter (known_ty kn) (fst fs.fs_scheme); List.iter (known_ty kn) (fst fs.fs_scheme);
begin match df with begin match df with
| Some (_,t) -> known_term kn t | Some f -> known_fmla kn f
| None -> () | None -> ()
end end
| Lpredicate (ps, dp) -> | Lpredicate (ps, dp) ->
List.iter (known_ty kn) ps.ps_scheme; List.iter (known_ty kn) ps.ps_scheme;
begin match dp with begin match dp with
| Some (_,f) -> known_fmla kn f | Some f -> known_fmla kn f
| None -> () | None -> ()
end end
| Linductive (ps, la) -> | Linductive (ps, la) ->
......
...@@ -34,8 +34,8 @@ type ty_decl = tysymbol * ty_def ...@@ -34,8 +34,8 @@ type ty_decl = tysymbol * ty_def
(* logic declaration *) (* logic declaration *)
type logic_decl = type logic_decl =
| Lfunction of fsymbol * (vsymbol list * term) option (* FIXME: binders *) | Lfunction of fsymbol * fmla option
| Lpredicate of psymbol * (vsymbol list * fmla) option (* FIXME: binders *) | Lpredicate of psymbol * fmla option
| Linductive of psymbol * (ident * fmla) list | Linductive of psymbol * (ident * fmla) list
(* proposition declaration *) (* proposition declaration *)
...@@ -61,6 +61,9 @@ type decl = private { ...@@ -61,6 +61,9 @@ type decl = private {
(* smart constructors *) (* smart constructors *)
val make_fdef : fsymbol -> vsymbol list -> term -> logic_decl
val make_pdef : psymbol -> vsymbol list -> fmla -> logic_decl
val create_type : ty_decl list -> decl val create_type : ty_decl list -> decl
val create_logic : logic_decl list -> decl val create_logic : logic_decl list -> decl
val create_prop : prop_kind -> preid -> fmla -> decl val create_prop : prop_kind -> preid -> fmla -> decl
...@@ -68,8 +71,8 @@ val create_prop : prop_kind -> preid -> fmla -> decl ...@@ -68,8 +71,8 @@ val create_prop : prop_kind -> preid -> fmla -> decl
(* exceptions *) (* exceptions *)
exception NotAConstructor of fsymbol exception NotAConstructor of fsymbol
exception MalformedDefinition of fmla
exception IllegalTypeAlias of tysymbol exception IllegalTypeAlias of tysymbol
exception DuplicateVariable of vsymbol
exception UnboundTypeVar of ident exception UnboundTypeVar of ident
exception UnboundVars of Svs.t exception UnboundVars of Svs.t
...@@ -124,11 +127,6 @@ val clone_export : theory_uc -> theory -> th_inst -> theory_uc ...@@ -124,11 +127,6 @@ val clone_export : theory_uc -> theory -> th_inst -> theory_uc
val get_namespace : theory_uc -> namespace val get_namespace : theory_uc -> namespace
(* builtin *)
val t_int : tysymbol
val t_real : tysymbol
(* exceptions *) (* exceptions *)
exception CloseTheory exception CloseTheory
......
...@@ -172,3 +172,11 @@ let rec matching s ty1 ty2 = ...@@ -172,3 +172,11 @@ let rec matching s ty1 ty2 =
let ty_match ty1 ty2 s = let ty_match ty1 ty2 s =
try Some (matching s ty1 ty2) with TypeMismatch -> None try Some (matching s ty1 ty2) with TypeMismatch -> None
(* built-in symbols *)
let ts_int = create_tysymbol (id_fresh "int") [] None
let ts_real = create_tysymbol (id_fresh "real") [] None
let ty_int = ty_app ts_int []
let ty_real = ty_app ts_real []
...@@ -70,3 +70,11 @@ exception TypeMismatch ...@@ -70,3 +70,11 @@ exception TypeMismatch
val matching : ty Mid.t -> ty -> ty -> ty Mid.t val matching : ty Mid.t -> ty -> ty -> ty Mid.t
val ty_match : ty -> ty -> ty Mid.t -> ty Mid.t option val ty_match : ty -> ty -> ty Mid.t -> ty Mid.t option
(* built-in symbols *)
val ts_int : tysymbol
val ts_real : tysymbol
val ty_int : ty
val ty_real : ty
...@@ -371,9 +371,9 @@ and dterm_node loc env = function ...@@ -371,9 +371,9 @@ and dterm_node loc env = function
let tl = dtype_args s.fs_name loc env tyl tl in let tl = dtype_args s.fs_name loc env tyl tl in
Tapp (s, tl), ty Tapp (s, tl), ty
| PPconst (ConstInt _ as c) -> | PPconst (ConstInt _ as c) ->
Tconst c, Tyapp (Theory.t_int, []) Tconst c, Tyapp (Ty.ts_int, [])
| PPconst (ConstReal _ as c) -> | PPconst (ConstReal _ as c) ->
Tconst c, Tyapp (Theory.t_real, []) Tconst c, Tyapp (Ty.ts_real, [])
| PPmatch _ -> | PPmatch _ ->
assert false (* TODO *) assert false (* TODO *)
| PPlet _ -> | PPlet _ ->
...@@ -607,31 +607,30 @@ let add_logics loc dl th = ...@@ -607,31 +607,30 @@ let add_logics loc dl th =
in in
create_vsymbol id ty create_vsymbol id ty
in in
let mk_vlist = List.map2 create_var d.ld_params in
match d.ld_type with match d.ld_type with
| None -> (* predicate *) | None -> (* predicate *)
let ps = Hashtbl.find psymbols id in let ps = Hashtbl.find psymbols id in
let def = match d.ld_def with begin match d.ld_def with
| None -> | None ->
None Lpredicate (ps, None)
| Some f -> | Some f ->
let f = dfmla denv f in let f = dfmla denv f in
let vl = List.map2 create_var d.ld_params ps.ps_scheme in let vl = mk_vlist ps.ps_scheme in
let env = env_of_vsymbol_list vl in let env = env_of_vsymbol_list vl in
Some (vl, fmla env f) make_pdef ps vl (fmla env f)
in end
Lpredicate (ps, def)
| Some _ -> (* function *) | Some _ -> (* function *)
let fs = Hashtbl.find fsymbols id in let fs = Hashtbl.find fsymbols id in
let def = match d.ld_def with begin match d.ld_def with
| None -> | None ->
None Lfunction (fs, None)
| Some t -> | Some t ->
let t = dterm denv t in let t = dterm denv t in
let vl = List.map2 create_var d.ld_params (fst fs.fs_scheme) in let vl = mk_vlist (fst fs.fs_scheme) in
let env = env_of_vsymbol_list vl in let env = env_of_vsymbol_list vl in
Some (vl, term env t) make_fdef fs vl (term env t)
in end
Lfunction (fs, def)
in in
let dl = List.map type_decl dl in let dl = List.map type_decl dl in
add_decl th (create_logic dl) add_decl th (create_logic dl)
......
...@@ -117,15 +117,13 @@ let print_vsymbol fmt {vs_name = vs_name; vs_ty = vs_ty} = ...@@ -117,15 +117,13 @@ let print_vsymbol fmt {vs_name = vs_name; vs_ty = vs_ty} =
let print_logic_decl fmt = function let print_logic_decl fmt = function
| Lfunction (fs,None) -> fprintf fmt "logic %a@." print_fsymbol fs | Lfunction (fs,None) -> fprintf fmt "logic %a@." print_fsymbol fs
| Lfunction (fs,Some (vsl,t)) -> | Lfunction (fs,Some fd) ->
fprintf fmt "logic %a%a =@ %a@." print_ident fs.fs_name fprintf fmt "logic %a @: %a@." print_ident fs.fs_name
(print_list_paren comma print_vsymbol) vsl print_fmla fd
print_term t
| Lpredicate (fs,None) -> fprintf fmt "logic %a@." print_psymbol fs | Lpredicate (fs,None) -> fprintf fmt "logic %a@." print_psymbol fs
| Lpredicate (ps,Some (vsl,t)) -> | Lpredicate (ps,Some fd) ->
fprintf fmt "logic %a%a =@ %a@." print_ident ps.ps_name fprintf fmt "logic %a @: %a@." print_ident ps.ps_name
(print_list_paren comma print_vsymbol) vsl print_fmla fd
print_fmla t
| Linductive _ -> assert false (*TODO*) | Linductive _ -> assert false (*TODO*)
let print_decl fmt d = match d.d_node with let print_decl fmt d = match d.d_node with
......
...@@ -106,14 +106,14 @@ let elt d = ...@@ -106,14 +106,14 @@ let elt d =
| Lfunction (fs,l) -> | Lfunction (fs,l) ->
let s = match l with let s = match l with
| None -> Sid.empty | None -> Sid.empty
| Some (_,t) -> | Some fd ->
t_fold_trans toccurences foccurences Sid.empty t in f_fold_trans toccurences foccurences Sid.empty fd in
Mid.add fs.fs_name s acc Mid.add fs.fs_name s acc
| Lpredicate (ps,l) -> | Lpredicate (ps,l) ->
let s = match l with let s = match l with
| None -> Sid.empty | None -> Sid.empty
| Some (_,f) -> | Some fd ->
f_fold_trans toccurences foccurences Sid.empty f in f_fold_trans toccurences foccurences Sid.empty fd in
Mid.add ps.ps_name s acc Mid.add ps.ps_name s acc
| Linductive (ps,l) -> | Linductive (ps,l) ->
let s = List.fold_left let s = List.fold_left
......
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