Commit 094ab658 authored by Andrei Paskevich's avatar Andrei Paskevich

several improvements, refactorings, and fixes

- prevent leak of idents by separating them into two types:
  - "preid" -- user-created and non-unique
  - "ident" -- unique, generated from "preid" by various
               smart constructors: create_tysymbol, etc

  This guarantees that two different symbols never share
  an ident.

- no need to hashcons tysymbols, fsymbols, and psymbols,
  as they are unique by construction

- make separate hashconsing smart constructors for decl

- export namespace as a private record (no reason to not to)

- some code rearrangement in hashconsing of decls

- fix namespace merging in close_namespace

- namespace name can be just a string, no need to use ident
parent e0d252af
......@@ -33,29 +33,40 @@ and origin =
module Id = struct
type t = ident
let equal = (==)
let hash id1 = id1.id_tag
let equal id1 id2 = id1.id_tag == id2.id_tag
let compare id1 id2 = Pervasives.compare id1.id_tag id2.id_tag
end
module Mid = Map.Make(Id)
module Sid = Set.Make(Id)
module Hid = Hashtbl.Make(Id)
type preid = ident
(* constructors *)
let gentag = let r = ref 0 in fun () -> incr r; !r
let id_register id = { id with id_tag = gentag () }
let create_ident short long origin = {
id_short = short;
id_long = long;
id_origin = origin;
id_tag = gentag ()
id_tag = -1
}
let id_fresh sh ln = create_ident sh ln Fresh
let id_derive sh ln id = create_ident sh ln (Derived id)
let id_fresh sh = create_ident sh sh Fresh
let id_fresh_long sh ln = create_ident sh ln Fresh
let id_user sh loc = create_ident sh sh (User loc)
let id_user_long sh ln loc = create_ident sh ln (User loc)
let id_derive sh id = create_ident sh sh (Derived id)
let id_derive_long sh ln id = create_ident sh ln (Derived id)
let id_clone id = create_ident id.id_short id.id_long (Derived id)
let id_user sh ln loc = create_ident sh ln (User loc)
let id_dup id = { id with id_tag = -1 }
(** Unique names for pretty printing *)
......@@ -77,7 +88,7 @@ let find_unique indices name =
name
let id_unique (indices,values) id =
try
try
Hashtbl.find values id.id_tag
with Not_found ->
let name = find_unique indices id.id_long in
......
......@@ -35,17 +35,29 @@ module Sid : Set.S with type elt = ident
module Mid : Map.S with type key = ident
module Hid : Hashtbl.S with type key = ident
(* create a fresh ident *)
val id_fresh : string -> string -> ident
(* a user-created type of unregistered identifiers *)
type preid
(* create a derived ident *)
val id_derive : string -> string -> ident -> ident
(* register a pre-ident (never use this function) *)
val id_register : preid -> ident
(* create a derived ident with the same name *)
val id_clone : ident -> ident
(* create a fresh pre-ident *)
val id_fresh : string -> preid
val id_fresh_long : string -> string -> preid
(* create a localized ident *)
val id_user : string -> string -> Loc.position -> ident
(* create a localized pre-ident *)
val id_user : string -> Loc.position -> preid
val id_user_long : string -> string -> Loc.position -> preid
(* create a derived pre-ident *)
val id_derive : string -> ident -> preid
val id_derive_long : string -> string -> ident -> preid
(* create a derived pre-ident with the same name *)
val id_clone : ident -> preid
(* create a duplicate pre-ident *)
val id_dup : ident -> preid
(** Unique persistent names for pretty printing *)
......
......@@ -21,7 +21,7 @@ type t = { tag : int ; name : string }
let fresh =
let cnt = ref 0 in
fun t ->
fun t ->
let tag = !cnt in
incr cnt;
{ t with tag = tag }
......@@ -38,8 +38,8 @@ let name_map = Hashtbl.create 47
let default_string = "anon"
let strip_numbers s =
let rec aux n =
let strip_numbers s =
let rec aux n =
if n <= 0 then 0
else
match s.[n-1] with
......@@ -48,7 +48,7 @@ let strip_numbers s =
let n = aux (String.length s) in
if n = 0 then default_string else String.sub s 0 n
let fresh_string name =
let fresh_string name =
let s = strip_numbers name in
try
let i = Hashtbl.find name_map s in
......@@ -74,10 +74,10 @@ module S = Set.Make (HT)
let get_cur_name, reset =
let current_name_map = H.create 47 in
let reset () =
H.clear current_name_map;
let reset () =
H.clear current_name_map;
Hashtbl.clear name_map in
let get_name x =
let get_name x =
try H.find current_name_map x
with Not_found ->
let s = to_string x in
......@@ -86,12 +86,12 @@ let get_cur_name, reset =
get_name, reset
let to_string = get_cur_name
let print fmt x = Format.fprintf fmt "%s" (get_cur_name x)
let build_map nl =
let m,_ =
List.fold_left (fun (m, i) n -> M.add n i m, i + 1)
let build_map nl =
let m,_ =
List.fold_left (fun (m, i) n -> M.add n i m, i + 1)
(M.empty, 0) nl in
m
......@@ -26,25 +26,26 @@ open Ty
type vsymbol = {
vs_name : ident;
vs_ty : ty;
vs_tag : int;
}
module Vsym = struct
type t = vsymbol
let equal vs1 vs2 = vs1.vs_name == vs2.vs_name
let equal = (==)
let hash vs = vs.vs_name.id_tag
let tag n vs = { vs with vs_tag = n }
let compare vs1 vs2 = Pervasives.compare vs1.vs_tag vs2.vs_tag
let compare vs1 vs2 =
Pervasives.compare vs1.vs_name.id_tag vs2.vs_name.id_tag
end
module Hvs = Hashcons.Make(Vsym)
module Mvs = Map.Make(Vsym)
module Svs = Set.Make(Vsym)
module Hvs = Hashtbl.Make(Vsym)
let mk_vs name ty = { vs_name = name; vs_ty = ty; vs_tag = -1 }
let create_vsymbol name ty = Hvs.hashcons (mk_vs name ty)
let create_vsymbol name ty = {
vs_name = id_register name;
vs_ty = ty;
}
let fresh_vsymbol v = create_vsymbol (id_clone v.vs_name) v.vs_ty
let fresh_vsymbol v = create_vsymbol (id_dup v.vs_name) v.vs_ty
(** Function symbols *)
......@@ -52,50 +53,47 @@ type fsymbol = {
fs_name : ident;
fs_scheme : ty list * ty;
fs_constr : bool;
fs_tag : int;
}
module Fsym = struct
type t = fsymbol
let equal fs1 fs2 = fs1.fs_name == fs2.fs_name
let equal = (==)
let hash fs = fs.fs_name.id_tag
let tag n fs = { fs with fs_tag = n }
let compare fs1 fs2 = Pervasives.compare fs1.fs_tag fs2.fs_tag
let compare fs1 fs2 =
Pervasives.compare fs1.fs_name.id_tag fs2.fs_name.id_tag
end
module Hfs = Hashcons.Make(Fsym)
module Sfs = Set.Make(Fsym)
module Mfs = Map.Make(Fsym)
module Hfs = Hashtbl.Make(Fsym)
let mk_fs name scheme constr = {
fs_name = name;
let create_fsymbol name scheme constr = {
fs_name = id_register name;
fs_scheme = scheme;
fs_constr = constr;
fs_tag = -1
}
let create_fsymbol name scheme constr = Hfs.hashcons (mk_fs name scheme constr)
(** Predicate symbols *)
type psymbol = {
ps_name : ident;
ps_scheme : ty list;
ps_tag : int;
}
module Psym = struct
type t = psymbol
let equal ps1 ps2 = ps1.ps_name == ps2.ps_name
let equal = (==)
let hash ps = ps.ps_name.id_tag
let tag n ps = { ps with ps_tag = n }
let compare ps1 ps2 = Pervasives.compare ps1.ps_tag ps2.ps_tag
let compare ps1 ps2 =
Pervasives.compare ps1.ps_name.id_tag ps2.ps_name.id_tag
end
module Hps = Hashcons.Make(Psym)
module Sps = Set.Make(Psym)
module Mps = Map.Make(Psym)
module Hps = Hashtbl.Make(Psym)
let mk_ps name scheme = { ps_name = name; ps_scheme = scheme; ps_tag = -1 }
let create_psymbol name scheme = Hps.hashcons (mk_ps name scheme)
let create_psymbol name scheme = {
ps_name = id_register name;
ps_scheme = scheme;
}
(** Patterns *)
......@@ -129,9 +127,9 @@ module Hpat = struct
let hash_node = function
| Pwild -> 0
| Pvar v -> v.vs_tag
| Papp (s, pl) -> Hashcons.combine_list hash_pattern s.fs_tag pl
| Pas (p, v) -> Hashcons.combine (hash_pattern p) v.vs_tag
| Pvar v -> v.vs_name.id_tag
| Papp (s, pl) -> Hashcons.combine_list hash_pattern s.fs_name.id_tag pl
| Pas (p, v) -> Hashcons.combine (hash_pattern p) v.vs_name.id_tag
let hash p = Hashcons.combine (hash_node p.pat_node) p.pat_ty.ty_tag
......@@ -289,16 +287,16 @@ module T = struct
let t_hash_branch (p, _, t) = Hashcons.combine p.pat_tag t.t_tag
let t_hash_bound (v, t) = Hashcons.combine v.vs_tag t.t_tag
let t_hash_bound (v, t) = Hashcons.combine v.vs_name.id_tag t.t_tag
let f_hash_bound (v, f) = Hashcons.combine v.vs_tag f.f_tag
let f_hash_bound (v, f) = Hashcons.combine v.vs_name.id_tag f.f_tag
let t_hash t = t.t_tag
let t_hash_node = function
| Tbvar n -> n
| Tvar v -> v.vs_tag
| Tapp (f, tl) -> Hashcons.combine_list t_hash (f.fs_tag) tl
| Tvar v -> v.vs_name.id_tag
| Tapp (f, tl) -> Hashcons.combine_list t_hash (f.fs_name.id_tag) tl
| Tlet (t, bt) -> Hashcons.combine t.t_tag (t_hash_bound bt)
| Tcase (t, bl) -> Hashcons.combine_list t_hash_branch t.t_tag bl
| Teps f -> f_hash_bound f
......@@ -354,14 +352,14 @@ module F = struct
let f_hash_branch (p, _, f) = Hashcons.combine p.pat_tag f.f_tag
let f_hash_bound (v, f) = Hashcons.combine v.vs_tag f.f_tag
let f_hash_bound (v, f) = Hashcons.combine v.vs_name.id_tag f.f_tag
let t_hash t = t.t_tag
let f_hash f = f.f_tag
let f_hash_node = function
| Fapp (p, tl) -> Hashcons.combine_list t_hash p.ps_tag tl
| Fapp (p, tl) -> Hashcons.combine_list t_hash p.ps_name.id_tag tl
| Fquant (q, bf) -> Hashcons.combine (Hashtbl.hash q) (f_hash_bound bf)
| Fbinop (op, f1, f2) ->
Hashcons.combine2 (Hashtbl.hash op) f1.f_tag f2.f_tag
......
......@@ -29,13 +29,13 @@ exception ConstructorExpected
type vsymbol = private {
vs_name : ident;
vs_ty : ty;
vs_tag : int;
}
module Svs : Set.S with type elt = vsymbol
module Mvs : Map.S with type key = vsymbol
module Hvs : Hashtbl.S with type key = vsymbol
val create_vsymbol : ident -> ty -> vsymbol
val create_vsymbol : preid -> ty -> vsymbol
(** Function symbols *)
......@@ -43,26 +43,26 @@ type fsymbol = private {
fs_name : ident;
fs_scheme : ty list * ty;
fs_constr : bool;
fs_tag : int;
}
val create_fsymbol : ident -> ty list * ty -> bool -> fsymbol
val create_fsymbol : preid -> ty list * ty -> bool -> fsymbol
module Sfs : Set.S with type elt = fsymbol
module Mfs : Map.S with type key = fsymbol
module Hfs : Hashtbl.S with type key = fsymbol
(** Predicate symbols *)
type psymbol = private {
ps_name : ident;
ps_scheme : ty list;
ps_tag : int;
}
val create_psymbol : ident -> ty list -> psymbol
val create_psymbol : preid -> ty list -> psymbol
module Sps : Set.S with type elt = psymbol
module Mps : Map.S with type key = psymbol
module Hps : Hashtbl.S with type key = psymbol
(** Patterns *)
......
This diff is collapsed.
......@@ -21,50 +21,88 @@ open Ident
open Ty
open Term
type ty_def =
| Ty_abstract
| Ty_algebraic of fsymbol list
(** Declarations *)
type ty_decl = tysymbol * ty_def
(* type declaration *)
type logic_decl =
type ty_def =
| Tabstract
| Talgebraic of fsymbol list
type ty_decl = tysymbol * ty_def
(* logic declaration *)
type logic_decl =
| Lfunction of fsymbol * (vsymbol list * term) option (* FIXME: binders *)
| Lpredicate of psymbol * (vsymbol list * fmla) option (* FIXME: binders *)
| Linductive of psymbol * (ident * fmla) list
type prop_kind =
| Axiom | Lemma | Goal
(* proposition declaration *)
type prop_kind =
| Paxiom
| Plemma
| Pgoal
type prop_decl = prop_kind * ident * fmla
(* declaration *)
type decl_node =
| Dtype of ty_decl list
| Dlogic of logic_decl list
| Dprop of prop_kind * ident * fmla
| Dprop of prop_decl
type decl = private {
d_node : decl_node;
d_tag : int;
}
type decl = private {d_node : decl_node; d_tag : int}
(* smart constructors *)
type decl_or_use =
| Decl of decl
| Use of theory
val create_type : ty_decl list -> decl
val create_logic : logic_decl list -> decl
val create_prop : prop_kind -> preid -> fmla -> decl
(** Theory *)
and theory = private {
module Snm : Set.S with type elt = string
module Mnm : Map.S with type key = string
type theory = private {
th_name : ident;
th_param : Sid.t; (* locally declared abstract symbols *)
th_known : ident Mid.t; (* imported and locally declared symbols *)
th_param : Sid.t; (* locally declared abstract symbols *)
th_known : ident Mid.t; (* imported and locally declared symbols *)
th_export : namespace;
th_decls : decl_or_use list;
}
and namespace
and namespace = private {
ns_ts : tysymbol Mnm.t; (* type symbols *)
ns_fs : fsymbol Mnm.t; (* function symbols *)
ns_ps : psymbol Mnm.t; (* predicate symbols *)
ns_ns : namespace Mnm.t; (* inner namespaces *)
ns_prop : fmla Mnm.t; (* propositions *)
}
and decl_or_use =
| Decl of decl
| Use of theory
(** Building *)
type theory_uc
(** a theory under construction *)
type theory_uc (* a theory under construction *)
val create_theory : ident -> theory_uc
val create_theory : preid -> theory_uc
val close_theory : theory_uc -> theory
val open_namespace : theory_uc -> theory_uc
val close_namespace : theory_uc -> ident -> import:bool -> theory_uc
val close_namespace : theory_uc -> string -> import:bool -> theory_uc
val add_decl : theory_uc -> decl -> theory_uc
val use_export : theory_uc -> theory -> theory_uc
......@@ -76,26 +114,8 @@ type th_inst = {
val clone_export : theory_uc -> theory -> th_inst -> theory_uc
val add_decl : theory_uc -> decl_node -> theory_uc
val close_theory : theory_uc -> theory
(** Querying *)
val get_namespace : theory_uc -> namespace
val find_tysymbol : namespace -> string -> tysymbol
val find_fsymbol : namespace -> string -> fsymbol
val find_psymbol : namespace -> string -> psymbol
val find_namespace: namespace -> string -> namespace
val find_prop : namespace -> string -> fmla
val mem_tysymbol : namespace -> string -> bool
val mem_fsymbol : namespace -> string -> bool
val mem_psymbol : namespace -> string -> bool
val mem_namespace: namespace -> string -> bool
val mem_prop : namespace -> string -> bool
(** Exceptions *)
exception CloseTheory
......@@ -104,7 +124,6 @@ exception RedeclaredIdent of ident
exception CannotInstantiate
exception ClashSymbol of string
(** Debugging *)
val print_th : Format.formatter -> theory_uc -> unit
......
......@@ -30,7 +30,6 @@ type tysymbol = {
ts_name : ident;
ts_args : tvsymbol list;
ts_def : ty option;
ts_tag : int;
}
and ty = {
......@@ -44,23 +43,23 @@ and ty_node =
module Tsym = struct
type t = tysymbol
let equal ts1 ts2 = ts1.ts_name == ts2.ts_name
let equal = (==)
let hash ts = ts.ts_name.id_tag
let tag n ts = { ts with ts_tag = n }
let compare ts1 ts2 = Pervasives.compare ts1.ts_tag ts2.ts_tag
let compare ts1 ts2 =
Pervasives.compare ts1.ts_name.id_tag ts2.ts_name.id_tag
end
module Hts = Hashcons.Make(Tsym)
module Sts = Set.Make(Tsym)
module Mts = Map.Make(Tsym)
module Hts = Hashtbl.Make(Tsym)
let mk_ts name args def = {
ts_name = name;
ts_args = args;
ts_def = def;
ts_tag = -1
}
let create_tysymbol name args def = Hts.hashcons (mk_ts name args def)
let create_tvsymbol = id_register
let create_tysymbol name args def = mk_ts (id_register name) args def
module Ty = struct
......@@ -75,7 +74,7 @@ module Ty = struct
let hash ty = match ty.ty_node with
| Tyvar v -> v.id_tag
| Tyapp (s, tl) -> Hashcons.combine_list hash_ty (s.ts_tag) tl
| Tyapp (s, tl) -> Hashcons.combine_list hash_ty s.ts_name.id_tag tl
let tag n ty = { ty with ty_tag = n }
......
......@@ -29,7 +29,6 @@ type tysymbol = private {
ts_name : ident;
ts_args : tvsymbol list;
ts_def : ty option;
ts_tag : int;
}
and ty = private {
......@@ -44,10 +43,12 @@ and ty_node = private
exception NonLinear
exception UnboundTypeVariable
val create_tysymbol : ident -> tvsymbol list -> ty option -> tysymbol
val create_tvsymbol : preid -> tvsymbol
val create_tysymbol : preid -> tvsymbol list -> ty option -> tysymbol
module Sts : Set.S with type elt = tysymbol
module Mts : Map.S with type key = tysymbol
module Hts : Hashtbl.S with type key = tysymbol
exception BadTypeArity
......
......@@ -236,7 +236,8 @@ let find_user_type_var x env =
Hashtbl.find env.utyvars x
with Not_found ->
(* TODO: shouldn't we localize this ident? *)
let v = create_type_var ~user:true (id_fresh x x) in
let v = create_tvsymbol (id_fresh x) in
let v = create_type_var ~user:true v in
Hashtbl.add env.utyvars x v;
v
......@@ -261,7 +262,7 @@ let rec specialize env t = match t.ty_node with
(** generic find function using a path *)
let find_local_namespace {id=x; id_loc=loc} ns =
try find_namespace ns x
try Mnm.find x ns.ns_ns
with Not_found -> error ~loc (UnboundNamespace x)
let rec find_namespace q ns = match q with
......@@ -275,7 +276,7 @@ let rec find f q ns = match q with
(** specific find functions using a path *)
let find_tysymbol {id=x; id_loc=loc} ns =
try find_tysymbol ns x
try Mnm.find x ns.ns_ts
with Not_found -> error ~loc (UnboundType x)
let find_tysymbol p th =
......@@ -287,7 +288,7 @@ let specialize_tysymbol x env =
s, List.map (find_type_var env) s.ts_args
let find_fsymbol {id=x; id_loc=loc} ns =
try find_fsymbol ns x
try Mnm.find x ns.ns_fs
with Not_found -> error ~loc (UnboundSymbol x)
let find_fsymbol p th =
......@@ -300,7 +301,7 @@ let specialize_fsymbol x env =
s, List.map (specialize env) tl, specialize env t
let find_psymbol {id=x; id_loc=loc} ns =
try find_psymbol ns x
try Mnm.find x ns.ns_ps
with Not_found -> error ~loc (UnboundSymbol x)
let find_psymbol p th =
......@@ -457,7 +458,7 @@ and fmla env = function
f_if (fmla env f1) (fmla env f2) (fmla env f3)
| Fquant (q, x, t, f1) ->
(* TODO: shouldn't we localize this ident? *)
let v = create_vsymbol (id_fresh x x) (ty t) in
let v = create_vsymbol (id_fresh x) (ty t) in
let env = M.add x v env in
f_quant q v (fmla env f1)
| Fapp (s, tl) ->
......@@ -493,12 +494,12 @@ let add_types loc dl th =
(fun v ->
if Hashtbl.mem vars v.id then
error ~loc:v.id_loc (DuplicateTypeVar v.id);
let i = id_user v.id v.id v.id_loc in
let i = create_tvsymbol (id_user v.id v.id_loc) in
Hashtbl.add vars v.id i;
i)
d.td_params
in
let id = id_user id id d.td_ident.id_loc in
let id = id_user id d.td_ident.id_loc in
let ts = match d.td_def with
| TDalias ty ->
let rec apply = function
......@@ -533,33 +534,33 @@ let add_types loc dl th =
| None -> assert false
| Some ts -> ts),
(match d.td_def with
| TDabstract | TDalias _ -> Ty_abstract
| TDabstract | TDalias _ -> Tabstract
| TDalgebraic _ -> assert false (*TODO*))
in
let dl = List.map decl dl in
add_decl th (Dtype dl)
add_decl th (create_type dl)
let add_function loc pl t th {id=id} =
let ns = get_namespace th in
if mem_fsymbol ns id then error ~loc (Clash id);
if Mnm.mem id ns.ns_fs then error ~loc (Clash id);
let denv = create_denv th in
let pl = List.map (dty denv) pl and t = dty denv t in
let pl = List.map ty pl and t = ty t in
(* TODO: add the theory name to the long name *)
let v = id_user id id loc in
let v = id_user id loc in
let s = create_fsymbol v (pl, t) false in
add_decl th (Dlogic [Lfunction (s, None)])
add_decl th (create_logic [Lfunction (s, None)])
let add_predicate loc pl th {id=id} =
let ns = get_namespace th in
if mem_psymbol ns id then error ~loc (Clash id);
if Mnm.mem id ns.ns_ps then error ~loc (Clash id);
let denv = create_denv th in
let pl = List.map (dty denv) pl in
let pl = List.map ty pl in
(* TODO: add the theory name to the long name *)
let v = id_user id id loc in
let v = id_user id loc in
let s = create_psymbol v pl in
add_decl th (Dlogic [Lpredicate (s, None)])
add_decl th (create_logic [Lpredicate (s, None)])
let env_of_vsymbol_list vl =
List.fold_left (fun env v -> M.add v.vs_name.id_short v env) M.empty vl
......@@ -570,7 +571,7 @@ let add_logics loc dl th =
(* 1. create all symbols and make an environment with these symbols *)
let create_symbol th d =
let id = d.ld_ident.id in
let v = id_user id id loc in