| Anonymous | Login | Signup for a new account | 2013-05-22 18:30 CEST | ![]() |
| Main | My View | View Issues | Change Log | Roadmap |
| View Issue Details [ Jump to Notes ] | [ Issue History ] [ Print ] | ||||||||||
| ID | Project | Category | View Status | Date Submitted | Last Update | ||||||
| 0005283 | OCaml | OCaml general | public | 2011-06-06 18:19 | 2012-11-30 18:04 | ||||||
| Reporter | lefessan | ||||||||||
| Assigned To | xleroy | ||||||||||
| Priority | normal | Severity | feature | Reproducibility | have not tried | ||||||
| Status | feedback | Resolution | open | ||||||||
| Platform | all | OS | all | OS Version | all | ||||||
| Product Version | 3.12.0 | ||||||||||
| Target Version | 3.12.0 | Fixed in Version | |||||||||
| Summary | 0005283: patch to pack functors | ||||||||||
| Description | This patch aims at building multi-units functors, i.e. a functor whose body is defined in several compilation units. An example is provided in test-run.tar.gz. Each compilation unit in the functor should be compiled with "-functor x.mli", where x.mli (or x.cmi) defines the interface of the functor argument (several -functor arguments can be provided). To generate a functor, the option "-pack-functor FunctorName" should be provided. It will generate a module (as defined by "-o NameOfModule.cmo/.cmx"), containing the functor FunctorName, with one argument (corresponding to the -functor used for all its arguments), and all the provided modules as body. As an independant feature, it allows to pack interfaces: ocamlc -pack -o abc.cmi a.cmi b.cmi c.cmi an option that was not implemented before, while still useful. The patch is applied against 3.12.0, but should work with minimal changes against next versions. | ||||||||||
| Steps To Reproduce | Example of usage: $(OCAMLC) -c arguments/x.mli $(OCAMLC) -c -functor arguments/x.mli arguments/y.mli $(OCAMLC) -c -functor arguments/y.mli -functor arguments/x.mli a.mli $(OCAMLC) -c -functor arguments/y.mli -for-pack Lib.Make_a -functor arguments/x.mli a.ml $(OCAMLC) -I arguments -functor arguments/x.mli -for-pack Lib -pack-functor Make -o make_a.$(CMO) a.$(CMO) $(OCAMLC) -c -functor arguments/x.mli -for-pack Lib b.ml $(OCAMLC) -I arguments -pack-functor Make -o lib.$(CMO) make_a.$(CMO) b.$(CMO) | ||||||||||
| Tags | No tags attached. | ||||||||||
| Attached Files | diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/asmgen.ml ocaml-3.12.0+functor/asmcomp/asmgen.ml
*** ocaml-3.12.0/asmcomp/asmgen.ml 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/asmcomp/asmgen.ml 2011-06-06 14:45:13.425859003 +0200
***************
*** 104,108 ****
Emitaux.output_channel := oc;
Emit.begin_assembly();
! Closure.intro size lam
++ Cmmgen.compunit size
++ List.iter (compile_phrase ppf) ++ (fun () -> ());
--- 104,108 ----
Emitaux.output_channel := oc;
Emit.begin_assembly();
! let (size, ulam) = Closure.intro size lam in ulam
++ Cmmgen.compunit size
++ List.iter (compile_phrase ppf) ++ (fun () -> ());
diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/asmpackager.ml ocaml-3.12.0+functor/asmcomp/asmpackager.ml
*** ocaml-3.12.0/asmcomp/asmpackager.ml 2010-05-19 13:29:38.000000000 +0200
--- ocaml-3.12.0+functor/asmcomp/asmpackager.ml 2011-06-06 14:33:18.175859003 +0200
***************
*** 80,84 ****
(* Make the .o file for the package *)
! let make_package_object ppf members targetobj targetname coercion =
let objtemp =
if !Clflags.keep_asm_file
--- 80,84 ----
(* Make the .o file for the package *)
! let make_package_object ppf members targetobj targetname coercion functor_info =
let objtemp =
if !Clflags.keep_asm_file
***************
*** 99,103 ****
(chop_extension_if_any objtemp) ppf
(Translmod.transl_store_package
! components (Ident.create_persistent targetname) coercion);
let objfiles =
List.map
--- 99,103 ----
(chop_extension_if_any objtemp) ppf
(Translmod.transl_store_package
! components (Ident.create_persistent targetname) coercion functor_info);
let objfiles =
List.map
***************
*** 112,116 ****
(* Make the .cmx file for the package *)
! let build_package_cmx members cmxfile =
let unit_names =
List.map (fun m -> m.pm_name) members in
--- 112,116 ----
(* Make the .cmx file for the package *)
! let build_package_cmx members cmxfile functor_args =
let unit_names =
List.map (fun m -> m.pm_name) members in
***************
*** 148,151 ****
--- 148,153 ----
ui_force_link =
List.exists (fun info -> info.ui_force_link) units;
+ ui_functor_parts = []; (* TODO *)
+ ui_functor_args = functor_args; (* TODO *)
} in
Compilenv.write_unit_info pkg_infos cmxfile
***************
*** 154,158 ****
let package_object_files ppf files targetcmx
! targetobj targetname coercion =
let pack_path =
match !Clflags.for_package with
--- 156,160 ----
let package_object_files ppf files targetcmx
! targetobj targetname coercion (functor_info, functor_args) =
let pack_path =
match !Clflags.for_package with
***************
*** 161,170 ****
let members = map_left_right (read_member_info pack_path) files in
check_units members;
! make_package_object ppf members targetobj targetname coercion;
! build_package_cmx members targetcmx
(* The entry point *)
! let package_files ppf files targetcmx =
let files =
List.map
--- 163,172 ----
let members = map_left_right (read_member_info pack_path) files in
check_units members;
! make_package_object ppf members targetobj targetname coercion functor_info;
! build_package_cmx members targetcmx functor_args
(* The entry point *)
! let package_files ppf files targetcmx functor_name =
let files =
List.map
***************
*** 181,187 ****
(* Set the name of the current compunit *)
Compilenv.reset ?packname:!Clflags.for_package targetname;
try
! let coercion = Typemod.package_units files targetcmi targetname in
package_object_files ppf files targetcmx targetobj targetname coercion
with x ->
remove_file targetcmx; remove_file targetobj;
--- 183,194 ----
(* Set the name of the current compunit *)
Compilenv.reset ?packname:!Clflags.for_package targetname;
+ let functor_id = match functor_name with
+ None -> None
+ | Some modname -> Some (Ident.create modname) in
try
! let (coercion, functor_info, functor_args) =
! Typemod.package_units files targetcmi targetname functor_id in
package_object_files ppf files targetcmx targetobj targetname coercion
+ (functor_info, functor_args)
with x ->
remove_file targetcmx; remove_file targetobj;
diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/asmpackager.mli ocaml-3.12.0+functor/asmcomp/asmpackager.mli
*** ocaml-3.12.0/asmcomp/asmpackager.mli 2005-08-01 17:51:09.000000000 +0200
--- ocaml-3.12.0+functor/asmcomp/asmpackager.mli 2011-06-06 14:33:18.175859003 +0200
***************
*** 16,20 ****
original compilation units as sub-modules. *)
! val package_files: Format.formatter -> string list -> string -> unit
type error =
--- 16,20 ----
original compilation units as sub-modules. *)
! val package_files: Format.formatter -> string list -> string -> string option -> unit
type error =
diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/closure.ml ocaml-3.12.0+functor/asmcomp/closure.ml
*** ocaml-3.12.0/asmcomp/closure.ml 2008-08-01 14:52:14.000000000 +0200
--- ocaml-3.12.0+functor/asmcomp/closure.ml 2011-06-06 14:33:18.175859003 +0200
***************
*** 42,46 ****
contain the right names if the -for-pack option is active. *)
! let getglobal id =
Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
[], Debuginfo.none)
--- 42,50 ----
contain the right names if the -for-pack option is active. *)
! let getglobal cenv id =
! if Ident.is_functor_part id then
! let id = Env.get_functor_part (Ident.name id) in
! try Tbl.find id cenv with Not_found -> Uvar id
! else
Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
[], Debuginfo.none)
***************
*** 566,570 ****
| Lprim(Pgetglobal id, []) as lam ->
check_constant_result lam
! (getglobal id)
(Compilenv.global_approx id)
| Lprim(Pmakeblock(tag, mut) as prim, lams) ->
--- 570,574 ----
| Lprim(Pgetglobal id, []) as lam ->
check_constant_result lam
! (getglobal cenv id)
(Compilenv.global_approx id)
| Lprim(Pmakeblock(tag, mut) as prim, lams) ->
***************
*** 585,589 ****
let (ulam, approx) = close fenv cenv lam in
(!global_approx).(n) <- approx;
! (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none),
Value_unknown)
| Lprim(Praise, [Levent(arg, ev)]) ->
--- 589,593 ----
let (ulam, approx) = close fenv cenv lam in
(!global_approx).(n) <- approx;
! (Uprim(Psetfield(n, false), [getglobal cenv id; ulam], Debuginfo.none),
Value_unknown)
| Lprim(Praise, [Levent(arg, ev)]) ->
***************
*** 801,803 ****
let (ulam, approx) = close Tbl.empty Tbl.empty lam in
global_approx := [||];
! ulam
--- 805,816 ----
let (ulam, approx) = close Tbl.empty Tbl.empty lam in
global_approx := [||];
! if !Clflags.functors <> [] then begin
! (1,
! Uprim(Psetfield(0, false), [
! Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global
! (Ident.create_persistent (Compilenv.current_unit_name ())))),
! [], Debuginfo.none);
! ulam], Debuginfo.none)
! )
! end else
! (size, ulam)
diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/closure.mli ocaml-3.12.0+functor/asmcomp/closure.mli
*** ocaml-3.12.0/asmcomp/closure.mli 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/asmcomp/closure.mli 2011-06-06 14:33:18.175859003 +0200
***************
*** 15,17 ****
(* Introduction of closures, uncurrying, recognition of direct calls *)
! val intro: int -> Lambda.lambda -> Clambda.ulambda
--- 15,17 ----
(* Introduction of closures, uncurrying, recognition of direct calls *)
! val intro: int -> Lambda.lambda -> int * Clambda.ulambda
diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/cmmgen.ml ocaml-3.12.0+functor/asmcomp/cmmgen.ml
*** ocaml-3.12.0/asmcomp/cmmgen.ml 2010-05-19 13:29:38.000000000 +0200
--- ocaml-3.12.0+functor/asmcomp/cmmgen.ml 2011-06-06 14:36:42.535858999 +0200
***************
*** 801,804 ****
--- 801,807 ----
Uvar id ->
Cvar id
+ | Uprim(Pgetglobal id, [], _ ) when Ident.is_functor_part id ->
+ let exp = Uvar (Env.get_functor_part (Ident.name id)) in
+ transl exp
| Uconst sc ->
transl_constant sc
diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/cmx_format.mli ocaml-3.12.0+functor/asmcomp/cmx_format.mli
*** ocaml-3.12.0/asmcomp/cmx_format.mli 2010-05-19 13:29:38.000000000 +0200
--- ocaml-3.12.0+functor/asmcomp/cmx_format.mli 2011-06-06 14:33:18.185859004 +0200
***************
*** 35,38 ****
--- 35,40 ----
mutable ui_apply_fun: int list; (* Apply functions needed *)
mutable ui_send_fun: int list; (* Send functions needed *)
+ mutable ui_functor_parts : (string * (string * Digest.t) list) list;
+ mutable ui_functor_args : (string * Digest.t) list;
mutable ui_force_link: bool } (* Always linked *)
diff -C 2 -N -r -w ocaml-3.12.0/asmcomp/compilenv.ml ocaml-3.12.0+functor/asmcomp/compilenv.ml
*** ocaml-3.12.0/asmcomp/compilenv.ml 2010-05-19 13:29:38.000000000 +0200
--- ocaml-3.12.0+functor/asmcomp/compilenv.ml 2011-06-06 15:36:16.965859002 +0200
***************
*** 40,43 ****
--- 40,45 ----
ui_apply_fun = [];
ui_send_fun = [];
+ ui_functor_parts = [];
+ ui_functor_args = [];
ui_force_link = false }
***************
*** 149,153 ****
let global_approx id =
! if Ident.is_predef_exn id then Value_unknown
else try Hashtbl.find toplevel_approx (Ident.name id)
with Not_found ->
--- 151,155 ----
let global_approx id =
! if Ident.is_predef_exn id || Ident.is_functor_arg id then Value_unknown
else try Hashtbl.find toplevel_approx (Ident.name id)
with Not_found ->
***************
*** 199,202 ****
--- 201,206 ----
let save_unit_info filename =
current_unit.ui_imports_cmi <- Env.imported_units();
+ current_unit.ui_functor_args <- Env.get_functor_args ();
+ current_unit.ui_functor_parts <- Env.get_functor_parts ();
write_unit_info current_unit filename
Binary files ocaml-3.12.0/boot/ocamlc and ocaml-3.12.0+functor/boot/ocamlc differ
Binary files ocaml-3.12.0/boot/ocamldep and ocaml-3.12.0+functor/boot/ocamldep differ
Binary files ocaml-3.12.0/boot/ocamllex and ocaml-3.12.0+functor/boot/ocamllex differ
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/bytegen.ml ocaml-3.12.0+functor/bytecomp/bytegen.ml
*** ocaml-3.12.0/bytecomp/bytegen.ml 2009-05-20 13:52:42.000000000 +0200
--- ocaml-3.12.0+functor/bytecomp/bytegen.ml 2011-06-06 15:36:30.825859004 +0200
***************
*** 409,412 ****
--- 409,415 ----
fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id)
end
+ | Lprim(Pgetglobal id, []) when Ident.is_functor_part id ->
+ let exp = Lvar (Env.get_functor_part (Ident.name id)) in
+ comp_expr env exp sz cont
| Lconst cst ->
Kconst cst :: cont
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/bytepackager.ml ocaml-3.12.0+functor/bytecomp/bytepackager.ml
*** ocaml-3.12.0/bytecomp/bytepackager.ml 2010-05-21 14:00:49.000000000 +0200
--- ocaml-3.12.0+functor/bytecomp/bytepackager.ml 2011-06-06 14:33:18.185859004 +0200
***************
*** 156,160 ****
(* Generate the code that builds the tuple representing the package module *)
! let build_global_target oc target_name members mapping pos coercion =
let components =
List.map2
--- 156,165 ----
(* Generate the code that builds the tuple representing the package module *)
! let print_if ppf flag printer arg =
! if !flag then Format.fprintf ppf "%a@." printer arg
!
! let ppf = Format.err_formatter
!
! let build_global_target oc target_name members mapping pos coercion functor_info =
let components =
List.map2
***************
*** 166,172 ****
let lam =
Translmod.transl_package
! components (Ident.create_persistent target_name) coercion in
let instrs =
Bytegen.compile_implementation target_name lam in
let rel =
Emitcode.to_packed_file oc instrs in
--- 171,180 ----
let lam =
Translmod.transl_package
! components (Ident.create_persistent target_name) coercion functor_info in
! print_if ppf Clflags.dump_lambda Printlambda.lambda lam;
! print_if ppf Clflags.dump_rawlambda Printlambda.lambda lam;
let instrs =
Bytegen.compile_implementation target_name lam in
+ print_if ppf Clflags.dump_instr Printinstr.instrlist instrs;
let rel =
Emitcode.to_packed_file oc instrs in
***************
*** 175,179 ****
(* Build the .cmo file obtained by packaging the given .cmo files. *)
! let package_object_files files targetfile targetname coercion =
let members =
map_left_right read_member_info files in
--- 183,187 ----
(* Build the .cmo file obtained by packaging the given .cmo files. *)
! let package_object_files files targetfile targetname coercion (functor_info, functor_args) =
let members =
map_left_right read_member_info files in
***************
*** 193,197 ****
let pos_code = pos_out oc in
let ofs = rename_append_bytecode_list oc mapping [] 0 targetname Subst.identity members in
! build_global_target oc targetname members mapping ofs coercion;
let pos_debug = pos_out oc in
if !Clflags.debug && !events <> [] then
--- 201,205 ----
let pos_code = pos_out oc in
let ofs = rename_append_bytecode_list oc mapping [] 0 targetname Subst.identity members in
! build_global_target oc targetname members mapping ofs coercion functor_info;
let pos_debug = pos_out oc in
if !Clflags.debug && !events <> [] then
***************
*** 211,214 ****
--- 219,224 ----
cu_force_link = !force_link;
cu_debug = if pos_final > pos_debug then pos_debug else 0;
+ cu_functor_parts = []; (* TODO : add functor parts from submodules *)
+ cu_functor_args = functor_args;
cu_debugsize = pos_final - pos_debug } in
output_value oc compunit;
***************
*** 222,226 ****
(* The entry point *)
! let package_files files targetfile =
let files =
List.map
--- 232,236 ----
(* The entry point *)
! let package_files files targetfile functor_name =
let files =
List.map
***************
*** 232,238 ****
let targetcmi = prefix ^ ".cmi" in
let targetname = String.capitalize(Filename.basename prefix) in
try
! let coercion = Typemod.package_units files targetcmi targetname in
! package_object_files files targetfile targetname coercion
with x ->
remove_file targetfile; raise x
--- 242,253 ----
let targetcmi = prefix ^ ".cmi" in
let targetname = String.capitalize(Filename.basename prefix) in
+ let functor_id = match functor_name with
+ None -> None
+ | Some modname -> Some (Ident.create modname) in
try
! let (coercion, functor_info, functor_args) =
! Typemod.package_units files targetcmi targetname functor_id in
! package_object_files files targetfile targetname coercion (functor_info, functor_args)
!
with x ->
remove_file targetfile; raise x
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/bytepackager.mli ocaml-3.12.0+functor/bytecomp/bytepackager.mli
*** ocaml-3.12.0/bytecomp/bytepackager.mli 2002-02-08 17:55:44.000000000 +0100
--- ocaml-3.12.0+functor/bytecomp/bytepackager.mli 2011-06-06 14:33:18.185859004 +0200
***************
*** 16,20 ****
original compilation units as sub-modules. *)
! val package_files: string list -> string -> unit
type error =
--- 16,20 ----
original compilation units as sub-modules. *)
! val package_files: string list -> string -> string option -> unit
type error =
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/cmo_format.mli ocaml-3.12.0+functor/bytecomp/cmo_format.mli
*** ocaml-3.12.0/bytecomp/cmo_format.mli 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/bytecomp/cmo_format.mli 2011-06-06 14:33:18.185859004 +0200
***************
*** 34,37 ****
--- 34,39 ----
mutable cu_force_link: bool; (* Must be linked even if unref'ed *)
mutable cu_debug: int; (* Position of debugging info, or 0 *)
+ mutable cu_functor_parts : (string * (string * Digest.t) list) list;
+ mutable cu_functor_args : (string * Digest.t) list;
cu_debugsize: int } (* Length of debugging info *)
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/emitcode.ml ocaml-3.12.0+functor/bytecomp/emitcode.ml
*** ocaml-3.12.0/bytecomp/emitcode.ml 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/bytecomp/emitcode.ml 2011-06-06 14:33:18.185859004 +0200
***************
*** 376,379 ****
--- 376,381 ----
cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations;
cu_force_link = false;
+ cu_functor_parts = Env.get_functor_parts ();
+ cu_functor_args = Env.get_functor_args ();
cu_debug = pos_debug;
cu_debugsize = size_debug } in
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/lambda.ml ocaml-3.12.0+functor/bytecomp/lambda.ml
*** ocaml-3.12.0/bytecomp/lambda.ml 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/bytecomp/lambda.ml 2011-06-06 14:33:18.185859004 +0200
***************
*** 318,322 ****
let free_variables l =
! free_ids (function Lvar id -> [id] | _ -> []) l
let free_methods l =
--- 318,325 ----
let free_variables l =
! free_ids (function Lvar id -> [id]
! | Lprim( (Pgetglobal id | Psetglobal id), _) when Ident.is_functor_part id ->
! [Env.get_functor_part (Ident.name id)]
! | _ -> []) l
let free_methods l =
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/translmod.ml ocaml-3.12.0+functor/bytecomp/translmod.ml
*** ocaml-3.12.0/bytecomp/translmod.ml 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/bytecomp/translmod.ml 2011-06-06 15:36:43.625859004 +0200
***************
*** 346,356 ****
(* Compile an implementation *)
let transl_implementation module_name (str, cc) =
reset_labels ();
primitive_declarations := [];
let module_id = Ident.create_persistent module_name in
Lprim(Psetglobal module_id,
! [transl_label_init
! (transl_structure [] cc (global_path module_id) str)])
(* A variant of transl_structure used to compile toplevel structure definitions
--- 346,377 ----
(* Compile an implementation *)
+ (* TODO: check what happens if a module has the same name as a module given as
+ argument *)
+
+ let transl_functor_unit functor_env modname str =
+ let ids = Env.get_functor_parts () in
+ let (str, _) = List.fold_left (fun (str, tbl) (name, parts) ->
+ if name = modname || Tbl.mem name tbl then (str, tbl) else
+ let id = Env.get_functor_part name in
+ let str = Llet(Strict, id,
+ Lapply(mod_prim "find_functor_arg", [
+ Lconst(Const_base (Const_string (Ident.name id)));
+ Lvar functor_env;
+ ], Location.none), str) in
+ (str, Tbl.add name id tbl)
+ ) (str, Tbl.empty) ids
+ in
+ Lfunction(Curried, [ functor_env ], str)
+
let transl_implementation module_name (str, cc) =
reset_labels ();
primitive_declarations := [];
let module_id = Ident.create_persistent module_name in
+ let str = transl_label_init (transl_structure [] cc (global_path module_id) str) in
Lprim(Psetglobal module_id,
! [if !Clflags.functors <> [] then
! let functor_env = Ident.create "functor_env" in
! Lprim(Pmakeblock(0, Immutable), [transl_functor_unit functor_env module_name str])
! else str])
(* A variant of transl_structure used to compile toplevel structure definitions
***************
*** 501,504 ****
--- 522,526 ----
| Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
+
(* Transform a coercion and the list of value identifiers defined by
a toplevel structure into a table [id -> (pos, coercion)],
***************
*** 544,547 ****
--- 566,570 ----
primitive_declarations := [];
let module_id = Ident.create_persistent module_name in
+ if !Clflags.functors <> [] then Ident.make_functor_part module_id;
let (map, prims, size) = build_ident_map restr (defined_idents str) in
let f = function
***************
*** 561,565 ****
let r = transl_store_gen module_name (str, restr) false in
transl_store_subst := s;
! r
(* Compile a toplevel phrase *)
--- 584,597 ----
let r = transl_store_gen module_name (str, restr) false in
transl_store_subst := s;
! if !Clflags.functors <> [] then
! let (size, str) = r in
! let id = Env.get_functor_part module_name in
! let str = Llet(Strict, id,
! Lprim(Pmakeblock(0, Immutable), Array.to_list (Array.create size lambda_unit)),
! Lsequence (str, Lvar id) ) in
! let functor_env = Ident.create "functor_env" in
! let str = transl_functor_unit functor_env module_name str in
! (size, str)
! else r
(* Compile a toplevel phrase *)
***************
*** 665,668 ****
--- 697,763 ----
| Some id -> Lprim(Pgetglobal id, [])
+ let const_string s =
+ Lconst(Const_base (Const_string s))
+
+ let const_pack_unit_name id =
+ let name = Ident.name id in
+ let name = try
+ let pos = String.rindex name '.' in
+ String.sub name (pos+1) (String.length name - pos - 1)
+ with Not_found -> name
+ in
+ const_string name
+
+ let transl_functor_package component_names target_name coercion
+ (functor_id, functor_arg) initial_env =
+ let env0_id = Ident.create "functor_env0" in
+ let env1_id = Ident.create "functor_env1" in
+ let rec eval_components env comps evaluated =
+ match comps with
+ [] ->
+ let component_names = List.rev evaluated in
+ let components =
+ match coercion with
+ Tcoerce_none ->
+ component_names
+ | Tcoerce_structure pos_cc_list ->
+ let g = Array.of_list component_names in
+ List.map
+ (fun (pos, cc) -> apply_coercion cc (g.(pos)))
+ pos_cc_list
+ | _ ->
+ assert false in
+ Lprim(Pmakeblock(0, Immutable), components)
+ | None :: tail ->
+ eval_components env tail evaluated
+ | Some comp :: tail ->
+ Ident.make_functor_arg comp;
+ let comp_id = Ident.create (Ident.name comp) in
+ let newenv = Ident.create "env" in
+ Llet(Strict,
+ comp_id, Lapply(
+ Lprim(Pfield 0, [Lprim(Pgetglobal comp, [])]),
+ [Lvar env], Location.none),
+ Llet(Strict,
+ newenv, Lapply(mod_prim "add_functor_arg",
+ [const_pack_unit_name comp;
+ Lvar comp_id; Lvar env], Location.none),
+ eval_components newenv tail (Lvar comp_id :: evaluated)))
+ in
+ let components = eval_components env1_id component_names [] in
+ let functor_body =
+ Llet(Strict, env0_id, initial_env,
+ Llet(Strict, env1_id,
+ Lapply(mod_prim "add_functor_arg",
+ [const_pack_unit_name functor_arg; Lvar functor_arg; Lvar env0_id],
+ Location.none),
+ components))
+ in
+ (* Llet(Strict, functor_id, *)
+ Lfunction(Curried, [functor_arg], functor_body)
+ (* , store_global functor_id) *)
+
+ let gen_new_env () = Lapply(mod_prim "create_functor_env",[lambda_unit], Location.none)
+
let transl_package component_names target_name coercion =
let components =
***************
*** 679,682 ****
--- 774,793 ----
Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
+ let transl_package component_names target_name coercion functor_info =
+ match functor_info with
+ None -> transl_package component_names target_name coercion
+ | Some (functor_id, functor_arg) ->
+ let functor_env = Ident.create "functor_env" in
+ let str =
+ transl_functor_package component_names target_name coercion (functor_id, functor_arg)
+ (if Env.get_functor_args () <> [] then Lvar functor_env else gen_new_env ())
+ in
+ Lprim(Psetglobal target_name,
+ [Lprim(Pmakeblock(0, Immutable),
+ [if !Clflags.functors <> [] then
+ let str = Lprim(Pmakeblock(0, Immutable),[str]) in
+ transl_functor_unit functor_env (Ident.name target_name) str
+ else str])])
+
let transl_store_package component_names target_name coercion =
let rec make_sequence fn pos arg =
***************
*** 704,707 ****
--- 815,840 ----
| _ -> assert false
+
+ let transl_store_package component_names target_name coercion functor_info =
+ match functor_info with
+ None -> transl_store_package component_names target_name coercion
+ | Some (functor_id, functor_arg) ->
+ let functor_env = Ident.create "functor_env" in
+ let str =
+ transl_functor_package component_names target_name coercion (functor_id, functor_arg)
+ (if Env.get_functor_args () <> [] then Lvar functor_env else gen_new_env ())
+ in
+ (1,
+ if !Clflags.functors <> [] then
+ let module_name = Ident.name target_name in
+ let str = Lprim(Pmakeblock(0, Immutable), [str]) in
+ let str = transl_functor_unit functor_env module_name str in
+ str
+ else
+ Lprim(Psetfield(0, false),
+ [Lprim(Pgetglobal target_name, []);
+ str]))
+
+
(* Error report *)
diff -C 2 -N -r -w ocaml-3.12.0/bytecomp/translmod.mli ocaml-3.12.0+functor/bytecomp/translmod.mli
*** ocaml-3.12.0/bytecomp/translmod.mli 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/bytecomp/translmod.mli 2011-06-06 14:33:18.185859004 +0200
***************
*** 25,31 ****
val transl_toplevel_definition: structure -> lambda
val transl_package:
! Ident.t option list -> Ident.t -> module_coercion -> lambda
val transl_store_package:
! Ident.t option list -> Ident.t -> module_coercion -> int * lambda
val toplevel_name: Ident.t -> string
--- 25,33 ----
val transl_toplevel_definition: structure -> lambda
val transl_package:
! Ident.t option list -> Ident.t -> module_coercion ->
! (Ident.t * Ident.t) option -> lambda
val transl_store_package:
! Ident.t option list -> Ident.t -> module_coercion ->
! (Ident.t * Ident.t) option -> int * lambda
val toplevel_name: Ident.t -> string
***************
*** 34,37 ****
--- 36,41 ----
val primitive_declarations: Primitive.description list ref
+ (*val mod_prim : string -> Lambda.lambda *)
+
type error =
Circular_dependency of Ident.t
diff -C 2 -N -r -w ocaml-3.12.0/debugger/Makefile.shared ocaml-3.12.0+functor/debugger/Makefile.shared
*** ocaml-3.12.0/debugger/Makefile.shared 2010-05-17 17:49:53.000000000 +0200
--- ocaml-3.12.0+functor/debugger/Makefile.shared 2011-06-06 14:33:18.185859004 +0200
***************
*** 36,40 ****
../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
../typing/subst.cmo ../typing/predef.cmo \
! ../typing/datarepr.cmo ../typing/env.cmo ../typing/oprint.cmo \
../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \
../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \
--- 36,41 ----
../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
../typing/subst.cmo ../typing/predef.cmo \
! ../typing/datarepr.cmo ../typing/cmi_format.cmo \
! ../typing/env.cmo ../typing/oprint.cmo \
../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \
../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \
diff -C 2 -N -r -w ocaml-3.12.0/.depend ocaml-3.12.0+functor/.depend
*** ocaml-3.12.0/.depend 2010-07-23 17:30:37.000000000 +0200
--- ocaml-3.12.0+functor/.depend 2011-06-06 14:45:21.255858999 +0200
***************
*** 66,69 ****
--- 66,70 ----
typing/annot.cmi: parsing/location.cmi
typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
+ typing/cmi_format.cmi: typing/types.cmi typing/ident.cmi
typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \
typing/env.cmi parsing/asttypes.cmi
***************
*** 114,117 ****
--- 115,122 ----
typing/btype.cmx: typing/types.cmx typing/path.cmx utils/misc.cmx \
typing/btype.cmi
+ typing/cmi_format.cmo: typing/types.cmi typing/ident.cmi \
+ typing/cmi_format.cmi
+ typing/cmi_format.cmx: typing/types.cmx typing/ident.cmx \
+ typing/cmi_format.cmi
typing/ctype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \
utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \
***************
*** 127,137 ****
typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
! utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
! typing/env.cmi
typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \
typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
! utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
! typing/env.cmi
typing/ident.cmo: typing/ident.cmi
typing/ident.cmx: typing/ident.cmi
--- 132,142 ----
typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
! typing/cmi_format.cmi utils/clflags.cmi typing/btype.cmi \
! parsing/asttypes.cmi typing/annot.cmi typing/env.cmi
typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \
typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
! typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \
! parsing/asttypes.cmi typing/annot.cmi typing/env.cmi
typing/ident.cmo: typing/ident.cmi
typing/ident.cmx: typing/ident.cmi
***************
*** 252,257 ****
typing/typemod.cmo: typing/typetexp.cmi typing/types.cmi typing/typedtree.cmi \
typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
! typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/path.cmi \
! parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
--- 257,262 ----
typing/typemod.cmo: typing/typetexp.cmi typing/types.cmi typing/typedtree.cmi \
typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
! utils/tbl.cmi typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \
! typing/path.cmi parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
***************
*** 260,265 ****
typing/typemod.cmx: typing/typetexp.cmx typing/types.cmx typing/typedtree.cmx \
typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \
! typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx typing/path.cmx \
! parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
--- 265,270 ----
typing/typemod.cmx: typing/typetexp.cmx typing/types.cmx typing/typedtree.cmx \
typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \
! utils/tbl.cmx typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \
! typing/path.cmx parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
***************
*** 319,327 ****
bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
typing/stypes.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
! bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
typing/stypes.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
! bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
--- 324,332 ----
bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
typing/stypes.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
! bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
typing/stypes.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
! bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
***************
*** 342,352 ****
bytecomp/bytelink.cmi
bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \
! typing/subst.cmi typing/path.cmi utils/misc.cmi bytecomp/instruct.cmi \
! typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \
bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
bytecomp/bytegen.cmi bytecomp/bytepackager.cmi
bytecomp/bytepackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \
! typing/subst.cmx typing/path.cmx utils/misc.cmx bytecomp/instruct.cmx \
! typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \
bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \
bytecomp/bytegen.cmx bytecomp/bytepackager.cmi
--- 347,359 ----
bytecomp/bytelink.cmi
bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \
! typing/subst.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \
! typing/path.cmi utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi \
! typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \
bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
bytecomp/bytegen.cmi bytecomp/bytepackager.cmi
bytecomp/bytepackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \
! typing/subst.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \
! typing/path.cmx utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx \
! typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \
bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \
bytecomp/bytegen.cmx bytecomp/bytepackager.cmi
***************
*** 447,460 ****
bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \
bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
! typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
! typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \
bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
! typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
! typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \
parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
--- 454,469 ----
bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \
bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
! utils/tbl.cmi typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
! typing/ctype.cmi utils/clflags.cmi parsing/asttypes.cmi \
! bytecomp/translmod.cmi
bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \
bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
! utils/tbl.cmx typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
! typing/ctype.cmx utils/clflags.cmx parsing/asttypes.cmi \
! bytecomp/translmod.cmi
bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \
parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
***************
*** 566,576 ****
asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/closure.cmo: utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \
! utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
! asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \
! parsing/asttypes.cmi asmcomp/closure.cmi
asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \
! utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
! asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
! parsing/asttypes.cmi asmcomp/closure.cmi
asmcomp/cmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
asmcomp/cmm.cmi
--- 575,585 ----
asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/closure.cmo: utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \
! utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
! asmcomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
! asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/closure.cmi
asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \
! utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
! asmcomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
! asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/closure.cmi
asmcomp/cmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
asmcomp/cmm.cmi
***************
*** 579,592 ****
asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
! asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
! asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
! asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
! asmcomp/cmmgen.cmi
asmcomp/cmmgen.cmx: typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \
typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
! asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
! asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
! asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
! asmcomp/cmmgen.cmi
asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
--- 588,601 ----
asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
! typing/env.cmi asmcomp/debuginfo.cmi utils/config.cmi \
! asmcomp/compilenv.cmi asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
! utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
! asmcomp/arch.cmo asmcomp/cmmgen.cmi
asmcomp/cmmgen.cmx: typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \
typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
! typing/env.cmx asmcomp/debuginfo.cmx utils/config.cmx \
! asmcomp/compilenv.cmx asmcomp/cmx_format.cmi asmcomp/cmm.cmx \
! utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
! asmcomp/arch.cmx asmcomp/cmmgen.cmi
asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
***************
*** 741,752 ****
typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi
! driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
! driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmi \
! bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
! bytecomp/bytelibrarian.cmi driver/main.cmi
! driver/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
! driver/errors.cmx utils/config.cmx driver/compile.cmx utils/clflags.cmx \
! bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
! bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main_args.cmo: utils/warnings.cmi driver/main_args.cmi
driver/main_args.cmx: utils/warnings.cmx driver/main_args.cmi
--- 750,761 ----
typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi
! driver/main.cmo: utils/warnings.cmi typing/typemod.cmi utils/misc.cmi \
! driver/main_args.cmi driver/errors.cmi typing/env.cmi utils/config.cmi \
! driver/compile.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \
! bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi
! driver/main.cmx: utils/warnings.cmx typing/typemod.cmx utils/misc.cmx \
! driver/main_args.cmx driver/errors.cmx typing/env.cmx utils/config.cmx \
! driver/compile.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \
! bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main_args.cmo: utils/warnings.cmi driver/main_args.cmi
driver/main_args.cmx: utils/warnings.cmx driver/main_args.cmi
***************
*** 781,794 ****
asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
asmcomp/asmgen.cmx driver/opterrors.cmi
! driver/optmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \
! driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \
! driver/main_args.cmi utils/config.cmi utils/clflags.cmi \
! asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \
! asmcomp/arch.cmo driver/optmain.cmi
! driver/optmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \
! driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \
! driver/main_args.cmx utils/config.cmx utils/clflags.cmx \
! asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
! asmcomp/arch.cmx driver/optmain.cmi
driver/pparse.cmo: utils/misc.cmi parsing/location.cmi utils/clflags.cmi \
utils/ccomp.cmi driver/pparse.cmi
--- 790,803 ----
asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
asmcomp/asmgen.cmx driver/opterrors.cmi
! driver/optmain.cmo: utils/warnings.cmi typing/typemod.cmi \
! asmcomp/printmach.cmi driver/opterrors.cmi driver/optcompile.cmi \
! utils/misc.cmi driver/main_args.cmi typing/env.cmi utils/config.cmi \
! utils/clflags.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \
! asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi
! driver/optmain.cmx: utils/warnings.cmx typing/typemod.cmx \
! asmcomp/printmach.cmx driver/opterrors.cmx driver/optcompile.cmx \
! utils/misc.cmx driver/main_args.cmx typing/env.cmx utils/config.cmx \
! utils/clflags.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \
! asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi
driver/pparse.cmo: utils/misc.cmi parsing/location.cmi utils/clflags.cmi \
utils/ccomp.cmi driver/pparse.cmi
diff -C 2 -N -r -w ocaml-3.12.0/driver/compile.ml ocaml-3.12.0+functor/driver/compile.ml
*** ocaml-3.12.0/driver/compile.ml 2008-10-06 15:53:54.000000000 +0200
--- ocaml-3.12.0+functor/driver/compile.ml 2011-06-06 14:33:18.185859004 +0200
***************
*** 43,49 ****
Ident.reinit();
try
if !Clflags.nopervasives
! then Env.initial
! else Env.open_pers_signature "Pervasives" Env.initial
with Not_found ->
fatal_error "cannot open pervasives.cmi"
--- 43,50 ----
Ident.reinit();
try
+ let env = Env.initial in
if !Clflags.nopervasives
! then env
! else Env.open_pers_signature "Pervasives" env
with Not_found ->
fatal_error "cannot open pervasives.cmi"
***************
*** 84,87 ****
--- 85,89 ----
Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ Env.add_functor_arguments modulename;
let sg = Typemod.transl_signature (initial_env()) ast in
if !Clflags.print_types then
***************
*** 112,115 ****
--- 114,118 ----
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
+ Env.add_functor_arguments modulename;
let env = initial_env() in
if !Clflags.print_types then begin
diff -C 2 -N -r -w ocaml-3.12.0/driver/main_args.ml ocaml-3.12.0+functor/driver/main_args.ml
*** ocaml-3.12.0/driver/main_args.ml 2010-07-06 16:05:26.000000000 +0200
--- ocaml-3.12.0+functor/driver/main_args.ml 2011-06-06 14:33:18.185859004 +0200
***************
*** 193,196 ****
--- 193,202 ----
;;
+ let mk_functor f =
+ "-functor", Arg.String f, " <file.mli> : signature of functor argument"
+
+ let mk_pack_functor f =
+ "-pack-functor", Arg.String f, "<modname> : name of functor"
+
let mk_pp f =
"-pp", Arg.String f, "<command> Pipe sources through preprocessor <command>"
***************
*** 400,403 ****
--- 406,411 ----
val _output_obj : unit -> unit
val _pack : unit -> unit
+ val _pack_functor : string -> unit
+ val _functor : string -> unit
val _pp : string -> unit
val _principal : unit -> unit
***************
*** 483,486 ****
--- 491,496 ----
val _p : unit -> unit
val _pack : unit -> unit
+ val _pack_functor : string -> unit
+ val _functor : string -> unit
val _pp : string -> unit
val _principal : unit -> unit
***************
*** 602,605 ****
--- 612,617 ----
mk_output_obj F._output_obj;
mk_pack_byt F._pack;
+ mk_pack_functor F._pack_functor;
+ mk_functor F._functor;
mk_pp F._pp;
mk_principal F._principal;
***************
*** 693,696 ****
--- 705,710 ----
mk_p F._p;
mk_pack_opt F._pack;
+ mk_pack_functor F._pack_functor;
+ mk_functor F._functor;
mk_pp F._pp;
mk_principal F._principal;
diff -C 2 -N -r -w ocaml-3.12.0/driver/main_args.mli ocaml-3.12.0+functor/driver/main_args.mli
*** ocaml-3.12.0/driver/main_args.mli 2010-05-20 16:06:29.000000000 +0200
--- ocaml-3.12.0+functor/driver/main_args.mli 2011-06-06 14:33:18.195859009 +0200
***************
*** 42,45 ****
--- 42,47 ----
val _output_obj : unit -> unit
val _pack : unit -> unit
+ val _pack_functor : string -> unit
+ val _functor : string -> unit
val _pp : string -> unit
val _principal : unit -> unit
***************
*** 126,129 ****
--- 128,133 ----
val _p : unit -> unit
val _pack : unit -> unit
+ val _pack_functor : string -> unit
+ val _functor : string -> unit
val _pp : string -> unit
val _principal : unit -> unit
diff -C 2 -N -r -w ocaml-3.12.0/driver/main.ml ocaml-3.12.0+functor/driver/main.ml
*** ocaml-3.12.0/driver/main.ml 2010-05-20 16:06:29.000000000 +0200
--- ocaml-3.12.0+functor/driver/main.ml 2011-06-06 15:37:02.775859002 +0200
***************
*** 48,52 ****
else if Filename.check_suffix name ".cmi" && !make_package then
objfiles := name :: !objfiles
! else if Filename.check_suffix name ext_obj
|| Filename.check_suffix name ext_lib then
ccobjs := name :: !ccobjs
--- 48,55 ----
else if Filename.check_suffix name ".cmi" && !make_package then
objfiles := name :: !objfiles
! else if Filename.check_suffix name ".cmi" && !print_types then begin
! Compile.init_path ();
! Typemod.print_types ppf name
! end else if Filename.check_suffix name ext_obj
|| Filename.check_suffix name ext_lib then
ccobjs := name :: !ccobjs
***************
*** 117,120 ****
--- 120,127 ----
let _output_obj () = output_c_object := true; custom_runtime := true
let _pack = set make_package
+ let _pack_functor s =
+ set make_package ();
+ pack_functor := Some s
+ let _functor s = functors := s :: !functors
let _pp s = preprocessor := Some s
let _principal = set principal
***************
*** 154,157 ****
--- 161,167 ----
| None -> Config.default_executable_name
+ let module_name filename =
+ String.capitalize (Misc.chop_extensions (Filename.basename filename))
+
let main () =
try
***************
*** 174,179 ****
else if !make_package then begin
Compile.init_path();
Bytepackager.package_files (List.rev !objfiles)
! (extract_output !output_name)
end
else if not !compile_only && !objfiles <> [] then begin
--- 184,195 ----
else if !make_package then begin
Compile.init_path();
+ let target = extract_output !output_name in
+ Env.add_functor_arguments (module_name target);
+ if Filename.check_suffix target ".cmi" then
+ Typemod.package_interfaces (List.rev !objfiles)
+ target !pack_functor
+ else
Bytepackager.package_files (List.rev !objfiles)
! target !pack_functor
end
else if not !compile_only && !objfiles <> [] then begin
***************
*** 202,204 ****
exit 2
! let _ = main ()
--- 218,222 ----
exit 2
! let _ =
! main ()
!
diff -C 2 -N -r -w ocaml-3.12.0/driver/optcompile.ml ocaml-3.12.0+functor/driver/optcompile.ml
*** ocaml-3.12.0/driver/optcompile.ml 2008-12-03 19:09:09.000000000 +0100
--- ocaml-3.12.0+functor/driver/optcompile.ml 2011-06-06 14:33:18.195859009 +0200
***************
*** 40,46 ****
Ident.reinit();
try
if !Clflags.nopervasives
! then Env.initial
! else Env.open_pers_signature "Pervasives" Env.initial
with Not_found ->
fatal_error "cannot open pervasives.cmi"
--- 40,47 ----
Ident.reinit();
try
+ let env = Env.initial in
if !Clflags.nopervasives
! then env
! else Env.open_pers_signature "Pervasives" env
with Not_found ->
fatal_error "cannot open pervasives.cmi"
***************
*** 81,84 ****
--- 82,86 ----
Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ Env.add_functor_arguments modulename;
let sg = Typemod.transl_signature (initial_env()) ast in
if !Clflags.print_types then
***************
*** 113,116 ****
--- 115,119 ----
let inputfile = Pparse.preprocess sourcefile in
let env = initial_env() in
+ Env.add_functor_arguments modulename;
Compilenv.reset ?packname:!Clflags.for_package modulename;
let cmxfile = outputprefix ^ ".cmx" in
***************
*** 138,141 ****
--- 141,145 ----
Stypes.dump (outputprefix ^ ".annot");
with x ->
+ Printexc.print_backtrace stderr;
remove_file objfile;
remove_file cmxfile;
***************
*** 146,147 ****
--- 150,153 ----
let c_file name =
if Ccomp.compile_file name <> 0 then exit 2
+
+
diff -C 2 -N -r -w ocaml-3.12.0/driver/optmain.ml ocaml-3.12.0+functor/driver/optmain.ml
*** ocaml-3.12.0/driver/optmain.ml 2010-05-20 16:06:29.000000000 +0200
--- ocaml-3.12.0+functor/driver/optmain.ml 2011-06-06 15:37:10.035859003 +0200
***************
*** 45,48 ****
--- 45,52 ----
else if Filename.check_suffix name ".cmi" && !make_package then
objfiles := name :: !objfiles
+ else if Filename.check_suffix name ".cmi" && !print_types then begin
+ Optcompile.init_path ();
+ Typemod.print_types ppf name
+ end
else if Filename.check_suffix name ext_obj
|| Filename.check_suffix name ext_lib then
***************
*** 126,129 ****
--- 130,137 ----
let _p = set gprofile
let _pack = set make_package
+ let _pack_functor s =
+ set make_package ();
+ pack_functor := Some s
+ let _functor s = functors := s :: !functors
let _pp s = preprocessor := Some s
let _principal = set principal
***************
*** 164,167 ****
--- 172,178 ----
end);;
+ let module_name filename =
+ String.capitalize (Misc.chop_extensions (Filename.basename filename))
+
let main () =
native_code := true;
***************
*** 183,187 ****
Optcompile.init_path();
let target = extract_output !output_name in
! Asmpackager.package_files ppf (List.rev !objfiles) target;
end
else if !shared then begin
--- 194,203 ----
Optcompile.init_path();
let target = extract_output !output_name in
! Env.add_functor_arguments (module_name target);
! if Filename.check_suffix target ".cmi" then
! Typemod.package_interfaces (List.rev !objfiles)
! target !pack_functor
! else
! Asmpackager.package_files ppf (List.rev !objfiles) target !pack_functor;
end
else if !shared then begin
***************
*** 214,216 ****
exit 2
! let _ = main ()
--- 230,234 ----
exit 2
!
! let _ =
! main ()
diff -C 2 -N -r -w ocaml-3.12.0/Makefile ocaml-3.12.0+functor/Makefile
*** ocaml-3.12.0/Makefile 2010-06-16 03:32:26.000000000 +0200
--- ocaml-3.12.0+functor/Makefile 2011-06-06 14:33:18.175859003 +0200
***************
*** 20,25 ****
CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
! COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES)
! LINKFLAGS=
CAMLYACC=boot/ocamlyacc
--- 20,25 ----
CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
! COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES) -g
! LINKFLAGS=-g
CAMLYACC=boot/ocamlyacc
***************
*** 49,53 ****
typing/btype.cmo typing/oprint.cmo \
typing/subst.cmo typing/predef.cmo \
! typing/datarepr.cmo typing/env.cmo \
typing/typedtree.cmo typing/ctype.cmo \
typing/printtyp.cmo typing/includeclass.cmo \
--- 49,53 ----
typing/btype.cmo typing/oprint.cmo \
typing/subst.cmo typing/predef.cmo \
! typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \
typing/typedtree.cmo typing/ctype.cmo \
typing/printtyp.cmo typing/includeclass.cmo \
***************
*** 546,550 ****
tools/cvt_emit: tools/cvt_emit.mll
cd tools; \
! $(MAKE) CAMLC="../$(CAMLRUN) ../boot/ocamlc -I ../stdlib" cvt_emit
# The "expunge" utility
--- 546,550 ----
tools/cvt_emit: tools/cvt_emit.mll
cd tools; \
! $(MAKE) CAMLC="../$(CAMLRUN) ../boot/ocamlc -I ../boot" cvt_emit
# The "expunge" utility
diff -C 2 -N -r -w ocaml-3.12.0/ocamldoc/Makefile ocaml-3.12.0+functor/ocamldoc/Makefile
*** ocaml-3.12.0/ocamldoc/Makefile 2010-06-16 13:38:22.000000000 +0200
--- ocaml-3.12.0+functor/ocamldoc/Makefile 2011-06-06 14:33:18.195859009 +0200
***************
*** 154,157 ****
--- 154,158 ----
$(OCAMLSRCDIR)/typing/datarepr.cmo \
$(OCAMLSRCDIR)/typing/subst.cmo \
+ $(OCAMLSRCDIR)/typing/cmi_format.cmo \
$(OCAMLSRCDIR)/typing/env.cmo \
$(OCAMLSRCDIR)/typing/ctype.cmo \
diff -C 2 -N -r -w ocaml-3.12.0/ocamldoc/Makefile.nt ocaml-3.12.0+functor/ocamldoc/Makefile.nt
*** ocaml-3.12.0/ocamldoc/Makefile.nt 2010-05-28 13:21:46.000000000 +0200
--- ocaml-3.12.0+functor/ocamldoc/Makefile.nt 2011-06-06 14:33:18.195859009 +0200
***************
*** 149,152 ****
--- 149,153 ----
$(OCAMLSRCDIR)/typing/datarepr.cmo \
$(OCAMLSRCDIR)/typing/subst.cmo \
+ $(OCAMLSRCDIR)/typing/cmi_format.cmo \
$(OCAMLSRCDIR)/typing/env.cmo \
$(OCAMLSRCDIR)/typing/ctype.cmo \
diff -C 2 -N -r -w ocaml-3.12.0/otherlibs/dynlink/Makefile ocaml-3.12.0+functor/otherlibs/dynlink/Makefile
*** ocaml-3.12.0/otherlibs/dynlink/Makefile 2010-05-28 17:09:22.000000000 +0200
--- ocaml-3.12.0+functor/otherlibs/dynlink/Makefile 2011-06-06 14:33:18.195859009 +0200
***************
*** 34,38 ****
../../typing/primitive.cmo ../../typing/types.cmo \
../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \
! ../../typing/datarepr.cmo ../../typing/env.cmo \
../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \
../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \
--- 34,40 ----
../../typing/primitive.cmo ../../typing/types.cmo \
../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \
! ../../typing/datarepr.cmo \
! ../../typing/cmi_format.cmo \
! ../../typing/env.cmo \
../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \
../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \
diff -C 2 -N -r -w ocaml-3.12.0/parsing/location.ml ocaml-3.12.0+functor/parsing/location.ml
*** ocaml-3.12.0/parsing/location.ml 2008-01-11 17:13:18.000000000 +0100
--- ocaml-3.12.0+functor/parsing/location.ml 2011-06-06 14:33:18.195859009 +0200
***************
*** 206,210 ****
let get_pos_info pos =
let (filename, linenum, linebeg) =
! if pos.pos_fname = "" && !input_name = "" then
("", -1, 0)
else if pos.pos_fname = "" then
--- 206,210 ----
let get_pos_info pos =
let (filename, linenum, linebeg) =
! if pos.pos_fname = "" && (!input_name = "" || !input_name = "_none_") then
("", -1, 0)
else if pos.pos_fname = "" then
diff -C 2 -N -r -w ocaml-3.12.0/stdlib/camlinternalMod.ml ocaml-3.12.0+functor/stdlib/camlinternalMod.ml
*** ocaml-3.12.0/stdlib/camlinternalMod.ml 2008-01-11 17:13:18.000000000 +0100
--- ocaml-3.12.0+functor/stdlib/camlinternalMod.ml 2011-06-06 14:33:18.195859009 +0200
***************
*** 67,68 ****
--- 67,76 ----
update_mod comps.(i) (Obj.field o i) (Obj.field n i)
done
+
+ module StringMap = Map.Make(String)
+
+ type functor_arg
+ type functor_env = functor_arg StringMap.t
+ let create_functor_env () = StringMap.empty
+ let find_functor_arg = StringMap.find
+ let add_functor_arg = StringMap.add
diff -C 2 -N -r -w ocaml-3.12.0/stdlib/camlinternalMod.mli ocaml-3.12.0+functor/stdlib/camlinternalMod.mli
*** ocaml-3.12.0/stdlib/camlinternalMod.mli 2004-08-12 14:57:00.000000000 +0200
--- ocaml-3.12.0+functor/stdlib/camlinternalMod.mli 2011-06-06 14:33:18.195859009 +0200
***************
*** 22,23 ****
--- 22,29 ----
val init_mod: string * int * int -> shape -> Obj.t
val update_mod: shape -> Obj.t -> Obj.t -> unit
+
+ type functor_env
+ type functor_arg
+ val create_functor_env : unit -> functor_env
+ val find_functor_arg : string -> functor_env -> functor_arg
+ val add_functor_arg : string -> functor_arg -> functor_env -> functor_env
diff -C 2 -N -r -w ocaml-3.12.0/tools/Makefile.shared ocaml-3.12.0+functor/tools/Makefile.shared
*** ocaml-3.12.0/tools/Makefile.shared 2010-06-07 08:58:41.000000000 +0200
--- ocaml-3.12.0+functor/tools/Makefile.shared 2011-06-06 14:33:18.205858999 +0200
***************
*** 234,238 ****
OBJINFO=../utils/misc.cmo ../utils/config.cmo ../bytecomp/bytesections.cmo \
! objinfo.cmo
objinfo: objinfo_helper$(EXE) $(OBJINFO)
--- 234,238 ----
OBJINFO=../utils/misc.cmo ../utils/config.cmo ../bytecomp/bytesections.cmo \
! ../typing/cmi_format.cmo objinfo.cmo
objinfo: objinfo_helper$(EXE) $(OBJINFO)
diff -C 2 -N -r -w ocaml-3.12.0/tools/objinfo.ml ocaml-3.12.0+functor/tools/objinfo.ml
*** ocaml-3.12.0/tools/objinfo.ml 2010-05-24 16:27:50.000000000 +0200
--- ocaml-3.12.0+functor/tools/objinfo.ml 2011-06-06 14:33:18.205858999 +0200
***************
*** 24,27 ****
--- 24,28 ----
open Cmo_format
open Clambda
+ open Cmi_format
let input_stringlist ic len =
***************
*** 45,52 ****
--- 46,65 ----
printf "\t%s\n" name
+ let print_functor_infos functor_args functor_parts =
+ if functor_args <> [] then begin
+ printf "Functor args:\n";
+ List.iter print_name_crc functor_args;
+ printf "Functors parts:\n";
+ List.iter (fun (id, deps) ->
+ printf "\t%s\n" ( id);
+ List.iter (fun (id, crc) -> printf "\t\t(%s:%s)\n" (id) (Digest.to_hex crc)) deps;
+ ) functor_parts
+ end
+
let print_cmo_infos cu =
printf "Unit name: %s\n" cu.cu_name;
print_string "Interfaces imported:\n";
List.iter print_name_crc cu.cu_imports;
+ print_functor_infos cu.cu_functor_args cu.cu_functor_parts;
printf "Uses unsafe features: ";
match cu.cu_primitives with
***************
*** 98,105 ****
List.iter print_cmo_infos lib.lib_units
! let print_cmi_infos name sign comps crcs =
! printf "Unit name: %s\n" name;
printf "Interfaces imported:\n";
! List.iter print_name_crc crcs
let print_general_infos name crc defines cmi cmx =
--- 111,119 ----
List.iter print_cmo_infos lib.lib_units
! let print_cmi_infos cmi cmi_crc =
! printf "Unit name: %s\n" cmi.cmi_name;
printf "Interfaces imported:\n";
! List.iter print_name_crc cmi.cmi_crcs;
! print_functor_infos cmi.cmi_functor_args cmi.cmi_functor_parts
let print_general_infos name crc defines cmi cmx =
***************
*** 118,121 ****
--- 132,136 ----
print_general_infos
ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
+ print_functor_infos ui.ui_functor_args ui.ui_functor_parts;
printf "Approximation:\n";
Format.fprintf Format.std_formatter " %a@." print_approx_infos ui.ui_approx;
***************
*** 223,230 ****
print_cma_infos toc
end else if magic_number = cmi_magic_number then begin
! let (name, sign, comps) = input_value ic in
! let crcs = input_value ic in
close_in ic;
! print_cmi_infos name sign comps crcs
end else if magic_number = cmx_magic_number then begin
let ui = (input_value ic : unit_infos) in
--- 238,244 ----
print_cma_infos toc
end else if magic_number = cmi_magic_number then begin
! let (cmi, cmi_crc) = Cmi_format.input_cmi_info ic in
close_in ic;
! print_cmi_infos cmi cmi_crc
end else if magic_number = cmx_magic_number then begin
let ui = (input_value ic : unit_infos) in
diff -C 2 -N -r -w ocaml-3.12.0/tools/ocamlcp.ml ocaml-3.12.0+functor/tools/ocamlcp.ml
*** ocaml-3.12.0/tools/ocamlcp.ml 2010-05-20 16:06:29.000000000 +0200
--- ocaml-3.12.0+functor/tools/ocamlcp.ml 2011-06-06 14:33:18.205858999 +0200
***************
*** 71,74 ****
--- 71,76 ----
let _output_obj = option "-output-obj"
let _pack = option "-pack"
+ let _pack_functor = option_with_arg "-pack-functor"
+ let _functor = option_with_arg "-functor"
let _pp s = incompatible "-pp"
let _principal = option "-principal"
diff -C 2 -N -r -w ocaml-3.12.0/typing/cmi_format.ml ocaml-3.12.0+functor/typing/cmi_format.ml
*** ocaml-3.12.0/typing/cmi_format.ml 1970-01-01 01:00:00.000000000 +0100
--- ocaml-3.12.0+functor/typing/cmi_format.ml 2011-06-06 14:33:18.205858999 +0200
***************
*** 0 ****
--- 1,24 ----
+ type pers_flags = Rectypes
+
+ type cmi_info = {
+ cmi_name : string;
+ cmi_sig : Types.signature_item list;
+ mutable cmi_crcs : (string * Digest.t) list;
+ cmi_flags : pers_flags list;
+ cmi_arg_id : Ident.t;
+ cmi_functor_args : (string * Digest.t) list;
+ cmi_functor_parts : (string * (string * Digest.t) list) list;
+ }
+
+ let input_cmi_info ic =
+ let cmi = (input_value ic : cmi_info) in
+ let cmi_crc = (input_value ic : Digest.t) in
+ cmi, cmi_crc
+
+ let output_cmi_info oc cmi =
+ let s = Marshal.to_string cmi [] in
+ let crc = Digest.string s in
+ output_string oc s;
+ output_value oc crc;
+ crc
+
diff -C 2 -N -r -w ocaml-3.12.0/typing/cmi_format.mli ocaml-3.12.0+functor/typing/cmi_format.mli
*** ocaml-3.12.0/typing/cmi_format.mli 1970-01-01 01:00:00.000000000 +0100
--- ocaml-3.12.0+functor/typing/cmi_format.mli 2011-06-06 14:33:18.205858999 +0200
***************
*** 0 ****
--- 1,21 ----
+ type pers_flags = Rectypes
+
+ type cmi_info = {
+ cmi_name : string;
+ cmi_sig : Types.signature_item list;
+ mutable cmi_crcs : (string * Digest.t) list;
+ cmi_flags : pers_flags list;
+ cmi_arg_id : Ident.t;
+ (* For functors: this interface corresponds to a file that depends
+ on these arguments, with the corresponding digests.
+ *)
+ cmi_functor_args : (string * Digest.t) list;
+ (* For functors: this interface corresponds to a file that depends
+ on these units, with the corresponding argument dependencies.
+ The dependencies should be a suffix of the current dependencies.
+ *)
+ cmi_functor_parts : (string * (string * Digest.t) list) list;
+ }
+
+ val input_cmi_info : in_channel -> cmi_info * Digest.t
+ val output_cmi_info : out_channel -> cmi_info -> Digest.t
diff -C 2 -N -r -w ocaml-3.12.0/typing/ctype.ml ocaml-3.12.0+functor/typing/ctype.ml
*** ocaml-3.12.0/typing/ctype.ml 2010-06-24 10:43:39.000000000 +0200
--- ocaml-3.12.0+functor/typing/ctype.ml 2011-06-06 14:33:18.205858999 +0200
***************
*** 3474,3475 ****
--- 3474,3576 ----
let collapse_conj_params env params =
List.iter (collapse_conj env []) params
+
+ module PrintDebugType = struct
+
+ type context = {
+ table : (int, string) Hashtbl.t;
+ }
+
+ let rec type_expr c t =
+ try
+ Hashtbl.find c.table t.id
+ with Not_found ->
+ Hashtbl.add c.table t.id (Printf.sprintf "{ty.id = %d}" t.id);
+ let b = Buffer.create 100 in
+ Printf.bprintf b "{ desc = %s;\n" (type_desc c t.desc);
+ Printf.bprintf b " level = %d;\n" t.level;
+ Printf.bprintf b " id = %d }" t.id;
+ let s = Buffer.contents b in
+ Hashtbl.add c.table t.id s;
+ s
+
+ and type_desc c t =
+ match t with
+ Tvar -> "Tvar"
+ | Tarrow _ -> "Tarrow"
+ | Ttuple _ -> "Ttuple"
+ | Tconstr _ -> "Tconstr"
+ | Tobject _ -> "Tobject"
+ | Tfield _ -> "Tfield"
+ | Tnil -> "Tnil"
+ | Tlink _ -> "Tlink"
+ | Tsubst _ -> "Tsubst"
+ | Tvariant _ -> "Tvariant"
+ | Tunivar -> "Tunivar"
+ | Tpoly _ -> "Tpoly"
+ | Tpackage _ -> "Tpackage"
+
+ (*
+ | Tarrow of label * type_expr * type_expr * commutable
+ | Ttuple of type_expr list
+ | Tconstr of Path.t * type_expr list * abbrev_memo ref
+ | Tobject of type_expr * (Path.t * type_expr list) option ref
+ | Tfield of string * field_kind * type_expr * type_expr
+ | Tnil
+ | Tlink of type_expr
+ | Tsubst of type_expr (* for copying *)
+ | Tvariant of row_desc
+ | Tunivar
+ | Tpoly of type_expr * type_expr list
+ | Tpackage of Path.t * string list * type_expr list
+ *)
+
+ (*
+ and row_desc =
+ { row_fields: (label * row_field) list;
+ row_more: type_expr;
+ row_bound: unit;
+ row_closed: bool;
+ row_fixed: bool;
+ row_name: (Path.t * type_expr list) option }
+
+ and row_field =
+ Rpresent of type_expr option
+ | Reither of bool * type_expr list * bool * row_field option ref
+ (* 1st true denotes a constant constructor *)
+ (* 2nd true denotes a tag in a pattern matching, and
+ is erased later *)
+ | Rabsent
+
+ and abbrev_memo =
+ Mnil
+ | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
+ | Mlink of abbrev_memo ref
+
+ and field_kind =
+ Fvar of field_kind option ref
+ | Fpresent
+ | Fabsent
+
+ and commutable =
+ Cok
+ | Cunknown
+ | Clink of commutable ref
+ *)
+
+ let type_expr t = type_expr { table = Hashtbl.create 13 } t
+
+ end
+
+ let _ =
+ Printexc.register_printer (fun e ->
+ match e with
+ Unify list ->
+ let b = Buffer.create 100 in
+ Printf.bprintf b "Ctype.Unify [\n";
+ List.iter (fun (t1, t2) ->
+ Printf.bprintf b " (%s,\n" (PrintDebugType.type_expr t1);
+ Printf.bprintf b " %s)\n" (PrintDebugType.type_expr t2);
+ ) list;
+ Printf.bprintf b " ]\n";
+ Some (Buffer.contents b)
+ | _ -> None)
diff -C 2 -N -r -w ocaml-3.12.0/typing/env.ml ocaml-3.12.0+functor/typing/env.ml
*** ocaml-3.12.0/typing/env.ml 2010-04-30 03:56:21.000000000 +0200
--- ocaml-3.12.0+functor/typing/env.ml 2011-06-06 15:35:45.245858999 +0200
***************
*** 22,25 ****
--- 22,26 ----
open Types
+ type intf_info = string * Digest.t
type error =
***************
*** 28,31 ****
--- 29,33 ----
| Illegal_renaming of string * string
| Inconsistent_import of string * string * string
+ | Inconsistent_arguments of string * intf_info list * intf_info list
| Need_recursive_types of string * string
***************
*** 135,141 ****
let current_unit = ref ""
(* Persistent structure descriptions *)
! type pers_flags = Rectypes
type pers_struct =
--- 137,153 ----
let current_unit = ref ""
+ let functor_args = ref ([] : (string * Digest.t) list)
+ let functor_arg_crcs = (Hashtbl.create 17 : (string, Digest.t * string) Hashtbl.t)
+ let functor_parts = ref ([] : (string * (string * Digest.t) list) list)
+ let functor_parts_table = (Hashtbl.create 17 : (string, Ident.t) Hashtbl.t)
+
(* Persistent structure descriptions *)
! (* type pers_flags = Rectypes moved to Cmi_format *)
!
! type ps_kind =
! PersistentStructureDependency
! | PersistentStructureArgument
! | PersistentStructureUnit
type pers_struct =
***************
*** 145,152 ****
ps_crcs: (string * Digest.t) list;
ps_filename: string;
! ps_flags: pers_flags list }
! let persistent_structures =
! (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
(* Consistency between persistent structures *)
--- 157,169 ----
ps_crcs: (string * Digest.t) list;
ps_filename: string;
! ps_flags: Cmi_format.pers_flags list;
! ps_id : Ident.t;
! ps_kind : ps_kind;
! ps_crc : Digest.t;
! ps_functor_args : (string * Digest.t) list;
! ps_functor_parts : (string * (string * Digest.t) list) list;
! }
! let persistent_structures = (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
(* Consistency between persistent structures *)
***************
*** 162,168 ****
raise(Error(Inconsistent_import(name, auth, source)))
(* Reading persistent structures from .cmi files *)
! let read_pers_struct modname filename =
let ic = open_in_bin filename in
try
--- 179,223 ----
raise(Error(Inconsistent_import(name, auth, source)))
+ let check_functor_args filename crcs =
+ if crcs <> [] then
+ let rec iter current_crcs =
+ match current_crcs with
+ [] ->
+ raise(Error(Inconsistent_arguments(filename, crcs, !functor_args)))
+ | _ :: tail ->
+ if current_crcs = crcs then () else
+ iter tail
+
+ in
+ iter !functor_args
+
(* Reading persistent structures from .cmi files *)
! open Cmi_format
!
! (* TODO: check the case where two modules have inconsistent
! assumptions on a module: one uses it as an argument, the other one as
! a dependency. This should fail. *)
!
! let add_functor_arg id =
! Ident.make_functor_part id;
! Ident.make_functor_arg id;
! let name = Ident.name id in
! functor_parts := (Ident.name id, []) :: !functor_parts;
! if not (Hashtbl.mem functor_parts_table name) then
! Hashtbl.add functor_parts_table name (Ident.create name)
!
! let add_functor_part id deps =
! Ident.make_functor_part id;
! let name = Ident.name id in
! functor_parts := (Ident.name id, deps) :: !functor_parts;
! if not (Hashtbl.mem functor_parts_table name) then
! Hashtbl.add functor_parts_table name (Ident.create name)
!
! let get_functor_part name = Hashtbl.find functor_parts_table name
!
! let get_functor_parts () = !functor_parts
!
! let read_pers_struct modname filename ps_kind =
let ic = open_in_bin filename in
try
***************
*** 173,193 ****
raise(Error(Not_an_interface filename))
end;
! let (name, sign) = input_value ic in
! let crcs = input_value ic in
! let flags = input_value ic in
close_in ic;
let comps =
!components_of_module' empty Subst.identity
! (Pident(Ident.create_persistent name))
! (Tmty_signature sign) in
! let ps = { ps_name = name;
! ps_sig = sign;
ps_comps = comps;
! ps_crcs = crcs;
ps_filename = filename;
! ps_flags = flags } in
if ps.ps_name <> modname then
raise(Error(Illegal_renaming(ps.ps_name, filename)));
check_consistency filename ps.ps_crcs;
List.iter
(function Rectypes ->
--- 228,262 ----
raise(Error(Not_an_interface filename))
end;
! let (cmi, crc) = Cmi_format.input_cmi_info ic in
close_in ic;
+ let ps_id = Ident.create_persistent cmi.cmi_name in
+ begin
+ match ps_kind with
+ | PersistentStructureArgument -> add_functor_arg ps_id
+ | PersistentStructureDependency ->
+ if cmi.cmi_functor_args <> [] then add_functor_part ps_id cmi.cmi_functor_args
+ | PersistentStructureUnit -> ()
+ end;
let comps =
!components_of_module' empty Subst.identity
! (Pident ps_id)
! (Tmty_signature cmi.cmi_sig) in
! let ps = { ps_name = cmi.cmi_name;
! ps_sig = cmi.cmi_sig;
ps_comps = comps;
! ps_crcs = (cmi.cmi_name, crc) :: cmi.cmi_crcs;
! ps_crc = crc;
ps_filename = filename;
! ps_flags = cmi.cmi_flags;
! ps_kind = ps_kind;
! ps_id = ps_id;
! ps_functor_args = cmi.cmi_functor_args;
! ps_functor_parts = cmi.cmi_functor_parts;
! } in
if ps.ps_name <> modname then
raise(Error(Illegal_renaming(ps.ps_name, filename)));
check_consistency filename ps.ps_crcs;
+ if ps_kind <> PersistentStructureUnit then
+ check_functor_args filename ps.ps_functor_args;
List.iter
(function Rectypes ->
***************
*** 206,213 ****
--- 275,287 ----
with Not_found ->
read_pers_struct name (find_in_path_uncap !load_path (name ^ ".cmi"))
+ PersistentStructureDependency
let reset_cache () =
current_unit := "";
Hashtbl.clear persistent_structures;
+ functor_args := [];
+ functor_parts := [];
+ Hashtbl.clear functor_parts_table;
+ Hashtbl.clear functor_arg_crcs;
Consistbl.clear crc_units
***************
*** 226,230 ****
if Ident.persistent id
then (find_pers_struct (Ident.name id)).ps_comps
! else raise Not_found
end
| Pdot(p, s, pos) ->
--- 300,306 ----
if Ident.persistent id
then (find_pers_struct (Ident.name id)).ps_comps
! else begin
! raise Not_found
! end
end
| Pdot(p, s, pos) ->
***************
*** 312,316 ****
let ps = find_pers_struct (Ident.name id) in
Tmty_signature(ps.ps_sig)
! else raise Not_found
end
| Pdot(p, s, pos) ->
--- 388,394 ----
let ps = find_pers_struct (Ident.name id) in
Tmty_signature(ps.ps_sig)
! else begin
! raise Not_found
! end
end
| Pdot(p, s, pos) ->
***************
*** 334,338 ****
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
! (Pident(Ident.create_persistent s), ps.ps_comps)
end
| Ldot(l, s) ->
--- 412,416 ----
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
! (Pident ps.ps_id, ps.ps_comps)
end
| Ldot(l, s) ->
***************
*** 364,368 ****
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
! (Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig)
end
| Ldot(l, s) ->
--- 442,446 ----
if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
! (Pident ps.ps_id, Tmty_signature ps.ps_sig)
end
| Ldot(l, s) ->
***************
*** 783,792 ****
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 CRC of the interface of the given compilation unit *)
--- 861,881 ----
let open_pers_signature name env =
let ps = find_pers_struct name in
! open_signature (Pident ps.ps_id) ps.ps_sig env
(* Read a signature from a file *)
let read_signature modname filename =
! let ps = read_pers_struct modname filename PersistentStructureDependency in
! ps.ps_sig
!
! let read_my_signature modname filename =
! let ps = read_pers_struct modname filename PersistentStructureDependency in
! if ps.ps_functor_args <> !functor_args then
! raise (Error(Inconsistent_arguments (filename, ps.ps_functor_args, !functor_args)));
! ps.ps_sig
!
! let read_signature_and_args modname filename =
! let ps = read_pers_struct modname filename PersistentStructureUnit in
! (ps.ps_sig, ps.ps_functor_args, ps.ps_functor_parts)
(* Return the CRC of the interface of the given compilation unit *)
***************
*** 813,836 ****
try
output_string oc cmi_magic_number;
! output_value oc (modname, sg);
! flush oc;
! let crc = Digest.file filename in
! let crcs = (modname, crc) :: imports in
! output_value oc crcs;
! let flags = if !Clflags.recursive_types then [Rectypes] else [] in
! output_value oc flags;
close_out oc;
(* Enter signature in persistent table so that imported_unit()
will also return its crc *)
let comps =
components_of_module empty Subst.identity
! (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
let ps =
{ ps_name = modname;
ps_sig = sg;
ps_comps = comps;
! ps_crcs = crcs;
ps_filename = filename;
! ps_flags = flags } in
Hashtbl.add persistent_structures modname ps;
Consistbl.set crc_units modname crc filename
--- 902,935 ----
try
output_string oc cmi_magic_number;
! let cmi = {
! cmi_name = modname;
! cmi_sig = sg;
! cmi_crcs = imports;
! cmi_functor_args = !functor_args;
! cmi_arg_id = Ident.create modname;
! cmi_flags = (if !Clflags.recursive_types then [Rectypes] else []);
! cmi_functor_parts = !functor_parts;
! } in
! let crc = output_cmi_info oc cmi in
close_out oc;
(* Enter signature in persistent table so that imported_unit()
will also return its crc *)
+ let ps_pers_id = Ident.create_persistent modname in
let comps =
components_of_module empty Subst.identity
! (Pident ps_pers_id) (Tmty_signature sg) in
let ps =
{ ps_name = modname;
ps_sig = sg;
ps_comps = comps;
! ps_crcs = (modname, crc) :: cmi.cmi_crcs;
! ps_crc = crc;
ps_filename = filename;
! ps_flags = cmi.cmi_flags;
! ps_id = ps_pers_id;
! ps_kind = PersistentStructureDependency;
! ps_functor_args = cmi.cmi_functor_args;
! ps_functor_parts = cmi.cmi_functor_parts;
! } in
Hashtbl.add persistent_structures modname ps;
Consistbl.set crc_units modname crc filename
***************
*** 845,848 ****
--- 944,970 ----
(* Make the initial environment *)
+ (* TODO Add checks: identifiers loaded for functor arguments should not conflict
+ with any local identifier. This is simply done in the case of persistent modules,
+ as their identifier is marked persistent. This is harder:
+ - for namespaces (check !!!)
+ - for these local identifiers
+ *)
+
+ let add_functor_arguments modname =
+ if !Clflags.functors <> [] then begin
+ add_functor_part (Ident.create_persistent modname) [];
+ functor_args := [];
+ List.iter (fun filename ->
+ let filename = Filename.chop_suffix filename ".mli" (* could be .cmi *) in
+ let modname = String.capitalize (Filename.basename filename) in
+ let filename = filename ^ ".cmi" in
+ let ps = read_pers_struct modname filename PersistentStructureArgument in
+ functor_args := (Ident.name ps.ps_id, ps.ps_crc) :: !functor_args;
+ Hashtbl.add functor_arg_crcs (Ident.name ps.ps_id) (ps.ps_crc, filename);
+ ) !Clflags.functors
+ end
+
+ let get_functor_args () = !functor_args
+
let initial = Predef.build_initial_env add_type add_exception empty
***************
*** 867,870 ****
--- 989,1000 ----
make inconsistent assumptions@ over interface %s@]"
source1 source2 name
+ | Inconsistent_arguments(filename, file_functor_args, current_functor_args) ->
+ fprintf ppf
+ "@[<hov>Inconsistent functor arguments with file %s@." filename;
+ fprintf ppf "File arguments:";
+ List.iter (fun (id,_) -> fprintf ppf "(%s)" id) file_functor_args;
+ fprintf ppf "@.Current arguments:";
+ List.iter (fun (id,_) -> fprintf ppf "(%s)" id) current_functor_args;
+ fprintf ppf "@]"
| Need_recursive_types(import, export) ->
fprintf ppf
diff -C 2 -N -r -w ocaml-3.12.0/typing/env.mli ocaml-3.12.0+functor/typing/env.mli
*** ocaml-3.12.0/typing/env.mli 2008-10-06 15:53:54.000000000 +0200
--- ocaml-3.12.0+functor/typing/env.mli 2011-06-06 14:33:18.205858999 +0200
***************
*** 19,24 ****
--- 19,30 ----
type t
+ type intf_info = string * Digest.t
+
val empty: t
val initial: t
+ val add_functor_arguments : string -> unit
+ val get_functor_args : unit -> (string * Digest.t) list
+ val get_functor_parts : unit -> (string * (string * Digest.t) list) list
+ val get_functor_part : string -> Ident.t
val diff: t -> t -> Ident.t list
***************
*** 91,94 ****
--- 97,103 ----
val read_signature: string -> string -> signature
+ val read_my_signature: string -> string -> signature
+ val read_signature_and_args: string -> string ->
+ signature * (string * Digest.t) list * (string * (string * Digest.t) list) list
(* Arguments: module name, file name. Results: signature. *)
val save_signature: signature -> string -> string -> unit
***************
*** 134,137 ****
--- 143,147 ----
| Illegal_renaming of string * string
| Inconsistent_import of string * string * string
+ | Inconsistent_arguments of string * intf_info list * intf_info list
| Need_recursive_types of string * string
diff -C 2 -N -r -w ocaml-3.12.0/typing/ident.ml ocaml-3.12.0+functor/typing/ident.ml
*** ocaml-3.12.0/typing/ident.ml 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/typing/ident.ml 2011-06-06 14:33:18.205858999 +0200
***************
*** 19,22 ****
--- 19,24 ----
let global_flag = 1
let predef_exn_flag = 2
+ let functor_part_flag = 4
+ let functor_arg_flag = 8
(* A stamp of 0 denotes a persistent identifier *)
***************
*** 43,48 ****
let stamp i = i.stamp
- let unique_name i = i.name ^ "_" ^ string_of_int i.stamp
-
let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp
--- 45,48 ----
***************
*** 78,81 ****
--- 78,93 ----
(i.flags land global_flag) <> 0
+ let make_functor_part i =
+ i.flags <- i.flags lor functor_part_flag
+
+ let is_functor_part i =
+ (i.flags land functor_part_flag) <> 0
+
+ let make_functor_arg i =
+ i.flags <- i.flags lor functor_arg_flag
+
+ let is_functor_arg i =
+ (i.flags land functor_arg_flag) <> 0
+
let is_predef_exn i =
(i.flags land predef_exn_flag) <> 0
***************
*** 83,90 ****
let print ppf i =
match i.stamp with
! | 0 -> fprintf ppf "%s!" i.name
| -1 -> fprintf ppf "%s#" i.name
| n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "")
type 'a tbl =
Empty
--- 95,108 ----
let print ppf i =
match i.stamp with
! | 0 -> fprintf ppf "%s!%s" i.name (if is_functor_arg i then "@" else if is_functor_part i then "$" else "")
| -1 -> fprintf ppf "%s#" i.name
| n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "")
+
+ let unique_name i = i.name ^ "_" ^ string_of_int i.stamp ^
+ (if is_functor_arg i then "a" else "") ^
+ (if is_functor_part i then "p" else "") ^
+ (if is_functor_arg i then "g" else "")
+
type 'a tbl =
Empty
diff -C 2 -N -r -w ocaml-3.12.0/typing/ident.mli ocaml-3.12.0+functor/typing/ident.mli
*** ocaml-3.12.0/typing/ident.mli 2010-01-22 13:48:24.000000000 +0100
--- ocaml-3.12.0+functor/typing/ident.mli 2011-06-06 14:33:18.205858999 +0200
***************
*** 41,44 ****
--- 41,48 ----
val make_global: t -> unit
val global: t -> bool
+ val make_functor_part: t -> unit
+ val is_functor_part: t -> bool
+ val make_functor_arg: t -> unit
+ val is_functor_arg: t -> bool
val is_predef_exn: t -> bool
diff -C 2 -N -r -w ocaml-3.12.0/typing/printtyp.ml ocaml-3.12.0+functor/typing/printtyp.ml
*** ocaml-3.12.0/typing/printtyp.ml 2010-04-30 09:11:27.000000000 +0200
--- ocaml-3.12.0+functor/typing/printtyp.ml 2011-06-06 14:33:18.205858999 +0200
***************
*** 36,40 ****
let unique_names = ref Ident.empty
! let ident_name id =
try Ident.find_same id !unique_names with Not_found -> Ident.name id
--- 36,40 ----
let unique_names = ref Ident.empty
! let ident_name id = (* Ident.unique_name id *)
try Ident.find_same id !unique_names with Not_found -> Ident.name id
diff -C 2 -N -r -w ocaml-3.12.0/typing/typemod.ml ocaml-3.12.0+functor/typing/typemod.ml
*** ocaml-3.12.0/typing/typemod.ml 2010-06-07 10:24:02.000000000 +0200
--- ocaml-3.12.0+functor/typing/typemod.ml 2011-06-06 14:39:22.775859001 +0200
***************
*** 40,43 ****
--- 40,47 ----
| Not_allowed_in_functor_body
| With_need_typeconstr
+ | Inconsistent_functor_arguments of string * string
+ | No_functor_argument
+ | Functor_argument_not_found of string
+ | File_not_found of string
exception Error of Location.t * error
***************
*** 996,999 ****
--- 1000,1015 ----
end
+ let module_name filename =
+ String.capitalize (Misc.chop_extensions (Filename.basename filename))
+
+ let print_types ppf f =
+ let filename =
+ try find_in_path !Config.load_path f
+ with Not_found -> raise(Error(Location.none, File_not_found f))
+ in
+ let (sg,_,_) = Env.read_signature_and_args (module_name filename) filename in
+ fprintf ppf "%a@." Printtyp.signature sg
+
+
(* "Packaging" of several compilation units into one unit
having them as sub-modules. *)
***************
*** 1001,1013 ****
let rec package_signatures subst = function
[] -> []
! | (name, sg) :: rem ->
let sg' = Subst.signature subst sg in
! let oldid = Ident.create_persistent name
! and newid = Ident.create name in
Tsig_module(newid, Tmty_signature sg', Trec_not) ::
package_signatures (Subst.add_module oldid (Pident newid) subst) rem
! let package_units objfiles cmifile modulename =
(* Read the signatures of the units *)
let units =
List.map
--- 1017,1033 ----
let rec package_signatures subst = function
[] -> []
! | (name, sg, parts) :: rem ->
let sg' = Subst.signature subst sg in
! let oldid = Ident.create_persistent name in
! if parts <> [] then Ident.make_functor_part oldid;
! let newid = Ident.create name in
Tsig_module(newid, Tmty_signature sg', Trec_not) ::
package_signatures (Subst.add_module oldid (Pident newid) subst) rem
! let package_units objfiles cmifile modulename functor_id =
(* Read the signatures of the units *)
+ let needed_impl = ref Tbl.empty in
+ let provided_impl = ref Tbl.empty in
+ let functor_args = ref None in
let units =
List.map
***************
*** 1015,1030 ****
let pref = chop_extensions f in
let modname = String.capitalize(Filename.basename pref) in
! let sg = Env.read_signature modname (pref ^ ".cmi") in
! if Filename.check_suffix f ".cmi" &&
! not(Mtype.no_code_needed_sig Env.initial sg)
! then raise(Error(Location.none, Implementation_is_required f));
! (modname, Env.read_signature modname (pref ^ ".cmi")))
objfiles in
(* Compute signature of packaged unit *)
Ident.reinit();
! let sg = package_signatures Subst.identity units in
(* See if explicit interface is provided *)
let mlifile =
chop_extension_if_any cmifile ^ !Config.interface_suffix in
if Sys.file_exists mlifile then begin
if not (Sys.file_exists cmifile) then begin
--- 1035,1107 ----
let pref = chop_extensions f in
let modname = String.capitalize(Filename.basename pref) in
! let (sg, f_args, f_parts) =
! Env.read_signature_and_args modname (pref ^ ".cmi") in
! if Filename.check_suffix f ".cmi" then begin
! if not(Mtype.no_code_needed_sig Env.initial sg)
! then needed_impl := Tbl.add modname f !needed_impl
! end else
! provided_impl := Tbl.remove modname !provided_impl;
!
! begin match !functor_args with
! None -> functor_args := Some (f, f_args)
! | Some (f1, f_args1) ->
! if f_args1 <> f_args then
! raise (Error(Location.none,
! Inconsistent_functor_arguments(f1, f)));
! end;
! (* TODO: fix the double read of the signature in the trunk *)
! (modname, sg, f_parts))
objfiles in
+ Tbl.iter (fun modname f ->
+ if not (Tbl.mem modname !provided_impl) then
+ raise(Error(Location.none, Implementation_is_required f));
+ ) !needed_impl;
+ let (functor_args, functor_info) =
+ match !functor_args, functor_id with
+ None, None -> ([], None)
+ | Some (_, fargs), None -> (fargs, None)
+ | (None | Some (_, [])), Some id ->
+ raise (Error (Location.none, No_functor_argument))
+ | Some (_, (name,_) :: fargs), Some id ->
+ let newarg = Ident.create name in
+ let arg = Ident.create_persistent name in
+ Ident.make_functor_arg arg;
+ Ident.make_functor_part arg;
+ (fargs, Some (id, arg, newarg))
+ in
(* Compute signature of packaged unit *)
Ident.reinit();
! let subst = Subst.identity in
! let (subst, functor_info) = match functor_info with
! None -> (subst, None)
! | Some (functor_id, functor_oldarg, functor_newarg) ->
! let subst = Subst.add_module functor_oldarg (Pident functor_newarg) subst in
! (subst, Some (functor_id, functor_newarg))
! in
! let sg = package_signatures subst units in
! let sg = match functor_info with
! None -> sg
! | Some (functor_id, functor_arg_id) ->
! let functor_arg_name = Ident.name functor_arg_id in
! let functor_arg_file =
! try
! find_in_path_uncap !Config.load_path (functor_arg_name ^ ".cmi")
! with Not_found ->
! raise (Error(Location.none, Functor_argument_not_found functor_arg_name))
! in
! (* TODO: check consistency of arguments ? *)
! let (functor_arg_sg, _, _) = Env.read_signature_and_args functor_arg_name functor_arg_file
! in
! [
! Tsig_module(functor_id,
! Tmty_functor(functor_arg_id,
! Tmty_signature functor_arg_sg,
! Tmty_signature sg), Trec_not)
! ]
! in
(* See if explicit interface is provided *)
let mlifile =
chop_extension_if_any cmifile ^ !Config.interface_suffix in
+ let cc =
if Sys.file_exists mlifile then begin
if not (Sys.file_exists cmifile) then begin
***************
*** 1035,1039 ****
end else begin
(* Determine imports *)
! let unit_names = List.map fst units in
let imports =
List.filter
--- 1112,1116 ----
end else begin
(* Determine imports *)
! let unit_names = List.map (fun (name, _, _) -> name) units in
let imports =
List.filter
***************
*** 1044,1047 ****
--- 1121,1213 ----
Tcoerce_none
end
+ in
+ (cc, functor_info, functor_args)
+
+ let package_interfaces objfiles targetfile functor_name =
+ let objfiles =
+ List.map
+ (fun f ->
+ try find_in_path !Config.load_path f
+ with Not_found -> raise(Error(Location.none, File_not_found f)))
+ objfiles in
+ let prefix = chop_extensions targetfile in
+ let targetcmi = prefix ^ ".cmi" in
+ let targetname = String.capitalize(Filename.basename prefix) in
+ let functor_id = match functor_name with
+ None -> None
+ | Some modname -> Some (Ident.create modname) in
+ try
+
+ (* Read the signatures of the units *)
+ let functor_args = ref None in
+ let units =
+ List.map
+ (fun f ->
+ let pref = chop_extensions f in
+ let modname = String.capitalize(Filename.basename pref) in
+ let (sg, f_args, f_parts) = Env.read_signature_and_args modname f in
+ begin match !functor_args with
+ None -> functor_args := Some (f, f_args)
+ | Some (f1, f_args1) ->
+ if f_args1 <> f_args then
+ raise (Error(Location.none,
+ Inconsistent_functor_arguments(f1, f)));
+ end;
+ (modname, sg, f_parts))
+ objfiles in
+ let (functor_args, functor_info) =
+ match !functor_args, functor_id with
+ None, None -> ([], None)
+ | Some (_, fargs), None -> (fargs, None)
+ | (None | Some (_, [])), Some id ->
+ raise (Error (Location.none, No_functor_argument))
+ | Some (_, (name,_) :: fargs), Some id ->
+ let newarg = Ident.create name in
+ let arg = Ident.create_persistent name in
+ Ident.make_functor_arg arg;
+ Ident.make_functor_part arg;
+ (fargs, Some (id, arg, newarg))
+ in
+ (* Compute signature of packaged unit *)
+ Ident.reinit();
+ let subst = Subst.identity in
+ let (subst, functor_info) = match functor_info with
+ None -> (subst, None)
+ | Some (functor_id, functor_oldarg, functor_newarg) ->
+ let subst = Subst.add_module functor_oldarg (Pident functor_newarg) subst in
+ (subst, Some (functor_id, functor_newarg))
+ in
+ let sg = package_signatures subst units in
+ let sg = match functor_info with
+ None -> sg
+ | Some (functor_id, functor_arg_id) ->
+ let functor_arg_name = Ident.name functor_arg_id in
+ let functor_arg_file =
+ try
+ find_in_path_uncap !Config.load_path (functor_arg_name ^ ".cmi")
+ with Not_found ->
+ raise (Error(Location.none, Functor_argument_not_found functor_arg_name))
+ in
+ let (functor_arg_sg, _, _) = Env.read_signature_and_args functor_arg_name functor_arg_file
+ in
+ [
+ Tsig_module(functor_id,
+ Tmty_functor(functor_arg_id,
+ Tmty_signature functor_arg_sg,
+ Tmty_signature sg), Trec_not)
+ ]
+ in
+
+ (* Determine imports *)
+ let unit_names = List.map (fun (name, _, _) -> name) units in
+ let imports =
+ List.filter
+ (fun (name, crc) -> not (List.mem name unit_names))
+ (Env.imported_units()) in
+ (* Write packaged signature *)
+ Env.save_signature_with_imports sg targetname targetcmi imports
+
+ with x ->
+ remove_file targetfile; raise x
(* Error report *)
***************
*** 1107,1108 ****
--- 1273,1283 ----
fprintf ppf
"Only type constructors with identical parameters can be substituted."
+ | Inconsistent_functor_arguments (f1, f2) ->
+ fprintf ppf
+ "Files %s and %s make inconsistent assumptions on their arguments" f1 f2
+ | No_functor_argument ->
+ fprintf ppf "Cannot build a functor with toplevel modules"
+ | Functor_argument_not_found s ->
+ fprintf ppf "Compiled interface for functor argument %s could not be found" s
+ | File_not_found file ->
+ fprintf ppf "File %s not found" file
diff -C 2 -N -r -w ocaml-3.12.0/typing/typemod.mli ocaml-3.12.0+functor/typing/typemod.mli
*** ocaml-3.12.0/typing/typemod.mli 2010-05-18 19:18:24.000000000 +0200
--- ocaml-3.12.0+functor/typing/typemod.mli 2011-06-06 14:39:39.595859002 +0200
***************
*** 33,38 ****
val simplify_signature: signature -> signature
val package_units:
! string list -> string -> string -> Typedtree.module_coercion
type error =
--- 33,44 ----
val simplify_signature: signature -> signature
+ val package_interfaces:
+ (* objfiles *) string list -> (* target *) string -> (* pack_functor *) string option -> unit
+
val package_units:
! string list -> string -> string -> Ident.t option ->
! Typedtree.module_coercion * (Ident.t * Ident.t) option * (string * Digest.t) list
!
! val print_types : formatter -> string -> unit
type error =
***************
*** 52,55 ****
--- 58,65 ----
| Not_allowed_in_functor_body
| With_need_typeconstr
+ | Inconsistent_functor_arguments of string * string
+ | No_functor_argument
+ | Functor_argument_not_found of string
+ | File_not_found of string
exception Error of Location.t * error
diff -C 2 -N -r -w ocaml-3.12.0/utils/clflags.ml ocaml-3.12.0+functor/utils/clflags.ml
*** ocaml-3.12.0/utils/clflags.ml 2009-12-09 10:17:12.000000000 +0100
--- ocaml-3.12.0+functor/utils/clflags.ml 2011-06-06 14:33:18.215859000 +0200
***************
*** 93,94 ****
--- 93,98 ----
let shared = ref false (* -shared *)
let dlcode = ref true (* not -nodynlink *)
+
+
+ let pack_functor = ref None (* module name of functor *)
+ let functors = ref [] (* list of interface files, used as functor argument spec *)
diff -C 2 -N -r -w ocaml-3.12.0/utils/clflags.mli ocaml-3.12.0+functor/utils/clflags.mli
*** ocaml-3.12.0/utils/clflags.mli 2009-12-09 10:17:12.000000000 +0100
--- ocaml-3.12.0+functor/utils/clflags.mli 2011-06-06 14:33:18.215859000 +0200
***************
*** 77,78 ****
--- 77,82 ----
val shared : bool ref
val dlcode : bool ref
+
+ val pack_functor : string option ref (* module name of functor *)
+ val functors : string list ref (* list of interface files, used as functor argument spec *)
+
diff -C 2 -N -r -w ocaml-3.12.0/utils/config.mlp ocaml-3.12.0+functor/utils/config.mlp
*** ocaml-3.12.0/utils/config.mlp 2010-05-19 13:29:38.000000000 +0200
--- ocaml-3.12.0+functor/utils/config.mlp 2011-06-06 15:31:17.035859008 +0200
***************
*** 51,62 ****
let exec_magic_number = "Caml1999X008"
! and cmi_magic_number = "Caml1999I012"
! and cmo_magic_number = "Caml1999O007"
! and cma_magic_number = "Caml1999A008"
! and cmx_magic_number = "Caml1999Y011"
! and cmxa_magic_number = "Caml1999Z010"
and ast_impl_magic_number = "Caml1999M013"
and ast_intf_magic_number = "Caml1999N012"
! and cmxs_magic_number = "Caml2007D001"
let load_path = ref ([] : string list)
--- 51,62 ----
let exec_magic_number = "Caml1999X008"
! and cmi_magic_number = "Caml1999I013"
! and cmo_magic_number = "Caml1999O008"
! and cma_magic_number = "Caml1999A009"
! and cmx_magic_number = "Caml1999Y012"
! and cmxa_magic_number = "Caml1999Z011"
and ast_impl_magic_number = "Caml1999M013"
and ast_intf_magic_number = "Caml1999N012"
! and cmxs_magic_number = "Caml2007D002"
let load_path = ref ([] : string list)
| ||||||||||
Notes |
|
|
(0005984) lefessan (developer) 2011-06-06 18:24 |
I should add it was a request of Jane Street, and it builds on Alain's idea to extend the pack mechanism for functors, from this caml-list thread: http://groups.google.com/group/fa.caml/browse_thread/thread/86d82441e7ce7e9a/246f18fe94ee8b06?hl=en&ie=UTF-8&q=yminsky+functorize+multiple+files&pli=1 [^] |
|
(0005985) guesdon (manager) 2011-06-06 18:31 |
I'm afraid that programs will become harder to understandif part of the code moves to the Makefile. And it will become a nightmare to develop tools (I'm thinking about ocamldoc here, for example). |
|
(0006007) yminsky (reporter) 2011-06-14 00:09 edited on: 2011-06-14 00:12 |
Fabrice mentioned that Xavier was interested in seeing some examples. We certainly have them. Sadly, the description is a little abstract, but here goes: One of our core applications is a big framework organized around a central functor where the business logic is contained. In that core application, we have a somewhat awkward mix of polymorphism and functor application, to avoid the need to functorize the entire library. That core application worked out OK because the polymorphism that needed to be extended out was fairly small. But then we built a user-interface system for connecting to instances of this core application. The polymorphism in the UI was out of control, so that we ended up with types that had 8 free type variables. It was horribly confusing, and the whole thing would have gone away if we could have functorized the whole thing around a single module. In the end, we used first-class packaged modules to dynamically choose the module in question based on an environment variable. That got rid of the confusing type parameters. But it's an ugly solution, and it also required us to restructure our code considerably to make this approach work. Basically, we had weeks of rewriting of an application to deal with the lack of this feature, and we ended up with an uglier solution than we would have liked. Sadly, I can point to no examples of this in our publically released code. That said, this thread from 9 years ago on the caml list came up in my work on the SKS keyserver, and hits on very much the same issue: http://caml.inria.fr/pub/ml-archives/caml-list/2002/03/67cc0f6f75a9bd7ced9f03f724a92bdf.en.html [^] Here's the source for that: http://code.google.com/p/sks-keyserver/ [^] |
|
(0006595) chambart (reporter) 2012-01-05 11:20 |
This can also be usefull for ocsigen. In ocsigen a site is registered by calling the service creation functions in the right context. This is achieved by dynlinking the cma file of the site at the right time during the server initialisation. The problem is that it is difficult to do static linking of the whole server with the site: There is no right order of evaluation of the different modules, the initialisation must occur in the middle of a function. It is possible to circumvent that by doing the whole site initialisation inside a single function, but that adds the restriction that every services must be declared in the same file. With this functor pack option, we could transform every site into a functor, and registration whould be applying the functor to its context. |
|
(0006771) xleroy (administrator) 2012-01-23 12:01 |
This proposal was discussed among the dev team, so let me record the pros and cons. - On the positive side: this is a natural extension of the "-pack" mechanism that can indeed be useful to functorize code a posteriori without the burden of functorizing by hand each compilation unit. - On the negative side: several important users of OCaml (e.g. Jane Street), as well as many of the dev team members, are unhappy about "-pack" (inefficient linking, lack of tool support, etc) and have been pushing for other approaches to namespace management that would subsume "-pack". Several namespace designs were floated on the caml-devel and caml-consortium mailing lists. My big concern here is that if we add packed functors (this patch) on top of packed modules (the -pack option), we get something that is very very hard to subsume via a namespace mechanism. In turn, this would, in my opinion, delay or even prohibit the integration of a different namespace mechanism. So, here is my question to the supporters of this proposal: if you have to choose between packed functors (this proposal) or a future namespace mechanism, which one do you choose, knowing that you won't get both? Which one is more important to you? To finish, Alain Frisch also remarked that for small to medium-sized collections of compilation units, one can always use "cat" and a bit of shell scripting to produce the packed functor as an OCaml source file, then compile it as usual. |
|
(0006772) frisch (developer) 2012-01-23 12:26 |
We don't have a real need either for the current -pack or for a new namespace mechanism. Being able to split the implementation of a functor's body over several files would be useful to us. Another approach to this problem could be an ad hoc (independent of -pack) solution where the compiler is instructed to compile one functor by taking the source code in several files; this would be cleaner than the "cat" solution. |
|
(0006777) hcarty (reporter) 2012-01-23 14:57 |
I would much rather have a namespace mechanism. |
|
(0006784) glondu (reporter) 2012-01-23 16:35 |
Generating big files with a mechanism external to the compiler looks fine to me. A namespace mechanism looks more useful. |
|
(0006789) yminsky (reporter) 2012-01-24 02:45 |
A few thoughts: A cat based solution seems decidedly second class. Among things that won't work well: a) resolution of error messages in the tools to the proper files. Maybe there's some way to make this work nicely, but cat isn't it. b) It also plays poorly with other parts of the building process. What if you want to run different syntax extensions on different parts of the code thus combined? c) We have some non-trivial codebases that we'd want to be able to use this with. Since this kills separate compilation, such codebases would become quite inconvenient to build. All of which is to say: the "cat" implementation seems pretty painful. Maybe there's some intermediate solution that doesn't use -pack, as Alain suggests. I agree that namespaces are more important, though, since some workaround for library-wide functors that addresses at least point (a) above is probably possible. |
|
(0006802) frisch (developer) 2012-01-25 20:20 |
Addressing a) is easy with a shell script (or within omake directly); it's just about adding a #line-directive before each included file. For b), I've no real solution. Do you really use incompatible syntax extensions for various modules intended to be part of the same functor's body? For c), are you concerned with the complexity of the build system or with slower builds? |
|
(0008548) hongboz (developer) 2012-11-30 18:04 |
For b) it can be solved in the future, each file can describe which syntax it used, self-explainable, and we could provide a include which respects this |
Issue History |
|||
| Date Modified | Username | Field | Change |
| 2011-06-06 18:19 | lefessan | New Issue | |
| 2011-06-06 18:19 | lefessan | Status | new => assigned |
| 2011-06-06 18:19 | lefessan | Assigned To | => xleroy |
| 2011-06-06 18:19 | lefessan | File Added: lib-as-functor-3.12.0.2011-06-06.patch | |
| 2011-06-06 18:19 | lefessan | File Added: test-run.tar.gz | |
| 2011-06-06 18:24 | lefessan | Note Added: 0005984 | |
| 2011-06-06 18:31 | guesdon | Note Added: 0005985 | |
| 2011-06-14 00:09 | yminsky | Note Added: 0006007 | |
| 2011-06-14 00:12 | yminsky | Note Edited: 0006007 | |
| 2012-01-05 11:20 | chambart | Note Added: 0006595 | |
| 2012-01-23 12:01 | xleroy | Note Added: 0006771 | |
| 2012-01-23 12:01 | xleroy | Status | assigned => feedback |
| 2012-01-23 12:26 | frisch | Note Added: 0006772 | |
| 2012-01-23 14:57 | hcarty | Note Added: 0006777 | |
| 2012-01-23 16:35 | glondu | Note Added: 0006784 | |
| 2012-01-24 02:45 | yminsky | Note Added: 0006789 | |
| 2012-01-25 20:20 | frisch | Note Added: 0006802 | |
| 2012-11-30 18:04 | hongboz | Note Added: 0008548 | |
| Copyright © 2000 - 2011 MantisBT Group |



