797 lines
26 KiB
OCaml
797 lines
26 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* Environment handling *)
|
|
|
|
open Format
|
|
open Config
|
|
open Misc
|
|
open Asttypes
|
|
open Longident
|
|
open Path
|
|
open Types
|
|
|
|
|
|
type error =
|
|
Not_an_interface of string
|
|
| Corrupted_interface of string
|
|
| Illegal_renaming of string * string
|
|
| Inconsistent_import of string * string * string
|
|
|
|
exception Error of error
|
|
|
|
type summary =
|
|
Env_empty
|
|
| Env_value of summary * Ident.t * value_description
|
|
| Env_type of summary * Ident.t * type_declaration
|
|
| Env_exception of summary * Ident.t * exception_declaration
|
|
| Env_module of summary * Ident.t * module_type
|
|
| Env_modtype of summary * Ident.t * modtype_declaration
|
|
| Env_class of summary * Ident.t * class_declaration
|
|
| Env_cltype of summary * Ident.t * cltype_declaration
|
|
| Env_open of summary * Path.t
|
|
|
|
type t = {
|
|
values: (Path.t * value_description) Ident.tbl;
|
|
constrs: constructor_description Ident.tbl;
|
|
labels: label_description Ident.tbl;
|
|
types: (Path.t * type_declaration) Ident.tbl;
|
|
modules: (Path.t * module_type) Ident.tbl;
|
|
modtypes: (Path.t * modtype_declaration) Ident.tbl;
|
|
components: (Path.t * module_components) Ident.tbl;
|
|
classes: (Path.t * class_declaration) Ident.tbl;
|
|
cltypes: (Path.t * cltype_declaration) Ident.tbl;
|
|
summary: summary
|
|
}
|
|
|
|
and module_components =
|
|
Structure_comps of structure_components
|
|
| Functor_comps of functor_components
|
|
|
|
and structure_components = {
|
|
mutable comp_values: (string, (value_description * int)) Tbl.t;
|
|
mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
|
|
mutable comp_labels: (string, (label_description * int)) Tbl.t;
|
|
mutable comp_types: (string, (type_declaration * int)) Tbl.t;
|
|
mutable comp_modules: (string, (module_type * int)) Tbl.t;
|
|
mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
|
|
mutable comp_components: (string, (module_components * int)) Tbl.t;
|
|
mutable comp_classes: (string, (class_declaration * int)) Tbl.t;
|
|
mutable comp_cltypes: (string, (cltype_declaration * int)) Tbl.t
|
|
}
|
|
|
|
and functor_components = {
|
|
fcomp_param: Ident.t;
|
|
fcomp_arg: module_type;
|
|
fcomp_res: module_type;
|
|
fcomp_env: t
|
|
}
|
|
|
|
let empty = {
|
|
values = Ident.empty; constrs = Ident.empty;
|
|
labels = Ident.empty; types = Ident.empty;
|
|
modules = Ident.empty; modtypes = Ident.empty;
|
|
components = Ident.empty; classes = Ident.empty;
|
|
cltypes = Ident.empty;
|
|
summary = Env_empty }
|
|
|
|
(* Persistent structure descriptions *)
|
|
|
|
type pers_struct =
|
|
{ ps_name: string;
|
|
ps_sig: signature;
|
|
ps_comps: module_components;
|
|
ps_crcs: (string * Digest.t) list }
|
|
|
|
let persistent_structures =
|
|
(Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
|
|
|
|
let read_pers_struct modname filename =
|
|
let ic = open_in_bin filename in
|
|
try
|
|
let buffer = String.create (String.length cmi_magic_number) in
|
|
really_input ic buffer 0 (String.length cmi_magic_number);
|
|
if buffer <> cmi_magic_number then begin
|
|
close_in ic;
|
|
raise(Error(Not_an_interface filename))
|
|
end;
|
|
let (name, sign, comps) = input_value ic in
|
|
let crcs = input_value ic in
|
|
close_in ic;
|
|
let ps = { ps_name = name;
|
|
ps_sig = sign;
|
|
ps_comps = comps;
|
|
ps_crcs = crcs } in
|
|
if ps.ps_name <> modname then
|
|
raise(Error(Illegal_renaming(ps.ps_name, filename)));
|
|
Hashtbl.add persistent_structures modname ps;
|
|
ps
|
|
with End_of_file | Failure _ ->
|
|
close_in ic;
|
|
raise(Error(Corrupted_interface(filename)))
|
|
|
|
let find_pers_struct name =
|
|
try
|
|
Hashtbl.find persistent_structures name
|
|
with Not_found ->
|
|
read_pers_struct name
|
|
(find_in_path !load_path (String.uncapitalize name ^ ".cmi"))
|
|
|
|
let reset_cache() =
|
|
Hashtbl.clear persistent_structures
|
|
|
|
(* Forward declarations *)
|
|
|
|
let components_of_functor_appl =
|
|
ref ((fun f p1 p2 -> fatal_error "Env.components_of_functor_appl") :
|
|
functor_components -> Path.t -> Path.t -> module_components)
|
|
|
|
let check_modtype_inclusion =
|
|
(* to be filled with includemod.check_modtype_inclusion *)
|
|
ref ((fun env mty1 mty2 -> fatal_error "Env.include_modtypes") :
|
|
t -> module_type -> module_type -> unit)
|
|
|
|
(* Lookup by identifier *)
|
|
|
|
let rec find_module_descr path env =
|
|
match path with
|
|
Pident id ->
|
|
begin try
|
|
let (p, desc) = Ident.find_same id env.components
|
|
in desc
|
|
with Not_found ->
|
|
if Ident.persistent id
|
|
then (find_pers_struct (Ident.name id)).ps_comps
|
|
else raise Not_found
|
|
end
|
|
| Pdot(p, s, pos) ->
|
|
begin match find_module_descr p env with
|
|
Structure_comps c ->
|
|
let (descr, pos) = Tbl.find s c.comp_components in
|
|
descr
|
|
| Functor_comps f ->
|
|
raise Not_found
|
|
end
|
|
| Papply(p1, p2) ->
|
|
begin match find_module_descr p1 env with
|
|
Functor_comps f ->
|
|
!components_of_functor_appl f p1 p2
|
|
| Structure_comps c ->
|
|
raise Not_found
|
|
end
|
|
|
|
let find proj1 proj2 path env =
|
|
match path with
|
|
Pident id ->
|
|
let (p, data) = Ident.find_same id (proj1 env)
|
|
in data
|
|
| Pdot(p, s, pos) ->
|
|
begin match find_module_descr p env with
|
|
Structure_comps c ->
|
|
let (data, pos) = Tbl.find s (proj2 c) in data
|
|
| Functor_comps f ->
|
|
raise Not_found
|
|
end
|
|
| Papply(p1, p2) ->
|
|
raise Not_found
|
|
|
|
let find_value =
|
|
find (fun env -> env.values) (fun sc -> sc.comp_values)
|
|
and find_type =
|
|
find (fun env -> env.types) (fun sc -> sc.comp_types)
|
|
and find_modtype =
|
|
find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
|
|
and find_class =
|
|
find (fun env -> env.classes) (fun sc -> sc.comp_classes)
|
|
and find_cltype =
|
|
find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
|
|
|
|
let find_type_expansion path env =
|
|
let decl = find_type path env in
|
|
match decl.type_manifest with
|
|
None -> raise Not_found
|
|
| Some body -> (decl.type_params, body)
|
|
|
|
let find_modtype_expansion path env =
|
|
match find_modtype path env with
|
|
Tmodtype_abstract -> raise Not_found
|
|
| Tmodtype_manifest mty -> mty
|
|
|
|
let find_module path env =
|
|
match path with
|
|
Pident id ->
|
|
begin try
|
|
let (p, data) = Ident.find_same id env.modules
|
|
in data
|
|
with Not_found ->
|
|
if Ident.persistent id then
|
|
let ps = find_pers_struct (Ident.name id) in
|
|
Tmty_signature(ps.ps_sig)
|
|
else raise Not_found
|
|
end
|
|
| Pdot(p, s, pos) ->
|
|
begin match find_module_descr p env with
|
|
Structure_comps c ->
|
|
let (data, pos) = Tbl.find s c.comp_modules in data
|
|
| Functor_comps f ->
|
|
raise Not_found
|
|
end
|
|
| Papply(p1, p2) ->
|
|
raise Not_found (* not right *)
|
|
|
|
(* Lookup by name *)
|
|
|
|
let rec lookup_module_descr lid env =
|
|
match lid with
|
|
Lident s ->
|
|
begin try
|
|
Ident.find_name s env.components
|
|
with Not_found ->
|
|
let ps = find_pers_struct s in
|
|
(Pident(Ident.create_persistent s), ps.ps_comps)
|
|
end
|
|
| Ldot(l, s) ->
|
|
let (p, descr) = lookup_module_descr l env in
|
|
begin match descr with
|
|
Structure_comps c ->
|
|
let (descr, pos) = Tbl.find s c.comp_components in
|
|
(Pdot(p, s, pos), descr)
|
|
| Functor_comps f ->
|
|
raise Not_found
|
|
end
|
|
| Lapply(l1, l2) ->
|
|
let (p1, desc1) = lookup_module_descr l1 env in
|
|
let (p2, mty2) = lookup_module l2 env in
|
|
begin match desc1 with
|
|
Functor_comps f ->
|
|
!check_modtype_inclusion env mty2 f.fcomp_arg;
|
|
(Papply(p1, p2), !components_of_functor_appl f p1 p2)
|
|
| Structure_comps c ->
|
|
raise Not_found
|
|
end
|
|
|
|
and lookup_module lid env =
|
|
match lid with
|
|
Lident s ->
|
|
begin try
|
|
Ident.find_name s env.modules
|
|
with Not_found ->
|
|
let ps = find_pers_struct s in
|
|
(Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig)
|
|
end
|
|
| Ldot(l, s) ->
|
|
let (p, descr) = lookup_module_descr l env in
|
|
begin match descr with
|
|
Structure_comps c ->
|
|
let (data, pos) = Tbl.find s c.comp_modules in
|
|
(Pdot(p, s, pos), data)
|
|
| Functor_comps f ->
|
|
raise Not_found
|
|
end
|
|
| Lapply(l1, l2) ->
|
|
let (p1, desc1) = lookup_module_descr l1 env in
|
|
let (p2, mty2) = lookup_module l2 env in
|
|
let p = Papply(p1, p2) in
|
|
begin match desc1 with
|
|
Functor_comps f ->
|
|
!check_modtype_inclusion env mty2 f.fcomp_arg;
|
|
(p, Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity)
|
|
f.fcomp_res)
|
|
| Structure_comps c ->
|
|
raise Not_found
|
|
end
|
|
|
|
let lookup proj1 proj2 lid env =
|
|
match lid with
|
|
Lident s ->
|
|
Ident.find_name s (proj1 env)
|
|
| Ldot(l, s) ->
|
|
begin match lookup_module_descr l env with
|
|
(p, Structure_comps c) ->
|
|
let (data, pos) = Tbl.find s (proj2 c) in
|
|
(Pdot(p, s, pos), data)
|
|
| (p, Functor_comps f) ->
|
|
raise Not_found
|
|
end
|
|
| Lapply(l1, l2) ->
|
|
raise Not_found
|
|
|
|
let lookup_simple proj1 proj2 lid env =
|
|
match lid with
|
|
Lident s ->
|
|
Ident.find_name s (proj1 env)
|
|
| Ldot(l, s) ->
|
|
begin match lookup_module_descr l env with
|
|
(p, Structure_comps c) ->
|
|
let (data, pos) = Tbl.find s (proj2 c) in
|
|
data
|
|
| (p, Functor_comps f) ->
|
|
raise Not_found
|
|
end
|
|
| Lapply(l1, l2) ->
|
|
raise Not_found
|
|
|
|
let lookup_value =
|
|
lookup (fun env -> env.values) (fun sc -> sc.comp_values)
|
|
and lookup_constructor =
|
|
lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
|
|
and lookup_label =
|
|
lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
|
|
and lookup_type =
|
|
lookup (fun env -> env.types) (fun sc -> sc.comp_types)
|
|
and lookup_modtype =
|
|
lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
|
|
and lookup_class =
|
|
lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
|
|
and lookup_cltype =
|
|
lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
|
|
|
|
(* Scrape a module type *)
|
|
|
|
let rec scrape_modtype mty env =
|
|
match mty with
|
|
Tmty_ident path ->
|
|
begin try
|
|
scrape_modtype (find_modtype_expansion path env) env
|
|
with Not_found ->
|
|
mty
|
|
end
|
|
| _ -> mty
|
|
|
|
(* Compute constructor descriptions *)
|
|
|
|
let constructors_of_type ty_path decl =
|
|
match decl.type_kind with
|
|
Type_variant cstrs ->
|
|
Datarepr.constructor_descrs
|
|
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
|
|
cstrs
|
|
| _ -> []
|
|
|
|
(* Compute label descriptions *)
|
|
|
|
let labels_of_type ty_path decl =
|
|
match decl.type_kind with
|
|
Type_record labels ->
|
|
Datarepr.label_descrs
|
|
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
|
|
labels
|
|
| _ -> []
|
|
|
|
(* Given a signature and a root path, prefix all idents in the signature
|
|
by the root path and build the corresponding substitution. *)
|
|
|
|
let rec prefix_idents root pos sub = function
|
|
[] -> ([], sub)
|
|
| Tsig_value(id, decl) :: rem ->
|
|
let p = Pdot(root, Ident.name id, pos) in
|
|
let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
|
|
let (pl, final_sub) = prefix_idents root nextpos sub rem in
|
|
(p::pl, final_sub)
|
|
| Tsig_type(id, decl) :: rem ->
|
|
let p = Pdot(root, Ident.name id, nopos) in
|
|
let (pl, final_sub) =
|
|
prefix_idents root pos (Subst.add_type id p sub) rem in
|
|
(p::pl, final_sub)
|
|
| Tsig_exception(id, decl) :: rem ->
|
|
let p = Pdot(root, Ident.name id, pos) in
|
|
let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
|
|
(p::pl, final_sub)
|
|
| Tsig_module(id, mty) :: rem ->
|
|
let p = Pdot(root, Ident.name id, pos) in
|
|
let (pl, final_sub) =
|
|
prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
|
|
(p::pl, final_sub)
|
|
| Tsig_modtype(id, decl) :: rem ->
|
|
let p = Pdot(root, Ident.name id, nopos) in
|
|
let (pl, final_sub) =
|
|
prefix_idents root pos
|
|
(Subst.add_modtype id (Tmty_ident p) sub) rem in
|
|
(p::pl, final_sub)
|
|
| Tsig_class(id, decl) :: rem ->
|
|
let p = Pdot(root, Ident.name id, pos) in
|
|
let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in
|
|
(p::pl, final_sub)
|
|
| Tsig_cltype(id, decl) :: rem ->
|
|
let p = Pdot(root, Ident.name id, nopos) in
|
|
let (pl, final_sub) = prefix_idents root pos sub rem in
|
|
(p::pl, final_sub)
|
|
|
|
|
|
(* Compute structure descriptions *)
|
|
|
|
let rec components_of_module env sub path mty =
|
|
match scrape_modtype mty env with
|
|
Tmty_signature sg ->
|
|
let c =
|
|
{ comp_values = Tbl.empty; comp_constrs = Tbl.empty;
|
|
comp_labels = Tbl.empty; comp_types = Tbl.empty;
|
|
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
|
|
comp_components = Tbl.empty; comp_classes = Tbl.empty;
|
|
comp_cltypes = Tbl.empty } in
|
|
let (pl, sub) = prefix_idents path 0 sub sg in
|
|
let env = ref env in
|
|
let pos = ref 0 in
|
|
List.iter2 (fun item path ->
|
|
match item with
|
|
Tsig_value(id, decl) ->
|
|
let decl' = Subst.value_description sub decl in
|
|
c.comp_values <-
|
|
Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
|
|
begin match decl.val_kind with
|
|
Val_prim _ -> () | _ -> incr pos
|
|
end
|
|
| Tsig_type(id, decl) ->
|
|
let decl' = Subst.type_declaration sub decl in
|
|
c.comp_types <-
|
|
Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
|
|
List.iter
|
|
(fun (name, descr) ->
|
|
c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
|
|
(constructors_of_type path decl');
|
|
List.iter
|
|
(fun (name, descr) ->
|
|
c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
|
|
(labels_of_type path decl')
|
|
| Tsig_exception(id, decl) ->
|
|
let decl' = Subst.exception_declaration sub decl in
|
|
let cstr = Datarepr.exception_descr path decl' in
|
|
c.comp_constrs <-
|
|
Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
|
|
incr pos
|
|
| Tsig_module(id, mty) ->
|
|
let mty' = Subst.modtype sub mty in
|
|
c.comp_modules <-
|
|
Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
|
|
let comps = components_of_module !env sub path mty in
|
|
c.comp_components <-
|
|
Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
|
|
env := store_components id path comps !env;
|
|
incr pos
|
|
| Tsig_modtype(id, decl) ->
|
|
let decl' = Subst.modtype_declaration sub decl in
|
|
c.comp_modtypes <-
|
|
Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
|
|
env := store_modtype id path decl' !env
|
|
| Tsig_class(id, decl) ->
|
|
let decl' = Subst.class_declaration sub decl in
|
|
c.comp_classes <-
|
|
Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
|
|
incr pos
|
|
| Tsig_cltype(id, decl) ->
|
|
let decl' = Subst.cltype_declaration sub decl in
|
|
c.comp_cltypes <-
|
|
Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
|
|
sg pl;
|
|
Structure_comps c
|
|
| Tmty_functor(param, ty_arg, ty_res) ->
|
|
Functor_comps {
|
|
fcomp_param = param;
|
|
fcomp_arg = Subst.modtype sub ty_arg;
|
|
fcomp_res = Subst.modtype sub ty_res;
|
|
fcomp_env = env }
|
|
| Tmty_ident p ->
|
|
Structure_comps {
|
|
comp_values = Tbl.empty; comp_constrs = Tbl.empty;
|
|
comp_labels = Tbl.empty; comp_types = Tbl.empty;
|
|
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
|
|
comp_components = Tbl.empty; comp_classes = Tbl.empty;
|
|
comp_cltypes = Tbl.empty }
|
|
|
|
(* Insertion of bindings by identifier + path *)
|
|
|
|
and store_value id path decl env =
|
|
{ values = Ident.add id (path, decl) env.values;
|
|
constrs = env.constrs;
|
|
labels = env.labels;
|
|
types = env.types;
|
|
modules = env.modules;
|
|
modtypes = env.modtypes;
|
|
components = env.components;
|
|
classes = env.classes;
|
|
cltypes = env.cltypes;
|
|
summary = Env_value(env.summary, id, decl) }
|
|
|
|
and store_type id path info env =
|
|
{ values = env.values;
|
|
constrs =
|
|
List.fold_right
|
|
(fun (name, descr) constrs ->
|
|
Ident.add (Ident.create name) descr constrs)
|
|
(constructors_of_type path info)
|
|
env.constrs;
|
|
labels =
|
|
List.fold_right
|
|
(fun (name, descr) labels ->
|
|
Ident.add (Ident.create name) descr labels)
|
|
(labels_of_type path info)
|
|
env.labels;
|
|
types = Ident.add id (path, info) env.types;
|
|
modules = env.modules;
|
|
modtypes = env.modtypes;
|
|
components = env.components;
|
|
classes = env.classes;
|
|
cltypes = env.cltypes;
|
|
summary = Env_type(env.summary, id, info) }
|
|
|
|
and store_exception id path decl env =
|
|
{ values = env.values;
|
|
constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
|
|
labels = env.labels;
|
|
types = env.types;
|
|
modules = env.modules;
|
|
modtypes = env.modtypes;
|
|
components = env.components;
|
|
classes = env.classes;
|
|
cltypes = env.cltypes;
|
|
summary = Env_exception(env.summary, id, decl) }
|
|
|
|
and store_module id path mty env =
|
|
{ values = env.values;
|
|
constrs = env.constrs;
|
|
labels = env.labels;
|
|
types = env.types;
|
|
modules = Ident.add id (path, mty) env.modules;
|
|
modtypes = env.modtypes;
|
|
components =
|
|
Ident.add id (path, components_of_module env Subst.identity path mty)
|
|
env.components;
|
|
classes = env.classes;
|
|
cltypes = env.cltypes;
|
|
summary = Env_module(env.summary, id, mty) }
|
|
|
|
and store_modtype id path info env =
|
|
{ values = env.values;
|
|
constrs = env.constrs;
|
|
labels = env.labels;
|
|
types = env.types;
|
|
modules = env.modules;
|
|
modtypes = Ident.add id (path, info) env.modtypes;
|
|
components = env.components;
|
|
classes = env.classes;
|
|
cltypes = env.cltypes;
|
|
summary = Env_modtype(env.summary, id, info) }
|
|
|
|
and store_components id path comps env =
|
|
{ values = env.values;
|
|
constrs = env.constrs;
|
|
labels = env.labels;
|
|
types = env.types;
|
|
modules = env.modules;
|
|
modtypes = env.modtypes;
|
|
components = Ident.add id (path, comps) env.components;
|
|
classes = env.classes;
|
|
cltypes = env.cltypes;
|
|
summary = env.summary }
|
|
|
|
and store_class id path desc env =
|
|
{ values = env.values;
|
|
constrs = env.constrs;
|
|
labels = env.labels;
|
|
types = env.types;
|
|
modules = env.modules;
|
|
modtypes = env.modtypes;
|
|
components = env.components;
|
|
classes = Ident.add id (path, desc) env.classes;
|
|
cltypes = env.cltypes;
|
|
summary = Env_class(env.summary, id, desc) }
|
|
|
|
and store_cltype id path desc env =
|
|
{ values = env.values;
|
|
constrs = env.constrs;
|
|
labels = env.labels;
|
|
types = env.types;
|
|
modules = env.modules;
|
|
modtypes = env.modtypes;
|
|
components = env.components;
|
|
classes = env.classes;
|
|
cltypes = Ident.add id (path, desc) env.cltypes;
|
|
summary = Env_cltype(env.summary, id, desc) }
|
|
|
|
(* Memoized function to compute the components of a functor application
|
|
in a path. *)
|
|
|
|
let funappl_memo =
|
|
(Hashtbl.create 17 : (Path.t, module_components) Hashtbl.t)
|
|
|
|
let _ =
|
|
components_of_functor_appl :=
|
|
(fun f p1 p2 ->
|
|
let p = Papply(p1, p2) in
|
|
try
|
|
Hashtbl.find funappl_memo p
|
|
with Not_found ->
|
|
let mty =
|
|
Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity)
|
|
f.fcomp_res in
|
|
let comps = components_of_module f.fcomp_env Subst.identity p mty in
|
|
Hashtbl.add funappl_memo p comps;
|
|
comps)
|
|
|
|
(* Insertion of bindings by identifier *)
|
|
|
|
let add_value id desc env =
|
|
store_value id (Pident id) desc env
|
|
|
|
and add_type id info env =
|
|
store_type id (Pident id) info env
|
|
|
|
and add_exception id decl env =
|
|
store_exception id (Pident id) decl env
|
|
|
|
and add_module id mty env =
|
|
store_module id (Pident id) mty env
|
|
|
|
and add_modtype id info env =
|
|
store_modtype id (Pident id) info env
|
|
|
|
and add_class id ty env =
|
|
store_class id (Pident id) ty env
|
|
|
|
and add_cltype id ty env =
|
|
store_cltype id (Pident id) ty env
|
|
|
|
(* Insertion of bindings by name *)
|
|
|
|
let enter store_fun name data env =
|
|
let id = Ident.create name in (id, store_fun id (Pident id) data env)
|
|
|
|
let enter_value = enter store_value
|
|
and enter_type = enter store_type
|
|
and enter_exception = enter store_exception
|
|
and enter_module = enter store_module
|
|
and enter_modtype = enter store_modtype
|
|
and enter_class = enter store_class
|
|
and enter_cltype = enter store_cltype
|
|
|
|
(* Insertion of all components of a signature *)
|
|
|
|
let add_item comp env =
|
|
match comp with
|
|
Tsig_value(id, decl) -> add_value id decl env
|
|
| Tsig_type(id, decl) -> add_type id decl env
|
|
| Tsig_exception(id, decl) -> add_exception id decl env
|
|
| Tsig_module(id, mty) -> add_module id mty env
|
|
| Tsig_modtype(id, decl) -> add_modtype id decl env
|
|
| Tsig_class(id, decl) -> add_class id decl env
|
|
| Tsig_cltype(id, decl) -> add_cltype id decl env
|
|
|
|
let rec add_signature sg env =
|
|
match sg with
|
|
[] -> env
|
|
| comp :: rem -> add_signature rem (add_item comp env)
|
|
|
|
(* Open a signature path *)
|
|
|
|
let open_signature root sg env =
|
|
(* First build the paths and substitution *)
|
|
let (pl, sub) = prefix_idents root 0 Subst.identity sg in
|
|
(* Then enter the components in the environment after substitution *)
|
|
let newenv =
|
|
List.fold_left2
|
|
(fun env item p ->
|
|
match item with
|
|
Tsig_value(id, decl) ->
|
|
store_value (Ident.hide id) p
|
|
(Subst.value_description sub decl) env
|
|
| Tsig_type(id, decl) ->
|
|
store_type (Ident.hide id) p
|
|
(Subst.type_declaration sub decl) env
|
|
| Tsig_exception(id, decl) ->
|
|
store_exception (Ident.hide id) p
|
|
(Subst.exception_declaration sub decl) env
|
|
| Tsig_module(id, mty) ->
|
|
store_module (Ident.hide id) p (Subst.modtype sub mty) env
|
|
| Tsig_modtype(id, decl) ->
|
|
store_modtype (Ident.hide id) p
|
|
(Subst.modtype_declaration sub decl) env
|
|
| Tsig_class(id, decl) ->
|
|
store_class (Ident.hide id) p
|
|
(Subst.class_declaration sub decl) env
|
|
| Tsig_cltype(id, decl) ->
|
|
store_cltype (Ident.hide id) p
|
|
(Subst.cltype_declaration sub decl) env)
|
|
env sg pl in
|
|
{ values = newenv.values;
|
|
constrs = newenv.constrs;
|
|
labels = newenv.labels;
|
|
types = newenv.types;
|
|
modules = newenv.modules;
|
|
modtypes = newenv.modtypes;
|
|
components = newenv.components;
|
|
classes = newenv.classes;
|
|
cltypes = newenv.cltypes;
|
|
summary = Env_open(env.summary, root) }
|
|
|
|
(* Open a signature from a file *)
|
|
|
|
let open_pers_signature name env =
|
|
let ps = find_pers_struct name in
|
|
open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
|
|
|
|
(* Read a signature from a file *)
|
|
|
|
let read_signature modname filename =
|
|
let ps = read_pers_struct modname filename in ps.ps_sig
|
|
|
|
(* Return the list of imported interfaces with their CRCs *)
|
|
|
|
let imported_units() =
|
|
let imported_units =
|
|
ref ([] : (string * Digest.t) list) in
|
|
let units_xref =
|
|
(Hashtbl.create 13 : (string, Digest.t * string) Hashtbl.t) in
|
|
let add_unit source (name, crc) =
|
|
try
|
|
let (oldcrc, oldsource) = Hashtbl.find units_xref name in
|
|
if oldcrc <> crc then
|
|
raise(Error(Inconsistent_import(name, oldsource, source)))
|
|
with Not_found ->
|
|
Hashtbl.add units_xref name (crc, source);
|
|
imported_units := (name, crc) :: !imported_units in
|
|
Hashtbl.iter
|
|
(fun name ps -> List.iter (add_unit ps.ps_name) ps.ps_crcs)
|
|
persistent_structures;
|
|
!imported_units
|
|
|
|
(* Save a signature to a file *)
|
|
|
|
let save_signature sg modname filename =
|
|
Btype.cleanup_abbrev ();
|
|
let oc = open_out_bin filename in
|
|
output_string oc cmi_magic_number;
|
|
let comps =
|
|
components_of_module empty Subst.identity
|
|
(Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
|
|
output_value oc (modname, sg, comps);
|
|
flush oc;
|
|
let crc = Digest.file filename in
|
|
let crcs = (modname, crc) :: imported_units() in
|
|
output_value oc crcs;
|
|
close_out oc;
|
|
(* Enter signature in persistent table so that imported_unit()
|
|
will also return its crc *)
|
|
let ps =
|
|
{ ps_name = modname; ps_sig = sg; ps_comps = comps; ps_crcs = crcs } in
|
|
Hashtbl.add persistent_structures modname ps
|
|
|
|
(* Make the initial environment *)
|
|
|
|
let initial = Predef.build_initial_env add_type add_exception empty
|
|
|
|
(* Return the environment summary *)
|
|
|
|
let summary env = env.summary
|
|
|
|
(* Error report *)
|
|
|
|
let report_error = function
|
|
Not_an_interface filename ->
|
|
print_string filename; print_space();
|
|
print_string "is not a compiled interface."
|
|
| Corrupted_interface filename ->
|
|
print_string "Corrupted compiled interface"; print_space();
|
|
print_string filename
|
|
| Illegal_renaming(modname, filename) ->
|
|
print_string "Wrong file naming:"; print_space();
|
|
print_string filename; print_space();
|
|
print_string "contains the compiled interface for"; print_space();
|
|
print_string modname
|
|
| Inconsistent_import(name, source1, source2) ->
|
|
open_hvbox 0;
|
|
print_string "The compiled interfaces for "; print_string source1;
|
|
print_string " and "; print_string source2; print_space();
|
|
print_string "make inconsistent assumptions over interface ";
|
|
print_string name;
|
|
close_box()
|