typing/oprint.cmx: typing/outcometree.cmi parsing/asttypes.cmi \
typing/oprint.cmi
typing/parmatch.cmo: utils/warnings.cmi typing/types.cmi typing/typedtree.cmi \
- typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \
- typing/ident.cmi typing/env.cmi typing/datarepr.cmi typing/ctype.cmi \
- typing/btype.cmi parsing/asttypes.cmi typing/parmatch.cmi
+ typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
+ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \
+ typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \
+ typing/parmatch.cmi
typing/parmatch.cmx: utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \
- typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/location.cmx \
- typing/ident.cmx typing/env.cmx typing/datarepr.cmx typing/ctype.cmx \
- typing/btype.cmx parsing/asttypes.cmi typing/parmatch.cmi
+ typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
+ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \
+ typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \
+ typing/parmatch.cmi
typing/path.cmo: typing/ident.cmi typing/path.cmi
typing/path.cmx: typing/ident.cmx typing/path.cmi
typing/predef.cmo: typing/types.cmi typing/path.cmi typing/ident.cmi \
bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi
bytecomp/dll.cmi:
bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi
-bytecomp/instruct.cmi: typing/types.cmi parsing/location.cmi \
+bytecomp/instruct.cmi: typing/types.cmi typing/subst.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \
bytecomp/lambda.cmi
-bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/stypes.cmi \
- typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
+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/stypes.cmx \
- typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
+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 \
utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \
bytecomp/bytelink.cmi
bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.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
+ 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 \
- 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
+ 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
bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi
bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi
bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi
bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \
bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi bytecomp/emitcode.cmi
-bytecomp/instruct.cmo: typing/types.cmi parsing/location.cmi \
+bytecomp/instruct.cmo: typing/types.cmi typing/subst.cmi parsing/location.cmi \
bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi
-bytecomp/instruct.cmx: typing/types.cmx parsing/location.cmx \
+bytecomp/instruct.cmx: typing/types.cmx typing/subst.cmx parsing/location.cmx \
bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/instruct.cmi
bytecomp/lambda.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \
utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
+Objective Caml 3.11.1:
+----------------------
+
+Bug fixes:
+- PR#4095: ocamldebug: strange behaviour of control-C
+- PR#4403: ocamldebug: improved handling of packed modules
+- PR#4650: Str.regexp_case_fold mis-handling complemented character sets [^a]
+- PR#4660: Scanf.format_from_string: handling of double quote
+- PR#4666: Unix.exec* failure in multithread programs under MacOS X and FreeBSD
+- PR#4667: debugger out of sync with dynlink changes
+- PR#4678: random "out of memory" error with systhreads
+- PR#4690: issue with dynamic loading under MacOS 10.5
+- PR#4692: wrong error message with options -i and -pack passed to ocamlc
+- PR#4699: in otherlibs/dbm, fixed construction of dlldbm.so.
+- PR#4704: error in caml_modify_generational_global_root()
+- PR#4708: (ocamldoc) improved printing of infix identifiers such as "lor".
+- PR#4722: typo in configure script
+- PR#4729: documented the fact that PF_INET6 is not available on all platforms
+- PR#4730: incorrect typing involving abbreviation "type 'a t = 'a"
+- PR#4731: incorrect quoting of arguments passed to the assembler on x86-64
+- PR#4735: Unix.LargeFile.fstat cannot report size over 32bits on Win32
+- PR#4740: guard against possible processor error in
+ {Int32,Int64,Nativeint}.{div,rem}
+- PR#4745: type inference wrongly produced non-generalizable type variables.
+- PR#4749: better pipe size for win32unix
+- PR#4756: printf: no error reported for wrong format '%_s'
+- PR#4758: scanf: handling of \<newline> by format '%S'
+- PR#4766: incorrect simplification of some type abbreviations.
+- PR#4768: printf: %F does not respect width and precision specifications
+- PR#4769: Format.bprintf fails to flush
+- PR#4775: compiler crash on crazy types (temporary fix)
+- PR#4776: bad interaction between exceptions and classes
+- PR#4780: labltk build problem under Windows.
+- PR#4790: under Windows, map ERROR_NO_DATA Win32 error to EPIPE Unix error.
+- PR#4792: bug in Big_int.big_int_of_int64 on 32-bit platforms.
+- Module Parsing: improved computation of locations when an ocamlyacc rule
+ starts with an empty nonterminal
+- Type-checker: fixed wrong variance computation for private types
+- x86-32 code generator, MSVC port: wrong "fld" instruction generated.
+- ocamlbuild: incorrectly using the compile-time value of $OCAMLLIB
+- Makefile problem when configured with -no-shared-libs
+- ocamldoc: use dynamic loading in native code
+
+Other changes:
+- Improved wording of various error messages
+ (contributed by Jonathan Davies, Citrix).
+- Support for 64-bit mode in Solaris/x86 (PR#4670).
+
Objective Caml 3.11.0:
----------------------
* First public release.
-$Id: Changes,v 1.183.2.8 2008/12/03 16:16:30 doligez Exp $
+$Id: Changes,v 1.183.2.13 2009/05/19 14:46:13 doligez Exp $
# #
#########################################################################
-# $Id: Makefile,v 1.222.2.2 2008/10/23 15:29:11 ertai Exp $
+# $Id: Makefile,v 1.222.2.3 2009/05/19 14:46:13 doligez Exp $
# The main Makefile
$(CAMLOPT) $(COMPFLAGS) -c $<
partialclean::
- rm -f utils/*.cm[iox] utils/*.[so] utils/*~
- rm -f parsing/*.cm[iox] parsing/*.[so] parsing/*~
- rm -f typing/*.cm[iox] typing/*.[so] typing/*~
- rm -f bytecomp/*.cm[iox] bytecomp/*.[so] bytecomp/*~
- rm -f asmcomp/*.cm[iox] asmcomp/*.[so] asmcomp/*~
- rm -f driver/*.cm[iox] driver/*.[so] driver/*~
- rm -f toplevel/*.cm[iox] toplevel/*.[so] toplevel/*~
- rm -f tools/*.cm[iox] tools/*.[so] tools/*~
+ for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \
+ do rm -f $$d/*.cm[iox] $$d/*.annot $$d/*.[so] $$d/*~; done
rm -f *~
depend: beforedepend
-3.11.0
+3.11.1+rc0
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
-# $Id: VERSION,v 1.26.2.7 2008/12/03 16:16:30 doligez Exp $
+# $Id: VERSION,v 1.26.2.13 2009/05/19 14:46:13 doligez Exp $
<ocamldoc/**>: -debug
<ocamldoc/*.ml>: ocamldoc_sources
<ocamldoc/*.ml*>: include_unix, include_str, include_dynlink
-"ocamldoc/odoc.byte": use_unix, use_str, use_dynlink
-"ocamldoc/odoc_opt.native": use_unix, use_str
+<ocamldoc/odoc.{byte,native}>: use_unix, use_str, use_dynlink
<camlp4/**/*.ml*>: camlp4boot, -warn_Alez, warn_Ale
<camlp4/Camlp4_{config,import}.ml*>: -camlp4boot
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.16.2.2 2008/11/08 16:08:09 xleroy Exp $ *)
+(* $Id: emit.mlp,v 1.16.2.4 2009/03/28 15:10:04 xleroy Exp $ *)
(* Emission of x86-64 (AMD 64) assembly code *)
bound_error_call := 0;
` .text\n`;
emit_align 16;
- ` .globl {emit_symbol fundecl.fun_name}\n`;
+ if macosx && is_generic_function fundecl.fun_name
+ then (* PR#4690 *)
+ ` .private_extern {emit_symbol fundecl.fun_name}\n`
+ else
+ ` .globl {emit_symbol fundecl.fun_name}\n`;
`{emit_symbol fundecl.fun_name}:\n`;
if !Clflags.gprofile then emit_profile();
if frame_required() then begin
let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
` .text\n`;
` .globl {emit_symbol lbl_begin}\n`;
- `{emit_symbol lbl_begin}:\n`
+ `{emit_symbol lbl_begin}:\n`;
+ if macosx then ` nop\n` (* PR#4690 *)
let end_assembly() =
let lbl_end = Compilenv.make_symbol (Some "code_end") in
` .text\n`;
- if macosx then ` NOP\n`; (* suppress "ld warning: atom sorting error" *)
+ if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *)
` .globl {emit_symbol lbl_end}\n`;
`{emit_symbol lbl_end}:\n`;
` .data\n`;
(* *)
(***********************************************************************)
-(* $Id: proc.ml,v 1.5 2007/11/06 15:16:55 frisch Exp $ *)
+(* $Id: proc.ml,v 1.5.4.1 2009/03/28 15:52:13 xleroy Exp $ *)
(* Description of the AMD64 processor *)
(* Calling the assembler *)
let assemble_file infile outfile =
- Ccomp.command (Config.asm ^ " -o " ^ outfile ^ " " ^ infile)
-
+ Ccomp.command (Config.asm ^ " -o " ^
+ Filename.quote outfile ^ " " ^ Filename.quote infile)
(* *)
(***********************************************************************)
-(* $Id: cmmgen.ml,v 1.114 2008/08/05 13:35:20 xleroy Exp $ *)
+(* $Id: cmmgen.ml,v 1.114.2.1 2009/01/26 17:06:10 xleroy Exp $ *)
(* Translation from closed lambda to C-- *)
end)
let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty)
- (* These apply funs are always present in the main program.
- TODO: add more, and do the same for send and curry funs
- (maybe up to 10-15?). *)
+ (* These apply funs are always present in the main program because
+ the run-time system needs them (cf. asmrun/<arch>.S) . *)
let generic_functions shared units =
let (apply,send,curry) =
List.fold_right IntSet.add ui.Compilenv.ui_send_fun send,
List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry)
(IntSet.empty,IntSet.empty,IntSet.empty)
- units
- in
- let apply =
- if shared then IntSet.diff apply default_apply
- else IntSet.union apply default_apply
- in
+ units in
+ let apply = if shared then apply else IntSet.union apply default_apply in
let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in
let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in
IntSet.fold (fun n accu -> curry_function n @ accu) curry accu
(* *)
(***********************************************************************)
-(* $Id: emitaux.ml,v 1.12 2007/01/29 12:10:50 xleroy Exp $ *)
+(* $Id: emitaux.ml,v 1.12.12.1 2009/01/26 17:06:10 xleroy Exp $ *)
(* Common functions for emitting assembly code *)
List.iter emit_frame !frame_descriptors;
Hashtbl.iter emit_filename filenames;
frame_descriptors := []
+
+(* Detection of functions that can be duplicated between a DLL and
+ the main program (PR#4690) *)
+
+let isprefix s1 s2 =
+ String.length s1 <= String.length s2
+ && String.sub s2 0 (String.length s1) = s1
+
+let is_generic_function name =
+ List.exists
+ (fun p -> isprefix p name)
+ ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
+
(* *)
(***********************************************************************)
-(* $Id: emitaux.mli,v 1.12 2007/01/29 12:10:50 xleroy Exp $ *)
+(* $Id: emitaux.mli,v 1.12.12.1 2009/01/26 17:06:10 xleroy Exp $ *)
(* Common functions for emitting assembly code *)
efa_string: string -> unit }
val emit_frames: emit_frame_actions -> unit
+
+val is_generic_function: string -> bool
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.41.2.2 2008/11/08 16:08:09 xleroy Exp $ *)
+(* $Id: emit.mlp,v 1.41.2.4 2009/03/28 15:10:04 xleroy Exp $ *)
(* Emission of Intel 386 assembly code *)
bound_error_call := 0;
` .text\n`;
emit_align 16;
- ` .globl {emit_symbol fundecl.fun_name}\n`;
+ if macosx && is_generic_function fundecl.fun_name
+ then (* PR#4690 *)
+ ` .private_extern {emit_symbol fundecl.fun_name}\n`
+ else
+ ` .globl {emit_symbol fundecl.fun_name}\n`;
`{emit_symbol fundecl.fun_name}:\n`;
if !Clflags.gprofile then emit_profile();
let n = frame_size() - 4 in
let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
` .text\n`;
` .globl {emit_symbol lbl_begin}\n`;
- `{emit_symbol lbl_begin}:\n`
+ `{emit_symbol lbl_begin}:\n`;
+ if macosx then ` nop\n` (* PR#4690 *)
let end_assembly() =
let lbl_end = Compilenv.make_symbol (Some "code_end") in
` .text\n`;
- if macosx then ` NOP\n`; (* suppress "ld warning: atom sorting error" *)
+ if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *)
` .globl {emit_symbol lbl_end}\n`;
`{emit_symbol lbl_end}:\n`;
` .data\n`;
(* *)
(***********************************************************************)
-(* $Id: emit_nt.mlp,v 1.28 2008/01/11 16:13:11 doligez Exp $ *)
+(* $Id: emit_nt.mlp,v 1.28.4.1 2009/03/21 16:15:47 xleroy Exp $ *)
(* Emission of Intel 386 assembly code, MASM syntax. *)
if is_tos src then
` fstp {emit_reg dst}\n`
else if is_tos dst then
- ` fld {emit_reg dst}\n`
+ ` fld {emit_reg src}\n`
else begin
` fld {emit_reg src}\n`;
` fstp {emit_reg dst}\n`
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.26 2007/11/09 15:06:57 frisch Exp $ *)
+(* $Id: emit.mlp,v 1.26.4.1 2009/01/26 17:06:10 xleroy Exp $ *)
(* Emission of PowerPC assembly code *)
call_gc_label := 0;
float_literals := [];
int_literals := [];
+ if Config.system = "rhapsody" && is_generic_function fundecl.fun_name
+ then (* PR#4690 *)
+ ` .private_extern {emit_symbol fundecl.fun_name}\n`
+ else
` .globl {emit_symbol fundecl.fun_name}\n`;
begin match Config.system with
| "elf" | "bsd" ->
/* */
/***********************************************************************/
-/* $Id: signals_osdep.h,v 1.11.4.1 2008/11/07 10:34:16 xleroy Exp $ */
+/* $Id: signals_osdep.h,v 1.11.4.2 2009/03/28 15:18:31 xleroy Exp $ */
/* Processor- and OS-dependent signal interface */
#define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(rsp))
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+/****************** AMD64, Solaris x86 */
+
+#elif defined(TARGET_amd64) && defined (SYS_solaris)
+
+ #include <ucontext.h>
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ typedef greg_t context_reg;
+ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP])
+ #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
+ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
/****************** I386, Linux */
#elif defined(TARGET_i386) && defined(SYS_linux_elf)
#define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(eip))
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+/****************** I386, Solaris x86 */
+
+#elif defined(TARGET_i386) && defined(SYS_solaris)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, void * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
/****************** MIPS, all OS */
#elif defined(TARGET_mips)
(* *)
(***********************************************************************)
-(* $Id: bytegen.ml,v 1.72 2008/10/03 15:02:55 maranget Exp $ *)
+(* $Id: bytegen.ml,v 1.72.2.1 2009/04/02 09:06:32 xclerc Exp $ *)
(* bytegen.ml : translation of lambda terms to lists of instructions. *)
ev_kind = kind;
ev_info = info;
ev_typenv = ev.ev_typenv;
+ ev_typsubst = ev.ev_typsubst;
ev_compenv = ev.ev_compenv;
ev_stacksize = ev.ev_stacksize;
ev_repr = repr }
ev_kind = kind;
ev_info = info;
ev_typenv = lev.lev_env;
+ ev_typsubst = Subst.identity;
ev_compenv = env;
ev_stacksize = sz;
ev_repr =
(* *)
(***********************************************************************)
-(* $Id: bytepackager.ml,v 1.6 2007/02/23 13:44:51 ertai Exp $ *)
+(* $Id: bytepackager.ml,v 1.6.10.1 2009/04/02 09:06:32 xclerc Exp $ *)
(* "Package" a set of .cmo files into one .cmo file having the
original compilation units as sub-modules. *)
(* Record and relocate a debugging event *)
-let relocate_debug base ev =
- ev.ev_pos <- base + ev.ev_pos;
- events := ev :: !events
+let relocate_debug base prefix subst ev =
+ let ev' = { ev with ev_pos = base + ev.ev_pos;
+ ev_module = prefix ^ "." ^ ev.ev_module;
+ ev_typsubst = Subst.compose ev.ev_typsubst subst } in
+ events := ev' :: !events
(* Read the unit information from a .cmo file. *)
Accumulate relocs, debug info, etc.
Return size of bytecode. *)
-let rename_append_bytecode oc mapping defined ofs objfile compunit =
+let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit =
let ic = open_in_bin objfile in
try
Bytelink.check_consistency objfile compunit;
Misc.copy_file_chunk ic oc compunit.cu_codesize;
if !Clflags.debug && compunit.cu_debug > 0 then begin
seek_in ic compunit.cu_debug;
- List.iter (relocate_debug ofs) (input_value ic);
+ List.iter (relocate_debug ofs prefix subst) (input_value ic);
end;
close_in ic;
compunit.cu_codesize
(* Same, for a list of .cmo and .cmi files.
Return total size of bytecode. *)
-let rec rename_append_bytecode_list oc mapping defined ofs = function
+let rec rename_append_bytecode_list oc mapping defined ofs prefix subst = function
[] ->
ofs
| m :: rem ->
match m.pm_kind with
| PM_intf ->
- rename_append_bytecode_list oc mapping defined ofs rem
+ rename_append_bytecode_list oc mapping defined ofs prefix subst rem
| PM_impl compunit ->
let size =
- rename_append_bytecode oc mapping defined ofs
+ rename_append_bytecode oc mapping defined ofs prefix subst
m.pm_file compunit in
+ let id = Ident.create_persistent m.pm_name in
+ let root = Path.Pident (Ident.create_persistent prefix) in
rename_append_bytecode_list
- oc mapping (Ident.create_persistent m.pm_name :: defined)
- (ofs + size) rem
+ oc mapping (id :: defined)
+ (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem
(* Generate the code that builds the tuple representing the package module *)
let pos_depl = pos_out oc in
output_binary_int oc 0;
let pos_code = pos_out oc in
- let ofs = rename_append_bytecode_list oc mapping [] 0 members 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
(* *)
(***********************************************************************)
-(* $Id: dll.ml,v 1.13 2006/09/28 21:36:38 xleroy Exp $ *)
+(* $Id: dll.ml,v 1.13.14.1 2009/05/01 01:46:50 garrigue Exp $ *)
(* Handling of dynamically-linked libraries *)
Raise [Not_found] if not found. *)
let find_primitive prim_name =
- let rec find = function
+ let rec find seen = function
[] ->
raise Not_found
| dll :: rem ->
let addr = dll_sym dll prim_name in
- if addr == Obj.magic () then find rem else addr in
- find !opened_dlls
+ if addr == Obj.magic () then find (dll :: seen) rem else begin
+ if seen <> [] then opened_dlls := dll :: List.rev_append seen rem;
+ addr
+ end in
+ find [] !opened_dlls
(* If linking in core (dynlink or toplevel), synchronize the VM
table of primitive with the linker's table of primitive
(* *)
(***********************************************************************)
-(* $Id: instruct.ml,v 1.22 2005/08/25 15:35:16 doligez Exp $ *)
+(* $Id: instruct.ml,v 1.22.20.1 2009/04/02 09:06:32 xclerc Exp $ *)
open Lambda
ev_kind: debug_event_kind; (* Before/after event *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
+ ev_typsubst: Subst.t; (* Substitution over types *)
ev_compenv: compilation_env; (* Compilation environment *)
ev_stacksize: int; (* Size of stack frame *)
ev_repr: debug_event_repr } (* Position of the representative *)
(* *)
(***********************************************************************)
-(* $Id: instruct.mli,v 1.22 2005/10/25 15:56:45 doligez Exp $ *)
+(* $Id: instruct.mli,v 1.22.20.1 2009/04/02 09:06:32 xclerc Exp $ *)
(* The type of the instructions of the abstract machine *)
ev_kind: debug_event_kind; (* Before/after event *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
+ ev_typsubst: Subst.t; (* Substitution over types *)
ev_compenv: compilation_env; (* Compilation environment *)
ev_stacksize: int; (* Size of stack frame *)
ev_repr: debug_event_repr } (* Position of the representative *)
# #
#########################################################################
-# $Id: Makefile,v 1.64.2.1 2008/11/08 16:29:02 xleroy Exp $
+# $Id: Makefile,v 1.64.2.3 2009/05/13 05:00:48 garrigue Exp $
include Makefile.common
DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o
PICOBJS=$(OBJS:.o=.pic.o)
-#ifeq ($(SUPPORTS_SHARED_LIBRARIES),true)
+TMP_SHARED_LIBRARIES=$(SUPPORTS_SHARED_LIBRARIES:false=)
+SHARED_LIBRARIES_DEPS=$(TMP_SHARED_LIBRARIES:true=libcamlrun_shared.so)
-all:: libcamlrun_shared.so
+all:: $(SHARED_LIBRARIES_DEPS)
install::
- cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so
-
-#endif
+ if test -f libcamlrun_shared.so; then \
+ cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi
ocamlrun$(EXE): libcamlrun.a prims.o
$(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \
/* */
/***********************************************************************/
-/* $Id: finalise.c,v 1.23 2008/07/28 12:03:55 doligez Exp $ */
+/* $Id: finalise.c,v 1.23.2.1 2009/05/18 09:37:46 doligez Exp $ */
/* Handling of finalised values. */
-- to_do_hd->size;
f = to_do_hd->item[to_do_hd->size];
running_finalisation_function = 1;
- caml_callback (f.fun, f.val + f.offset);
+ caml_callback (f.fun, f.val + f.offset); /* FIXME PR#4742 */
running_finalisation_function = 0;
}
caml_gc_message (0x80, "Done calling finalisation functions.\n", 0);
/* */
/***********************************************************************/
-/* $Id: globroots.c,v 1.11 2008/07/14 06:28:27 xleroy Exp $ */
+/* $Id: globroots.c,v 1.11.2.1 2009/03/28 15:26:37 xleroy Exp $ */
/* Registration of global memory roots */
caml_delete_global_root(&caml_global_roots_old, r);
caml_insert_global_root(&caml_global_roots_young, r);
}
+ /* PR#4704 */
+ else if (!Is_block(oldval) && Is_block(newval)) {
+ /* The previous value in the root was unboxed but now it is boxed.
+ The root won't appear in any of the root lists thus far (by virtue
+ of the operation of [caml_register_generational_global_root]), so we
+ need to make sure it gets in, or else it will never be scanned. */
+ if (Is_young(newval))
+ caml_insert_global_root(&caml_global_roots_young, r);
+ else if (Is_in_heap(newval))
+ caml_insert_global_root(&caml_global_roots_old, r);
+ }
+ else if (Is_block(oldval) && !Is_block(newval)) {
+ /* The previous value in the root was boxed but now it is unboxed, so
+ the root should be removed. If [oldval] is young, this will happen
+ anyway at the next minor collection, but it is safer to delete it
+ here. */
+ if (Is_young(oldval))
+ caml_delete_global_root(&caml_global_roots_young, r);
+ else if (Is_in_heap(oldval))
+ caml_delete_global_root(&caml_global_roots_old, r);
+ }
+ /* end PR#4704 */
*r = newval;
}
/* */
/***********************************************************************/
-/* $Id: int64_emul.h,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */
+/* $Id: int64_emul.h,v 1.5.18.1 2009/03/28 18:34:19 xleroy Exp $ */
/* Software emulation of 64-bit integer arithmetic, for C compilers
that do not support it. */
}
#define I64_is_zero(x) (((x).l | (x).h) == 0)
-
#define I64_is_negative(x) ((int32) (x).h < 0)
+#define I64_is_min_int(x) ((x).l == 0 && (x).h = 0x80000000U)
+#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU)
/* Bitwise operations */
static int64 I64_and(int64 x, int64 y)
/* */
/***********************************************************************/
-/* $Id: int64_native.h,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */
+/* $Id: int64_native.h,v 1.5.18.1 2009/03/28 18:34:19 xleroy Exp $ */
/* Wrapper macros around native 64-bit integer arithmetic,
so that it has the same interface as the software emulation
#define I64_mul(x,y) ((x) * (y))
#define I64_is_zero(x) ((x) == 0)
#define I64_is_negative(x) ((x) < 0)
+#define I64_is_min_int(x) ((x) == ((int64)1 << 63))
+#define I64_is_minus_one(x) ((x) == -1)
+
#define I64_div(x,y) ((x) / (y))
#define I64_mod(x,y) ((x) % (y))
#define I64_udivmod(x,y,quo,rem) \
/* */
/***********************************************************************/
-/* $Id: ints.c,v 1.51 2008/01/11 16:13:16 doligez Exp $ */
+/* $Id: ints.c,v 1.51.4.2 2009/03/28 18:43:08 xleroy Exp $ */
#include <stdio.h>
#include <string.h>
CAMLprim value caml_int32_div(value v1, value v2)
{
+ int32 dividend = Int32_val(v1);
int32 divisor = Int32_val(v2);
if (divisor == 0) caml_raise_zero_divide();
+ /* PR#4740: on some processors, division crashes on overflow.
+ Implement the same behavior as for type "int". */
+ if (dividend == (1<<31) && divisor == -1) return v1;
#ifdef NONSTANDARD_DIV_MOD
- return caml_copy_int32(caml_safe_div(Int32_val(v1), divisor));
+ return caml_copy_int32(caml_safe_div(dividend, divisor));
#else
- return caml_copy_int32(Int32_val(v1) / divisor);
+ return caml_copy_int32(dividend / divisor);
#endif
}
CAMLprim value caml_int32_mod(value v1, value v2)
{
+ int32 dividend = Int32_val(v1);
int32 divisor = Int32_val(v2);
if (divisor == 0) caml_raise_zero_divide();
+ /* PR#4740: on some processors, modulus crashes if division overflows.
+ Implement the same behavior as for type "int". */
+ if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0);
#ifdef NONSTANDARD_DIV_MOD
- return caml_copy_int32(caml_safe_mod(Int32_val(v1), divisor));
+ return caml_copy_int32(caml_safe_mod(dividend, divisor));
#else
- return caml_copy_int32(Int32_val(v1) % divisor);
+ return caml_copy_int32(dividend % divisor);
#endif
}
CAMLprim value caml_int64_div(value v1, value v2)
{
+ int64 dividend = Int64_val(v1);
int64 divisor = Int64_val(v2);
if (I64_is_zero(divisor)) caml_raise_zero_divide();
+ /* PR#4740: on some processors, division crashes on overflow.
+ Implement the same behavior as for type "int". */
+ if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1;
return caml_copy_int64(I64_div(Int64_val(v1), divisor));
}
CAMLprim value caml_int64_mod(value v1, value v2)
{
+ int64 dividend = Int64_val(v1);
int64 divisor = Int64_val(v2);
if (I64_is_zero(divisor)) caml_raise_zero_divide();
+ /* PR#4740: on some processors, division crashes on overflow.
+ Implement the same behavior as for type "int". */
+ if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) {
+ int64 zero = I64_literal(0,0);
+ return caml_copy_int64(zero);
+ }
return caml_copy_int64(I64_mod(Int64_val(v1), divisor));
}
CAMLprim value caml_nativeint_mul(value v1, value v2)
{ return caml_copy_nativeint(Nativeint_val(v1) * Nativeint_val(v2)); }
+#define Nativeint_min_int ((intnat) 1 << (sizeof(intnat) * 8 - 1))
+
CAMLprim value caml_nativeint_div(value v1, value v2)
{
+ intnat dividend = Nativeint_val(v1);
intnat divisor = Nativeint_val(v2);
if (divisor == 0) caml_raise_zero_divide();
+ /* PR#4740: on some processors, modulus crashes if division overflows.
+ Implement the same behavior as for type "int". */
+ if (dividend == Nativeint_min_int && divisor == -1) return v1;
#ifdef NONSTANDARD_DIV_MOD
- return caml_copy_nativeint(caml_safe_div(Nativeint_val(v1), divisor));
+ return caml_copy_nativeint(caml_safe_div(dividend, divisor));
#else
- return caml_copy_nativeint(Nativeint_val(v1) / divisor);
+ return caml_copy_nativeint(dividend / divisor);
#endif
}
CAMLprim value caml_nativeint_mod(value v1, value v2)
{
+ intnat dividend = Nativeint_val(v1);
intnat divisor = Nativeint_val(v2);
if (divisor == 0) caml_raise_zero_divide();
+ /* PR#4740: on some processors, modulus crashes if division overflows.
+ Implement the same behavior as for type "int". */
+ if (dividend == Nativeint_min_int && divisor == -1) return caml_copy_nativeint(0);
#ifdef NONSTANDARD_DIV_MOD
- return caml_copy_nativeint(caml_safe_mod(Nativeint_val(v1), divisor));
+ return caml_copy_nativeint(caml_safe_mod(dividend, divisor));
#else
- return caml_copy_nativeint(Nativeint_val(v1) % divisor);
+ return caml_copy_nativeint(dividend % divisor);
#endif
}
pp f "@[<2>%a@ when@ %a@ ->@ %a@]"
o#patt p o#under_pipe#expr w o#under_pipe#expr e ];
- method sum_type f t = pp f "@[<hv0>[ %a ]@]" o#ctyp t;
+ method sum_type f =
+ fun
+ [ <:ctyp<>> -> pp f "[]"
+ | t -> pp f "@[<hv0>[ %a ]@]" o#ctyp t
+ ];
method ident f i =
let () = o#node f i Ast.loc_of_ident in
| "("; t = SELF; "*"; tl = star_ctyp; ")" ->
<:ctyp< ( $t$ * $tl$ ) >>
| "("; t = SELF; ")" -> t
+ | "["; "]" -> <:ctyp< [ ] >>
| "["; t = constructor_declarations; "]" -> <:ctyp< [ $t$ ] >>
| "["; "="; rfl = row_field; "]" ->
<:ctyp< [ = $rfl$ ] >>
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
-
(** Camlp4 signature repository *)
(** {6 Basic signatures} *)
(** Signature with just a type. *)
val register_str_item_filter : Ast.str_item filter -> unit
+ val register_topphrase_filter : Ast.str_item filter -> unit
+
val fold_interf_filters :
('a -> Ast.sig_item filter -> 'a) -> 'a -> 'a
val fold_implem_filters :
('a -> Ast.str_item filter -> 'a) -> 'a -> 'a
+ val fold_topphrase_filters :
+ ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a
+
end
module type DynAst =
let fold_implem_filters f i = Queue.fold f i implem_filters
+ let topphrase_filters = Queue.create ()
+
+ let fold_topphrase_filters f i = Queue.fold f i topphrase_filters
+
let register_sig_item_filter f = Queue.add f interf_filters
let register_str_item_filter f = Queue.add f implem_filters
+ let register_topphrase_filter f = Queue.add f topphrase_filters
+
end
end
end =
struct
module Id =
- struct let name = "Camlp4.Printers.Null"
- let version = Sys.ocaml_version
- end
+ struct
+ let name = "Camlp4.Printers.Null"
+
+ let version = Sys.ocaml_version
+
+ end
module Make (Syntax : Sig.Syntax) =
struct
open Format
module Id =
- struct let name = "Camlp4.Printers.OCaml"
- let version = Sys.ocaml_version
- end
+ struct
+ let name = "Camlp4.Printers.OCaml"
+
+ let version = Sys.ocaml_version
+
+ end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
open Format
module Id =
- struct let name = "Camlp4.Printers.OCamlr"
- let version = Sys.ocaml_version
- end
+ struct
+ let name = "Camlp4.Printers.OCamlr"
+
+ let version = Sys.ocaml_version
+
+ end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
end =
struct
- module Id = struct let name = "Camlp4.PreCast"
- let version = Sys.ocaml_version
- end
+ module Id =
+ struct let name = "Camlp4.PreCast"
+ let version = Sys.ocaml_version
+ end
type camlp4_token =
Sig.camlp4_token =
* - Nicolas Pouillard: refactoring
*)
module Id =
- struct let name = "Camlp4OCamlRevisedParser"
- let version = Sys.ocaml_version
- end
+ struct
+ let name = "Camlp4OCamlRevisedParser"
+
+ let version = Sys.ocaml_version
+
+ end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
(fun _ (t : 'constructor_declarations) _
(_loc : Gram.Loc.t) ->
(Ast.TySum (_loc, t) : 'ctyp))));
+ ([ Gram.Skeyword "["; Gram.Skeyword "]" ],
+ (Gram.Action.mk
+ (fun _ _ (_loc : Gram.Loc.t) ->
+ (Ast.TySum (_loc, Ast.TyNil _loc) : 'ctyp))));
([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
(Gram.Action.mk
(fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) ->
* - Nicolas Pouillard: initial version
*)
module Id =
- struct let name = "Camlp4QuotationCommon"
- let version = Sys.ocaml_version
- end
+ struct
+ let name = "Camlp4QuotationCommon"
+
+ let version = Sys.ocaml_version
+
+ end
module Make
(Syntax : Sig.Camlp4Syntax)
* - Nicolas Pouillard: refactoring
*)
module Id =
- struct let name = "Camlp4QuotationExpander"
- let version = Sys.ocaml_version
- end
+ struct
+ let name = "Camlp4QuotationExpander"
+
+ let version = Sys.ocaml_version
+
+ end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
* - Nicolas Pouillard: refactoring
*)
module Id : Sig.Id =
- struct let name = "Camlp4OCamlRevisedParserParser"
- let version = Sys.ocaml_version
-
+ struct
+ let name = "Camlp4OCamlRevisedParserParser"
+
+ let version = Sys.ocaml_version
+
end
module Make (Syntax : Sig.Camlp4Syntax) =
module Id =
struct let name = "Camlp4GrammarParser"
let version = Sys.ocaml_version
- end
+
+ end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
module Id =
struct let name = "Camlp4MacroParser"
let version = Sys.ocaml_version
- end
+
+ end
(*
Added statements:
module Id =
struct let name = "Camlp4DebugParser"
let version = Sys.ocaml_version
- end
+
+ end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
* - Nicolas Pouillard: revised syntax version
*)
module Id =
- struct let name = "Camlp4ListComprenhsion"
- let version = Sys.ocaml_version
- end
+ struct
+ let name = "Camlp4ListComprenhsion"
+
+ let version = Sys.ocaml_version
+
+ end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
-
open Camlp4
open PreCast.Syntax
<file>.ml Parse this implementation file
<file>.mli Parse this interface file
<file>.%s Load this module inside the Camlp4 core@."
- (if DynLoader.is_native then "cmx " else "(cmo|cma)");
+ (if DynLoader.is_native then "cmxs " else "(cmo|cma)");
Options.print_usage_list ini_sl;
(* loop (ini_sl @ ext_sl) where rec loop =
fun
("-loaded-modules", (Arg.Set print_loaded_modules),
"Print the list of loaded modules.");
("-parser", (Arg.String (rewrite_and_load "Parsers")),
- "<name> Load the parser Camlp4Parsers/<name>.cmo");
+ "<name> Load the parser Camlp4Parsers/<name>.cm(o|a|xs)");
("-printer", (Arg.String (rewrite_and_load "Printers")),
- "<name> Load the printer Camlp4Printers/<name>.cmo");
+ "<name> Load the printer Camlp4Printers/<name>.cm(o|a|xs)");
("-filter", (Arg.String (rewrite_and_load "Filters")),
- "<name> Load the filter Camlp4Filters/<name>.cmo");
+ "<name> Load the filter Camlp4Filters/<name>.cm(o|a|xs)");
("-ignore", (Arg.String ignore), "ignore the next argument");
("--", (Arg.Unit ignore), "Deprecated, does nothing") ]
# #
#########################################################################
-# $Id: configure,v 1.266.2.1 2008/11/07 10:34:16 xleroy Exp $
+# $Id: configure,v 1.266.2.4 2009/05/19 13:23:47 doligez Exp $
configure_options="$*"
prefix=/usr/local
dllccompopts="-D_WIN32 -DCAML_DLL"
flexlink="flexlink -chain cygwin -merge-manifest"
flexdir=`$flexlink -where | dos2unix`
- iflexdir="-I\"$flexdir\""
- mkexe="$flexlink -exe"
+ if test -z "$flexdir"; then
+ echo "flexlink not found: native shared libraries won't be available"
+ withsharedlibs=no
+ else
+ iflexdir="-I\"$flexdir\""
+ mkexe="$flexlink -exe"
+ fi
exe=".exe"
ostype="Cygwin";;
gcc*,x86_64-*-linux*)
i[3456]86-*-linux*) arch=i386; system=linux_`sh ./runtest elf.c`;;
i[3456]86-*-*bsd*) arch=i386; system=bsd_`sh ./runtest elf.c`;;
i[3456]86-*-nextstep*) arch=i386; system=nextstep;;
- i[3456]86-*-solaris*) arch=i386; system=solaris;;
+ i[3456]86-*-solaris*) if $arch64; then
+ arch=amd64; system=solaris
+ else
+ arch=i386; system=solaris
+ fi;;
i[3456]86-*-beos*) arch=i386; system=beos;;
i[3456]86-*-cygwin*) arch=i386; system=cygwin;;
i[3456]86-*-darwin*) if $arch64; then
if $arch64; then partialld="ld -r -arch ppc64"; fi;;
*,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";;
amd64,gcc*,macosx,*) partialld="ld -r -arch x86_64";;
+ amd64,gcc*,solaris,*) partialld="ld -r -m elf_x86_64";;
*,gcc*,*,*) nativecccompopts="$gcc_warnings";;
esac
aspp='gcc -c';;
amd64,*,macosx) as='as -arch x86_64'
aspp='gcc -arch x86_64 -c';;
+ amd64,*,solaris) as='as --64'
+ aspp='gcc -m64 -c';;
amd64,*,*) as='as'
aspp='gcc -c';;
arm,*,*) as='as';
echo "Cannot detect system stack overflow.";;
esac
-x# Determine the target architecture for the "num" library
+# Determine the target architecture for the "num" library
case "$arch" in
alpha) bng_arch=alpha; bng_asm_level=1;;
time_travel.cmi: primitives.cmi
trap_barrier.cmi:
unix_tools.cmi: ../otherlibs/unix/unix.cmi
-breakpoints.cmo: symbols.cmi source.cmi primitives.cmi pos.cmi \
- ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \
- breakpoints.cmi
-breakpoints.cmx: symbols.cmx source.cmx primitives.cmx pos.cmx \
- ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \
- breakpoints.cmi
+breakpoints.cmo: symbols.cmi primitives.cmi pos.cmi ../bytecomp/instruct.cmi \
+ exec.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi
+breakpoints.cmx: symbols.cmx primitives.cmx pos.cmx ../bytecomp/instruct.cmx \
+ exec.cmx debugcom.cmx checkpoints.cmx breakpoints.cmi
checkpoints.cmo: primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi
checkpoints.cmx: primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi
command_line.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi \
../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \
show_source.cmi show_information.cmi question.cmi program_management.cmi \
program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \
- parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/location.cmi \
- loadprinter.cmi lexer.cmi int64ops.cmi ../bytecomp/instruct.cmi \
- input_handling.cmi history.cmi frames.cmi events.cmi eval.cmi envaux.cmi \
- debugger_config.cmi debugcom.cmi ../typing/ctype.cmi ../utils/config.cmi \
- checkpoints.cmi breakpoints.cmi command_line.cmi
+ parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/longident.cmi \
+ ../parsing/location.cmi loadprinter.cmi lexer.cmi int64ops.cmi \
+ ../bytecomp/instruct.cmi input_handling.cmi history.cmi frames.cmi \
+ events.cmi eval.cmi envaux.cmi debugger_config.cmi debugcom.cmi \
+ ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi breakpoints.cmi \
+ command_line.cmi
command_line.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx \
../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \
show_source.cmx show_information.cmx question.cmx program_management.cmx \
program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \
- parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/location.cmx \
- loadprinter.cmx lexer.cmx int64ops.cmx ../bytecomp/instruct.cmx \
- input_handling.cmx history.cmx frames.cmx events.cmx eval.cmx envaux.cmx \
- debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../utils/config.cmx \
- checkpoints.cmx breakpoints.cmx command_line.cmi
+ parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/longident.cmx \
+ ../parsing/location.cmx loadprinter.cmx lexer.cmx int64ops.cmx \
+ ../bytecomp/instruct.cmx input_handling.cmx history.cmx frames.cmx \
+ events.cmx eval.cmx envaux.cmx debugger_config.cmx debugcom.cmx \
+ ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx breakpoints.cmx \
+ command_line.cmi
debugcom.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \
input_handling.cmi debugcom.cmi
debugcom.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \
../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \
../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \
dynlink.cmi
-envaux.cmo: ../typing/types.cmi ../typing/printtyp.cmi ../typing/path.cmi \
- ../typing/mtype.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \
- ../typing/env.cmi envaux.cmi
-envaux.cmx: ../typing/types.cmx ../typing/printtyp.cmx ../typing/path.cmx \
- ../typing/mtype.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx \
- ../typing/env.cmx envaux.cmi
-eval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \
- ../typing/printtyp.cmi ../typing/predef.cmi ../typing/path.cmi \
- parser_aux.cmi ../utils/misc.cmi ../parsing/longident.cmi \
- ../bytecomp/instruct.cmi ../typing/ident.cmi frames.cmi ../typing/env.cmi \
- debugger_config.cmi debugcom.cmi ../typing/ctype.cmi ../typing/btype.cmi \
- eval.cmi
-eval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \
- ../typing/printtyp.cmx ../typing/predef.cmx ../typing/path.cmx \
- parser_aux.cmi ../utils/misc.cmx ../parsing/longident.cmx \
- ../bytecomp/instruct.cmx ../typing/ident.cmx frames.cmx ../typing/env.cmx \
- debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../typing/btype.cmx \
- eval.cmi
-events.cmo: primitives.cmi ../parsing/location.cmi ../bytecomp/instruct.cmi \
- checkpoints.cmi events.cmi
-events.cmx: primitives.cmx ../parsing/location.cmx ../bytecomp/instruct.cmx \
- checkpoints.cmx events.cmi
+envaux.cmo: ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \
+ ../typing/path.cmi ../typing/mtype.cmi ../utils/misc.cmi \
+ ../bytecomp/instruct.cmi ../typing/env.cmi envaux.cmi
+envaux.cmx: ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \
+ ../typing/path.cmx ../typing/mtype.cmx ../utils/misc.cmx \
+ ../bytecomp/instruct.cmx ../typing/env.cmx envaux.cmi
+eval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \
+ printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \
+ ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \
+ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \
+ frames.cmi ../typing/env.cmi debugcom.cmi ../typing/ctype.cmi \
+ ../typing/btype.cmi eval.cmi
+eval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \
+ printval.cmx ../typing/printtyp.cmx ../typing/predef.cmx \
+ ../typing/path.cmx parser_aux.cmi ../utils/misc.cmx \
+ ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \
+ frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \
+ ../typing/btype.cmx eval.cmi
+events.cmo: ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi
+events.cmx: ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi
exec.cmo: exec.cmi
exec.cmx: exec.cmi
-frames.cmo: symbols.cmi primitives.cmi ../utils/misc.cmi \
- ../bytecomp/instruct.cmi events.cmi debugcom.cmi checkpoints.cmi \
- frames.cmi
-frames.cmx: symbols.cmx primitives.cmx ../utils/misc.cmx \
- ../bytecomp/instruct.cmx events.cmx debugcom.cmx checkpoints.cmx \
- frames.cmi
-history.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \
- debugger_config.cmi checkpoints.cmi history.cmi
-history.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \
- debugger_config.cmx checkpoints.cmx history.cmi
+frames.cmo: symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi events.cmi \
+ debugcom.cmi frames.cmi
+frames.cmx: symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx events.cmx \
+ debugcom.cmx frames.cmi
+history.cmo: primitives.cmi int64ops.cmi debugger_config.cmi checkpoints.cmi \
+ history.cmi
+history.cmx: primitives.cmx int64ops.cmx debugger_config.cmx checkpoints.cmx \
+ history.cmi
input_handling.cmo: ../otherlibs/unix/unix.cmi primitives.cmi \
input_handling.cmi
input_handling.cmx: ../otherlibs/unix/unix.cmx primitives.cmx \
input_handling.cmi
int64ops.cmo: int64ops.cmi
int64ops.cmx: int64ops.cmi
-lexer.cmo: primitives.cmi parser.cmi lexer.cmi
-lexer.cmx: primitives.cmx parser.cmx lexer.cmi
+lexer.cmo: parser.cmi lexer.cmi
+lexer.cmx: parser.cmx lexer.cmi
loadprinter.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \
../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \
../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \
- dynlink.cmi debugger_config.cmi ../typing/ctype.cmi ../utils/config.cmi \
- loadprinter.cmi
+ dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi
loadprinter.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \
../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \
../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \
- dynlink.cmx debugger_config.cmx ../typing/ctype.cmx ../utils/config.cmx \
- loadprinter.cmi
+ dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi
main.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi time_travel.cmi \
- show_information.cmi question.cmi program_management.cmi primitives.cmi \
- parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \
+ show_information.cmi question.cmi program_management.cmi parameters.cmi \
+ ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \
../typing/env.cmi debugger_config.cmi ../utils/config.cmi \
command_line.cmi ../utils/clflags.cmi checkpoints.cmi
main.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx time_travel.cmx \
- show_information.cmx question.cmx program_management.cmx primitives.cmx \
- parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \
+ show_information.cmx question.cmx program_management.cmx parameters.cmx \
+ ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \
../typing/env.cmx debugger_config.cmx ../utils/config.cmx \
command_line.cmx ../utils/clflags.cmx checkpoints.cmx
-parameters.cmo: primitives.cmi ../utils/misc.cmi envaux.cmi \
+parameters.cmo: primitives.cmi envaux.cmi debugger_config.cmi \
../utils/config.cmi parameters.cmi
-parameters.cmx: primitives.cmx ../utils/misc.cmx envaux.cmx \
+parameters.cmx: primitives.cmx envaux.cmx debugger_config.cmx \
../utils/config.cmx parameters.cmi
-parser.cmo: primitives.cmi parser_aux.cmi ../parsing/longident.cmi \
- int64ops.cmi input_handling.cmi parser.cmi
-parser.cmx: primitives.cmx parser_aux.cmi ../parsing/longident.cmx \
- int64ops.cmx input_handling.cmx parser.cmi
+parser.cmo: parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \
+ input_handling.cmi parser.cmi
+parser.cmx: parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \
+ input_handling.cmx parser.cmi
pattern_matching.cmo: ../typing/typedtree.cmi parser_aux.cmi \
../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \
pattern_matching.cmi
primitives.cmx: ../otherlibs/unix/unix.cmx primitives.cmi
printval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi \
../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \
- ../typing/outcometree.cmi ../typing/oprint.cmi ../utils/misc.cmi \
+ ../typing/outcometree.cmi ../typing/oprint.cmi \
../toplevel/genprintval.cmi debugcom.cmi printval.cmi
printval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx \
../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \
- ../typing/outcometree.cmi ../typing/oprint.cmx ../utils/misc.cmx \
+ ../typing/outcometree.cmi ../typing/oprint.cmx \
../toplevel/genprintval.cmx debugcom.cmx printval.cmi
program_loading.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi primitives.cmi \
- parameters.cmi ../utils/misc.cmi input_handling.cmi debugger_config.cmi \
- program_loading.cmi
+ parameters.cmi input_handling.cmi debugger_config.cmi program_loading.cmi
program_loading.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx primitives.cmx \
- parameters.cmx ../utils/misc.cmx input_handling.cmx debugger_config.cmx \
- program_loading.cmi
+ parameters.cmx input_handling.cmx debugger_config.cmx program_loading.cmi
program_management.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi \
time_travel.cmi symbols.cmi question.cmi program_loading.cmi \
- primitives.cmi parameters.cmi ../utils/misc.cmi int64ops.cmi \
- ../bytecomp/instruct.cmi input_handling.cmi history.cmi \
- debugger_config.cmi debugcom.cmi breakpoints.cmi program_management.cmi
+ primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \
+ debugger_config.cmi breakpoints.cmi program_management.cmi
program_management.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx \
time_travel.cmx symbols.cmx question.cmx program_loading.cmx \
- primitives.cmx parameters.cmx ../utils/misc.cmx int64ops.cmx \
- ../bytecomp/instruct.cmx input_handling.cmx history.cmx \
- debugger_config.cmx debugcom.cmx breakpoints.cmx program_management.cmi
+ primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \
+ debugger_config.cmx breakpoints.cmx program_management.cmi
question.cmo: primitives.cmi lexer.cmi input_handling.cmi question.cmi
question.cmx: primitives.cmx lexer.cmx input_handling.cmx question.cmi
-show_information.cmo: symbols.cmi show_source.cmi printval.cmi primitives.cmi \
+show_information.cmo: symbols.cmi show_source.cmi printval.cmi \
../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \
debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi
-show_information.cmx: symbols.cmx show_source.cmx printval.cmx primitives.cmx \
+show_information.cmx: symbols.cmx show_source.cmx printval.cmx \
../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \
debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi
-show_source.cmo: source.cmi primitives.cmi parameters.cmi ../utils/misc.cmi \
+show_source.cmo: source.cmi primitives.cmi parameters.cmi \
../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \
debugger_config.cmi show_source.cmi
-show_source.cmx: source.cmx primitives.cmx parameters.cmx ../utils/misc.cmx \
+show_source.cmx: source.cmx primitives.cmx parameters.cmx \
../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \
debugger_config.cmx show_source.cmi
-source.cmo: primitives.cmi ../utils/misc.cmi ../utils/config.cmi source.cmi
-source.cmx: primitives.cmx ../utils/misc.cmx ../utils/config.cmx source.cmi
-symbols.cmo: ../bytecomp/symtable.cmi primitives.cmi ../bytecomp/instruct.cmi \
- events.cmi debugger_config.cmi debugcom.cmi checkpoints.cmi \
+source.cmo: primitives.cmi ../utils/misc.cmi debugger_config.cmi \
+ ../utils/config.cmi source.cmi
+source.cmx: primitives.cmx ../utils/misc.cmx debugger_config.cmx \
+ ../utils/config.cmx source.cmi
+symbols.cmo: ../bytecomp/symtable.cmi ../bytecomp/instruct.cmi events.cmi \
+ debugger_config.cmi debugcom.cmi checkpoints.cmi \
../bytecomp/bytesections.cmi symbols.cmi
-symbols.cmx: ../bytecomp/symtable.cmx primitives.cmx ../bytecomp/instruct.cmx \
- events.cmx debugger_config.cmx debugcom.cmx checkpoints.cmx \
+symbols.cmx: ../bytecomp/symtable.cmx ../bytecomp/instruct.cmx events.cmx \
+ debugger_config.cmx debugcom.cmx checkpoints.cmx \
../bytecomp/bytesections.cmx symbols.cmi
time_travel.cmo: trap_barrier.cmi symbols.cmi question.cmi \
program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \
(* *)
(***********************************************************************)
-(* $Id: breakpoints.ml,v 1.13 2005/08/23 20:16:43 doligez Exp $ *)
+(* $Id: breakpoints.ml,v 1.13.18.1 2009/04/02 09:44:21 xclerc Exp $ *)
(******************************* Breakpoints ***************************)
open Instruct
open Primitives
open Printf
-open Source
(*** Debugging. ***)
let debug_breakpoints = ref false
[]
end
@
- List.map fst (filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints)
+ List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints)
(* Is there a breakpoint at `pc' ? *)
let breakpoint_at_pc pc =
let count = List.assoc pos !positions in
decr count;
if !count = 0 then begin
- positions := assoc_remove !positions pos;
+ positions := List.remove_assoc pos !positions;
new_version ()
end
let pos = ev.ev_pos in
Exec.protect
(function () ->
- breakpoints := assoc_remove !breakpoints number;
+ breakpoints := List.remove_assoc number !breakpoints;
remove_position pos;
printf "Removed breakpoint %d at %d : %s" number ev.ev_pos
(Pos.get_desc ev);
let count = List.assoc pc !positions in
decr count;
if !count = 0 then begin
- positions := assoc_remove !positions pc;
+ positions := List.remove_assoc pc !positions;
reset_instr pc;
Symbols.set_event_at_pc pc
end
(* *)
(***********************************************************************)
-(* $Id: command_line.ml,v 1.25 2008/07/29 08:31:41 xleroy Exp $ *)
+(* $Id: command_line.ml,v 1.25.2.2 2009/04/02 09:44:21 xclerc Exp $ *)
(************************ Reading and executing commands ***************)
end_of_line Lexer.lexeme
let matching_elements list name instr =
- filter (function a -> isprefix instr (name a)) !list
+ List.filter (function a -> isprefix instr (name a)) !list
let all_matching_instructions =
matching_elements instruction_list (fun i -> i.instr_name)
let matching_instructions instr =
let all = all_matching_instructions instr in
- let prio = filter (fun i -> i.instr_prio) all in
+ let prio = List.filter (fun i -> i.instr_prio) all in
if prio = [] then all else prio
let matching_variables =
end
in try_add 0
+let module_of_longident id =
+ match id with
+ | Some x -> Some (String.concat "." (Longident.flatten x))
+ | None -> None
+
let convert_module mdle =
match mdle with
| Some m ->
if yes_or_no "Reinitialize directory list" then begin
Config.load_path := !default_load_path;
Envaux.reset_cache ();
+ Hashtbl.clear Debugger_config.load_path_for;
flush_buffer_list ()
end
end
- else
- List.iter (function x -> add_path (expand_path x))
- (List.rev new_directory);
+ else begin
+ let new_directory' = List.rev new_directory in
+ match new_directory' with
+ | mdl :: for_keyw :: tl when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 ->
+ List.iter (function x -> add_path_for mdl (expand_path x)) tl
+ | _ ->
+ List.iter (function x -> add_path (expand_path x)) new_directory'
+ end;
let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in
- fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path
+ fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path;
+ Hashtbl.iter
+ (fun mdl dirs ->
+ fprintf ppf "@[<2>Source directories for %s :%a@]@." mdl print_dirs dirs)
+ Debugger_config.load_path_for
let instr_kill ppf lexbuf =
eol lexbuf;
raise Toplevel
end
| BA_pos1 (mdle, line, column) -> (* break @ [MODULE] LINE [COL] *)
- let module_name = convert_module mdle in
+ let module_name = convert_module (module_of_longident mdle) in
new_breakpoint
(try
let buffer =
raise Toplevel)
| BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *)
try
- new_breakpoint (event_near_pos (convert_module mdle) position)
+ new_breakpoint (event_near_pos (convert_module (module_of_longident mdle)) position)
with
| Not_found ->
eprintf "Can't find any event there.@."
| Not_found ->
("", -1)
in
- let mdle = convert_module mo in
+ let mdle = convert_module (module_of_longident mo) in
let pos = Lexing.dummy_pos in
let beginning =
match beg with
let info_events ppf lexbuf =
ensure_loaded ();
- let mdle = convert_module (opt_identifier_eol Lexer.lexeme lexbuf) in
+ let mdle = convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) in
print_endline ("Module : " ^ mdle);
print_endline " Address Characters Kind Repr.";
List.iter
(* *)
(***********************************************************************)
-(* $Id: debugger_config.ml,v 1.11 2008/07/29 08:31:41 xleroy Exp $ *)
+(* $Id: debugger_config.ml,v 1.11.2.1 2009/04/02 09:06:32 xclerc Exp $ *)
(**************************** Configuration file ***********************)
(* Time history size (for `last') *)
let history_size = ref 30
+let load_path_for = Hashtbl.create 7
+
(*** Time travel parameters. ***)
(* Step between checkpoints for long displacements.*)
(* *)
(***********************************************************************)
-(* $Id: debugger_config.mli,v 1.5 2002/11/17 16:42:10 xleroy Exp $ *)
+(* $Id: debugger_config.mli,v 1.5.28.1 2009/04/02 09:06:32 xclerc Exp $ *)
(********************** Configuration file *****************************)
val shell : string
val runtime_program : string
val history_size : int ref
+val load_path_for : (string, string list) Hashtbl.t
(*** Time travel paramaters. ***)
(* *)
(***********************************************************************)
-(* $Id: dynlink.ml,v 1.2 2006/09/28 21:36:38 xleroy Exp $ *)
+(* $Id: dynlink.ml,v 1.2.14.1 2009/04/02 09:21:20 xclerc Exp $ *)
(* Dynamic loading of .cmo files *)
| Corrupted_interface of string
| File_not_found of string
| Cannot_open_dll of string
+ | Inconsistent_implementation of string
exception Error of error
(* Initialize the linker tables and everything *)
+let inited = ref false
+
let init () =
- default_crcs := Symtable.init_toplevel();
- default_available_units ()
+ if not !inited then begin
+ default_crcs := Symtable.init_toplevel();
+ default_available_units ();
+ inited := true;
+ end
+
+let clear_available_units () = init(); clear_available_units ()
+let allow_only l = init(); allow_only l
+let prohibit l = init(); prohibit l
+let add_available_units l = init(); add_available_units l
+let default_available_units () = init(); default_available_units ()
(* Read the CRC of an interface from its .cmi file *)
end
let loadfile file_name =
+ init();
let ic = open_in_bin file_name in
try
let buffer = String.create (String.length Config.cmo_magic_number) in
close_in ic; raise exc
let loadfile_private file_name =
+ init();
let initial_symtable = Symtable.current_state()
and initial_crc = !crc_interfaces in
try
"cannot find file " ^ name ^ " in search path"
| Cannot_open_dll reason ->
"error loading shared library: " ^ reason
+ | Inconsistent_implementation name ->
+ "implementation mismatch on " ^ name
+
+let is_native = false
+let adapt_filename f = f
(* *)
(***********************************************************************)
-(* $Id: dynlink.mli,v 1.1 2006/05/11 15:51:31 xleroy Exp $ *)
+(* $Id: dynlink.mli,v 1.1.14.1 2009/04/02 09:21:20 xclerc Exp $ *)
-(** Dynamic loading of bytecode object files. *)
+(** Dynamic loading of object files. *)
-(** {6 Initialization} *)
+val is_native: bool
+(** [true] if the program is native,
+ [false] if the program is bytecode. *)
-val init : unit -> unit
-(** Initialize the [Dynlink] library.
- Must be called before any other function in this module. *)
-
-(** {6 Dynamic loading of compiled bytecode files} *)
+(** {6 Dynamic loading of compiled files} *)
val loadfile : string -> unit
-(** Load the given bytecode object file ([.cmo] file) or
- bytecode library file ([.cma] file), and link it with the running program.
+(** In bytecode: load the given bytecode object file ([.cmo] file) or
+ bytecode library file ([.cma] file), and link it with the running
+ program. In native code: load the given OCaml plugin file (usually
+ [.cmxs]), and link it with the running
+ program.
All toplevel expressions in the loaded compilation units
are evaluated. No facilities are provided to
access value names defined by the unit. Therefore, the unit
are hidden (cannot be referenced) from other modules dynamically
loaded afterwards. *)
+val adapt_filename : string -> string
+(** In bytecode, the identity function. In native code, replace the last
+ extension with [.cmxs]. *)
+
(** {6 Access control} *)
val allow_only: string list -> unit
dynamically linked. A compilation unit is ``unsafe'' if it contains
declarations of external functions, which can break type safety.
By default, dynamic linking of unsafe object files is
- not allowed. *)
+ not allowed. In native code, this function does nothing; object files
+ with external functions are always allowed to be dynamically linked. *)
(** {6 Deprecated, low-level API for access control} *)
since the default initialization of allowed units, along with the
[allow_only] and [prohibit] function, provides a better, safer
mechanism to control access to program units. The three functions
- below are provided for backward compatibility only. *)
+ below are provided for backward compatibility only and are not
+ available in native code. *)
val add_interfaces : string list -> string list -> unit
(** [add_interfaces units path] grants dynamically-linked object
(** Empty the list of compilation units accessible to dynamically-linked
programs. *)
+(** {6 Deprecated, initialization} *)
+
+val init : unit -> unit
+(** @deprecated Initialize the [Dynlink] library. This function is called
+ automatically when needed. *)
+
(** {6 Error reporting} *)
type linking_error =
| Corrupted_interface of string
| File_not_found of string
| Cannot_open_dll of string
+ | Inconsistent_implementation of string
exception Error of error
(** Errors in dynamic linking are reported by raising the [Error]
(* *)
(***********************************************************************)
-(* $Id: envaux.ml,v 1.7 2000/03/06 22:11:17 weis Exp $ *)
+(* $Id: envaux.ml,v 1.7.38.1 2009/04/02 09:06:32 xclerc Exp $ *)
open Misc
open Types
exception Error of error
let env_cache =
- (Hashtbl.create 59 : (Env.summary, Env.t) Hashtbl.t)
+ (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
let reset_cache () =
Hashtbl.clear env_cache;
Tmty_signature sg -> sg
| _ -> fatal_error "Envaux.extract_sig"
-let rec env_from_summary sum =
+let rec env_from_summary sum subst =
try
- Hashtbl.find env_cache sum
+ Hashtbl.find env_cache (sum, subst)
with Not_found ->
let env =
match sum with
Env_empty ->
Env.empty
| Env_value(s, id, desc) ->
- Env.add_value id desc (env_from_summary s)
+ Env.add_value id (Subst.value_description subst desc) (env_from_summary s subst)
| Env_type(s, id, desc) ->
- Env.add_type id desc (env_from_summary s)
+ Env.add_type id (Subst.type_declaration subst desc) (env_from_summary s subst)
| Env_exception(s, id, desc) ->
- Env.add_exception id desc (env_from_summary s)
+ Env.add_exception id (Subst.exception_declaration subst desc) (env_from_summary s subst)
| Env_module(s, id, desc) ->
- Env.add_module id desc (env_from_summary s)
+ Env.add_module id (Subst.modtype subst desc) (env_from_summary s subst)
| Env_modtype(s, id, desc) ->
- Env.add_modtype id desc (env_from_summary s)
+ Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst)
| Env_class(s, id, desc) ->
- Env.add_class id desc (env_from_summary s)
+ Env.add_class id (Subst.class_declaration subst desc) (env_from_summary s subst)
| Env_cltype (s, id, desc) ->
- Env.add_cltype id desc (env_from_summary s)
+ Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst)
| Env_open(s, path) ->
- let env = env_from_summary s in
+ let env = env_from_summary s subst in
+ let path' = Subst.module_path subst path in
let mty =
try
- Env.find_module path env
+ Env.find_module path' env
with Not_found ->
- raise (Error (Module_not_found path))
+ raise (Error (Module_not_found path'))
in
- Env.open_signature path (extract_sig env mty) env
+ Env.open_signature path' (extract_sig env mty) env
in
- Hashtbl.add env_cache sum env;
+ Hashtbl.add env_cache (sum, subst) env;
env
let env_of_event =
function
None -> Env.empty
- | Some ev -> env_from_summary ev.Instruct.ev_typenv
+ | Some ev -> env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst
(* Error report *)
(* *)
(***********************************************************************)
-(* $Id: eval.ml,v 1.30 2007/11/28 22:32:14 weis Exp $ *)
+(* $Id: eval.ml,v 1.30.4.5 2009/04/19 08:42:43 xleroy Exp $ *)
-open Debugger_config
open Misc
open Path
open Instruct
let rec path event = function
Pident id ->
if Ident.global id then
- Debugcom.Remote_value.global (Symtable.get_global_position id)
+ try
+ Debugcom.Remote_value.global (Symtable.get_global_position id)
+ with Symtable.Error _ -> raise(Error(Unbound_identifier id))
else
begin match event with
Some ev ->
end
| E_result ->
begin match event with
- Some {ev_kind = Event_after ty} when !Frames.current_frame = 0 ->
- (Debugcom.Remote_value.accu(), ty)
+ Some {ev_kind = Event_after ty; ev_typsubst = subst} when !Frames.current_frame = 0 ->
+ (Debugcom.Remote_value.accu(), Subst.type_expr subst ty)
| _ ->
raise(Error(No_result))
end
| Tuple_index(ty, len, pos) ->
Printtyp.reset_and_mark_loops ty;
fprintf ppf
- "@[Cannot extract field number %i from a %i-components \
- tuple of type@ %a@]@."
+ "@[Cannot extract field number %i from a %i-tuple of type@ %a@]@."
pos len Printtyp.type_expr ty
| Array_index(len, pos) ->
fprintf ppf
- "@[Cannot extract element number %i from array of length %i@]@." pos len
+ "@[Cannot extract element number %i from an array of length %i@]@." pos len
| List_index(len, pos) ->
fprintf ppf
- "@[Cannot extract element number %i from list of length %i@]@." pos len
+ "@[Cannot extract element number %i from a list of length %i@]@." pos len
| String_index(s, len, pos) ->
fprintf ppf
"@[Cannot extract character number %i@ \
(* *)
(***********************************************************************)
-(* $Id: events.ml,v 1.6 2005/08/25 15:35:16 doligez Exp $ *)
+(* $Id: events.ml,v 1.6.18.1 2009/04/02 09:44:21 xclerc Exp $ *)
(********************************* Events ******************************)
open Instruct
-open Primitives
-open Checkpoints
let get_pos ev =
match ev.ev_kind with
(* *)
(***********************************************************************)
-(* $Id: frames.ml,v 1.10 2005/08/25 15:35:16 doligez Exp $ *)
+(* $Id: frames.ml,v 1.10.18.1 2009/04/02 09:44:21 xclerc Exp $ *)
(***************************** Frames **********************************)
open Instruct
-open Primitives
open Debugcom
-open Checkpoints
open Events
open Symbols
(* *)
(***********************************************************************)
-(* $Id: history.ml,v 1.5 2002/10/29 17:53:24 doligez Exp $ *)
+(* $Id: history.ml,v 1.5.28.1 2009/04/02 09:44:21 xclerc Exp $ *)
open Int64ops
open Checkpoints
-open Misc
open Primitives
open Debugger_config
(* *)
(***********************************************************************)
-(* $Id: input_handling.ml,v 1.5 2006/12/09 13:49:10 ertai Exp $ *)
+(* $Id: input_handling.ml,v 1.5.14.1 2009/04/02 09:44:21 xclerc Exp $ *)
(**************************** Input control ****************************)
(* Remove a file from the list of actives files. *)
let remove_file file =
- active_files := assoc_remove !active_files file.io_fd
+ active_files := List.remove_assoc file.io_fd !active_files
(* Change the controller for the given file. *)
let change_controller file controller =
(* *)
(***********************************************************************)
-(* $Id: lexer.mll,v 1.8 2003/01/03 15:39:54 doligez Exp $ *)
+(* $Id: lexer.mll,v 1.8.28.1 2009/04/02 09:44:21 xclerc Exp $ *)
{
-open Primitives
open Parser
}
(* *)
(***********************************************************************)
-(* $Id: loadprinter.ml,v 1.19 2004/11/29 02:27:25 garrigue Exp $ *)
+(* $Id: loadprinter.ml,v 1.19.20.1 2009/04/02 09:44:21 xclerc Exp $ *)
(* Loading and installation of user-defined printer functions *)
open Misc
-open Debugger_config
open Longident
open Path
open Types
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.21 2008/07/29 08:31:41 xleroy Exp $ *)
+(* $Id: main.ml,v 1.21.2.2 2009/04/02 09:44:21 xclerc Exp $ *)
-open Primitives
-open Misc
open Input_handling
open Question
open Command_line
!current_checkpoint.c_pid;
pp_print_flush ppf ();
stop_user_input ();
- loop ppf)
+ restart ppf)
| Toplevel ->
protect ppf restart (function ppf ->
pp_print_flush ppf ();
stop_user_input ();
- loop ppf)
+ restart ppf)
| Sys.Break ->
protect ppf restart (function ppf ->
fprintf ppf "Interrupted.@.";
try_select_frame 0;
show_current_event ppf;
end);
- loop ppf)
+ restart ppf)
| Current_checkpoint_lost ->
protect ppf restart (function ppf ->
fprintf ppf "Trying to recover...@.";
recover ();
try_select_frame 0;
show_current_event ppf;
- loop ppf)
+ restart ppf)
| Current_checkpoint_lost_start_at (time, init_duration) ->
protect ppf restart (function ppf ->
let b =
(* *)
(***********************************************************************)
-(* $Id: parameters.ml,v 1.3 2002/02/14 15:17:10 doligez Exp $ *)
+(* $Id: parameters.ml,v 1.3.28.1 2009/04/02 09:06:32 xclerc Exp $ *)
(* Miscellaneous parameters *)
open Primitives
open Config
-open Misc
+open Debugger_config
let program_loaded = ref false
let program_name = ref ""
load_path := dir :: except dir !load_path;
Envaux.reset_cache()
+let add_path_for mdl dir =
+ let old = try Hashtbl.find load_path_for mdl with Not_found -> [] in
+ Hashtbl.replace load_path_for mdl (dir :: old)
+
(* Used by emacs ? *)
let emacs = ref false
(* *)
(***********************************************************************)
-(* $Id: parameters.mli,v 1.2 1999/11/17 18:57:26 xleroy Exp $ *)
+(* $Id: parameters.mli,v 1.2.40.1 2009/04/02 09:06:32 xclerc Exp $ *)
(* Miscellaneous parameters *)
val default_load_path : string list ref
val add_path : string -> unit
+val add_path_for : string -> string -> unit
(* Used by emacs ? *)
val emacs : bool ref
/* */
/***********************************************************************/
-/* $Id: parser.mly,v 1.7 2002/10/29 17:53:24 doligez Exp $ */
+/* $Id: parser.mly,v 1.7.28.3 2009/04/15 11:09:56 xclerc Exp $ */
%{
open Int64ops
-open Primitives
open Input_handling
open Longident
open Parser_aux
%type <Parser_aux.break_arg> break_argument_eol
%start list_arguments_eol
-%type <string option * int option * int option> list_arguments_eol
+%type <Longident.t option * int option * int option> list_arguments_eol
%start end_of_line
%type <unit> end_of_line
%start longident_eol
%type <Longident.t> longident_eol
+%start opt_longident
+%type <Longident.t option> opt_longident
+
+%start opt_longident_eol
+%type <Longident.t option> opt_longident_eol
+
%%
/* Raw arguments */
;
longident_eol :
- longident end_of_line { $1 };
+ longident end_of_line { $1 };
+
+opt_longident :
+ UIDENT { Some (Lident $1) }
+ | module_path DOT UIDENT { Some (Ldot($1, $3)) }
+ | { None };
+
+opt_longident_eol :
+ opt_longident end_of_line { $1 };
identifier :
LIDENT { $1 }
end_of_line { BA_none }
| integer_eol { BA_pc $1 }
| expression end_of_line { BA_function $1 }
- | AT opt_identifier INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)}
- | AT opt_identifier SHARP integer_eol { BA_pos2 ($2, $4) }
+ | AT opt_longident INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)}
+ | AT opt_longident SHARP integer_eol { BA_pos2 ($2, $4) }
;
/* Arguments for list */
list_arguments_eol :
- opt_identifier integer opt_integer_eol
+ opt_longident integer opt_integer_eol
{ ($1, Some $2, $3) }
- | opt_identifier_eol
+ | opt_longident_eol
{ ($1, None, None) };
/* End of line */
(* *)
(***********************************************************************)
-(* $Id: parser_aux.mli,v 1.4 1999/11/17 18:57:26 xleroy Exp $ *)
+(* $Id: parser_aux.mli,v 1.4.40.1 2009/04/02 09:06:32 xclerc Exp $ *)
(*open Globals*)
BA_none (* break *)
| BA_pc of int (* break PC *)
| BA_function of expression (* break FUNCTION *)
- | BA_pos1 of string option * int * int option
+ | BA_pos1 of Longident.t option * int * int option
(* break @ [MODULE] LINE [POS] *)
- | BA_pos2 of string option * int (* break @ [MODULE] # OFFSET *)
+ | BA_pos2 of Longident.t option * int (* break @ [MODULE] # OFFSET *)
(* *)
(***********************************************************************)
-(* $Id: primitives.ml,v 1.6 2002/10/29 17:53:24 doligez Exp $ *)
+(* $Id: primitives.ml,v 1.6.28.1 2009/04/02 09:44:21 xclerc Exp $ *)
(*********************** Basic functions and types *********************)
| b::l -> if a = b then i else index_rec (i + 1) l
in index_rec 0 l
-(* Remove an element from an association list *)
-let assoc_remove lst elem =
- let rec remove =
- function
- [] -> []
- | ((a, _) as c::t) ->
- if a = elem then t
- else c::(remove t)
- in remove lst
-
-(* Nth element of a list. *)
-let rec list_nth p0 p1 =
- match (p0,p1) with
- ([], _) ->
- invalid_arg "list_nth"
- | ((a::_), 0) ->
- a
- | ((_::l), n) ->
- list_nth l (n - 1)
-
(* Return the `n' first elements of `l' *)
(* ### n l -> l' *)
let rec list_truncate =
else a::(repl l)
in repl
-(* Filter `list' according to `predicate'. *)
-(* ### predicate list -> list' *)
-let filter p =
- let rec filter2 =
- function
- [] ->
- []
- | a::l ->
- if p a then
- a::(filter2 l)
- else
- filter2 l
- in filter2
-
-(* Find the first element `element' of `list' *)
-(* so that `predicate element' holds. *)
-(* ### predicate list -> element *)
-let find p =
- let rec find2 =
- function
- [] ->
- raise Not_found
- | a::l ->
- if p a then a
- else find2 l
- in find2
-
(*** Operations on strings. ***)
-(* Return the position of the first occurence of char `c' in string `s' *)
-(* Raise `Not_found' if `s' does not contain `c'. *)
-(* ### c s -> pos *)
-let string_pos s c =
- let i = ref 0 and l = String.length s in
- while !i < l && String.get s !i != c do i := !i + 1 done;
- if !i = l then raise Not_found;
- !i
-
(* Remove blanks (spaces and tabs) at beginning and end of a string. *)
let is_space = function
| ' ' | '\t' -> true | _ -> false
(* *)
(***********************************************************************)
-(* $Id: primitives.mli,v 1.2 1999/11/17 18:57:26 xleroy Exp $ *)
+(* $Id: primitives.mli,v 1.2.40.1 2009/04/02 09:44:21 xclerc Exp $ *)
(********************* Basic functions and types ***********************)
(* Position of an element in a list. Head of list has position 0. *)
val index : 'a -> 'a list -> int
-(* Remove on element from an association list. *)
-val assoc_remove : ('a * 'b) list -> 'a -> ('a * 'b) list
-
-(* Nth element of a list. *)
-val list_nth : 'a list -> int -> 'a
-
(* Return the `n' first elements of `l'. *)
(* ### n l -> l' *)
val list_truncate : int -> 'a list -> 'a list
(* ### x y l -> l' *)
val list_replace : 'a -> 'a -> 'a list -> 'a list
-(* Filter `list' according to `predicate'. *)
-(* ### predicate list -> list' *)
-val filter : ('a -> bool) -> 'a list -> 'a list
-
-(* Find the first element `element' of `list' *)
-(* so that `predicate element' holds. *)
-(* Raise `Not_found' if no such element. *)
-(* ### predicate list -> element *)
-val find : ('a -> bool) -> 'a list -> 'a
-
(*** Operations on strings. ***)
-(* Return the position of the first occurence of char `c' in string `s' *)
-(* Raise `Not_found' if `s' does not contain `c'. *)
-(* ### c s -> pos *)
-val string_pos : string -> char -> int
-
(* Remove blanks (spaces and tabs) at beginning and end of a string. *)
val string_trim : string -> string
(* *)
(***********************************************************************)
-(* $Id: printval.ml,v 1.21 2002/02/13 11:09:17 ddr Exp $ *)
+(* $Id: printval.ml,v 1.21.28.1 2009/04/02 09:44:21 xclerc Exp $ *)
(* To print values *)
-open Misc
-open Obj
open Format
open Parser_aux
open Path
(* *)
(***********************************************************************)
-(* $Id: program_loading.ml,v 1.8 2008/07/29 08:31:41 xleroy Exp $ *)
+(* $Id: program_loading.ml,v 1.8.2.1 2009/04/02 09:44:21 xclerc Exp $ *)
(* Program loading *)
open Unix
-open Misc
open Debugger_config
open Parameters
open Input_handling
(* *)
(***********************************************************************)
-(* $Id: program_management.ml,v 1.13 2008/07/29 08:31:41 xleroy Exp $ *)
+(* $Id: program_management.ml,v 1.13.2.1 2009/04/02 09:44:21 xclerc Exp $ *)
(* Manage the loading of the program *)
open Unix
open Unix_tools
open Debugger_config
-open Misc
-open Instruct
open Primitives
open Parameters
open Input_handling
open Question
-open Debugcom
open Program_loading
open Time_travel
(* *)
(***********************************************************************)
-(* $Id: show_information.ml,v 1.13 2005/08/25 15:35:16 doligez Exp $ *)
+(* $Id: show_information.ml,v 1.13.18.1 2009/04/02 09:44:21 xclerc Exp $ *)
open Instruct
open Format
-open Primitives
open Debugcom
open Checkpoints
open Events
(* *)
(***********************************************************************)
-(* $Id: show_source.ml,v 1.14 2006/12/09 13:49:10 ertai Exp $ *)
+(* $Id: show_source.ml,v 1.14.14.1 2009/04/02 09:44:21 xclerc Exp $ *)
open Debugger_config
open Instruct
-open Misc
open Parameters
open Primitives
open Printf
(* *)
(***********************************************************************)
-(* $Id: source.ml,v 1.8 2006/12/09 13:49:10 ertai Exp $ *)
+(* $Id: source.ml,v 1.8.14.1 2009/04/02 09:06:32 xclerc Exp $ *)
(************************ Source management ****************************)
(*** Conversion function. ***)
let source_of_module pos mdle =
+ let is_submodule m m' =
+ let len' = String.length m' in
+ try
+ (String.sub m 0 len') = m' && (String.get m len') = '.'
+ with
+ Invalid_argument _ -> false in
+ let path =
+ Hashtbl.fold
+ (fun mdl dirs acc ->
+ if is_submodule mdle mdl then
+ dirs
+ else
+ acc)
+ Debugger_config.load_path_for
+ !Config.load_path in
let fname = pos.Lexing.pos_fname in
if fname = "" then
+ let innermost_module =
+ try
+ let dot_index = String.rindex mdle '.' in
+ String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index))
+ with Not_found -> mdle in
let rec loop =
function
| [] -> raise Not_found
| ext :: exts ->
- try find_in_path_uncap !Config.load_path (mdle ^ ext)
+ try find_in_path_uncap path (innermost_module ^ ext)
with Not_found -> loop exts
in loop source_extensions
else if Filename.is_implicit fname then
- find_in_path !Config.load_path fname
+ find_in_path path fname
else
fname
(* *)
(***********************************************************************)
-(* $Id: symbols.ml,v 1.18 2005/08/25 15:35:16 doligez Exp $ *)
+(* $Id: symbols.ml,v 1.18.18.1 2009/04/02 09:44:21 xclerc Exp $ *)
(* Handling of symbol tables (globals and events) *)
modules := md :: !modules;
Hashtbl.add all_events_by_module md sorted_evl;
let real_evl =
- Primitives.filter
+ List.filter
(function
{ev_kind = Event_pseudo} -> false
| _ -> true)
(* *)
(***********************************************************************)
-(* $Id: time_travel.ml,v 1.21 2006/12/09 16:23:37 ertai Exp $ *)
+(* $Id: time_travel.ml,v 1.21.14.1 2009/04/02 09:44:21 xclerc Exp $ *)
(**************************** Time travel ******************************)
(* --- Assume that the checkpoint is valid. *)
let forget_process fd pid =
let checkpoint =
- find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints)
+ List.find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints)
in
Printf.eprintf "Lost connection with process %d" pid;
let kont =
(* *)
(***********************************************************************)
-(* $Id: unix_tools.ml,v 1.9 2008/07/29 08:31:41 xleroy Exp $ *)
+(* $Id: unix_tools.ml,v 1.9.2.1 2009/04/02 09:44:21 xclerc Exp $ *)
(****************** Tools for Unix *************************************)
(*** Convert a socket name into a socket address. ***)
let convert_address address =
try
- let n = string_pos address ':' in
+ let n = String.index address ':' in
let host = String.sub address 0 n
and port = String.sub address (n + 1) (String.length address - n - 1)
in
let rec expand_path ch =
let rec subst_variable ch =
try
- let pos = string_pos ch '$' in
+ let pos = String.index ch '$' in
if (pos + 1 < String.length ch) && (ch.[pos + 1] = '$') then
(String.sub ch 0 (pos + 1))
^ (subst_variable
in
if ch.[0] = '~' then
try
- match string_pos ch '/' with
+ match String.index ch '/' with
1 ->
(let tail = String.sub ch 2 (String.length ch - 2)
in
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.71.2.1 2008/10/15 08:48:51 xleroy Exp $ *)
+(* $Id: main.ml,v 1.71.2.2 2009/01/14 13:19:32 doligez Exp $ *)
open Config
open Clflags
Arg.parse Options.list anonymous usage;
if
List.length (List.filter (fun x -> !x)
- [make_archive;make_package;compile_only;output_c_object]) > 1
+ [make_archive;make_package;compile_only;output_c_object])
+ > 1
then
- fatal "Please specify at most one of -pack, -a, -c, -output-obj";
+ if !print_types then
+ fatal "Option -i is incompatible with -pack, -a, -output-obj"
+ else
+ fatal "Please specify at most one of -pack, -a, -c, -output-obj";
if !make_archive then begin
Compile.init_path();
-\" $Id: ocaml.m,v 1.10 2008/09/15 14:05:30 doligez Exp $
+\" $Id: ocaml.m,v 1.10.2.1 2009/01/13 15:17:09 doligez Exp $
.TH OCAML 1
The following command-line options are recognized by
.BR ocaml (1).
.TP
-.BI -I \ directory
+.BI \-I \ directory
Add the given directory to the list of directories searched for
source and compiled files. By default, the current directory is
searched first, then the standard library directory. Directories added
(* *)
(***********************************************************************)
-(* $Id: myocamlbuild.ml,v 1.23.2.2 2008/10/23 15:29:11 ertai Exp $ *)
+(* $Id: myocamlbuild.ml,v 1.23.2.5 2009/05/05 13:40:18 ertai Exp $ *)
open Ocamlbuild_plugin
open Command
"stdlib/std_exit.cmx"; "stdlib/std_exit"-.-C.o] in
let byte_deps = ["ocamlc"; "stdlib/stdlib.cma"; "stdlib/std_exit.cmo"] in
fun () ->
+ if Pathname.exists "../ocamlcomp.sh" then S[A"../ocamlcomp.sh"] else
if List.for_all Pathname.exists native_deps then
S[A"./ocamlc.opt"; A"-nostdlib"]
else if List.for_all Pathname.exists byte_deps then
Command.setup_virtual_command_solver "OCAMLCWIN" (convert_for_windows_shell ocamlc_solver);;
let ocamlopt_solver () =
- S[if Pathname.exists "ocamlopt.opt" && Pathname.exists ("stdlib/stdlib.cmxa")
+ S[if Pathname.exists "../ocamlcompopt.sh" then S[A"../ocamlcompopt.sh"] else
+ if Pathname.exists "ocamlopt.opt" && Pathname.exists ("stdlib/stdlib.cmxa")
then A"./ocamlopt.opt"
else S[ocamlrun; A"./ocamlopt"];
A"-nostdlib"];;
copy_rule' "lex/main.native" "lex/ocamllex.opt";;
copy_rule' "debugger/main.byte" "debugger/ocamldebug";;
copy_rule' "ocamldoc/odoc.byte" "ocamldoc/ocamldoc";;
-copy_rule' "ocamldoc/odoc_opt.native" "ocamldoc/ocamldoc.opt";;
+copy_rule' "ocamldoc/odoc.native" "ocamldoc/ocamldoc.opt";;
copy_rule' "tools/ocamlmklib.byte" "tools/ocamlmklib";;
copy_rule' "otherlibs/dynlink/extract_crc.byte" "otherlibs/dynlink/extract_crc";;
+copy_rule' "myocamlbuild_config.mli" "ocamlbuild/ocamlbuild_Myocamlbuild_config.mli";;
+copy_rule' "myocamlbuild_config.ml" "ocamlbuild/ocamlbuild_Myocamlbuild_config.ml";;
copy_rule' ~insert:`bottom "%" "%.exe";;
OCAMLBUILD_OPTIONS := $(OCAMLBUILD_OPTIONS) $(O)
endif
+ifeq ($(wildcard ./ocamlbuild_Myocamlbuil*_config.ml),./ocamlbuild_Myocamlbuild_config.ml)
ifeq ($(wildcard ./boot/oc*build),./boot/ocamlbuild)
OCAMLBUILD=INSTALL_LIB=$(INSTALL_LIB) INSTALL_BIN=$(INSTALL_BIN) $(OCAMLBUILDCMD) -build-dir $(BUILDDIR) -no-links $(OCAMLBUILD_OPTIONS)
LIBS=ocamlbuildlib ocamlbuildlightlib
$(OCAMLBUILD) $(BYTE) $(NATIVE)
byte:
$(OCAMLBUILD) $(BYTE)
+native:
+ $(OCAMLBUILD) $(NATIVE)
profile:
$(OCAMLBUILD) $(LIBS:=.p.cmxa) $(PROGRAMS:=.p.native)
debug:
cp $(BUILDDIR)/ocamlbuild.native boot/ocamlbuild
$(MAKE) $(MFLAGS) $(MAKECMDGOALS) OCAMLBUILD_OPTIONS="-nothing-should-be-rebuilt -verbose -1"
endif
+else
+all byte native:
+ @echo "Please copy the myocamlbuild_config.ml of the OCaml source distribution"
+ @echo " as ocamlbuild_Myocamlbuild_config.ml"
+ @echo
+ @echo "$$ cp ../myocamlbuild_config.ml ocamlbuild_Myocamlbuild_config.ml"
+endif
ocamlbuild.byte.start:
./start.sh
(* *)
(***********************************************************************)
-(* $Id: bool.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Bool *)
(* *)
(***********************************************************************)
-(* $Id: bool.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Bool *)
(* *)
(***********************************************************************)
-(* $Id: command.ml,v 1.8 2008/07/25 14:28:56 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Command *)
(* *)
(***********************************************************************)
-(* $Id: command.mli,v 1.6 2008/07/25 14:25:20 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Command *)
(* *)
(***********************************************************************)
-(* $Id: configuration.ml,v 1.2 2007/11/28 16:03:48 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Log
(* *)
(***********************************************************************)
-(* $Id: configuration.mli,v 1.3 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Configuration *)
(* *)
(***********************************************************************)
-(* $Id: discard_printf.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
let rec greedy _ = greedy
(* *)
(***********************************************************************)
-(* $Id: discard_printf.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Discard_printf *)
(* *)
(***********************************************************************)
-(* $Id: display.ml,v 1.3.4.1 2008/11/06 15:40:39 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Display *)
open My_std;;
(* *)
(***********************************************************************)
-(* $Id: display.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Display *)
(* *)
(***********************************************************************)
-(* $Id: fda.ml,v 1.4 2007/11/22 18:29:31 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* FDA *)
(* *)
(***********************************************************************)
-(* $Id: fda.mli,v 1.2 2007/02/08 16:53:39 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Fda *)
(* *)
(***********************************************************************)
-(* $Id: flags.ml,v 1.2 2007/02/26 17:05:30 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open Command
open Bool (* FIXME remove me *)
(* *)
(***********************************************************************)
-(* $Id: flags.mli,v 1.2 2007/02/26 17:05:30 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
val of_tags : Tags.t -> Command.spec
val of_tag_list : Tags.elt list -> Command.spec
(* *)
(***********************************************************************)
-(* $Id: glob.ml,v 1.5 2008/07/25 14:38:31 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Glob *)
open My_std;;
(* *)
(***********************************************************************)
-(* $Id: glob.mli,v 1.2 2007/11/21 21:02:15 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Glob *)
(* *)
(***********************************************************************)
-(* $Id: glob_ast.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Glob_ast *)
(* *)
(***********************************************************************)
-(* $Id: glob_ast.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Glob_ast *)
(* *)
(***********************************************************************)
-(* $Id: glob_lexer.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Berke Durak *)
open Glob_ast
(* *)
(***********************************************************************)
-(* $Id: glob_lexer.mll,v 1.4 2007/11/21 21:03:14 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Glob *)
{
(* *)
(***********************************************************************)
-(* $Id: hooks.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
type message =
| Before_hygiene
(* *)
(***********************************************************************)
-(* $Id: hooks.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
type message =
| Before_hygiene
(* *)
(***********************************************************************)
-(* $Id: hygiene.ml,v 1.5 2007/11/22 18:29:32 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Hygiene *)
open My_std
(* *)
(***********************************************************************)
-(* $Id: hygiene.mli,v 1.3 2007/02/22 15:56:23 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Hygiene *)
(* *)
(***********************************************************************)
-(* $Id: lexers.mli,v 1.5 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
exception Error of string
(* *)
(***********************************************************************)
-(* $Id: lexers.mll,v 1.7 2008/07/25 14:24:29 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
{
exception Error of string
(* *)
(***********************************************************************)
-(* $Id: log.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
(* *)
(***********************************************************************)
-(* $Id: log.mli,v 1.3 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Log *)
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.21.4.1 2008/11/06 15:40:39 ertai Exp $ *)
+
(* Original author: Berke Durak *)
open My_std
open Log
(* *)
(***********************************************************************)
-(* $Id: main.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
val main : unit -> unit
(* *)
(***********************************************************************)
-(* $Id: opentracer.ml,v 1.1 2007/02/07 08:59:15 ertai Exp $ *)
+
open My_std
module type TRACER = sig
(* *)
(***********************************************************************)
-(* $Id: my_std.ml,v 1.10 2008/10/01 08:36:26 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open Format
(* *)
(***********************************************************************)
-(* $Id: my_std.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* My_std *)
(* *)
(***********************************************************************)
-(* $Id: my_unix.ml,v 1.5 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
(* *)
(***********************************************************************)
-(* $Id: my_unix.mli,v 1.4 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
type file_kind =
| FK_dir
(* *)
(***********************************************************************)
-(* $Id: ocaml_arch.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Command
(* *)
(***********************************************************************)
-(* $Id: ocaml_arch.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
include Signatures.ARCH
(* *)
(***********************************************************************)
-(* $Id: ocaml_compiler.ml,v 1.10 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
(* *)
(***********************************************************************)
-(* $Id: ocaml_compiler.mli,v 1.2 2007/02/12 10:26:08 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
val forpack_flags : string -> Tags.t -> Command.spec
(* *)
(***********************************************************************)
-(* $Id: ocaml_dependencies.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Log
(* *)
(***********************************************************************)
-(* $Id: ocaml_dependencies.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(** Ocaml dependencies *)
(* *)
(***********************************************************************)
-(* $Id: ocaml_specific.ml,v 1.23.2.1 2008/10/22 11:23:57 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
flag ["ocaml"; "doc"; "docfile"; "extension:ltx"] (A"-latex");;
flag ["ocaml"; "doc"; "docfile"; "extension:texi"] (A"-texi");;
-(** Ocamlbuild plugin for it's own building *)
-let install_lib = lazy (try Sys.getenv "INSTALL_LIB" with Not_found -> !*stdlib_dir/"ocamlbuild" (* not My_std.getenv since it's lazy*)) in
-let install_bin = lazy (My_std.getenv ~default:"/usr/local/bin" "INSTALL_BIN") in
-rule "ocamlbuild_where.ml"
- ~prod:"%ocamlbuild_where.ml"
- begin fun env _ ->
- Echo(
- ["let bindir = ref \""; String.escaped !*install_bin; "\";;\n";
- "let libdir = ref (try Filename.concat (Sys.getenv \"OCAMLLIB\") \"ocamlbuild\" with Not_found -> \"";
- String.escaped !*install_lib; "\");;\n"],
- env "%ocamlbuild_where.ml")
- end;;
ocaml_lib "ocamlbuildlib";;
ocaml_lib "ocamlbuildlightlib";;
(* *)
(***********************************************************************)
-(* $Id: ocaml_specific.mli,v 1.2 2007/02/26 16:27:45 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* *)
(***********************************************************************)
-(* $Id: ocaml_tools.ml,v 1.12 2008/07/25 15:06:47 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Pathname.Operators
(* *)
(***********************************************************************)
-(* $Id: ocaml_tools.mli,v 1.7 2008/07/25 15:06:47 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
val ocamldoc_c : Tags.t -> string -> string -> Command.t
(* *)
(***********************************************************************)
-(* $Id: ocaml_utils.ml,v 1.8 2008/07/25 14:49:03 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
(* *)
(***********************************************************************)
-(* $Id: ocaml_utils.mli,v 1.6 2008/07/25 14:26:13 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
val stdlib_dir : Pathname.t Lazy.t
val module_name_of_filename : Pathname.t -> string
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
Ocamlbuild_unix_plugin.setup ();
Ocamlbuild_pack.Main.main ()
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(** Nothing to export for now *)
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild_executor.ml,v 1.4 2007/11/28 17:21:59 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Ocamlbuild_executor *)
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild_executor.mli,v 1.4 2007/11/28 17:21:59 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Ocamlbuild_executor *)
Ocaml_specific
Ocaml_arch
Ocamlbuild_where
+Ocamlbuild_Myocamlbuild_config
Lexers
Glob
Bool
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild_plugin.ml,v 1.11 2008/07/25 14:42:28 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open Ocamlbuild_pack
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild_unix_plugin.ml,v 1.3 2008/07/31 07:36:12 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open Format
open Ocamlbuild_pack
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild_unix_plugin.mli,v 1.2 2007/11/22 18:34:22 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
val setup : unit -> unit
--- /dev/null
+let bindir = ref Ocamlbuild_Myocamlbuild_config.bindir;;
+let libdir = ref begin
+ try Filename.concat (Sys.getenv "OCAMLLIB") "ocamlbuild"
+ with Not_found -> Ocamlbuild_Myocamlbuild_config.libdir
+end;;
(* *)
(***********************************************************************)
-(* $Id: ocamlbuild_where.mli,v 1.2 2007/10/08 14:19:34 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* *)
(***********************************************************************)
-(* $Id: ocamlbuildlight.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
Ocamlbuild_pack.Main.main ();;
(* *)
(***********************************************************************)
-(* $Id: ocamlbuildlight.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Nothing *)
(* *)
(***********************************************************************)
-(* $Id: options.ml,v 1.16 2008/07/25 14:49:03 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
let version = "ocamlbuild "^(Sys.ocaml_version);;
(* *)
(***********************************************************************)
-(* $Id: options.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
include Signatures.OPTIONS with type command_spec = Command.spec
(* *)
(***********************************************************************)
-(* $Id: pathname.ml,v 1.6 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
(* *)
(***********************************************************************)
-(* $Id: pathname.mli,v 1.4 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
include Signatures.PATHNAME
val link_to_dir : t -> t -> bool
(* *)
(***********************************************************************)
-(* $Id: plugin.ml,v 1.4.4.1 2008/11/06 15:40:39 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
(* *)
(***********************************************************************)
-(* $Id: plugin.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Plugin *)
(* *)
(***********************************************************************)
-(* $Id: ppcache.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Command
(* *)
(***********************************************************************)
-(* $Id: ppcache.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* nothing to export *)
(* *)
(***********************************************************************)
-(* $Id: report.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Report *)
(* *)
(***********************************************************************)
-(* $Id: report.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Report *)
(* *)
(***********************************************************************)
-(* $Id: resource.ml,v 1.9 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
(* *)
(***********************************************************************)
-(* $Id: resource.mli,v 1.7 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
(* *)
(***********************************************************************)
-(* $Id: rule.ml,v 1.20 2008/07/25 14:50:47 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Format
(* *)
(***********************************************************************)
-(* $Id: rule.mli,v 1.12 2008/07/25 14:50:47 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Resource
(* *)
(***********************************************************************)
-(* $Id: shell.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
(* *)
(***********************************************************************)
-(* $Id: shell.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
val is_simple_filename : string -> bool
val quote_filename_if_needed : string -> string
(* *)
(***********************************************************************)
-(* $Id: signatures.mli,v 1.28 2008/07/25 14:42:28 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(** This module contains all module signatures that the user
could use to build an ocamlbuild plugin. *)
(* *)
(***********************************************************************)
-(* $Id: slurp.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Slurp *)
open My_std
(* *)
(***********************************************************************)
-(* $Id: slurp.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *)
+
(* Original author: Berke Durak *)
(* Slurp *)
(* *)
(***********************************************************************)
-(* $Id: solver.ml,v 1.8 2008/07/25 14:50:47 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
open My_std
open Log
(* *)
(***********************************************************************)
-(* $Id: solver.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
type backtrace = private
| Leaf of Pathname.t
# #
#########################################################################
-# $Id: start.sh,v 1.6 2008/01/11 16:13:16 doligez Exp $
+
set -e
set -x
(* *)
(***********************************************************************)
-(* $Id: std_signatures.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(** Some signatures from the standard library. *)
(* *)
(***********************************************************************)
-(* $Id: tags.ml,v 1.2 2007/02/22 15:56:23 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
include Set.Make(String)
(* *)
(***********************************************************************)
-(* $Id: tags.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *)
+
(* Original author: Nicolas Pouillard *)
include Signatures.TAGS
(* *)
(***********************************************************************)
-(* $Id: tools.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Tools *)
(* *)
(***********************************************************************)
-(* $Id: tools.mli,v 1.3 2008/01/11 16:13:16 doligez Exp $ *)
+
(* Original author: Nicolas Pouillard *)
(* Tools *)
odoc_name.cmi
odoc_ocamlhtml.cmo:
odoc_ocamlhtml.cmx:
-odoc_opt.cmo: ../typing/typedtree.cmi odoc_texi.cmo odoc_messages.cmo \
- odoc_man.cmo odoc_latex.cmo odoc_info.cmi odoc_html.cmo odoc_global.cmi \
- odoc_dot.cmo odoc_args.cmi odoc_analyse.cmi ../utils/misc.cmi \
- ../utils/config.cmi ../utils/clflags.cmi
-odoc_opt.cmx: ../typing/typedtree.cmx odoc_texi.cmx odoc_messages.cmx \
- odoc_man.cmx odoc_latex.cmx odoc_info.cmx odoc_html.cmx odoc_global.cmx \
- odoc_dot.cmx odoc_args.cmx odoc_analyse.cmx ../utils/misc.cmx \
- ../utils/config.cmx ../utils/clflags.cmx
odoc_parameter.cmo: ../typing/types.cmi odoc_types.cmi
odoc_parameter.cmx: ../typing/types.cmx odoc_types.cmx
odoc_parser.cmo: odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi
#(* *)
#(***********************************************************************)
-# $Id: Makefile,v 1.66 2008/01/11 16:13:16 doligez Exp $
+# $Id: Makefile,v 1.66.4.1 2009/04/09 13:56:38 guesdon Exp $
include ../config/Makefile
CMXFILES= $(CMOFILES:.cmo=.cmx)
CMIFILES= $(CMOFILES:.cmo=.cmi)
-EXECMOFILES=$(CMOFILES)\
- odoc_dag2html.cmo\
- odoc_to_text.cmo\
- odoc_ocamlhtml.cmo\
- odoc_html.cmo\
- odoc_man.cmo\
+EXECMOFILES=$(CMOFILES) \
+ odoc_dag2html.cmo \
+ odoc_to_text.cmo \
+ odoc_ocamlhtml.cmo \
+ odoc_html.cmo \
+ odoc_man.cmo \
odoc_latex_style.cmo \
- odoc_latex.cmo\
- odoc_texi.cmo\
- odoc_dot.cmo
+ odoc_latex.cmo \
+ odoc_texi.cmo \
+ odoc_dot.cmo \
+ odoc.cmo
EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
EXECMIFILES= $(EXECMOFILES:.cmo=.cmi)
debug:
make OCAMLPP=""
-$(OCAMLDOC): $(EXECMOFILES) odoc.cmo
- $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc.cmo
-$(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx
- $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx
+$(OCAMLDOC): $(EXECMOFILES)
+ $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES)
+$(OCAMLDOC_OPT): $(EXECMXFILES)
+ $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES)
$(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
$(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES)
manpages: stdlib_man/Pervasives.3o
-dot: $(EXECMOFILES) odoc.cmo
+dot: $(EXECMOFILES)
$(OCAMLDOC_RUN) -dot -dot-reduce -o ocamldoc.dot $(INCLUDES) \
odoc*.ml
#(* *)
#(***********************************************************************)
-# $Id: Makefile.nt,v 1.27 2007/11/06 15:16:56 frisch Exp $
+# $Id: Makefile.nt,v 1.27.4.1 2009/04/09 13:56:38 guesdon Exp $
include ../config/Makefile
odoc_latex.cmo\
odoc_texi.cmo\
odoc_dot.cmo\
+ odoc.cmo
EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
debug:
make OCAMLPP=""
-$(OCAMLDOC): $(EXECMOFILES) odoc.cmo
- $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc.cmo
-$(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx
- $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx
+$(OCAMLDOC): $(EXECMOFILES)
+ $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES)
+$(OCAMLDOC_OPT): $(EXECMXFILES)
+ $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES)
$(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
$(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES)
(* *)
(***********************************************************************)
-(* $Id: odoc.ml,v 1.9 2006/09/20 11:14:36 doligez Exp $ *)
+(* $Id: odoc.ml,v 1.9.14.1 2009/04/09 13:56:38 guesdon Exp $ *)
(** Main module for bytecode. *)
(* we check if we must load a module given on the command line *)
let arg_list = Array.to_list Sys.argv
-let (cmo_or_cma_opt, paths) =
+let (cm_opt, paths) =
let rec iter (f_opt, inc) = function
[] | _ :: [] -> (f_opt, inc)
| "-g" :: file :: q when
((Filename.check_suffix file "cmo") or
- (Filename.check_suffix file "cma")) &
+ (Filename.check_suffix file "cma") or
+ (Filename.check_suffix file "cmxs")) &
(f_opt = None) ->
- iter (Some file, inc) q
- | "-i" :: dir :: q ->
- iter (f_opt, inc @ [dir]) q
- | _ :: q ->
+ iter (Some file, inc) q
+ | "-i" :: dir :: q ->
+ iter (f_opt, inc @ [dir]) q
+ | _ :: q ->
iter (f_opt, inc) q
in
iter (None, []) arg_list
)
let _ =
- match cmo_or_cma_opt with
+ match cm_opt with
None ->
()
| Some file ->
- (* initializations for dynamic loading *)
- Dynlink.init ();
+ let file = Dynlink.adapt_filename file in
Dynlink.allow_unsafe_modules true;
try
let real_file = get_real_filename file in
exit 0
-(* eof $Id: odoc.ml,v 1.9 2006/09/20 11:14:36 doligez Exp $ *)
+(* eof $Id: odoc.ml,v 1.9.14.1 2009/04/09 13:56:38 guesdon Exp $ *)
(* *)
(***********************************************************************)
-(* cvsid $Id: odoc_args.ml,v 1.22 2008/07/25 13:28:23 guesdon Exp $ *)
+(* cvsid $Id: odoc_args.ml,v 1.22.2.1 2009/04/09 13:56:38 guesdon Exp $ *)
(** Command-line arguments. *)
let include_dirs = Clflags.include_dirs
-let bytecode_mode = ref true
-
class type doc_generator =
object
method generate : Odoc_module.t_module list -> unit
"-dot", Arg.Unit (fun () -> set_doc_generator !default_dot_generator), M.generate_dot ;
"-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0),
M.display_custom_generators_dir ;
- "-i", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-i"); exit 1)),
- M.add_load_dir ;
- "-g", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-g"); exit 1)),
- M.load_file ^
+ "-i", Arg.String (fun s -> ()), M.add_load_dir ;
+ "-g", Arg.String (fun s -> ()), M.load_file ^
"\n\n *** HTML options ***\n";
(* html only options *)
(* *)
(***********************************************************************)
-(* $Id: odoc_args.mli,v 1.17 2008/07/25 13:28:23 guesdon Exp $ *)
+(* $Id: odoc_args.mli,v 1.17.2.1 2009/04/09 13:56:38 guesdon Exp $ *)
(** Analysis of the command line arguments. *)
(** The include_dirs in the OCaml compiler. *)
val include_dirs : string list ref
-(** Indicate if we are in bytecode mode or not.
- (For the [ocamldoc] command).*)
-val bytecode_mode : bool ref
-
(** The class type of documentation generators. *)
class type doc_generator =
object method generate : Odoc_module.t_module list -> unit end
(* *)
(***********************************************************************)
-(* $Id: odoc_messages.ml,v 1.32 2008/07/25 13:28:23 guesdon Exp $ *)
+(* $Id: odoc_messages.ml,v 1.32.2.1 2009/04/09 13:56:38 guesdon Exp $ *)
(** The messages of the application. *)
let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n"
let options_are = "Options are :"
let option_version = "\tPrint version and exit"
-let bytecode_only = "(bytecode version only)"
let latex_only = "(LaTeX only)"
let texi_only = "(TeXinfo only)"
let latex_texi_only = "(LaTeX and TeXinfo only)"
let option_text ="<file>\tConsider <file> as a .txt file"
let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit"
let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^
- "\t\tgenerators "^bytecode_only
-let load_file = "<file.cm[o|a]>\n\t\tLoad file defining a new documentation generator\n\t\t"^bytecode_only
+ "\t\tgenerators"
+let load_file = "<file.cm[o|a|xs]>\n\t\tLoad file defining a new documentation generator"
let nolabels = "\tIgnore non-optional labels in types"
let werr = "\tTreat ocamldoc warnings as errors"
let hide_warnings = "\n\t\tdo not print ocamldoc warnings"
(* *)
(***********************************************************************)
-(* $Id: odoc_name.ml,v 1.10 2006/07/06 07:19:06 pouillar Exp $ *)
+(* $Id: odoc_name.ml,v 1.10.14.1 2009/03/12 18:21:08 doligez Exp $ *)
(** Representation of element names. *)
let parens_if_infix name =
match name with
- "" -> ""
- | s ->
- if List.mem s.[0] infix_chars then
- "("^s^")"
- else
- s
+ | "" -> ""
+ | s when s.[0] = '*' || s.[String.length s - 1] = '*' -> "( " ^ s ^ " )"
+ | s when List.mem s.[0] infix_chars -> "(" ^ s ^ ")"
+ | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" ->
+ "(" ^ name ^ ")"
+ | _ -> name
+;;
let cut name =
match name with
+++ /dev/null
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id: odoc_opt.ml,v 1.6 2006/09/20 11:14:37 doligez Exp $ *)
-
-(** Main module for native version.*)
-
-open Config
-open Clflags
-open Misc
-open Format
-open Typedtree
-
-let _ = Odoc_args.bytecode_mode := false
-
-
-let html_generator = new Odoc_html.html
-let default_latex_generator = new Odoc_latex.latex
-let default_texi_generator = new Odoc_texi.texi
-let default_man_generator = new Odoc_man.man
-let default_dot_generator = new Odoc_dot.dot
-let _ = Odoc_args.parse
- (html_generator :> Odoc_args.doc_generator)
- (default_latex_generator :> Odoc_args.doc_generator)
- (default_texi_generator :> Odoc_args.doc_generator)
- (default_man_generator :> Odoc_args.doc_generator)
- (default_dot_generator :> Odoc_args.doc_generator)
-
-let loaded_modules =
- List.flatten
- (List.map
- (fun f ->
- Odoc_info.verbose (Odoc_messages.loading f);
- try
- let l = Odoc_analyse.load_modules f in
- Odoc_info.verbose Odoc_messages.ok;
- l
- with Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- []
- )
- !Odoc_args.load
- )
-
-let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files
-
-let _ =
- match !Odoc_args.dump with
- None -> ()
- | Some f ->
- try Odoc_analyse.dump_modules f modules
- with Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors
-
-let _ =
- match !Odoc_args.doc_generator with
- None ->
- ()
- | Some gen ->
- Odoc_info.verbose Odoc_messages.generating_doc;
- gen#generate modules;
- Odoc_info.verbose Odoc_messages.ok
-
-let _ =
- if !Odoc_global.errors > 0 then
- (
- prerr_endline (Odoc_messages.errors_occured !Odoc_global.errors) ;
- exit 1
- )
- else
- exit 0
# #
#########################################################################
-# $Id: Makefile,v 1.26 2007/11/06 15:16:56 frisch Exp $
+# $Id: Makefile,v 1.26.4.1 2009/03/31 11:33:25 xleroy Exp $
# Makefile for the ndbm library
COBJS=cldbm.o
EXTRACFLAGS=$(DBM_INCLUDES)
LINKOPTS=$(DBM_LINK)
+LDOPTS=-ldopt "$(DBM_LINK)"
include ../Makefile
$(MAKE) superclean
cd ../labltk; $(MAKE)
cd ../camltk; $(MAKE)
- $(MKLIB) -ocamlc '$(CAMLC)' -o $(LIBNAME) \
+ $(MKLIB) -ocamlc '$(CAMLCB)' -o $(LIBNAME) \
-I ../labltk -I ../camltk $(TKOBJS) \
-ccopt "\"$(TK_LINK)\""
$(MAKE) superclean
cd ../labltk; $(MAKE) opt
cd ../camltk; $(MAKE) opt
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o $(LIBNAME) -oc $(LIBNAME) \
+ $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o $(LIBNAME) -oc $(LIBNAME) \
-I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \
-ccopt "\"$(TK_LINK)\""
## Tools from the Objective Caml distribution
CAMLRUN=$(TOPDIR)/boot/ocamlrun
-CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -nostdlib -I $(TOPDIR)/stdlib
-CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -nostdlib -I $(TOPDIR)/stdlib
+CAMLC=$(TOPDIR)/ocamlcomp.sh
+CAMLOPT=$(TOPDIR)/ocamlcompopt.sh
+CAMLCB=$(CAMLRUN) $(TOPDIR)/ocamlc
+CAMLOPTB=$(CAMLRUN) $(TOPDIR)/ocamlopt
CAMLCOMP=$(CAMLC) -c -warn-error A
CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v
CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex
COBJS= cltkaniminit.$(O) tkAnimGIF.$(O)
tkanim.cma: $(OBJS)
- $(MKLIB) -ocamlc '$(CAMLC)' -o tkanim $(OBJS)
+ $(MKLIB) -ocamlc '$(CAMLCB)' -o tkanim $(OBJS)
tkanim.cmxa: $(OBJS:.cmo=.cmx)
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o tkanim $(OBJS:.cmo=.cmx)
+ $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o tkanim $(OBJS:.cmo=.cmx)
libtkanim.$(A): $(COBJS)
$(MKLIB) -o tkanim $(COBJS)
(* *)
(***********************************************************************)
-(* $Id: big_int.ml,v 1.24 2008/08/03 09:04:40 xleroy Exp $ *)
+(* $Id: big_int.ml,v 1.24.2.1 2009/05/18 13:08:03 xleroy Exp $ *)
open Int_misc
open Nat
else if i > 0L then (1, i)
else (-1, Int64.neg i) in
let res = create_nat 2 in
- set_digit_nat_native res 0 (Int64.to_nativeint i);
- set_digit_nat_native res 1 (Int64.to_nativeint (Int64.shift_right i 32));
+ set_digit_nat_native res 0 (Int64.to_nativeint absi);
+ set_digit_nat_native res 1 (Int64.to_nativeint (Int64.shift_right absi 32));
{ sign = sg; abs_value = res }
end
(big_int_of_int64 9223372036854775807L, big_int_of_string "9223372036854775807");;
test 3 eq_big_int
(big_int_of_int64 (-9223372036854775808L), big_int_of_string "-9223372036854775808");;
+test 4 eq_big_int (*PR#4792*)
+ (big_int_of_int64 (Int64.of_int32 Int32.min_int), big_int_of_string "-2147483648");;
+test 5 eq_big_int
+ (big_int_of_int64 1234L, big_int_of_string "1234");;
+test 6 eq_big_int
+ (big_int_of_int64 0x1234567890ABCDEFL, big_int_of_string "1311768467294899695");;
+test 7 eq_big_int
+ (big_int_of_int64 (-1234L), big_int_of_string "-1234");;
+test 8 eq_big_int
+ (big_int_of_int64 (-0x1234567890ABCDEFL), big_int_of_string "-1311768467294899695");;
testing_function "int64_of_big_int";;
(* *)
(***********************************************************************)
-(* $Id: str.ml,v 1.22 2008/08/01 12:27:13 xleroy Exp $ *)
+(* $Id: str.ml,v 1.22.2.1 2008/12/12 08:54:15 xleroy Exp $ *)
(** String utilities *)
type re_syntax =
Char of char
| String of string
- | CharClass of Charset.t
+ | CharClass of Charset.t * bool (* true = complemented, false = normal *)
| Seq of re_syntax list
| Alt of re_syntax * re_syntax
| Star of re_syntax
let rec is_nullable = function
Char c -> false
| String s -> s = ""
- | CharClass cl -> false
+ | CharClass(cl, cmpl) -> false
| Seq rl -> List.for_all is_nullable rl
| Alt (r1, r2) -> is_nullable r1 || is_nullable r2
| Star r -> true
let rec first = function
Char c -> Charset.singleton c
| String s -> if s = "" then Charset.full else Charset.singleton s.[0]
- | CharClass cl -> cl
+ | CharClass(cl, cmpl) -> if cmpl then Charset.complement cl else cl
| Seq rl -> first_seq rl
| Alt (r1, r2) -> Charset.union (first r1) (first r2)
| Star r -> Charset.full
(* Transform a Char or CharClass regexp into a character class *)
let charclass_of_regexp fold_case re =
- let cl =
+ let (cl1, compl) =
match re with
- Char c -> Charset.singleton c
- | CharClass cl -> cl
+ | Char c -> (Charset.singleton c, false)
+ | CharClass(cl, compl) -> (cl, compl)
| _ -> assert false in
- if fold_case then Charset.fold_case cl else cl
+ let cl2 = if fold_case then Charset.fold_case cl1 else cl1 in
+ if compl then Charset.complement cl2 else cl2
(* The case fold table: maps characters to their lowercase equivalent *)
else
emit_instr op_STRING (cpool_index s)
end
- | CharClass cl ->
- let cl' = if fold_case then Charset.fold_case cl else cl in
- emit_instr op_CHARCLASS (cpool_index cl')
+ | CharClass(cl, compl) ->
+ let cl1 = if fold_case then Charset.fold_case cl else cl in
+ let cl2 = if compl then Charset.complement cl1 else cl1 in
+ emit_instr op_CHARCLASS (cpool_index cl2)
| Seq rl ->
emit_seq_code rl
| Alt(r1, r2) ->
and regexp3 i =
match s.[i] with
'\\' -> regexpbackslash (i+1)
- | '[' -> let (c, j) = regexpclass0 (i+1) in (CharClass c, j)
+ | '[' -> let (c, compl, j) = regexpclass0 (i+1) in
+ (CharClass(c, compl), j)
| '^' -> (Bol, i+1)
| '$' -> (Eol, i+1)
- | '.' -> (CharClass dotclass, i+1)
+ | '.' -> (CharClass(dotclass, false), i+1)
| c -> (Char c, i+1)
and regexpbackslash i =
if i >= len then (Char '\\', i) else
(Char c, i + 1)
and regexpclass0 i =
if i < len && s.[i] = '^'
- then let (c, j) = regexpclass1 (i+1) in (Charset.complement c, j)
- else regexpclass1 i
+ then let (c, j) = regexpclass1 (i+1) in (c, true, j)
+ else let (c, j) = regexpclass1 i in (c, false, j)
and regexpclass1 i =
let c = Charset.make_empty() in
let j = regexpclass2 c i i in
/* */
/***********************************************************************/
-/* $Id: posix.c,v 1.58 2008/09/27 10:46:55 xleroy Exp $ */
+/* $Id: posix.c,v 1.58.2.2 2009/03/28 17:35:59 xleroy Exp $ */
/* Thread interface for POSIX 1003.1c threads */
/* Condition signaled when caml_runtime_busy becomes 0 */
static pthread_cond_t caml_runtime_is_free = PTHREAD_COND_INITIALIZER;
+/* Whether the ``tick'' thread is already running */
+static int caml_tick_thread_running = 0;
+
/* The key used for storing the thread descriptor in the specific data
of the corresponding Posix thread. */
static pthread_key_t thread_descriptor_key;
static void caml_thread_reinitialize(void)
{
caml_thread_t thr, next;
- pthread_t tick_pthread;
- pthread_attr_t attr;
struct channel * chan;
/* Remove all other threads (now nonexistent)
pthread_cond_init(&caml_runtime_is_free, NULL);
caml_runtime_waiters = 0; /* no other thread is waiting for the RTS */
caml_runtime_busy = 1; /* normally useless */
+ /* Tick thread is not currently running in child process, will be
+ re-created at next Thread.create */
+ caml_tick_thread_running = 0;
/* Reinitialize all IO mutexes */
for (chan = caml_all_opened_channels;
chan != NULL;
chan = chan->next) {
if (chan->mutex != NULL) pthread_mutex_init(chan->mutex, NULL);
}
- /* Fork a new tick thread */
- pthread_attr_init(&attr);
- pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
- pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL);
}
/* Initialize the thread machinery */
value caml_thread_initialize(value unit) /* ML */
{
- pthread_t tick_pthread;
- pthread_attr_t attr;
value mu = Val_unit;
value descr;
curr_thread->descr = descr;
curr_thread->next = curr_thread;
curr_thread->prev = curr_thread;
+ curr_thread->backtrace_last_exn = Val_unit;
#ifdef NATIVE_CODE
curr_thread->exit_buf = &caml_termination_jmpbuf;
#endif
caml_channel_mutex_lock = caml_io_mutex_lock;
caml_channel_mutex_unlock = caml_io_mutex_unlock;
caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
- /* Fork the tick thread */
- pthread_attr_init(&attr);
- pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
- caml_pthread_check(
- pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL),
- "Thread.init");
/* Set up fork() to reinitialize the thread machinery in the child
(PR#4577) */
pthread_atfork(NULL, NULL, caml_thread_reinitialize);
{
pthread_attr_t attr;
caml_thread_t th;
+ pthread_t tick_pthread;
value mu = Val_unit;
value descr;
int err;
th->prev = curr_thread;
curr_thread->next->prev = th;
curr_thread->next = th;
- /* Fork the new thread */
+ /* Create the new thread */
pthread_attr_init(&attr);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
err = pthread_create(&th->pthread, &attr, caml_thread_start, (void *) th);
if (err != 0) {
- /* Fork failed, remove thread info block from list of threads */
+ /* Creation failed, remove thread info block from list of threads */
th->next->prev = curr_thread;
curr_thread->next = th->next;
#ifndef NATIVE_CODE
caml_pthread_check(err, "Thread.create");
}
End_roots();
+ /* Create the tick thread if not already done.
+ Because of PR#4666, we start the tick thread late, only when we create
+ the first additional thread in the current process*/
+ if (! caml_tick_thread_running) {
+ caml_tick_thread_running = 1;
+ pthread_attr_init(&attr);
+ pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
+ err = pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL);
+ caml_pthread_check(err, "Thread.create");
+ }
return descr;
}
(* *)
(***********************************************************************)
-(* $Id: unix.mli,v 1.89 2008/09/04 13:53:43 doligez Exp $ *)
+(* $Id: unix.mli,v 1.89.2.1 2009/03/28 16:58:56 xleroy Exp $ *)
(** Interface to the Unix system *)
PF_UNIX (** Unix domain *)
| PF_INET (** Internet domain (IPv4) *)
| PF_INET6 (** Internet domain (IPv6) *)
-(** The type of socket domains. *)
+(** The type of socket domains. Not all platforms support
+ IPv6 sockets (type [PF_INET6]). *)
type socket_type =
SOCK_STREAM (** Stream socket *)
/* */
/***********************************************************************/
-/* $Id: pipe.c,v 1.7 2001/12/07 13:40:45 xleroy Exp $ */
+/* $Id: pipe.c,v 1.7.28.1 2009/03/28 15:30:08 xleroy Exp $ */
#include <mlvalues.h>
#include <memory.h>
#include "unixsupport.h"
#include <fcntl.h>
-#define SIZEBUF 1024
+/* PR#4749: pick a size that matches that of I/O buffers */
+#define SIZEBUF 4096
CAMLprim value unix_pipe(value unit)
{
/* */
/***********************************************************************/
-/* $Id: stat.c,v 1.3 2006/09/21 13:57:34 xleroy Exp $ */
+/* $Id: stat.c,v 1.3.14.1 2009/03/28 16:39:50 xleroy Exp $ */
#include <errno.h>
#include <mlvalues.h>
ret = _fstati64(win_CRT_fd_of_filedescr(handle), &buf);
if (ret == -1) uerror("fstat", Nothing);
- if (buf.st_size > Max_long) {
- win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
- uerror("fstat", Nothing);
- }
return stat_aux(1, &buf);
}
/* */
/***********************************************************************/
-/* $Id: unixsupport.c,v 1.21 2007/02/07 14:45:46 doligez Exp $ */
+/* $Id: unixsupport.c,v 1.21.12.1 2009/05/19 12:32:36 xleroy Exp $ */
#include <stddef.h>
#include <mlvalues.h>
{ ERROR_NO_PROC_SLOTS, 0, EAGAIN},
{ ERROR_DRIVE_LOCKED, 0, EACCES},
{ ERROR_BROKEN_PIPE, 0, EPIPE},
+ { ERROR_NO_DATA, 0, EPIPE},
{ ERROR_DISK_FULL, 0, ENOSPC},
{ ERROR_INVALID_TARGET_HANDLE, 0, EBADF},
{ ERROR_INVALID_HANDLE, 0, EINVAL},
(* *)
(***********************************************************************)
-(* $Id: format.ml,v 1.74 2008/09/08 12:30:19 weis Exp $ *)
+(* $Id: format.ml,v 1.74.2.1 2009/04/29 18:33:31 weis Exp $ *)
(* A pretty-printing facility and definition of formatters for ``parallel''
(i.e. unrelated or independent) pretty-printing on multiple out channels. *)
s
;;
-(* [ppf] is supposed to be a pretty-printer that outputs in buffer [b]:
- to extract contents of [ppf] as a string we flush [ppf] and get the string
- out of [b]. *)
+(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]:
+ to extract the contents of [ppf] as a string we flush [ppf] and get the
+ string out of [b]. *)
let string_out b ppf =
pp_flush_queue ppf false;
get_buffer_out b
mkprintf false (fun _ -> formatter_of_buffer b) k
;;
-let bprintf b = kbprintf ignore b;;
+let bprintf b =
+ let k ppf = pp_flush_queue ppf false in
+ kbprintf k b
+;;
let ksprintf k =
let b = Buffer.create 512 in
(* *)
(***********************************************************************)
-(* $Id: map.mli,v 1.33 2005/10/25 18:34:07 doligez Exp $ *)
+(* $Id: map.mli,v 1.33.18.1 2009/03/21 16:35:48 xleroy Exp $ *)
(** Association tables over ordered types.
(** [iter f m] applies [f] to all bindings in map [m].
[f] receives the key as first argument, and the associated value
as second argument. The bindings are passed to [f] in increasing
- order with respect to the ordering over the type of the keys.
- Only current bindings are presented to [f]:
- bindings hidden by more recent bindings are not passed to [f]. *)
+ order with respect to the ordering over the type of the keys. *)
val map: ('a -> 'b) -> 'a t -> 'b t
(** [map f m] returns a map with same domain as [m], where the
(* *)
(***********************************************************************)
-(* $Id: parsing.ml,v 1.19 2008/08/06 09:38:21 xleroy Exp $ *)
+(* $Id: parsing.ml,v 1.19.2.1 2009/01/13 15:17:51 doligez Exp $ *)
(* The parsing engine *)
Obj.magic env.v_stack.(env.asp - n)
let symbol_start_pos () =
- if env.rule_len > 0
- then env.symb_start_stack.(env.asp - env.rule_len + 1)
- else env.symb_end_stack.(env.asp)
+ let rec loop i =
+ if i <= 0 then env.symb_end_stack.(env.asp)
+ else begin
+ let st = env.symb_start_stack.(env.asp - i + 1) in
+ let en = env.symb_end_stack.(env.asp - i + 1) in
+ if st <> en then st else loop (i - 1)
+ end
+ in
+ loop env.rule_len
;;
let symbol_end_pos () = env.symb_end_stack.(env.asp);;
let rhs_start_pos n = env.symb_start_stack.(env.asp - (env.rule_len - n));;
(* *)
(***********************************************************************)
-(* $Id: pervasives.mli,v 1.113 2008/10/06 13:33:21 doligez Exp $ *)
+(* $Id: pervasives.mli,v 1.113.2.2 2009/04/30 09:05:57 weis Exp $ *)
(** The initially opened module.
name, without prefixing them by [Pervasives].
*)
+
(** {6 Exceptions} *)
external raise : exn -> 'a = "%raise"
(** {6 Comparisons} *)
-
external ( = ) : 'a -> 'a -> bool = "%equal"
(** [e1 = e2] tests for structural equality of [e1] and [e2].
Mutable structures (e.g. references and arrays) are equal
external ( == ) : 'a -> 'a -> bool = "%eq"
(** [e1 == e2] tests for physical equality of [e1] and [e2].
- On integers and characters, physical equality is identical to structural
- equality. On mutable structures, [e1 == e2] is true if and only if
+ On mutable structures, [e1 == e2] is true if and only if
physical modification of [e1] also affects [e2].
On non-mutable structures, the behavior of [(==)] is
implementation-dependent; however, it is guaranteed that
(** {6 Boolean operations} *)
-
external not : bool -> bool = "%boolnot"
(** The boolean negation. *)
(** The smallest representable integer. *)
-
(** {7 Bitwise operations} *)
-
external ( land ) : int -> int -> int = "%andint"
(** Bitwise logical and. *)
(** Floating-point division. *)
external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
-(** Exponentiation *)
+(** Exponentiation. *)
external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float"
-(** Square root *)
+(** Square root. *)
external exp : float -> float = "caml_exp_float" "exp" "float"
(** Exponential. *)
(** Base 10 logarithm. *)
external cos : float -> float = "caml_cos_float" "cos" "float"
-(** See {!Pervasives.atan2}. *)
+(** [cos a] returns the cosine of angle [a] measured in radians. *)
external sin : float -> float = "caml_sin_float" "sin" "float"
-(** See {!Pervasives.atan2}. *)
+(** [sin a] returns the sine of angle [a] measured in radians. *)
external tan : float -> float = "caml_tan_float" "tan" "float"
-(** See {!Pervasives.atan2}. *)
+(** [tan a] returns the tangent of angle [a] measured in radians. *)
external acos : float -> float = "caml_acos_float" "acos" "float"
-(** See {!Pervasives.atan2}. *)
+(** [acos f] returns the arc cosine of [f]. The return angle is measured
+ in radians. *)
external asin : float -> float = "caml_asin_float" "asin" "float"
-(** See {!Pervasives.atan2}. *)
+(** [asin f] returns the arc sine of [f]. The return angle is measured
+ in radians. *)
external atan : float -> float = "caml_atan_float" "atan" "float"
-(** See {!Pervasives.atan2}. *)
+(** [atan f] returns the arc tangent of [f]. The return angle is measured
+ in radians. *)
external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
-(** The usual trigonometric functions. *)
+(** [atan2 y x] returns the principal value of the arc tangent of
+ [y / x], using the signs of both arguments to determine the quadrant of the
+ result. The return angle is measured in radians. *)
external cosh : float -> float = "caml_cosh_float" "cosh" "float"
-(** See {!Pervasives.tanh}. *)
+(** [cosh a] returns the hyperbolic cosine of angle [a] measured
+ in radians. *)
external sinh : float -> float = "caml_sinh_float" "sinh" "float"
-(** See {!Pervasives.tanh}. *)
+(** [sinh a] returns the hyperbolic sine of angle [a] measured
+ in radians. *)
external tanh : float -> float = "caml_tanh_float" "tanh" "float"
-(** The usual hyperbolic trigonometric functions. *)
+(** [tanh f] returns the hyperbolic tangent of angle [a] measured
+ in radians. *)
external ceil : float -> float = "caml_ceil_float" "ceil" "float"
-(** See {!Pervasives.floor}. *)
+(** Round the given float to an integer value.
+ [ceil f] returns the least integer value greater than or
+ equal to [f].
+ See also {!Pervasives.floor}. *)
external floor : float -> float = "caml_floor_float" "floor" "float"
(** Round the given float to an integer value.
[floor f] returns the greatest integer value less than or
equal to [f].
- [ceil f] returns the least integer value greater than or
- equal to [f]. *)
+ See also {!Pervasives.ceil}. *)
external abs_float : float -> float = "%absfloat"
-(** Return the absolute value of the argument. *)
+(** [abs_float f] returns the absolute value of [f]. *)
external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
(** [mod_float a b] returns the remainder of [a] with respect to
if the given string is not a valid representation of a float. *)
-
(** {6 Pair operations} *)
external fst : 'a * 'b -> 'a = "%field0"
The result is unspecified if the line read is not a valid
representation of a floating-point number. *)
-(** {7 General output functions} *)
+(** {7 General output functions} *)
type open_flag =
Open_rdonly (** open for reading. *)
This function has no effect under operating systems that
do not distinguish between text mode and binary mode. *)
+
(** {7 Operations on large files} *)
module LargeFile :
regular integers (type [int]), these alternate functions allow
operating on files whose sizes are greater than [max_int]. *)
+
(** {6 References} *)
type 'a ref = { mutable contents : 'a }
(** {6 Program termination} *)
-
val exit : int -> 'a
(** Terminate the process, returning the given status code
to the operating system: usually 0 to indicate no errors,
(* *)
(***********************************************************************)
-(* $Id: printf.ml,v 1.58 2008/09/27 20:50:01 weis Exp $ *)
+(* $Id: printf.ml,v 1.58.2.2 2009/04/29 19:02:05 weis Exp $ *)
external format_float: string -> float -> string
= "caml_format_float"
| ('*', []) ->
assert false (* should not happen *)
| (c, _) ->
- Buffer.add_char b c; fill_format (succ i) widths in
+ Buffer.add_char b c;
+ fill_format (succ i) widths in
fill_format start (List.rev widths);
Buffer.contents b
;;
| _ -> sfmt
;;
+let extract_format_float conv fmt start stop widths =
+ let sfmt = extract_format fmt start stop widths in
+ match conv with
+ | 'F' ->
+ sfmt.[String.length sfmt - 1] <- 'f';
+ sfmt
+ | _ -> sfmt
+;;
+
(* Returns the position of the next character following the meta format
string, starting from position [i], inside a given format [fmt].
According to the character [conv], the meta format string is
let count_arguments_of_format fmt =
let ac = ac_of_format fmt in
- ac.ac_rglr + ac.ac_skip + ac.ac_rdrs
+ ac.ac_rglr
;;
let list_iter_i f l =
| Spec_index p -> p
;;
+(* Format a float argument as a valid Caml lexem. *)
+let format_float_lexem =
+ let valid_float_lexem sfmt s =
+ let l = String.length s in
+ if l = 0 then "nan" else
+ let add_dot sfmt s =
+ if s.[0] = ' ' || s.[0] = '+' || s.[0] = '0'
+ then String.sub s 1 (l - 1) ^ "."
+ else String.sub s 0 (l - 1) ^ "." in
+
+ let rec loop i =
+ if i >= l then add_dot sfmt s else
+ match s.[i] with
+ | '.' -> s
+ | _ -> loop (i + 1) in
+
+ loop 0 in
+
+ (fun sfmt x ->
+ let s = format_float sfmt x in
+ match classify_float x with
+ | FP_normal | FP_subnormal | FP_zero -> valid_float_lexem sfmt s
+ | FP_nan | FP_infinite -> s)
+;;
+
(* Decode a format string and act on it.
[fmt] is the [printf] format string, and [pos] points to a [%] character in
the format string.
let (x : float) = get_arg spec n in
let s = format_float (extract_format fmt pos i widths) x in
cont_s (next_index spec n) s (succ i)
- | 'F' ->
+ | 'F' as conv ->
let (x : float) = get_arg spec n in
- cont_s (next_index spec n) (string_of_float x) (succ i)
+ let s =
+ format_float_lexem (extract_format_float conv fmt pos i widths) x in
+ cont_s (next_index spec n) s (succ i)
| 'B' | 'b' ->
let (x : bool) = get_arg spec n in
cont_s (next_index spec n) (string_of_bool x) (succ i)
(* *)
(***********************************************************************)
-(* $Id: scanf.ml,v 1.80 2008/09/27 20:45:05 weis Exp $ *)
+(* $Id: scanf.ml,v 1.80.2.2 2009/04/29 18:27:37 weis Exp $ *)
(* The run-time library for scanners. *)
| '\n', true
| ' ', false ->
skip_spaces false (Scanning.ignore_char ib max)
- | '\\', false -> loop false max
- | c, false -> loop false (Scanning.store_char ib c max)
+ | c, false -> loop false max
| _, _ -> loop false (scan_backslash_char (max - 1) ib) in
loop true max
;;
let bscanf_format ib fmt f =
let fmt = Sformat.unsafe_to_string fmt in
- let fmt1 = ignore (scan_String max_int ib); token_string ib in
+ let fmt1 =
+ ignore (scan_String max_int ib);
+ token_string ib in
if not (compatible_format_type fmt1 fmt) then
format_mismatch fmt1 fmt else
f (string_to_format fmt1)
;;
-let sscanf_format s fmt f = bscanf_format (Scanning.from_string s) fmt f;;
+let sscanf_format s fmt = bscanf_format (Scanning.from_string s) fmt;;
-let quote_string s =
- let b = Buffer.create (String.length s + 2) in
+let string_to_String s =
+ let l = String.length s in
+ let b = Buffer.create (l + 2) in
Buffer.add_char b '\"';
- Buffer.add_string b s;
+ for i = 0 to l - 1 do
+ let c = s.[i] in
+ if c = '\"' then Buffer.add_char b '\\';
+ Buffer.add_char b c;
+ done;
Buffer.add_char b '\"';
Buffer.contents b
;;
let format_from_string s fmt =
- sscanf_format (quote_string s) fmt (fun x -> x)
+ sscanf_format (string_to_String s) fmt (fun x -> x)
;;
(* *)
(***********************************************************************)
-(* $Id: ctype.ml,v 1.216.2.1 2008/10/08 13:07:13 doligez Exp $ *)
+(* $Id: ctype.ml,v 1.216.2.5 2009/05/19 05:51:03 garrigue Exp $ *)
(* Operations on core types *)
exception Non_closed of type_expr * bool
let free_variables = ref []
+let really_closed = ref None
let rec free_vars_rec real ty =
let ty = repr ty in
if ty.level >= lowest_level then begin
ty.level <- pivot_level - ty.level;
- begin match ty.desc with
- Tvar ->
+ begin match ty.desc, !really_closed with
+ Tvar, _ ->
free_variables := (ty, real) :: !free_variables
+ | Tconstr (path, tl, _), Some env ->
+ begin try
+ let (_, body) = Env.find_type_expansion path env in
+ if (repr body).level <> generic_level then
+ free_variables := (ty, real) :: !free_variables
+ with Not_found -> ()
+ end;
+ List.iter (free_vars_rec true) tl
(* Do not count "virtual" free variables
| Tobject(ty, {contents = Some (_, p)}) ->
free_vars_rec false ty; List.iter (free_vars_rec true) p
*)
- | Tobject (ty, _) ->
+ | Tobject (ty, _), _ ->
free_vars_rec false ty
- | Tfield (_, _, ty1, ty2) ->
+ | Tfield (_, _, ty1, ty2), _ ->
free_vars_rec true ty1; free_vars_rec false ty2
- | Tvariant row ->
+ | Tvariant row, _ ->
let row = row_repr row in
iter_row (free_vars_rec true) row;
if not (static_row row) then free_vars_rec false row.row_more
end;
end
-let free_vars ty =
+let free_vars ?env ty =
free_variables := [];
+ really_closed := env;
free_vars_rec true ty;
let res = !free_variables in
free_variables := [];
+ really_closed := None;
res
-let free_variables ty =
- let tl = List.map fst (free_vars ty) in
+let free_variables ?env ty =
+ let tl = List.map fst (free_vars ?env ty) in
unmark_type ty;
tl
with Not_found ->
TypePairs.add type_pairs (t1', t2') ();
match (t1'.desc, t2'.desc) with
- (Tvar, _) when may_instantiate inst_nongen t1 ->
+ (Tvar, _) when may_instantiate inst_nongen t1' ->
moregen_occur env t1'.level t2;
link_type t1' t2
| (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
in check_cycle [] ty
(* Normalize a type before printing, saving... *)
-let rec normalize_type_rec env ty =
+(* Cannot use mark_type because deep_occur uses it too *)
+let rec normalize_type_rec env visited ty =
let ty = repr ty in
- if ty.level >= lowest_level then begin
- mark_type_node ty;
+ if not (TypeSet.mem ty !visited) then begin
+ visited := TypeSet.add ty !visited;
begin match ty.desc with
| Tvariant row ->
let row = row_repr row in
begin match !nm with
| None -> ()
| Some (n, v :: l) ->
- let v' = repr v in
+ if deep_occur ty (newgenty (Ttuple l)) then
+ (* The abbreviation may be hiding something, so remove it *)
+ set_name nm None
+ else let v' = repr v in
begin match v'.desc with
| Tvar|Tunivar ->
if v' != v then set_name nm (Some (n, v' :: l))
- | Tnil -> log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
+ | Tnil ->
+ log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
| _ -> set_name nm None
end
| _ ->
log_type ty; fi.desc <- fi'.desc
| _ -> ()
end;
- iter_type_expr (normalize_type_rec env) ty
+ iter_type_expr (normalize_type_rec env visited) ty
end
let normalize_type env ty =
- normalize_type_rec env ty;
- unmark_type ty
+ normalize_type_rec env (ref TypeSet.empty) ty
(*************************)
(recursive type), so one cannot just take its
description.
*)
- with Cannot_expand ->
- raise Not_found
+ with Cannot_expand | Unify _ -> (* expand_abbrev failed *)
+ raise Not_found (* cf. PR4775 for Unify *)
end
else
Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil)
(* *)
(***********************************************************************)
-(* $Id: ctype.mli,v 1.55.4.1 2008/10/16 03:05:26 garrigue Exp $ *)
+(* $Id: ctype.mli,v 1.55.4.2 2009/02/13 05:05:36 garrigue Exp $ *)
(* Operations on core types *)
(* Check whether the given type scheme contains no non-generic
type variables *)
-val free_variables: type_expr -> type_expr list
+val free_variables: ?env:Env.t -> type_expr -> type_expr list
+ (* If env present, then check for incomplete definitions too *)
val closed_type_decl: type_declaration -> type_expr option
type closed_class_failure =
CC_Method of type_expr * bool * string * type_expr
(* *)
(***********************************************************************)
-(* $Id: env.ml,v 1.66 2008/10/06 13:53:54 doligez Exp $ *)
+(* $Id: env.ml,v 1.66.2.1 2009/04/28 05:11:54 garrigue Exp $ *)
(* Environment handling *)
cltypes = Ident.empty;
summary = Env_empty }
-let diff_keys tbl1 tbl2 =
+let diff_keys is_local tbl1 tbl2 =
let keys2 = Ident.keys tbl2 in
List.filter
(fun id ->
- match Ident.find_same id tbl2 with Pident _, _ ->
- (try ignore (Ident.find_same id tbl1); false with Not_found -> true)
- | _ -> false)
+ is_local (Ident.find_same id tbl2) &&
+ try ignore (Ident.find_same id tbl1); false with Not_found -> true)
keys2
+let is_ident = function
+ Pident _ -> true
+ | Pdot _ | Papply _ -> false
+
+let is_local (p, _) = is_ident p
+
+let is_local_exn = function
+ {cstr_tag = Cstr_exception p} -> is_ident p
+ | _ -> false
+
let diff env1 env2 =
- diff_keys env1.values env2.values @
- diff_keys env1.modules env2.modules @
- diff_keys env1.classes env2.classes
+ diff_keys is_local env1.values env2.values @
+ diff_keys is_local_exn env1.constrs env2.constrs @
+ diff_keys is_local env1.modules env2.modules @
+ diff_keys is_local env1.classes env2.classes
(* Forward declarations *)
(* *)
(***********************************************************************)
-(* $Id: includeclass.ml,v 1.8 2006/04/05 02:28:13 garrigue Exp $ *)
+(* $Id: includeclass.ml,v 1.8.16.1 2009/04/19 08:42:43 xleroy Exp $ *)
(* Inclusion checks for the class language *)
fprintf ppf "@[%a@]"
(Printtyp.unification_error false trace
(function ppf ->
- fprintf ppf "One type parameter has type"))
+ fprintf ppf "A type parameter has type"))
(function ppf ->
fprintf ppf "but is expected to have type")
| CM_Class_type_mismatch (cty1, cty2) ->
fprintf ppf "@[%a@]"
(Printtyp.unification_error false trace
(function ppf ->
- fprintf ppf "One parameter has type"))
+ fprintf ppf "A parameter has type"))
(function ppf ->
fprintf ppf "but is expected to have type")
| CM_Val_type_mismatch (lab, trace) ->
| CM_Public_method lab ->
fprintf ppf "@[The public method %s cannot become private" lab
| CM_Virtual_method lab ->
- fprintf ppf "@[The virtual method %s cannot become concrete" lab
+ fprintf ppf "@[The virtual method %s cannot become concrete" lab
| CM_Private_method lab ->
fprintf ppf "The private method %s cannot become public" lab
(* *)
(***********************************************************************)
-(* $Id: parmatch.ml,v 1.76 2008/07/15 18:11:46 mauny Exp $ *)
+(* $Id: parmatch.ml,v 1.76.2.2 2009/03/16 04:24:05 garrigue Exp $ *)
(* Detection of partial matches and unused match cases. *)
exception Empty (* Empty pattern *)
+(* May need a clean copy, cf. PR#4745 *)
+let clean_copy ty =
+ if ty.level = Btype.generic_level then ty
+ else Subst.type_expr Subst.identity ty
+
let get_type_path ty tenv =
- let ty = Ctype.repr (Ctype.expand_head tenv ty) in
+ let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
match ty.desc with
| Tconstr (path,_,_) -> path
| _ -> fatal_error "Parmatch.get_type_path"
-let get_type_descr ty tenv =
+let rec get_type_descr ty tenv =
match (Ctype.repr ty).desc with
| Tconstr (path,_,_) -> Env.find_type path tenv
| _ -> fatal_error "Parmatch.get_type_descr"
| {type_kind=Type_variant constr_list} ->
Datarepr.find_constr_by_tag tag constr_list
| {type_manifest = Some _} ->
- get_constr tag (Ctype.expand_head_once tenv ty) tenv
+ get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv
| _ -> fatal_error "Parmatch.get_constr"
let find_label lbl lbls =
match get_type_descr ty tenv with
| {type_kind = Type_record(lbls, rep)} -> lbls
| {type_manifest = Some _} ->
- get_record_labels (Ctype.expand_head_once tenv ty) tenv
+ get_record_labels (Ctype.expand_head_once tenv (clean_copy ty)) tenv
| _ -> fatal_error "Parmatch.get_record_labels"
(* *)
(***********************************************************************)
-(* $Id: subst.ml,v 1.52 2008/01/11 16:13:16 doligez Exp $ *)
+(* $Id: subst.ml,v 1.52.4.1 2009/04/02 09:06:32 xclerc Exp $ *)
(* Substitutions *)
and modtype_declaration s = function
Tmodtype_abstract -> Tmodtype_abstract
| Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty)
+
+(* Composition of substitutions:
+ apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+
+let compose s1 s2 =
+ { types = Tbl.map (fun id p -> type_path s2 p) s1.types;
+ modules = Tbl.map (fun id p -> module_path s2 p) s1.modules;
+ modtypes = Tbl.map (fun id mty -> modtype s2 mty) s1.modtypes;
+ for_saving = false }
(* *)
(***********************************************************************)
-(* $Id: subst.mli,v 1.13 2008/01/11 16:13:16 doligez Exp $ *)
+(* $Id: subst.mli,v 1.13.4.1 2009/04/02 09:06:33 xclerc Exp $ *)
(* Substitutions *)
val modtype: t -> module_type -> module_type
val signature: t -> signature -> signature
val modtype_declaration: t -> modtype_declaration -> modtype_declaration
+
+(* Composition of substitutions:
+ apply (compose s1 s2) x = apply s2 (apply s1 x) *)
+val compose: t -> t -> t
(* *)
(***********************************************************************)
-(* $Id: typeclass.ml,v 1.93 2008/02/29 14:21:22 doligez Exp $ *)
+(* $Id: typeclass.ml,v 1.93.4.1 2009/04/19 08:42:43 xleroy Exp $ *)
open Misc
open Parsetree
fprintf ppf
"@[The type of self cannot be coerced to@ \
the type of the current class:@ %a.@.\
- Some occurences are contravariant@]"
+ Some occurrences are contravariant@]"
Printtyp.type_scheme ty
| Non_collapsable_conjunction (id, clty, trace) ->
fprintf ppf
"@[The type of this class,@ %a,@ \
- contains non-collapsable conjunctive types in constraints@]"
+ contains non-collapsible conjunctive types in constraints@]"
(Printtyp.class_declaration id) clty;
Printtyp.report_unification_error ppf trace
(fun ppf -> fprintf ppf "Type")
(function ppf ->
fprintf ppf "This object is expected to have type")
(function ppf ->
- fprintf ppf "but has actually type")
+ fprintf ppf "but actually has type")
| Mutability_mismatch (lab, mut) ->
let mut1, mut2 =
if mut = Immutable then "mutable", "immutable"
else "immutable", "mutable" in
fprintf ppf
- "@[The instance variable is %s,@ it cannot be redefined as %s@]"
+ "@[The instance variable is %s;@ it cannot be redefined as %s@]"
mut1 mut2
(* *)
(***********************************************************************)
-(* $Id: typecore.ml,v 1.199 2008/07/29 15:42:44 doligez Exp $ *)
+(* $Id: typecore.ml,v 1.199.2.3 2009/04/19 09:21:08 xleroy Exp $ *)
(* Typechecking for the core language *)
begin match arg.exp_desc, !self_coercion, (repr ty').desc with
Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
Tconstr(path',_,_) when Path.same path path' ->
+ (* prerr_endline "self coercion"; *)
r := sexp.pexp_loc :: !r;
force ()
- | _ when free_variables arg.exp_type = []
- && free_variables ty' = [] ->
+ | _ when free_variables ~env arg.exp_type = []
+ && free_variables ~env ty' = [] ->
if not gen && (* first try a single coercion *)
let snap = snapshot () in
let ty, b = enlarge_type env ty' in
Location.prerr_warning sexp.pexp_loc
(Warnings.Not_principal "this ground coercion");
with Subtype (tr1, tr2) ->
+ (* prerr_endline "coercion failed"; *)
raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
end;
| _ ->
| Constructor_arity_mismatch(lid, expected, provided) ->
fprintf ppf
"@[The constructor %a@ expects %i argument(s),@ \
- but is here applied to %i argument(s)@]"
+ but is applied here to %i argument(s)@]"
longident lid expected provided
| Label_mismatch(lid, trace) ->
report_unification_error ppf trace
fprintf ppf "The record field label %a@ belongs to the type"
longident lid)
(function ppf ->
- fprintf ppf "but is here mixed with labels of type")
+ fprintf ppf "but is mixed here with labels of type")
| Pattern_type_clash trace ->
report_unification_error ppf trace
(function ppf ->
fprintf ppf "This pattern matches values of type")
(function ppf ->
- fprintf ppf "but is here used to match values of type")
+ fprintf ppf "but a pattern was expected which matches values of type")
| Multiply_bound_variable name ->
fprintf ppf "Variable %s is bound several times in this matching" name
| Orpat_vars id ->
(function ppf ->
fprintf ppf "This expression has type")
(function ppf ->
- fprintf ppf "but is here used with type")
+ fprintf ppf "but an expression was expected of type")
| Apply_non_function typ ->
begin match (repr typ).desc with
Tarrow _ ->
- fprintf ppf "This function is applied to too many arguments,@ ";
+ fprintf ppf "This function is applied to too many arguments;@ ";
fprintf ppf "maybe you forgot a `;'"
| _ ->
fprintf ppf
- "This expression is not a function, it cannot be applied"
+ "This expression is not a function; it cannot be applied"
end
| Apply_wrong_label (l, ty) ->
let print_label ppf = function
in
reset_and_mark_loops ty;
fprintf ppf
- "@[<v>@[<2>Expecting function has type@ %a@]@.\
+ "@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
This argument cannot be applied %a@]"
type_expr ty print_label l
| Label_multiply_defined lid ->
| Unbound_class cl ->
fprintf ppf "Unbound class %a" longident cl
| Virtual_class cl ->
- fprintf ppf "One cannot create instances of the virtual class %a"
+ fprintf ppf "Cannot instantiate the virtual class %a"
longident cl
| Unbound_instance_variable v ->
fprintf ppf "Unbound instance variable %s" v
| Instance_variable_not_mutable v ->
fprintf ppf "The instance variable %s is not mutable" v
| Not_subtype(tr1, tr2) ->
- report_subtyping_error ppf tr1 "is not a subtype of type" tr2
+ report_subtyping_error ppf tr1 "is not a subtype of" tr2
| Outside_class ->
fprintf ppf "This object duplication occurs outside a method definition"
| Value_multiply_overridden v ->
end
| Abstract_wrong_label (l, ty) ->
let label_mark = function
- | "" -> "but its first argument is not labeled"
- | l -> sprintf "but its first argument is labeled ~%s" l in
+ | "" -> "but its first argument is not labelled"
+ | l -> sprintf "but its first argument is labelled ~%s" l in
reset_and_mark_loops ty;
fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
type_expr ty (label_mark l)
(* *)
(***********************************************************************)
-(* $Id: typedecl.ml,v 1.82 2008/08/07 09:29:22 xleroy Exp $ *)
+(* $Id: typedecl.ml,v 1.82.2.2 2009/04/19 08:42:43 xleroy Exp $ *)
(**** Typing of type definitions ****)
compute_variance env tvl true cn cn ty)
ftl
end;
- let priv = decl.type_private
- and required =
+ let required =
List.map (fun (c,n as r) -> if c || n then r else (true,true))
required
in
List.iter2
(fun (ty, co, cn, ct) (c, n) ->
- if ty.desc <> Tvar || priv = Private then begin
+ if ty.desc <> Tvar then begin
co := c; cn := n; ct := n;
compute_variance env tvl2 c n n ty
end)
incr pos;
if !co && not c || !cn && not n
then raise (Error(loc, Bad_variance (!pos, (!co,!cn), (c,n))));
+ if decl.type_private = Private then (c,n,n) else
let ct = if decl.type_kind = Type_abstract then ct else cn in
(!co, !cn, !ct))
tvl0 required
(function ppf ->
fprintf ppf "This type constructor expands to type")
(function ppf ->
- fprintf ppf "but is here used with type")
+ fprintf ppf "but is used here with type")
| Null_arity_external ->
fprintf ppf "External identifiers must be functions"
| Missing_native_external ->
fprintf ppf "@[<hv>An external function with more than 5 arguments \
- requires second stub function@ \
+ requires a second stub function@ \
for native-code compilation@]"
| Unbound_type_var (ty, decl) ->
fprintf ppf "A type variable is unbound in this type declaration";
| (false,true) -> "contravariant"
| (false,false) -> "unrestricted"
in
+ let suffix n =
+ let teen = (n mod 100)/10 = 1 in
+ match n mod 10 with
+ | 1 when not teen -> "st"
+ | 2 when not teen -> "nd"
+ | 3 when not teen -> "rd"
+ | _ -> "th"
+ in
if n < 1 then
fprintf ppf "%s@ %s@ %s"
"In this definition, a type variable"
"has a variance that is not reflected"
- "by its occurence in type parameters."
+ "by its occurrence in type parameters."
else
fprintf ppf "%s@ %s@ %s %d%s %s %s,@ %s %s"
"In this definition, expected parameter"
"variances are not satisfied."
- "The" n (match n with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th")
+ "The" n (suffix n)
"type parameter was expected to be" (variance v2)
"but it is" (variance v1)
| Unavailable_type_constructor p ->
Printtyp.type_expr ty
| Variant_tags (lab1, lab2) ->
fprintf ppf
- "Variant tags `%s@ and `%s have same hash value.@ Change one of them."
+ "Variant tags `%s@ and `%s have the same hash value.@ Change one of them."
lab1 lab2
| Invalid_variable_name name ->
fprintf ppf "The type variable name %s is not allowed in programs" name
(* *)
(***********************************************************************)
-(* $Id: config.mlbuild,v 1.3 2007/11/27 12:22:59 ertai Exp $ *)
+(* $Id: config.mlbuild,v 1.3.4.4 2009/05/19 14:41:21 doligez Exp $ *)
+
+(***********************************************************************)
+(** **)
+(** WARNING WARNING WARNING **)
+(** **)
+(** When you change this file, you must make the parallel change **)
+(** in config.mlp **)
+(** **)
+(***********************************************************************)
+
(* The main OCaml version string has moved to ../VERSION *)
let version = Sys.ocaml_version
else C.bindir^"/ocamlrun"
let ccomp_type = C.ccomptype
let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts
-let bytecomp_c_linker = if windows then "flexlink" else sf "%s %s" C.bytecc C.bytecclinkopts
let bytecomp_c_libraries = C.bytecclibs
let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts
-let native_c_linker = if windows then "flexlink" else sf "%s %s" C.nativecc C.nativecclinkopts
let native_c_libraries = C.nativecclibs
let native_pack_linker = C.packld
let ranlib = C.ranlibcmd
let exec_magic_number = "Caml1999X008"
and cmi_magic_number = "Caml1999I011"
-and cmo_magic_number = "Caml1999O006"
-and cma_magic_number = "Caml1999A007"
+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 = "Caml1999M012"
p "standard_runtime" standard_runtime;
p "ccomp_type" ccomp_type;
p "bytecomp_c_compiler" bytecomp_c_compiler;
- p "bytecomp_c_linker" bytecomp_c_linker;
p "bytecomp_c_libraries" bytecomp_c_libraries;
p "native_c_compiler" native_c_compiler;
- p "native_c_linker" native_c_linker;
p "native_c_libraries" native_c_libraries;
p "native_pack_linker" native_pack_linker;
p "ranlib" ranlib;
(* *)
(***********************************************************************)
-(* $Id: config.mlp,v 1.208 2008/04/16 06:50:31 frisch Exp $ *)
+(* $Id: config.mlp,v 1.208.2.2 2009/05/18 09:38:16 doligez Exp $ *)
+
+(***********************************************************************)
+(** **)
+(** WARNING WARNING WARNING **)
+(** **)
+(** When you change this file, you must make the parallel change **)
+(** in config.mlbuild **)
+(** **)
+(***********************************************************************)
+
(* The main OCaml version string has moved to ../VERSION *)
let version = Sys.ocaml_version
let exec_magic_number = "Caml1999X008"
and cmi_magic_number = "Caml1999I011"
-and cmo_magic_number = "Caml1999O006"
-and cma_magic_number = "Caml1999A007"
+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 = "Caml1999M012"
(* *)
(***********************************************************************)
-(* $Id: tbl.ml,v 1.13 2004/11/25 13:28:27 doligez Exp $ *)
+(* $Id: tbl.ml,v 1.13.22.1 2009/04/02 09:06:33 xclerc Exp $ *)
type ('a, 'b) t =
Empty
| Node(l, v, d, r, _) ->
iter f l; f v d; iter f r
+let rec map f = function
+ Empty -> Empty
+ | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h)
+
open Format
let print print_key print_data ppf tbl =
(* *)
(***********************************************************************)
-(* $Id: tbl.mli,v 1.7 2000/04/21 08:13:22 weis Exp $ *)
+(* $Id: tbl.mli,v 1.7.44.1 2009/04/02 09:06:33 xclerc Exp $ *)
(* Association tables from any ordered type to any type.
We use the generic ordering to compare keys. *)
val mem: 'a -> ('a, 'b) t -> bool
val remove: 'a -> ('a, 'b) t -> ('a, 'b) t
val iter: ('a -> 'b -> 'c) -> ('a, 'b) t -> unit
+val map: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
open Format
projects / ocaml.git / commitdiff