Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Refactor load path management and initial environment 

- Add a Load_path module which caches files lookup

- Instead of falling back to the external environment, allow to
  declare in the environment that a module comes from the external
  world. This allows persistent structures to shadows non-persistent
  ones
master
Jeremie Dimino 2018-09-18 14:49:18 +01:00 committed by David Allsopp
parent 2956845681
commit 7e0862a212
57 changed files with 760 additions and 321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
.depend
View File

@ -10,11 +10,13 @@ utils/build_path_prefix_map.cmx : \
utils/build_path_prefix_map.cmi :
utils/ccomp.cmo : \
utils/misc.cmi \
utils/load_path.cmi \
utils/config.cmi \
utils/clflags.cmi \
utils/ccomp.cmi
utils/ccomp.cmx : \
utils/misc.cmx \
utils/load_path.cmx \
utils/config.cmx \
utils/clflags.cmx \
utils/ccomp.cmi
@ -53,6 +55,13 @@ utils/identifiable.cmx : \
utils/misc.cmx \
utils/identifiable.cmi
utils/identifiable.cmi :
utils/load_path.cmo : \
utils/misc.cmi \
utils/load_path.cmi
utils/load_path.cmx : \
utils/misc.cmx \
utils/load_path.cmi
utils/load_path.cmi :
utils/misc.cmo : \
utils/config.cmi \
utils/build_path_prefix_map.cmi \
@ -169,6 +178,7 @@ parsing/ast_mapper.cmo : \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/load_path.cmi \
utils/config.cmi \
utils/clflags.cmi \
parsing/asttypes.cmi \
@ -179,6 +189,7 @@ parsing/ast_mapper.cmx : \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
utils/load_path.cmx \
utils/config.cmx \
utils/clflags.cmx \
parsing/asttypes.cmi \
@ -438,6 +449,7 @@ typing/cmt_format.cmo : \
typing/tast_mapper.cmi \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
parsing/lexer.cmi \
typing/env.cmi \
utils/config.cmi \
@ -450,6 +462,7 @@ typing/cmt_format.cmx : \
typing/tast_mapper.cmx \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
parsing/lexer.cmx \
typing/env.cmx \
utils/config.cmx \
@ -526,6 +539,7 @@ typing/env.cmo : \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/load_path.cmi \
typing/ident.cmi \
typing/datarepr.cmi \
utils/consistbl.cmi \
@ -545,6 +559,7 @@ typing/env.cmx : \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
utils/load_path.cmx \
typing/ident.cmx \
typing/datarepr.cmx \
utils/consistbl.cmx \
@ -563,6 +578,7 @@ typing/env.cmi : \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/load_path.cmi \
typing/ident.cmi \
utils/consistbl.cmi \
typing/cmi_format.cmi \
@ -573,6 +589,7 @@ typing/envaux.cmo : \
typing/path.cmi \
typing/ident.cmi \
typing/env.cmi \
parsing/asttypes.cmi \
typing/envaux.cmi
typing/envaux.cmx : \
typing/subst.cmx \
@ -580,6 +597,7 @@ typing/envaux.cmx : \
typing/path.cmx \
typing/ident.cmx \
typing/env.cmx \
parsing/asttypes.cmi \
typing/envaux.cmi
typing/envaux.cmi : \
typing/subst.cmi \
@ -1387,6 +1405,7 @@ typing/typemod.cmo : \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/load_path.cmi \
typing/includemod.cmi \
typing/ident.cmi \
typing/env.cmi \
@ -1418,6 +1437,7 @@ typing/typemod.cmx : \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
utils/load_path.cmx \
typing/includemod.cmx \
typing/ident.cmx \
typing/env.cmx \
@ -1623,6 +1643,7 @@ bytecomp/bytegen.cmi : \
bytecomp/bytelibrarian.cmo : \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
bytecomp/emitcode.cmi \
utils/config.cmi \
bytecomp/cmo_format.cmi \
@ -1632,6 +1653,7 @@ bytecomp/bytelibrarian.cmo : \
bytecomp/bytelibrarian.cmx : \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
bytecomp/emitcode.cmx \
utils/config.cmx \
bytecomp/cmo_format.cmi \
@ -1645,6 +1667,7 @@ bytecomp/bytelink.cmo : \
bytecomp/opcodes.cmo \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
bytecomp/instruct.cmi \
typing/ident.cmi \
bytecomp/emitcode.cmi \
@ -1662,6 +1685,7 @@ bytecomp/bytelink.cmx : \
bytecomp/opcodes.cmx \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
bytecomp/instruct.cmx \
typing/ident.cmx \
bytecomp/emitcode.cmx \
@ -1684,6 +1708,7 @@ bytecomp/bytepackager.cmo : \
typing/path.cmi \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
bytecomp/instruct.cmi \
typing/ident.cmi \
typing/env.cmi \
@ -1702,6 +1727,7 @@ bytecomp/bytepackager.cmx : \
typing/path.cmx \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
bytecomp/instruct.cmx \
typing/ident.cmx \
typing/env.cmx \
@ -1801,6 +1827,7 @@ bytecomp/lambda.cmo : \
typing/primitive.cmi \
typing/path.cmi \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
typing/ident.cmi \
typing/env.cmi \
@ -1811,6 +1838,7 @@ bytecomp/lambda.cmx : \
typing/primitive.cmx \
typing/path.cmx \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
typing/ident.cmx \
typing/env.cmx \
@ -2134,7 +2162,6 @@ bytecomp/translmod.cmo : \
typing/path.cmi \
typing/mtype.cmi \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
bytecomp/lambda.cmi \
typing/ident.cmi \
@ -2156,7 +2183,6 @@ bytecomp/translmod.cmx : \
typing/path.cmx \
typing/mtype.cmx \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
bytecomp/lambda.cmx \
typing/ident.cmx \
@ -2174,7 +2200,6 @@ bytecomp/translmod.cmi : \
bytecomp/translobj.cmo : \
typing/primitive.cmi \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
bytecomp/lambda.cmi \
typing/ident.cmi \
@ -2187,7 +2212,6 @@ bytecomp/translobj.cmo : \
bytecomp/translobj.cmx : \
typing/primitive.cmx \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
bytecomp/lambda.cmx \
typing/ident.cmx \
@ -2393,6 +2417,7 @@ asmcomp/asmgen.cmi : \
asmcomp/asmlibrarian.cmo : \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
asmcomp/export_info.cmi \
utils/config.cmi \
asmcomp/compilenv.cmi \
@ -2405,6 +2430,7 @@ asmcomp/asmlibrarian.cmo : \
asmcomp/asmlibrarian.cmx : \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
asmcomp/export_info.cmx \
utils/config.cmx \
asmcomp/compilenv.cmx \
@ -2420,6 +2446,7 @@ asmcomp/asmlink.cmo : \
utils/profile.cmi \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
asmcomp/emitaux.cmi \
asmcomp/emit.cmi \
utils/consistbl.cmi \
@ -2437,6 +2464,7 @@ asmcomp/asmlink.cmx : \
utils/profile.cmx \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
asmcomp/emitaux.cmx \
asmcomp/emit.cmx \
utils/consistbl.cmx \
@ -2458,6 +2486,7 @@ asmcomp/asmpackager.cmo : \
utils/misc.cmi \
middle_end/middle_end.cmi \
parsing/location.cmi \
utils/load_path.cmi \
bytecomp/lambda.cmi \
typing/ident.cmi \
asmcomp/export_info_for_pack.cmi \
@ -2479,6 +2508,7 @@ asmcomp/asmpackager.cmx : \
utils/misc.cmx \
middle_end/middle_end.cmx \
parsing/location.cmx \
utils/load_path.cmx \
bytecomp/lambda.cmx \
typing/ident.cmx \
asmcomp/export_info_for_pack.cmx \
@ -2781,6 +2811,7 @@ asmcomp/compilenv.cmo : \
typing/path.cmi \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
middle_end/base_types/linkage_name.cmi \
typing/ident.cmi \
asmcomp/export_info.cmi \
@ -2800,6 +2831,7 @@ asmcomp/compilenv.cmx : \
typing/path.cmx \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
middle_end/base_types/linkage_name.cmx \
typing/ident.cmx \
asmcomp/export_info.cmx \
@ -5408,6 +5440,7 @@ driver/compmisc.cmo : \
typing/typemod.cmi \
utils/misc.cmi \
parsing/location.cmi \
utils/load_path.cmi \
typing/ident.cmi \
typing/env.cmi \
utils/config.cmi \
@ -5419,6 +5452,7 @@ driver/compmisc.cmx : \
typing/typemod.cmx \
utils/misc.cmx \
parsing/location.cmx \
utils/load_path.cmx \
typing/ident.cmx \
typing/env.cmx \
utils/config.cmx \
@ -5429,18 +5463,16 @@ driver/compmisc.cmi : \
typing/env.cmi \
utils/clflags.cmi
driver/compplugin.cmo : \
utils/misc.cmi \
parsing/location.cmi \
utils/config.cmi \
utils/load_path.cmi \
driver/compmisc.cmi \
driver/compenv.cmi \
driver/compdynlink.cmi \
utils/clflags.cmi \
driver/compplugin.cmi
driver/compplugin.cmx : \
utils/misc.cmx \
parsing/location.cmx \
utils/config.cmx \
utils/load_path.cmx \
driver/compmisc.cmx \
driver/compenv.cmx \
driver/compdynlink.cmi \
@ -5702,6 +5734,8 @@ toplevel/opttopdirs.cmo : \
toplevel/opttoploop.cmi \
utils/misc.cmi \
parsing/longident.cmi \
utils/load_path.cmi \
typing/ident.cmi \
typing/env.cmi \
typing/ctype.cmi \
utils/config.cmi \
@ -5716,6 +5750,8 @@ toplevel/opttopdirs.cmx : \
toplevel/opttoploop.cmx \
utils/misc.cmx \
parsing/longident.cmx \
utils/load_path.cmx \
typing/ident.cmx \
typing/env.cmx \
typing/ctype.cmx \
utils/config.cmx \
@ -5750,6 +5786,7 @@ toplevel/opttoploop.cmo : \
middle_end/middle_end.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/load_path.cmi \
parsing/lexer.cmi \
bytecomp/lambda.cmi \
typing/includemod.cmi \
@ -5795,6 +5832,7 @@ toplevel/opttoploop.cmx : \
middle_end/middle_end.cmx \
parsing/longident.cmx \
parsing/location.cmx \
utils/load_path.cmx \
parsing/lexer.cmx \
bytecomp/lambda.cmx \
typing/includemod.cmx \
@ -5869,6 +5907,7 @@ toplevel/topdirs.cmo : \
bytecomp/meta.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/load_path.cmi \
typing/ident.cmi \
typing/env.cmi \
bytecomp/dll.cmi \
@ -5897,6 +5936,7 @@ toplevel/topdirs.cmx : \
bytecomp/meta.cmx \
parsing/longident.cmx \
parsing/location.cmx \
utils/load_path.cmx \
typing/ident.cmx \
typing/env.cmx \
bytecomp/dll.cmx \
@ -5938,6 +5978,7 @@ toplevel/toploop.cmo : \
bytecomp/meta.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/load_path.cmi \
parsing/lexer.cmi \
typing/includemod.cmi \
typing/ident.cmi \
@ -5982,6 +6023,7 @@ toplevel/toploop.cmx : \
bytecomp/meta.cmx \
parsing/longident.cmx \
parsing/location.cmx \
utils/load_path.cmx \
parsing/lexer.cmx \
typing/includemod.cmx \
typing/ident.cmx \

7
Changes
View File

@ -55,6 +55,10 @@ OCaml 4.08.0
(Alban Reynaud and Gabriel Scherer,
review by Jeremy Yallop and Armaël Guéneau)
* MPR#7814, GPR#2041: allow modules from include directories to shadow
other ones, even in the toplevel
(Jérémie Dimino, review by Alain Frisch and David Allsopp)
### Standard library:
- GPR#2128: Add Fun module.
@ -606,6 +610,9 @@ OCaml 4.08.0
for parser testing. See parsing/HACKING.adoc.
(Gabriel Scherer, review by Nicolás Ojeda Bär)
* GPR#2041: add a cache for looking up files in the load path
(Jérémie Dimino, review by Alain Frisch and David Allsopp)
- GPR#2047: a new type for unification traces
(Florian Angeletti, review by Thomas Refis and Gabriel Scherer)

1
Makefile
View File

@ -73,6 +73,7 @@ OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
UTILS=utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
utils/clflags.cmo utils/profile.cmo \
utils/load_path.cmo \
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo \
utils/strongly_connected_components.cmo \

2
asmcomp/asmlibrarian.ml
View File

@ -34,7 +34,7 @@ let default_ui_export_info =
let read_info name =
let filename =
try
find_in_path !load_path name
Load_path.find name
with Not_found ->
raise(Error(File_not_found name)) in
let (info, crc) = Compilenv.read_unit_info filename in

6
asmcomp/asmlink.ml
View File

@ -112,14 +112,14 @@ let runtime_lib () =
else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in
try
if !Clflags.nopervasives then []
else [ find_in_path !load_path libname ]
else [ Load_path.find libname ]
with Not_found ->
raise(Error(File_not_found libname))
let object_file_name name =
let file_name =
try
find_in_path !load_path name
Load_path.find name
with Not_found ->
fatal_errorf "Asmlink.object_file_name: %s not found" name in
if Filename.check_suffix file_name ".cmx" then
@ -159,7 +159,7 @@ type file =
let read_file obj_name =
let file_name =
try
find_in_path !load_path obj_name
Load_path.find obj_name
with Not_found ->
raise(Error(File_not_found obj_name)) in
if Filename.check_suffix file_name ".cmx" then begin

2
asmcomp/asmpackager.ml
View File

@ -237,7 +237,7 @@ let package_files ~ppf_dump initial_env files targetcmx ~backend =
let files =
List.map
(fun f ->
try find_in_path !Config.load_path f
try Load_path.find f
with Not_found -> raise(Error(File_not_found f)))
files in
let prefix = chop_extensions targetcmx in

3
asmcomp/compilenv.ml
View File

@ -22,7 +22,6 @@
[@@@ocaml.warning "+a-4-9-40-41-42"]
open Config
open Misc
open Cmx_format
type error =
@ -196,7 +195,7 @@ let get_global_info global_ident = (
else begin
try
let filename =
find_in_path_uncap !load_path (modname ^ ".cmx") in
Load_path.find_uncap (modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

2
bytecomp/bytelibrarian.ml
View File

@ -58,7 +58,7 @@ let add_ccobjs l =
let copy_object_file oc name =
let file_name =
try
find_in_path !load_path name
Load_path.find name
with Not_found ->
raise(Error(File_not_found name)) in
let ic = open_in_bin file_name in

6
bytecomp/bytelink.ml
View File

@ -109,7 +109,7 @@ let remove_required (rel, _pos) =
let scan_file obj_name tolink =
let file_name =
try
find_in_path !load_path obj_name
Load_path.find obj_name
with Not_found ->
raise(Error(File_not_found obj_name)) in
let ic = open_in_bin file_name in
@ -314,7 +314,7 @@ let link_bytecode tolink exec_name standalone =
if String.length !Clflags.use_runtime > 0
then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant
in
let inchan = open_in_bin (find_in_path !load_path header) in
let inchan = open_in_bin (Load_path.find header) in
copy_file inchan outchan;
close_in inchan
with Not_found | Sys_error _ -> ()
@ -335,7 +335,7 @@ let link_bytecode tolink exec_name standalone =
if check_dlls then begin
(* Initialize the DLL machinery *)
Dll.init_compile !Clflags.no_std_include;
Dll.add_path !load_path;
Dll.add_path (Load_path.get_paths ());
try Dll.open_dlls Dll.For_checking sharedobjs
with Failure reason -> raise(Error(Cannot_open_dll reason))
end;

2
bytecomp/bytepackager.ml
View File

@ -281,7 +281,7 @@ let package_files ~ppf_dump initial_env files targetfile =
let files =
List.map
(fun f ->
try find_in_path !Config.load_path f
try Load_path.find f
with Not_found -> raise(Error(File_not_found f)))
files in
let prefix = chop_extensions targetfile in

11
bytecomp/lambda.ml
View File

@ -638,6 +638,8 @@ let transl_path find loc env path =
fatal_error ("Cannot find address for: " ^ (Path.name path))
| addr -> transl_address loc addr
(* Translation of identifiers *)
let transl_module_path loc env path =
transl_path Env.find_module_address loc env path
@ -650,6 +652,15 @@ let transl_extension_path loc env path =
let transl_class_path loc env path =
transl_path Env.find_class_address loc env path
let transl_prim mod_name name =
let pers = Ident.create_persistent mod_name in
let env = Env.add_persistent_structure pers Env.empty in
let lid = Longident.Ldot (Longident.Lident mod_name, name) in
match Env.lookup_value lid env with
| path, _ -> transl_value_path Location.none env path
| exception Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
(* Compile a sequence of expressions *)
let rec make_sequence fn = function

7
bytecomp/lambda.mli
View File

@ -351,6 +351,13 @@ val shallow_iter:
(** Same as [iter_head_constructor], but use a different callback for
sub-terms which are in tail position or not. *)
val transl_prim: string -> string -> lambda
(** Translate a value from a persistent module. For instance:
{[
transl_internal_value "CamlinternalLazy" "force"
]}
*)
val free_variables: lambda -> Ident.Set.t

4
bytecomp/matching.ml
View File

@ -1464,7 +1464,9 @@ let prim_obj_tag =
let get_mod_field modname field =
lazy (
match Env.open_pers_signature modname Env.initial_safe_string with
let mod_ident = Ident.create_persistent modname in
let env = Env.add_persistent_structure mod_ident Env.initial_safe_string in
match Env.open_pers_signature modname env with
| exception Not_found -> fatal_error ("Module "^modname^" unavailable.")
| env -> begin
match Env.lookup_value (Longident.Lident field) env with

9
bytecomp/translmod.ml
View File

@ -18,7 +18,6 @@
open Misc
open Asttypes
open Longident
open Path
open Types
open Typedtree
@ -200,13 +199,7 @@ let record_primitive = function
(* Utilities for compiling "module rec" definitions *)
let mod_prim name =
let env = Env.empty in
let lid = Ldot (Lident "CamlinternalMod", name) in
match Env.lookup_value lid env with
| path, _ -> transl_value_path Location.none env path
| exception Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
let mod_prim = Lambda.transl_prim "CamlinternalMod"
let undefined_location loc =
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in

10
bytecomp/translobj.ml
View File

@ -13,20 +13,12 @@
(* *)
(**************************************************************************)
open Misc
open Asttypes
open Longident
open Lambda
(* Get oo primitives identifiers *)
let oo_prim name =
let env = Env.empty in
let lid = Ldot (Lident "CamlinternalOO", name) in
match Env.lookup_value lid env with
| path, _ -> transl_value_path Location.none env path
| exception Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
let oo_prim = Lambda.transl_prim "CamlinternalOO"
(* Share blocks *)

24
debugger/.depend
View File

@ -49,10 +49,10 @@ command_line.cmo : \
parser_aux.cmi \
parser.cmi \
parameters.cmi \
../utils/misc.cmi \
../parsing/longident.cmi \
../parsing/location.cmi \
loadprinter.cmi \
../utils/load_path.cmi \
lexer.cmi \
int64ops.cmi \
../bytecomp/instruct.cmi \
@ -66,7 +66,6 @@ command_line.cmo : \
debugger_config.cmi \
debugcom.cmi \
../typing/ctype.cmi \
../utils/config.cmi \
checkpoints.cmi \
breakpoints.cmi \
command_line.cmi
@ -88,10 +87,10 @@ command_line.cmx : \
parser_aux.cmi \
parser.cmx \
parameters.cmx \
../utils/misc.cmx \
../parsing/longident.cmx \
../parsing/location.cmx \
loadprinter.cmx \
../utils/load_path.cmx \
lexer.cmx \
int64ops.cmx \
../bytecomp/instruct.cmx \
@ -105,7 +104,6 @@ command_line.cmx : \
debugger_config.cmx \
debugcom.cmx \
../typing/ctype.cmx \
../utils/config.cmx \
checkpoints.cmx \
breakpoints.cmx \
command_line.cmi
@ -256,9 +254,9 @@ loadprinter.cmo : \
parameters.cmi \
../utils/misc.cmi \
../parsing/longident.cmi \
../utils/load_path.cmi \
../typing/env.cmi \
../typing/ctype.cmi \
../utils/config.cmi \
../driver/compdynlink.cmi \
loadprinter.cmi
loadprinter.cmx : \
@ -270,9 +268,9 @@ loadprinter.cmx : \
parameters.cmx \
../utils/misc.cmx \
../parsing/longident.cmx \
../utils/load_path.cmx \
../typing/env.cmx \
../typing/ctype.cmx \
../utils/config.cmx \
../driver/compdynlink.cmi \
loadprinter.cmi
loadprinter.cmi : \
@ -289,6 +287,7 @@ main.cmo : \
parameters.cmi \
../utils/misc.cmi \
loadprinter.cmi \
../utils/load_path.cmi \
input_handling.cmi \
frames.cmi \
exec.cmi \
@ -310,6 +309,7 @@ main.cmx : \
parameters.cmx \
../utils/misc.cmx \
loadprinter.cmx \
../utils/load_path.cmx \
input_handling.cmx \
frames.cmx \
exec.cmx \
@ -321,13 +321,13 @@ main.cmx : \
../utils/clflags.cmx \
checkpoints.cmx
parameters.cmo : \
primitives.cmi \
../utils/load_path.cmi \
../typing/envaux.cmi \
debugger_config.cmi \
../utils/config.cmi \
parameters.cmi
parameters.cmx : \
primitives.cmx \
../utils/load_path.cmx \
../typing/envaux.cmx \
debugger_config.cmx \
../utils/config.cmx \
@ -443,12 +443,12 @@ program_management.cmo : \
program_loading.cmi \
primitives.cmi \
parameters.cmi \
../utils/load_path.cmi \
int64ops.cmi \
input_handling.cmi \
history.cmi \
../typing/envaux.cmi \
debugger_config.cmi \
../utils/config.cmi \
breakpoints.cmi \
program_management.cmi
program_management.cmx : \
@ -460,12 +460,12 @@ program_management.cmx : \
program_loading.cmx \
primitives.cmx \
parameters.cmx \
../utils/load_path.cmx \
int64ops.cmx \
input_handling.cmx \
history.cmx \
../typing/envaux.cmx \
debugger_config.cmx \
../utils/config.cmx \
breakpoints.cmx \
program_management.cmi
program_management.cmi :
@ -533,14 +533,14 @@ show_source.cmi : \
source.cmo : \
primitives.cmi \
../utils/misc.cmi \
../utils/load_path.cmi \
debugger_config.cmi \
../utils/config.cmi \
source.cmi
source.cmx : \
primitives.cmx \
../utils/misc.cmx \
../utils/load_path.cmx \
debugger_config.cmx \
../utils/config.cmx \
source.cmi
source.cmi :
symbols.cmo : \

2
debugger/Makefile
View File

@ -39,7 +39,7 @@ INCLUDES=$(addprefix -I ,$(DIRECTORIES))
utils_modules := $(addprefix utils/,\
config build_path_prefix_map misc identifiable numbers arg_helper clflags \
consistbl warnings terminfo)
consistbl warnings terminfo load_path)
parsing_modules := $(addprefix parsing/,\
location longident docstrings syntaxerr ast_helper ast_mapper ast_iterator \

7
debugger/command_line.ml
View File

@ -18,7 +18,6 @@
open Int64ops
open Format
open Misc
open Instruct
open Unix
open Debugger_config
@ -263,7 +262,7 @@ let instr_dir ppf lexbuf =
let new_directory = argument_list_eol argument lexbuf in
if new_directory = [] then begin
if yes_or_no "Reinitialize directory list" then begin
Config.load_path := !default_load_path;
Load_path.init !default_load_path;
Envaux.reset_cache ();
Hashtbl.clear Debugger_config.load_path_for;
flush_buffer_list ()
@ -279,7 +278,7 @@ let instr_dir ppf lexbuf =
List.iter (function x -> add_path (expand_path x)) new_directory'
end;
let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in
fprintf ppf "@[<2>Directories: %a@]@." print_dirs !Config.load_path;
fprintf ppf "@[<2>Directories: %a@]@." print_dirs (Load_path.get_paths ());
Hashtbl.iter
(fun mdl dirs ->
fprintf ppf "@[<2>Source directories for %s: %a@]@." mdl print_dirs
@ -562,7 +561,7 @@ let instr_source ppf lexbuf =
let io_chan =
try
io_channel_of_descr
(openfile (find_in_path !Config.load_path (expand_path file))
(openfile (Load_path.find (expand_path file))
[O_RDONLY] 0)
with
| Not_found -> error "Source file not found."

6
debugger/loadprinter.ml
View File

@ -58,12 +58,12 @@ open Format
let rec loadfiles ppf name =
try
let filename = find_in_path !Config.load_path name in
let filename = Load_path.find name in
use_debugger_symtable Compdynlink.loadfile filename;
let d = Filename.dirname name in
if d <> Filename.current_dir_name then begin
if not (List.mem d !Config.load_path) then
Config.load_path := d :: !Config.load_path;
if not (List.mem d (Load_path.get_paths ())) then
Load_path.add_dir d;
end;
fprintf ppf "File %s loaded@." filename;
true

2
debugger/main.ml
View File

@ -226,7 +226,7 @@ let main () =
if !Parameters.version
then printf "\tOCaml Debugger version %s@.@." Config.version;
Loadprinter.init();
Config.load_path := !default_load_path;
Load_path.init !default_load_path;
Clflags.recursive_types := true; (* Allow recursive types. *)
toplevel_loop (); (* Toplevel. *)
kill_program ();

4
debugger/parameters.ml
View File

@ -16,8 +16,6 @@
(* Miscellaneous parameters *)
open Primitives
open Config
open Debugger_config
let program_name = ref ""
@ -35,7 +33,7 @@ let version = ref true
let topdirs_path = ref (Filename.concat Config.standard_library "compiler-libs")
let add_path dir =
load_path := dir :: except dir !load_path;
Load_path.add_dir dir;
Envaux.reset_cache()
let add_path_for mdl dir =

2
debugger/program_management.ml
View File

@ -127,7 +127,7 @@ let initialize_loading () =
raise Toplevel;
end;
Symbols.read_symbols !program_name;
Config.load_path := !Config.load_path @ !Symbols.program_source_dirs;
Load_path.init (Load_path.get_paths () @ !Symbols.program_source_dirs);
Envaux.reset_cache ();
if !debug_loading then
prerr_endline "Opening a socket...";

2
debugger/source.ml
View File

@ -40,7 +40,7 @@ let source_of_module pos mdle =
else
acc)
Debugger_config.load_path_for
!Config.load_path in
(Load_path.get_paths ()) in
let fname = pos.Lexing.pos_fname in
if fname = "" then
let innermost_module =

3
driver/compmisc.ml
View File

@ -34,8 +34,7 @@ let init_path ?(dir="") native =
in
let exp_dirs =
List.map (Misc.expand_directory Config.standard_library) dirs in
Config.load_path := dir ::
List.rev_append exp_dirs (Clflags.std_include_dir ());
Load_path.init (dir :: List.rev_append exp_dirs (Clflags.std_include_dir ()));
Env.reset_cache ()
(* Return the initial environment in which compilation proceeds. *)

2
driver/compplugin.ml
View File

@ -28,7 +28,7 @@ let load plugin_name =
if Filename.is_implicit plugin_name then
try
Compmisc.init_path !Clflags.native_code;
Misc.find_in_path !Config.load_path plugin_name
Load_path.find plugin_name
with Not_found ->
failwith (Printf.sprintf "Cannot find plugin %s in load path"
plugin_name)

2
otherlibs/dynlink/Makefile
View File

@ -46,7 +46,7 @@ COMPILEROBJS = $(addprefix $(ROOTDIR)/,\
utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
utils/clflags.cmo utils/consistbl.cmo \
utils/terminfo.cmo utils/warnings.cmo \
utils/terminfo.cmo utils/warnings.cmo utils/load_path.cmo \
parsing/location.cmo parsing/longident.cmo \
parsing/docstrings.cmo parsing/syntaxerr.cmo \
parsing/ast_helper.cmo parsing/ast_mapper.cmo parsing/ast_iterator.cmo \

4
parsing/ast_mapper.ml
View File

@ -798,7 +798,7 @@ module PpxContext = struct
[
lid "tool_name", make_string tool_name;
lid "include_dirs", make_list make_string !Clflags.include_dirs;
lid "load_path", make_list make_string !Config.load_path;
lid "load_path", make_list make_string (Load_path.get_paths ());
lid "open_modules", make_list make_string !Clflags.open_modules;
lid "for_package", make_option make_string !Clflags.for_package;
lid "debug", make_bool !Clflags.debug;
@ -868,7 +868,7 @@ module PpxContext = struct
| "include_dirs" ->
Clflags.include_dirs := get_list get_string payload
| "load_path" ->
Config.load_path := get_list get_string payload
Load_path.init (get_list get_string payload)
| "open_modules" ->
Clflags.open_modules := get_list get_string payload
| "for_package" ->

2
parsing/ast_mapper.mli
View File

@ -121,7 +121,7 @@ val tool_name: unit -> string
["ocaml"], ... Some global variables that reflect command-line
options are automatically synchronized between the calling tool
and the ppx preprocessor: {!Clflags.include_dirs},
{!Config.load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
{!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
{!Clflags.debug}. *)

6
testsuite/tests/self-contained-toplevel/main.ml
View File

@ -30,4 +30,10 @@ let () =
; cmi = Marshal.from_string Cached_cmi.foo 0
}
| _ -> old_loader unit_name);
Toploop.add_hook (function
| Toploop.After_setup ->
Toploop.toplevel_env :=
Env.add_persistent_structure (Ident.create_persistent "Foo")
!Toploop.toplevel_env
| _ -> ());
Topmain.main ()

2
testsuite/tests/tool-toplevel/pr6468.compilers.reference
View File

@ -8,5 +8,5 @@ val g : unit -> int = <fun>
Exception: Not_found.
Raised at file "//toplevel//", line 2, characters 17-26
Called from file "//toplevel//", line 1, characters 11-15
Called from file "toplevel/toploop.ml", line 193, characters 17-27
Called from file "toplevel/toploop.ml", line 208, characters 17-27

4
tools/.depend
View File

@ -50,10 +50,10 @@ cmt2annot.cmo : \
../typing/path.cmi \
../typing/oprint.cmi \
../parsing/location.cmi \
../utils/load_path.cmi \
../typing/ident.cmi \
../typing/envaux.cmi \
../typing/env.cmi \
../utils/config.cmi \
../typing/cmt_format.cmi \
../parsing/asttypes.cmi \
../typing/annot.cmi
@ -67,10 +67,10 @@ cmt2annot.cmx : \
../typing/path.cmx \
../typing/oprint.cmx \
../parsing/location.cmx \
../utils/load_path.cmx \
../typing/ident.cmx \
../typing/envaux.cmx \
../typing/env.cmx \
../utils/config.cmx \
../typing/cmt_format.cmx \
../parsing/asttypes.cmi \
../typing/annot.cmi

3
tools/Makefile
View File

@ -167,7 +167,8 @@ clean::
OCAMLMKTOP=ocamlmktop.cmo
OCAMLMKTOP_IMPORTS=config.cmo build_path_prefix_map.cmo misc.cmo \
identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo ccomp.cmo
identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo \
load_path.cmo ccomp.cmo
$(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),)

2
tools/cmt2annot.ml
View File

@ -197,7 +197,7 @@ let record_cmt_info cmt =
let gen_annot ?(save_cmt_info=false) target_filename filename cmt =
let open Cmt_format in
Envaux.reset_cache ();
Config.load_path := cmt.cmt_loadpath @ !Config.load_path;
List.iter Load_path.add_dir (List.rev cmt.cmt_loadpath);
let target_filename =
match target_filename with
| None -> Some (filename ^ ".annot")

21
toplevel/opttopdirs.ml
View File

@ -34,13 +34,26 @@ let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit)
let dir_directory s =
let d = expand_directory Config.standard_library s in
Config.load_path := d :: !Config.load_path
let dir = Load_path.Dir.create d in
Load_path.add dir;
toplevel_env :=
Stdlib.String.Set.fold
(fun name env ->
Env.add_persistent_structure (Ident.create_persistent name) env)
(Env.persistent_structures_of_dir dir)
!toplevel_env
let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
(* To remove a directory from the load path *)
let dir_remove_directory s =
let d = expand_directory Config.standard_library s in
Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path
let keep id =
match Load_path.find_uncap (Ident.name id ^ ".cmi") with
| exception Not_found -> true
| fn -> Filename.dirname fn <> d
in
toplevel_env := Env.filter_non_loaded_persistent keep !toplevel_env;
Load_path.remove_dir s
let _ =
Hashtbl.add directive_table "remove_directory"
@ -49,7 +62,7 @@ let _ =
let _ = Hashtbl.add directive_table "show_dirs"
(Directive_none
(fun () ->
List.iter print_endline !Config.load_path
List.iter print_endline (Load_path.get_paths ())
))
(* To change the current directory *)
@ -62,7 +75,7 @@ let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd)
let load_file ppf name0 =
let name =
try Some (find_in_path !Config.load_path name0)
try Some (Load_path.find name0)
with Not_found -> None
in
match name with

41
toplevel/opttoploop.ml
View File

@ -193,10 +193,26 @@ let parse_mod_use_file name lb =
]
]
(* Hooks for initialization *)
(* Hook for initialization *)
let toplevel_startup_hook = ref (fun () -> ())
type event = ..
type event +=
| Startup
| After_setup
let hooks = ref []
let add_hook f = hooks := f :: !hooks
let () =
add_hook (function
| Startup -> !toplevel_startup_hook ()
| _ -> ())
let run_hooks hook = List.iter (fun f -> f hook) !hooks
(* Load in-core and execute a lambda term *)
let phrase_seqid = ref 0
@ -437,7 +453,7 @@ let use_file ppf wrap_mod name =
if name = "" then
("(stdin)", stdin, false)
else begin
let filename = find_in_path !Config.load_path name in
let filename = Load_path.find name in
let ic = open_in_bin filename in
(filename, ic, true)
end
@ -544,14 +560,17 @@ let set_paths () =
but keep the directories that user code linked in with ocamlmktop
may have added to load_path. *)
let expand = Misc.expand_directory Config.standard_library in
load_path := List.concat [
[ "" ];
List.map expand (List.rev !Compenv.first_include_dirs);
List.map expand (List.rev !Clflags.include_dirs);
List.map expand (List.rev !Compenv.last_include_dirs);
!load_path;
[expand "+camlp4"];
]
let current_load_path = Load_path.get_paths () in
let load_path = List.concat [
[ "" ];
List.map expand (List.rev !Compenv.first_include_dirs);
List.map expand (List.rev !Clflags.include_dirs);
List.map expand (List.rev !Compenv.last_include_dirs);
current_load_path;
[expand "+camlp4"];
]
in
Load_path.init load_path
let initialize_toplevel_env () =
toplevel_env := Compmisc.initial_env()
@ -570,6 +589,7 @@ let loop ppf =
Location.input_name := "//toplevel//";
Location.input_lexbuf := Some lb;
Sys.catch_break true;
run_hooks After_setup;
load_ocamlinit ppf;
while true do
let snap = Btype.snapshot () in
@ -609,6 +629,7 @@ let run_script ppf name args =
(* Note: would use [Filename.abspath] here, if we had it. *)
toplevel_env := Compmisc.initial_env();
Sys.interactive := false;
run_hooks After_setup;
let explicit_name =
(* Prevent use_silently from searching in the path. *)
if Filename.is_implicit name

19
toplevel/opttoploop.mli
View File

@ -120,10 +120,27 @@ val print_out_phrase :
val read_interactive_input : (string -> bytes -> int -> int * bool) ref
(* Hooks for initialization *)
(* Hooks *)
val toplevel_startup_hook : (unit -> unit) ref
type event = ..
type event +=
| Startup
| After_setup
(* Just after the setup, when the toplevel is ready to evaluate user
input. This happens before the toplevel has evaluated any kind of
user input, in particular this happens before loading the
[.ocamlinit] file. *)
val add_hook : (event -> unit) -> unit
(* Add a function that will be called at key points of the toplevel
initialization process. *)
val run_hooks : event -> unit
(* Run all the registered hooks. *)
(* Misc *)
val override_sys_argv : string array -> unit

2
toplevel/opttopmain.ml
View File

@ -45,7 +45,7 @@ let prepare ppf =
let res =
List.for_all (Opttopdirs.load_file ppf) (List.rev !preload_objects)
in
!Opttoploop.toplevel_startup_hook ();
Opttoploop.run_hooks Opttoploop.Startup;
res
with x ->
try Location.report_exception ppf x; false

30
toplevel/topdirs.ml
View File

@ -70,8 +70,15 @@ let _ = add_directive "quit" (Directive_none dir_quit)
let dir_directory s =
let d = expand_directory Config.standard_library s in
Config.load_path := d :: !Config.load_path;
Dll.add_path [d]
Dll.add_path [d];
let dir = Load_path.Dir.create d in
Load_path.add dir;
toplevel_env :=
Stdlib.String.Set.fold
(fun name env ->
Env.add_persistent_structure (Ident.create_persistent name) env)
(Env.persistent_structures_of_dir dir)
!toplevel_env
let _ = add_directive "directory" (Directive_string dir_directory)
{
@ -83,7 +90,13 @@ let _ = add_directive "directory" (Directive_string dir_directory)
(* To remove a directory from the load path *)
let dir_remove_directory s =
let d = expand_directory Config.standard_library s in
Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path;
let keep id =
match Load_path.find_uncap (Ident.name id ^ ".cmi") with
| exception Not_found -> true
| fn -> Filename.dirname fn <> d
in
toplevel_env := Env.filter_non_loaded_persistent keep !toplevel_env;
Load_path.remove_dir s;
Dll.remove_path [d]
let _ = add_directive "remove_directory" (Directive_string dir_remove_directory)
@ -153,7 +166,7 @@ let load_compunit ic filename ppf compunit =
let rec load_file recursive ppf name =
let filename =
try Some (find_in_path !Config.load_path name) with Not_found -> None
try Some (Load_path.find name) with Not_found -> None
in
match filename with
| None -> fprintf ppf "Cannot find file %s.@." name; false
@ -176,12 +189,9 @@ and really_load_file recursive ppf name filename ic =
| (Reloc_getglobal id, _)
when not (Symtable.is_global_defined id) ->
let file = Ident.name id ^ ".cmo" in
begin match try Some (Misc.find_in_path_uncap !Config.load_path
file)
with Not_found -> None
with
| None -> ()
| Some file ->
begin match Load_path.find_uncap file with
| exception Not_found -> ()
| file ->
if not (load_file recursive ppf file) then raise Load_failed
end
| _ -> ()

44
toplevel/toploop.ml
View File

@ -16,7 +16,6 @@
(* The interactive toplevel loop *)
open Format
open Config
open Misc
open Parsetree
open Types
@ -154,10 +153,26 @@ let parse_mod_use_file name lb =
]
]
(* Hooks for initialization *)
(* Hook for initialization *)
let toplevel_startup_hook = ref (fun () -> ())
type event = ..
type event +=
| Startup
| After_setup
let hooks = ref []
let add_hook f = hooks := f :: !hooks
let () =
add_hook (function
| Startup -> !toplevel_startup_hook ()
| _ -> ())
let run_hooks hook = List.iter (fun f -> f hook) !hooks
(* Load in-core and execute a lambda term *)
let may_trace = ref false (* Global lock on tracing *)
@ -384,7 +399,7 @@ let use_file ppf wrap_mod name =
if name = "" then
("(stdin)", stdin, false)
else begin
let filename = find_in_path !Config.load_path name in
let filename = Load_path.find name in
let ic = open_in_bin filename in
(filename, ic, true)
end
@ -504,15 +519,18 @@ let set_paths () =
but keep the directories that user code linked in with ocamlmktop
may have added to load_path. *)
let expand = Misc.expand_directory Config.standard_library in
load_path := List.concat [
[ "" ];
List.map expand (List.rev !Compenv.first_include_dirs);
List.map expand (List.rev !Clflags.include_dirs);
List.map expand (List.rev !Compenv.last_include_dirs);
!load_path;
[expand "+camlp4"];
];
Dll.add_path !load_path
let current_load_path = Load_path.get_paths () in
let load_path = List.concat [
[ "" ];
List.map expand (List.rev !Compenv.first_include_dirs);
List.map expand (List.rev !Clflags.include_dirs);
List.map expand (List.rev !Compenv.last_include_dirs);
current_load_path;
[expand "+camlp4"];
]
in
Load_path.init load_path;
Dll.add_path load_path
let initialize_toplevel_env () =
toplevel_env := Compmisc.initial_env()
@ -536,6 +554,7 @@ let loop ppf =
Location.input_name := "//toplevel//";
Location.input_lexbuf := Some lb;
Sys.catch_break true;
run_hooks After_setup;
load_ocamlinit ppf;
while true do
let snap = Btype.snapshot () in
@ -574,6 +593,7 @@ let run_script ppf name args =
Location.report_exception ppf exn; exit 2
end;
Sys.interactive := false;
run_hooks After_setup;
let explicit_name =
(* Prevent use_silently from searching in the path. *)
if name <> "" && Filename.is_implicit name

20
toplevel/toploop.mli
View File

@ -71,7 +71,7 @@ val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool
First bool says whether the values and types of the results
should be printed. Uncaught exceptions are always printed. *)
val preprocess_phrase :
formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase
formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase
(* Preprocess the given toplevel phrase using regular and ppx
preprocessors. Return the updated phrase. *)
val use_file : formatter -> string -> bool
@ -141,10 +141,26 @@ val print_out_phrase :
val read_interactive_input : (string -> bytes -> int -> int * bool) ref
(* Hooks for initialization *)
(* Hooks *)
val toplevel_startup_hook : (unit -> unit) ref
type event = ..
type event +=
| Startup
| After_setup
(* Just after the setup, when the toplevel is ready to evaluate user
input. This happens before the toplevel has evaluated any kind of
user input, in particular this happens before loading the
[.ocamlinit] file. *)
val add_hook : (event -> unit) -> unit
(* Add a function that will be called at key points of the toplevel
initialization process. *)
val run_hooks : event -> unit
(* Run all the registered hooks. *)
(* Used by Trace module *)
val may_trace : bool ref

2
toplevel/topmain.ml
View File

@ -48,7 +48,7 @@ let prepare ppf =
in
List.for_all (Topdirs.load_file ppf) objects
in
!Toploop.toplevel_startup_hook ();
Toploop.run_hooks Toploop.Startup;
res
with x ->
try Location.report_exception ppf x; false

2
typing/cmt_format.ml
View File

@ -181,7 +181,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi =
cmt_args = Sys.argv;
cmt_sourcefile = sourcefile;
cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
cmt_loadpath = !Config.load_path;
cmt_loadpath = Load_path.get_paths ();
cmt_source_digest = source_digest;
cmt_initial_env = if need_to_clear_env then
keep_only_summary initial_env else initial_env;

372
typing/env.ml
View File

@ -16,7 +16,6 @@
(* Environment handling *)
open Cmi_format
open Config
open Misc
open Asttypes
open Longident
@ -172,10 +171,11 @@ type summary =
| Env_modtype of summary * Ident.t * modtype_declaration
| Env_class of summary * Ident.t * class_declaration
| Env_cltype of summary * Ident.t * class_type_declaration
| Env_open of summary * String.Set.t * Path.t
| Env_open of summary * Path.t
| Env_functor_arg of summary * Ident.t
| Env_constraints of summary * type_declaration Path.Map.t
| Env_copy_types of summary * string list
| Env_persistent of summary * Ident.t
type address =
| Aident of Ident.t
@ -329,6 +329,9 @@ module IdTbl =
let add id x tbl =
{tbl with current = Ident.add id x tbl.current}
let remove id tbl =
{tbl with current = Ident.remove id tbl.current}
let add_open slot wrap root components next =
let using =
match slot with
@ -462,14 +465,18 @@ type type_descriptions =
let in_signature_flag = 0x01
type 'a value_or_persistent =
| Value of 'a
| Persistent
type t = {
values: (value_description * address_lazy) IdTbl.t;
constrs: (constructor_description * address_lazy option) TycompTbl.t;
labels: label_description TycompTbl.t;
types: (type_declaration * type_descriptions) IdTbl.t;
modules: (module_declaration_lazy * address_lazy) IdTbl.t;
modules: (module_declaration_lazy * address_lazy) value_or_persistent IdTbl.t;
modtypes: modtype_declaration IdTbl.t;
components: (module_components * address_lazy) IdTbl.t;
components: (module_components * address_lazy) value_or_persistent IdTbl.t;
classes: (class_declaration * address_lazy) IdTbl.t;
cltypes: class_type_declaration IdTbl.t;
functor_args: unit Ident.tbl;
@ -736,11 +743,22 @@ module Persistent_signature = struct
cmi : Cmi_format.cmi_infos }
let load = ref (fun ~unit_name ->
match find_in_path_uncap !load_path (unit_name ^ ".cmi") with
| filename -> Some { filename; cmi = read_cmi filename }
| exception Not_found -> None)
match Load_path.find_uncap (unit_name ^ ".cmi") with
| filename -> Some { filename; cmi = read_cmi filename }
| exception Not_found -> None)
end
let add_persistent_structure id env =
if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure";
if Ident.name id <> !current_unit then
{ env with
modules = IdTbl.add id Persistent env.modules;
components = IdTbl.add id Persistent env.components;
summary = Env_persistent (env.summary, id);
}
else
env
let acknowledge_pers_struct check modname
{ Persistent_signature.filename; cmi } =
let name = cmi.cmi_name in
@ -755,9 +773,15 @@ let acknowledge_pers_struct check modname
let id = Ident.create_persistent name in
let path = Pident id in
let addr = EnvLazy.create_forced (Aident id) in
let env =
let add_imported_persistent env (name, _digest) =
add_persistent_structure (Ident.create_persistent name) env
in
List.fold_left add_imported_persistent empty crcs
in
let comps =
!components_of_module' ~alerts ~loc:Location.none
empty Subst.identity path addr (Mty_signature sign)
env Subst.identity path addr (Mty_signature sign)
in
let ps = { ps_name = name;
ps_sig = lazy (Subst.signature Subst.identity sign);
@ -896,12 +920,9 @@ let get_unit_name () =
let rec find_module_descr path env =
match path with
Pident id ->
begin try
fst (IdTbl.find_same id env.components)
with Not_found ->
if Ident.persistent id && not (Ident.name id = !current_unit)
then (find_pers_struct (Ident.name id)).ps_comps
else raise Not_found
begin match IdTbl.find_same id env.components with
| Value x -> fst x
| Persistent -> (find_pers_struct (Ident.name id)).ps_comps
end
| Pdot(p, s) ->
begin match get_components (find_module_descr p env) with
@ -1001,14 +1022,12 @@ let find_type_descrs p env =
let find_module ~alias path env =
match path with
Pident id ->
begin try
let data, _ = IdTbl.find_same id env.modules in
EnvLazy.force subst_modtype_maker data
with Not_found ->
if Ident.persistent id && not (Ident.name id = !current_unit) then
let ps = find_pers_struct (Ident.name id) in
md (Mty_signature(Lazy.force ps.ps_sig))
else raise Not_found
begin
match IdTbl.find_same id env.modules with
| Value (data, _) -> EnvLazy.force subst_modtype_maker data
| Persistent ->
let ps = find_pers_struct (Ident.name id) in
md (Mty_signature(Lazy.force ps.ps_sig))
end
| Pdot(p, s) ->
begin match get_components (find_module_descr p env) with
@ -1045,13 +1064,13 @@ let find_module ~alias path env =
let rec find_module_address path env =
match path with
| Pident id ->
begin try
let _, addr = IdTbl.find_same id env.modules in
get_address addr
with Not_found ->
if Ident.persistent id && not (Ident.name id = !current_unit) then
Aident id
else raise Not_found
begin
match IdTbl.find_same id env.modules with
| Value (_, addr) -> get_address addr
| Persistent ->
if not (Ident.name id = !current_unit) then
Aident id
else raise Not_found
end
| Pdot(p, s) -> begin
match get_components (find_module_descr p env) with
@ -1248,14 +1267,11 @@ let mark_module_used name loc =
let rec lookup_module_descr_aux ?loc ~mark lid env =
match lid with
Lident s ->
begin try
let path, (comp, _) = IdTbl.find_name ~mark s env.components in
path, comp
with Not_found ->
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
(Pident(Ident.create_persistent s), ps.ps_comps)
end
let (p, data) = IdTbl.find_name ~mark s env.components in
(p,
match data with
| Value (comp, _) -> comp
| Persistent -> (find_pers_struct s).ps_comps)
| Ldot(l, s) ->
let (p, descr) = lookup_module_descr ?loc ~mark l env in
begin match get_components descr with
@ -1293,33 +1309,36 @@ and lookup_module_descr ?loc ~mark lid env =
and lookup_module ~load ?loc ~mark lid env : Path.t =
match lid with
Lident s ->
begin try
let p, (data, _) = IdTbl.find_name ~mark s env.modules in
let {md_loc; md_attributes; md_type} =
EnvLazy.force subst_modtype_maker data
in
if mark then mark_module_used s md_loc;
begin match md_type with
| Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
(* see #5965 *)
raise Recmodule
| _ -> ()
end;
report_alerts ?loc p
(Builtin_attributes.alerts_of_attrs md_attributes);
p
with Not_found ->
if s = !current_unit then raise Not_found;
let p = Pident(Ident.create_persistent s) in
if !Clflags.transparent_modules && not load
then
let loc = match loc with Some l -> l | None -> Location.none in
check_pers_struct ~loc s
else begin
let ps = find_pers_struct s in
report_alerts ?loc p ps.ps_comps.alerts
end;
p
begin match IdTbl.find_name ~mark s env.modules with
| exception Not_found when !Clflags.transparent_modules && not load ->
check_pers_struct s
~loc:(Option.value loc ~default:Location.none);
Path.Pident (Ident.create_persistent s)
| p, data ->
begin match data with
| Value (data, _) ->
let {md_loc; md_attributes; md_type} =
EnvLazy.force subst_modtype_maker data
in
if mark then mark_module_used s md_loc;
begin match md_type with
| Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
(* see #5965 *)
raise Recmodule
| _ -> ()
end;
report_alerts ?loc p
(Builtin_attributes.alerts_of_attrs md_attributes)
| Persistent ->
if !Clflags.transparent_modules && not load then
check_pers_struct s
~loc:(Option.value loc ~default:Location.none)
else begin
let ps = find_pers_struct s in
report_alerts ?loc p ps.ps_comps.alerts
end
end;
p
end
| Ldot(l, s) ->
let (p, descr) = lookup_module_descr ?loc ~mark l env in
@ -1631,15 +1650,14 @@ let iter_env proj1 proj2 f env () =
| Functor_comps _ -> ()
in iter_env_cont := (path, cont) :: !iter_env_cont
in
Hashtbl.iter
(fun s pso ->
match pso with None -> ()
| Some ps ->
let id = Pident (Ident.create_persistent s) in
iter_components id id ps.ps_comps)
persistent_structures;
IdTbl.iter
(fun id (path, (comps, _)) -> iter_components (Pident id) path comps)
(fun id (path, comps) ->
match comps with
| Value (comps, _) -> iter_components (Pident id) path comps
| Persistent ->
match Hashtbl.find persistent_structures (Ident.name id) with
| exception Not_found | None -> ()
| Some ps -> iter_components (Pident id) path ps.ps_comps)
env.components
let run_iter_cont l =
@ -1672,7 +1690,12 @@ let find_all_comps proj s (p,(mcomps, _)) =
let rec find_shadowed_comps path env =
match path with
Pident id ->
IdTbl.find_all (Ident.name id) env.components
List.filter_map
(fun (p, data) ->
match data with
| Value x -> Some (p, x)
| Persistent -> None)
(IdTbl.find_all (Ident.name id) env.components)
| Pdot (p, s) ->
let l = find_shadowed_comps p env in
let l' =
@ -2055,11 +2078,13 @@ and store_module ~check id addr presence md env =
let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in
{ env with
modules =
IdTbl.add id (EnvLazy.create (Subst.identity, md), addr) env.modules;
IdTbl.add id (Value (EnvLazy.create (Subst.identity, md), addr))
env.modules;
components =
IdTbl.add id
(components_of_module ~alerts ~loc:md.md_loc
env Subst.identity (Pident id) addr md.md_type, addr)
(Value
(components_of_module ~alerts ~loc:md.md_loc
env Subst.identity (Pident id) addr md.md_type, addr))
env.components;
summary = Env_module(env.summary, id, presence, md) }
@ -2261,37 +2286,13 @@ let enter_signature ~scope sg env =
(* Open a signature path *)
let add_components ?filter_modules slot root env0 comps =
let add_components slot root env0 comps =
let add_l w comps env0 =
TycompTbl.add_open slot w comps env0
in
let add w comps env0 = IdTbl.add_open slot w root comps env0 in
let skipped_modules = ref String.Set.empty in
let filter tbl env0_tbl =
match filter_modules with
| None -> tbl
| Some f ->
NameMap.fold (fun m x acc ->
if f m then
NameMap.add m x acc
else begin
assert
(match IdTbl.find_name m env0_tbl~mark:false with
| (_ : _ * _) -> false
| exception _ -> true);
skipped_modules := String.Set.add m !skipped_modules;
acc
end)
tbl NameMap.empty
in
let filter_and_add w comps env0 =
let comps = filter comps env0 in
add w comps env0
in
let constrs =
add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
in
@ -2315,15 +2316,21 @@ let add_components ?filter_modules slot root env0 comps =
add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
in
let components =
filter_and_add (fun x -> `Component x) comps.comp_components env0.components
let components =
NameMap.map (fun x -> Value x) comps.comp_components
in
add (fun x -> `Component x) components env0.components
in
let modules =
filter_and_add (fun x -> `Module x) comps.comp_modules env0.modules
let modules =
NameMap.map (fun x -> Value x) comps.comp_modules
in
add (fun x -> `Module x) modules env0.modules
in
{ env0 with
summary = Env_open(env0.summary, !skipped_modules, root);
summary = Env_open(env0.summary, root);
constrs;
labels;
values;
@ -2335,11 +2342,11 @@ let add_components ?filter_modules slot root env0 comps =
modules;
}
let open_signature ?filter_modules slot root env0 =
let open_signature slot root env0 =
match get_components (find_module_descr root env0) with
| Functor_comps _ -> None
| Structure_comps comps ->
Some (add_components ?filter_modules slot root env0 comps)
Some (add_components slot root env0 comps)
(* Open a signature from a file *)
@ -2349,24 +2356,6 @@ let open_pers_signature name env =
| Some env -> env
| None -> assert false (* a compilation unit cannot refer to a functor *)
let open_signature_of_initially_opened_module root env =
let load_path = !Config.load_path in
let filter_modules m =
match Misc.find_in_path_uncap load_path (m ^ ".cmi") with
| (_ : string) -> false
| exception Not_found -> true
in
open_signature None root env ~filter_modules
let open_signature_from_env_summary root env ~hidden_submodules =
let filter_modules =
if String.Set.is_empty hidden_submodules then
None
else
Some (fun m -> not (String.Set.mem m hidden_submodules))
in
open_signature None root env ?filter_modules
let open_signature
?(used_slot = ref false)
?(loc = Location.none) ?(toplevel = false)
@ -2422,6 +2411,30 @@ let read_signature modname filename =
let ps = read_pers_struct modname filename in
Lazy.force ps.ps_sig
let is_identchar_latin1 = function
| 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
| '\248'..'\255' | '\'' | '0'..'9' -> true
| _ -> false
let unit_name_of_filename fn =
match Filename.extension fn with
| ".cmi" -> begin
let unit =
String.capitalize_ascii (Filename.remove_extension fn)
in
if String.for_all is_identchar_latin1 unit then
Some unit
else
None
end
| _ -> None
let persistent_structures_of_dir dir =
Load_path.Dir.files dir
|> List.to_seq
|> Seq.filter_map unit_name_of_filename
|> String.Set.of_seq
(* Return the CRC of the interface of the given compilation unit *)
let crc_of_unit name =
@ -2538,37 +2551,32 @@ let find_all_simple_list proj1 proj2 f lid env acc =
let fold_modules f lid env acc =
match lid with
| None ->
let acc =
IdTbl.fold_name
(fun name (p, (data, _)) acc ->
let data = EnvLazy.force subst_modtype_maker data in
f name p data acc
)
env.modules
acc
in
Hashtbl.fold
(fun name ps acc ->
match ps with
None -> acc
| Some ps ->
f name (Pident(Ident.create_persistent name))
(md (Mty_signature (Lazy.force ps.ps_sig))) acc)
persistent_structures
| None ->
IdTbl.fold_name
(fun name (p, data) acc ->
match data with
| Value (data, _) ->
let data = EnvLazy.force subst_modtype_maker data in
f name p data acc
| Persistent ->
match Hashtbl.find persistent_structures name with
| exception Not_found | None -> acc
| Some ps ->
f name p (md (Mty_signature (Lazy.force ps.ps_sig))) acc)
env.modules
acc
| Some l ->
| Some l ->
let p, desc = lookup_module_descr ~mark:true l env in
begin match get_components desc with
Structure_comps c ->
NameMap.fold
(fun s (data, _) acc ->
f s (Pdot (p, s))
(EnvLazy.force subst_modtype_maker data) acc)
c.comp_modules
acc
| Functor_comps _ ->
| Structure_comps c ->
NameMap.fold
(fun s (data, _) acc ->
f s (Pdot (p, s))
(EnvLazy.force subst_modtype_maker data) acc)
c.comp_modules
acc
| Functor_comps _ ->
acc
end
let fold_values f =
@ -2589,6 +2597,68 @@ and fold_classes f =
and fold_cltypes f =
find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f
let filter_non_loaded_persistent f env =
let to_remove =
IdTbl.fold_name
(fun name (_, data) acc ->
match data with
| Value _ -> acc
| Persistent ->
match Hashtbl.find persistent_structures name with
| Some _ -> acc
| exception Not_found | None ->
if f (Ident.create_persistent name) then
acc
else
String.Set.add name acc)
env.modules
String.Set.empty
in
let remove_ids tbl ids =
String.Set.fold
(fun name tbl -> IdTbl.remove (Ident.create_persistent name) tbl)
ids
tbl
in
let rec filter_summary summary ids =
if String.Set.is_empty ids then
summary
else
match summary with
| Env_empty -> summary
| Env_value (s, id, vd) ->
Env_value (filter_summary s ids, id, vd)
| Env_type (s, id, td) ->
Env_type (filter_summary s ids, id, td)
| Env_extension (s, id, ec) ->
Env_extension (filter_summary s ids, id, ec)
| Env_module (s, id, mp, md) ->
Env_module (filter_summary s ids, id, mp, md)
| Env_modtype (s, id, md) ->
Env_modtype (filter_summary s ids, id, md)
| Env_class (s, id, cd) ->
Env_class (filter_summary s ids, id, cd)
| Env_cltype (s, id, ctd) ->
Env_cltype (filter_summary s ids, id, ctd)
| Env_open (s, p) ->
Env_open (filter_summary s ids, p)
| Env_functor_arg (s, id) ->
Env_functor_arg (filter_summary s ids, id)
| Env_constraints (s, cstrs) ->
Env_constraints (filter_summary s ids, cstrs)
| Env_copy_types (s, types) ->
Env_copy_types (filter_summary s ids, types)
| Env_persistent (s, id) ->
if String.Set.mem (Ident.name id) ids then
filter_summary s (String.Set.remove (Ident.name id) ids)
else
Env_persistent (filter_summary s ids, id)
in
{ env with
modules = remove_ids env.modules to_remove;
components = remove_ids env.components to_remove;
summary = filter_summary env.summary to_remove;
}
(* Make the initial environment *)
let (initial_safe_string, initial_unsafe_string) =

40
typing/env.mli
View File

@ -16,7 +16,6 @@
(* Environment handling *)
open Types
open Misc.Stdlib
type summary =
Env_empty
@ -27,12 +26,13 @@ type summary =
| Env_modtype of summary * Ident.t * modtype_declaration
| Env_class of summary * Ident.t * class_declaration
| Env_cltype of summary * Ident.t * class_type_declaration
| Env_open of summary * String.Set.t * Path.t
| Env_open of summary * Path.t
(** The string set argument of [Env_open] represents a list of module names
to skip, i.e. that won't be imported in the toplevel namespace. *)
| Env_functor_arg of summary * Ident.t
| Env_constraints of summary * type_declaration Path.Map.t
| Env_copy_types of summary * string list
| Env_persistent of summary * Ident.t
type address =
| Aident of Ident.t
@ -169,6 +169,25 @@ val add_class: Ident.t -> class_declaration -> t -> t
val add_cltype: Ident.t -> class_type_declaration -> t -> t
val add_local_type: Path.t -> type_declaration -> t -> t
(* Insertion of persistent signatures *)
(* [add_persistent_structure id env] is an environment such that
module [id] points to the persistent structure contained in the
external compilation unit with the same name.
The compilation unit itself is looked up in the load path when the
contents of the module is accessed. *)
val add_persistent_structure : Ident.t -> t -> t
(* Returns the set of persistent structures found in the given
directory. *)
val persistent_structures_of_dir : Load_path.Dir.t -> Misc.Stdlib.String.Set.t
(* [filter_non_loaded_persistent f env] removes all the persistent
structures that are not yet loaded and for which [f] returns
[false]. *)
val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t
(* Insertion of all fields of a signature. *)
val add_item: signature_item -> t -> t
@ -183,23 +202,6 @@ val open_signature:
Asttypes.override_flag -> Path.t ->
t -> t option
(* Similar to [open_signature], except that modules from the load path
have precedence over sub-modules of the opened module.
For instance, if opening a module [M] with a sub-module [X]:
- if the load path contains a [x.cmi] file, then resolving [X] in the
new environment yields the same result as resolving [X] in the
old environment
- otherwise, in the new environment [X] resolves to [M.X]
*)
val open_signature_of_initially_opened_module:
Path.t -> t -> t option
(* Similar to [open_signature] except that sub-modules of the opened modules
that are in [hidden_submodules] are not added to the environment. *)
val open_signature_from_env_summary:
Path.t -> t -> hidden_submodules:String.Set.t -> t option
val open_pers_signature: string -> t -> t
(* Insertion by name *)

8
typing/envaux.ml
View File

@ -60,11 +60,10 @@ let rec env_from_summary sum subst =
| Env_cltype (s, id, desc) ->
Env.add_cltype id (Subst.cltype_declaration subst desc)
(env_from_summary s subst)
| Env_open(s, hidden_submodules, path) ->
| Env_open(s, path) ->
let env = env_from_summary s subst in
let path' = Subst.module_path subst path in
begin match Env.open_signature_from_env_summary path' env
~hidden_submodules with
begin match Env.open_signature Asttypes.Override path' env with
| Some env -> env
| None -> assert false
| exception Not_found -> raise (Error (Module_not_found path'))
@ -84,6 +83,9 @@ let rec env_from_summary sum subst =
| Env_copy_types (s, sl) ->
let env = env_from_summary s subst in
Env.do_copy_types (Env.make_copy_of_types sl env) env
| Env_persistent (s, id) ->
let env = env_from_summary s subst in
Env.add_persistent_structure id env
in
Hashtbl.add env_cache (sum, subst) env;
env

32
typing/ident.ml
View File

@ -205,6 +205,38 @@ let rec add id data = function
else
balance l k (add id data r)
let rec min_binding = function
Empty -> raise Not_found
| Node (Empty, d, _, _) -> d
| Node (l, _, _, _) -> min_binding l
let rec remove_min_binding = function
Empty -> invalid_arg "Map.remove_min_elt"
| Node (Empty, _, r, _) -> r
| Node (l, d, r, _) -> balance (remove_min_binding l) d r
let merge t1 t2 =
match (t1, t2) with
(Empty, t) -> t
| (t, Empty) -> t
| (_, _) ->
let d = min_binding t2 in
balance t1 d (remove_min_binding t2)
let rec remove id = function
Empty ->
Empty
| (Node (l, k, r, h) as m) ->
let c = compare (name id) (name k.ident) in
if c = 0 then
match k.previous with
| None -> merge l r
| Some k -> Node (l, k, r, h)
else if c < 0 then
let ll = remove id l in if l == ll then m else balance ll k r
else
let rr = remove id r in if r == rr then m else balance l k rr
let rec find_previous id = function
None ->
raise Not_found

2
typing/ident.mli
View File

@ -73,7 +73,7 @@ val find_all: string -> 'a tbl -> (t * 'a) list
val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
val iter: (t -> 'a -> unit) -> 'a tbl -> unit
val remove: t -> 'a tbl -> 'a tbl
(* Idents for sharing keys *)

61
typing/typemod.ml
View File

@ -152,37 +152,56 @@ let type_open_ ?used_slot ?toplevel ovf env loc lid =
ignore (extract_sig_open env lid.loc md.md_type);
assert false
let type_initially_opened_module env module_name =
let loc = Location.in_file "compiler internals" in
let lid = { Asttypes.loc; txt = Longident.Lident module_name } in
let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in
match Env.open_signature_of_initially_opened_module path env with
| Some env -> path, env
| None ->
let md = Env.find_module path env in
ignore (extract_sig_open env lid.loc md.md_type);
assert false
let initial_env ~loc ~safe_string ~initially_opened_module
~open_implicit_modules =
~open_implicit_modules =
let env =
if safe_string then
Env.initial_safe_string
else
Env.initial_unsafe_string
in
let env =
match initially_opened_module with
| None -> env
| Some name ->
snd (type_initially_opened_module env name)
in
let open_implicit_module env m =
let open_module env m =
let open Asttypes in
let lid = {loc; txt = Longident.parse m } in
snd (type_open_ Override env lid.loc lid)
in
List.fold_left open_implicit_module env open_implicit_modules
let add_units env units =
String.Set.fold
(fun name env ->
Env.add_persistent_structure (Ident.create_persistent name) env)
units
env
in
let units =
List.rev_map Env.persistent_structures_of_dir (Load_path.get ())
in
let env, units =
match initially_opened_module with
| None -> (env, units)
| Some m ->
(* Locate the directory that contains [m], adds the units it
contains to the environment and open [m] in the resulting
environment. *)
let rec loop before after =
match after with
| [] -> None
| units :: after ->
if String.Set.mem m units then
Some (units, List.rev_append before after)
else
loop (units :: before) after
in
let env, units =
match loop [] units with
| None ->
(env, units)
| Some (units_containing_m, other_units) ->
(add_units env units_containing_m, other_units)
in
(open_module env m, units)
in
let env = List.fold_left add_units env units in
List.fold_left open_module env open_implicit_modules
let type_open_descr ?used_slot ?toplevel env sod =
let (path, newenv) =
@ -2422,7 +2441,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
if Sys.file_exists sourceintf then begin
let intf_file =
try
find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
Load_path.find_uncap (modulename ^ ".cmi")
with Not_found ->
raise(Error(Location.in_file sourcefile, Env.empty,
Interface_not_compiled sourceintf)) in

6
utils/ccomp.ml
View File

@ -161,7 +161,7 @@ let expand_libname name =
let libname =
"lib" ^ String.sub name 2 (String.length name - 2) ^ Config.ext_lib in
try
Misc.find_in_path !Config.load_path libname
Load_path.find libname
with Not_found ->
libname
end
@ -191,7 +191,7 @@ let call_linker mode output_name files extra =
Printf.sprintf "%s%s %s %s %s"
Config.native_pack_linker
(Filename.quote output_name)
(quote_prefixed l_prefix !Config.load_path)
(quote_prefixed l_prefix (Load_path.get_paths ()))
(quote_files (remove_Wl files))
extra
else
@ -206,7 +206,7 @@ let call_linker mode output_name files extra =
(Filename.quote output_name)
(if !Clflags.gprofile then Config.cc_profile else "")
"" (*(Clflags.std_include_flag "-I")*)
(quote_prefixed "-L" !Config.load_path)
(quote_prefixed "-L" (Load_path.get_paths ()))
(String.concat " " (List.rev !Clflags.all_ccopts))
(quote_files files)
extra

3
utils/config.mli
View File

@ -84,9 +84,6 @@ val ar: string
val cc_profile : string
(** The command line option to the C compiler to enable profiling. *)
val load_path: string list ref
(** Directories in the search path for .cmi and .cmo files *)
val interface_suffix: string ref
(** Suffix for interface file names *)

2
utils/config.mlp
View File

@ -105,8 +105,6 @@ and cmxs_magic_number = "Caml1999D023"
(* cmxs_magic_number is duplicated in otherlibs/dynlink/natdynlink.ml *)
and cmt_magic_number = "Caml1999T023"
let load_path = ref ([] : string list)
let interface_suffix = ref ".mli"
let max_tag = 245

89
utils/load_path.ml Normal file
View File

@ -0,0 +1,89 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jeremie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
module SMap = Misc.Stdlib.String.Map
(* Mapping from basenames to full filenames *)
type registry = string SMap.t ref
let files : registry = ref SMap.empty
let files_uncap : registry = ref SMap.empty
module Dir = struct
type t = {
path : string;
files : string list;
}
let path t = t.path
let files t = t.files
(* For backward compatibility reason, simulate the behavior of
[Misc.find_in_path]: silently ignore directories that don't exist
+ treat [""] as the current directory. *)
let readdir_compat dir =
try
Sys.readdir (if dir = "" then Filename.current_dir_name else dir)
with Sys_error _ ->
[||]
let create path =
{ path; files = Array.to_list (readdir_compat path) }
end
let dirs = ref []
let reset () =
files := SMap.empty;
files_uncap := SMap.empty;
dirs := []
let get () = !dirs
let get_paths () = List.map Dir.path !dirs
let add dir =
let add_file base =
let fn = Filename.concat dir.Dir.path base in
files := SMap.add base fn !files;
files_uncap := SMap.add (String.uncapitalize_ascii base) fn !files_uncap;
in
List.iter add_file dir.Dir.files;
dirs := dir :: !dirs
let remove_dir dir =
let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in
if new_dirs <> !dirs then begin
reset ();
List.iter add (List.rev new_dirs)
end
let add_dir dir = add (Dir.create dir)
let init l =
reset ();
List.iter add_dir (List.rev l)
let is_basename fn = Filename.basename fn = fn
let find fn =
if is_basename fn then
SMap.find fn !files
else
Misc.find_in_path (get_paths ()) fn
let find_uncap fn =
if is_basename fn then
SMap.find (String.uncapitalize_ascii fn) !files_uncap
else
Misc.find_in_path_uncap (get_paths ()) fn

67
utils/load_path.mli Normal file
View File

@ -0,0 +1,67 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jeremie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Manangement of include directories.
This module offers a high level interface to locating files in the
load path, which is constructed from [-I] command line flags and a few
other parameters.
It makes the assumption that the contents of include directories
doesn't change during the execution of the compiler.
*)
val add_dir : string -> unit
(** Add a directory to the load path *)
val remove_dir : string -> unit
(** Remove a directory from the load path *)
val reset : unit -> unit
(** Remove all directories *)
val init : string list -> unit
(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *)
val get_paths : unit -> string list
(** Return the list of directories passed to [add_dir] so far, in
reverse order. *)
val find : string -> string
(** Locate a file in the load path. Raise [Not_found] if the file
cannot be found. This function is optimized for the case where the
filename is a basename, i.e. doesn't contain a directory
separator. *)
val find_uncap : string -> string
(** Same as [find], but search also for uncapitalized name, i.e. if
name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *)
module Dir : sig
type t
(** Represent one directory in the load path. *)
val create : string -> t
val path : t -> string
val files : t -> string list
(** All the files in that directory. This doesn't include files in
sub-directories of this directory. *)
end
val add : Dir.t -> unit
val get : unit -> Dir.t list
(** Same as [get_paths ()], except that it returns a [Dir.t list]. *)

7
utils/misc.ml
View File

@ -207,6 +207,13 @@ module Stdlib = struct
include String
let hash = Hashtbl.hash
end)
let for_all f t =
let len = String.length t in
let rec loop i =
i = len || (f t.[i] && loop (i + 1))
in
loop 0
end
external compare : 'a -> 'a -> int = "%compare"

2
utils/misc.mli
View File

@ -144,6 +144,8 @@ module Stdlib : sig
module Set : Set.S with type elt = string
module Map : Map.S with type key = string
module Tbl : Hashtbl.S with type key = string
val for_all : (char -> bool) -> t -> bool
end
external compare : 'a -> 'a -> int = "%compare"