diff options
| -rw-r--r-- | typing/env.ml | 153 | ||||
| -rw-r--r-- | typing/env.mli | 11 | ||||
| -rw-r--r-- | typing/predef.ml | 6 |
3 files changed, 88 insertions, 82 deletions
diff --git a/typing/env.ml b/typing/env.ml index 9e825d87a..e72272dcd 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -26,6 +26,7 @@ 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 @@ -86,8 +87,7 @@ type pers_struct = { ps_name: string; ps_sig: signature; ps_comps: module_components; - ps_crc: Digest.t; - mutable ps_used: bool } + ps_crcs: (string * Digest.t) list } let persistent_structures = (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t) @@ -102,15 +102,15 @@ let read_pers_struct modname filename = 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_crc = Digest.input ic; - ps_used = false } - in - close_in ic; + 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; @@ -120,13 +120,8 @@ let find_pers_struct name = try Hashtbl.find persistent_structures name with Not_found -> - let ps = - read_pers_struct name - (find_in_path !load_path (String.uncapitalize name ^ ".cmi")) in - Hashtbl.add persistent_structures name ps; - ps - -let mark_used = function None -> () | Some ps -> ps.ps_used <- true + read_pers_struct name + (find_in_path !load_path (String.uncapitalize name ^ ".cmi")) let reset_cache() = Hashtbl.clear persistent_structures @@ -149,66 +144,62 @@ let rec find_module_descr path env = Pident id -> begin try let (p, desc) = Ident.find_same id env.components - in (desc, None) + in desc with Not_found -> - if Ident.persistent id then - let ps = find_pers_struct (Ident.name id) in (ps.ps_comps, Some ps) + 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, ps) -> + Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in - (descr, ps) - | (Functor_comps f, _) -> + descr + | Functor_comps f -> raise Not_found end | Papply(p1, p2) -> begin match find_module_descr p1 env with - (Functor_comps f, ps) -> - (!components_of_functor_appl f p1 p2, ps) - | (Structure_comps c, _) -> + Functor_comps f -> + !components_of_functor_appl f p1 p2 + | Structure_comps c -> raise Not_found end -let find proj1 proj2 filter path env = +let find proj1 proj2 path env = match path with Pident id -> let (p, data) = Ident.find_same id (proj1 env) - in filter data None + in data | Pdot(p, s, pos) -> begin match find_module_descr p env with - (Structure_comps c, ps) -> - let (data, pos) = Tbl.find s (proj2 c) in filter data ps - | (Functor_comps f, _) -> + 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 strict_filter data ps = - mark_used ps; data - let find_value = - find (fun env -> env.values) (fun sc -> sc.comp_values) strict_filter + find (fun env -> env.values) (fun sc -> sc.comp_values) and find_type = - find (fun env -> env.types) (fun sc -> sc.comp_types) strict_filter -and find_modtype = - find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) strict_filter -and find_class = - find (fun env -> env.classes) (fun sc -> sc.comp_classes) strict_filter -and find_type_expansion = find (fun env -> env.types) (fun sc -> sc.comp_types) - (fun decl ps -> - match decl.type_manifest with - None -> raise Not_found - | Some body -> mark_used ps; (decl.type_params, body)) -and find_modtype_expansion = +and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) - (fun def ps -> - match def with - Tmodtype_abstract -> raise Not_found - | Tmodtype_manifest mty -> mark_used ps; mty) +and find_class = + find (fun env -> env.classes) (fun sc -> sc.comp_classes) + +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 @@ -219,15 +210,14 @@ let find_module path env = with Not_found -> if Ident.persistent id then let ps = find_pers_struct (Ident.name id) in - ps.ps_used <- true; Tmty_signature(ps.ps_sig) + 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, ps) -> - mark_used ps; + Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in data - | (Functor_comps f, _) -> + | Functor_comps f -> raise Not_found end | Papply(p1, p2) -> @@ -242,7 +232,6 @@ let rec lookup_module_descr lid env = Ident.find_name s env.components with Not_found -> let ps = find_pers_struct s in - ps.ps_used <- true; (Pident(Ident.create_persistent s), ps.ps_comps) end | Ldot(l, s) -> @@ -272,7 +261,6 @@ and lookup_module lid env = Ident.find_name s env.modules with Not_found -> let ps = find_pers_struct s in - ps.ps_used <- true; (Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig) end | Ldot(l, s) -> @@ -684,47 +672,58 @@ let open_signature root sg env = let open_pers_signature name env = let ps = find_pers_struct name in - ps.ps_used <- true; 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, ps.ps_crc) + let ps = read_pers_struct modname filename in ps.ps_sig -(* Save a signature to a file *) +(* Return the list of imported interfaces with their CRCs *) -let dummy_crc = Digest.string "" +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; - output_value oc - (modname, sg, - components_of_module empty Subst.identity - (Pident(Ident.create_persistent modname)) (Tmty_signature sg)); + 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 - Digest.output oc crc; + let crcs = (modname, crc) :: imported_units() in + output_value oc crcs; close_out oc; - crc + (* 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 list of imported interfaces with their CRCs *) - -let imported_units() = - let imported_units = ref [] in - Hashtbl.iter - (fun _ ps -> - if ps.ps_used then - imported_units := (ps.ps_name, ps.ps_crc) :: !imported_units) - persistent_structures; - !imported_units - (* Return the environment summary *) let summary env = env.summary @@ -743,4 +742,10 @@ let report_error = function 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() diff --git a/typing/env.mli b/typing/env.mli index fee611e8d..d3d0ee7f7 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -77,12 +77,10 @@ val reset_cache: unit -> unit (* Read, save a signature to/from a file *) -val read_signature: string -> string -> signature * Digest.t - (* Arguments: module name, file name. - Results: signature, CRC. *) -val save_signature: signature -> string -> string -> Digest.t - (* Arguments: signature, module name, file name. - Result: CRC. *) +val read_signature: string -> string -> signature + (* Arguments: module name, file name. Results: signature. *) +val save_signature: signature -> string -> string -> unit + (* Arguments: signature, module name, file name. *) (* Return the set of compilation units imported, with their CRC *) @@ -109,6 +107,7 @@ 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 diff --git a/typing/predef.ml b/typing/predef.ml index fc776a0ff..16223de7a 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -57,6 +57,7 @@ and ident_not_found = Ident.create "Not_found" and ident_sys_error = Ident.create "Sys_error" and ident_end_of_file = Ident.create "End_of_file" and ident_division_by_zero = Ident.create "Division_by_zero" +and ident_stack_overflow = Ident.create "Stack_overflow" let path_match_failure = Pident ident_match_failure @@ -102,6 +103,7 @@ let build_initial_env add_type add_exception empty_env = add_exception ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( add_exception ident_out_of_memory [] ( + add_exception ident_stack_overflow [] ( add_exception ident_invalid_argument [type_string] ( add_exception ident_failure [type_string] ( add_exception ident_not_found [] ( @@ -118,11 +120,11 @@ let build_initial_env add_type add_exception empty_env = add_type ident_string decl_abstr ( add_type ident_char decl_abstr ( add_type ident_int decl_abstr ( - empty_env)))))))))))))))))) + empty_env))))))))))))))))))) let builtin_values = List.map (fun id -> Ident.make_global id; (Ident.name id, id)) - [ident_match_failure; ident_out_of_memory; + [ident_match_failure; ident_out_of_memory; ident_stack_overflow; ident_invalid_argument; ident_failure; ident_not_found; ident_sys_error; ident_end_of_file; ident_division_by_zero] |