diff options
| author | Damien Doligez <damien.doligez-inria.fr> | 2009-05-20 11:52:42 +0000 |
|---|---|---|
| committer | Damien Doligez <damien.doligez-inria.fr> | 2009-05-20 11:52:42 +0000 |
| commit | ed32f569e3b636e0f12efdbbd5bba9e05cc434ac (patch) | |
| tree | 20b551901a72edf7733a6fe5287deab21ed9b83b | |
| parent | 7795eafa896b0c5b3066d5efec7ec49d69d44e4d (diff) | |
| download | ocaml-ed32f569e3b636e0f12efdbbd5bba9e05cc434ac.tar.gz | |
merge changes from ocaml3110 to ocaml3111rc0
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9270 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
109 files changed, 939 insertions, 511 deletions
@@ -164,13 +164,15 @@ typing/oprint.cmo: typing/outcometree.cmi parsing/asttypes.cmi \ 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 \ @@ -287,7 +289,7 @@ bytecomp/bytesections.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 @@ -310,12 +312,12 @@ bytecomp/translmod.cmi: typing/typedtree.cmi typing/primitive.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 \ @@ -335,15 +337,15 @@ bytecomp/bytelink.cmx: bytecomp/symtable.cmx bytecomp/opcodes.cmx \ 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 @@ -358,9 +360,9 @@ bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \ 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 \ @@ -1,3 +1,6 @@ +Objective Caml 3.12.0: +---------------------- + Standard library: * To prevent confusion when mixing Format printing functions and direct low level output, values Format.stdout and Format.stderr have been added. @@ -5,6 +8,58 @@ Standard library: * To prevent confusion when mixing Scanf scanning functions and direct low level input, value Scanf.stdin has been added. +Bug Fixes: +- PR#4775: compiler crash on crazy types (temporary fix) + + +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: ---------------------- @@ -739,14 +739,8 @@ clean:: $(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 @@ -1,4 +1,4 @@ -3.12.0+dev2 (2009-01-25) +3.12.0+dev3 (2009-05-20) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli @@ -26,8 +26,7 @@ true: use_stdlib <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 diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index d80b974aff..11bf78224b 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -667,7 +667,11 @@ let fundecl fundecl = 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 @@ -752,12 +756,13 @@ let begin_assembly() = 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`; diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 32d669dbbe..da2f886bbc 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -197,5 +197,5 @@ let contains_calls = ref false (* 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) diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 83cb1f6e39..00742dcf99 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1943,9 +1943,8 @@ module IntSet = Set.Make( 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) = @@ -1955,12 +1954,8 @@ let generic_functions shared units = 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 diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index d1964d3563..e851c8187d 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -156,3 +156,16 @@ let emit_frames a = 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"] + diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index 38e6df9607..112e276a12 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -45,3 +45,5 @@ type emit_frame_actions = efa_string: string -> unit } val emit_frames: emit_frame_actions -> unit + +val is_generic_function: string -> bool diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 7b857a0f73..9f43155613 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -888,7 +888,11 @@ let fundecl fundecl = 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 @@ -954,12 +958,13 @@ let begin_assembly() = 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`; diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index e4ac9d408d..a0c94e181d 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -379,7 +379,7 @@ let emit_instr i = 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` diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 81a1894e5d..baab697ae0 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -835,6 +835,10 @@ let fundecl fundecl = 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" -> diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 65b5e17bc6..76552e5ee2 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -95,6 +95,25 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) +/****************** 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) @@ -145,6 +164,19 @@ #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) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 98ad49f03e..384b60060a 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 68083183eb..b5aa793946 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex f6397e72eb..8e7af0db78 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index f7911aa3e5..09c254d4f3 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -171,6 +171,7 @@ let copy_event ev kind info repr = 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 } @@ -714,6 +715,7 @@ let rec comp_expr env exp sz cont = ev_kind = kind; ev_info = info; ev_typenv = lev.lev_env; + ev_typsubst = Subst.identity; ev_compenv = env; ev_stacksize = sz; ev_repr = diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index bb3a80aa6b..31eff07faa 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -66,9 +66,11 @@ let rename_relocation objfile mapping defined base (rel, ofs) = (* 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. *) @@ -110,7 +112,7 @@ let read_member_info 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; @@ -123,7 +125,7 @@ let rename_append_bytecode oc mapping defined ofs 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 @@ -134,20 +136,22 @@ let rename_append_bytecode oc mapping defined ofs objfile compunit = (* 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 *) @@ -187,7 +191,7 @@ let package_object_files files targetfile targetname coercion = 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 diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 4463d5b98d..f5ba48d4f5 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -85,13 +85,16 @@ let close_all_dlls () = 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 diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 9fd2cb9409..4f4fa14fa1 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -26,6 +26,7 @@ type debug_event = 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 *) diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 31f526d22e..6b9367f9a0 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -44,6 +44,7 @@ type debug_event = 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 *) diff --git a/byterun/Makefile b/byterun/Makefile index ec5f7ab915..5986bb2959 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -22,14 +22,14 @@ OBJS=$(COMMONOBJS) unix.o main.o 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) \ diff --git a/byterun/finalise.c b/byterun/finalise.c index 1e176dd170..6851558108 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -139,7 +139,7 @@ void caml_final_do_calls (void) -- 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); diff --git a/byterun/globroots.c b/byterun/globroots.c index 5de3d1315b..e4fec33287 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -232,6 +232,28 @@ CAMLexport void caml_modify_generational_global_root(value *r, value newval) 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; } diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h index 04e38656f3..c0b7440baf 100644 --- a/byterun/int64_emul.h +++ b/byterun/int64_emul.h @@ -96,8 +96,9 @@ static int64 I64_mul(int64 x, int64 y) } #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) diff --git a/byterun/int64_native.h b/byterun/int64_native.h index f5bef4a6f4..9c07909701 100644 --- a/byterun/int64_native.h +++ b/byterun/int64_native.h @@ -29,6 +29,9 @@ #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) \ diff --git a/byterun/ints.c b/byterun/ints.c index ed18e6f446..5fc15c6264 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -248,23 +248,31 @@ CAMLprim value caml_int32_mul(value v1, value v2) 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 } @@ -430,15 +438,26 @@ CAMLprim value caml_int64_mul(value v1, value v2) 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)); } @@ -650,25 +669,35 @@ CAMLprim value caml_nativeint_sub(value v1, value v2) 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 } @@ -305,8 +305,13 @@ case "$bytecc,$host" in 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*) @@ -617,7 +622,11 @@ case "$host" in 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 @@ -686,6 +695,7 @@ case "$arch,$nativecc,$system,$host_type" in 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 @@ -699,6 +709,8 @@ case "$arch,$model,$system" in 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'; diff --git a/debugger/.depend b/debugger/.depend index afac5c0d53..f71fcbef39 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -34,32 +34,32 @@ symbols.cmi: ../bytecomp/instruct.cmi 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 \ @@ -74,76 +74,70 @@ dynlink.cmx: ../bytecomp/symtable.cmx ../bytecomp/opcodes.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 @@ -158,49 +152,47 @@ primitives.cmo: ../otherlibs/unix/unix.cmi primitives.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 \ diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml index b8fd444f4d..9d85aff04c 100644 --- a/debugger/breakpoints.ml +++ b/debugger/breakpoints.ml @@ -20,7 +20,6 @@ open Debugcom open Instruct open Primitives open Printf -open Source (*** Debugging. ***) let debug_breakpoints = ref false @@ -68,7 +67,7 @@ let rec breakpoints_at_pc pc = [] 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 = @@ -155,7 +154,7 @@ let remove_position pos = 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 @@ -181,7 +180,7 @@ let remove_breakpoint number = 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); @@ -210,7 +209,7 @@ let exec_with_temporary_breakpoint pc funct = 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 diff --git a/debugger/command_line.ml b/debugger/command_line.ml index f37d529b34..27dbd34728 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -87,7 +87,7 @@ let eol = 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) @@ -97,7 +97,7 @@ let all_matching_instructions = 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 = @@ -143,6 +143,11 @@ let add_breakpoint_after_pc pc = 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 -> @@ -235,14 +240,24 @@ let instr_dir ppf lexbuf = 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; @@ -562,7 +577,7 @@ let instr_break ppf 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 = @@ -585,7 +600,7 @@ let instr_break ppf lexbuf = 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.@." @@ -697,7 +712,7 @@ let instr_list ppf lexbuf = | 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 @@ -841,7 +856,7 @@ let info_breakpoints ppf lexbuf = 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 diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index 13e3f086c0..ee707abb2e 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -62,6 +62,8 @@ let runtime_program = "ocamlrun" (* 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.*) diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli index 44f4fe582a..d3185f0832 100644 --- a/debugger/debugger_config.mli +++ b/debugger/debugger_config.mli @@ -25,6 +25,7 @@ val event_mark_after : string val shell : string val runtime_program : string val history_size : int ref +val load_path_for : (string, string list) Hashtbl.t (*** Time travel paramaters. ***) diff --git a/debugger/dynlink.ml b/debugger/dynlink.ml index 6f4fe5af7c..7d3e347f55 100644 --- a/debugger/dynlink.ml +++ b/debugger/dynlink.ml @@ -34,6 +34,7 @@ type error = | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string + | Inconsistent_implementation of string exception Error of error @@ -96,9 +97,20 @@ let default_available_units () = (* 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 *) @@ -186,6 +198,7 @@ let load_compunit ic file_name compunit = 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 @@ -213,6 +226,7 @@ let loadfile file_name = close_in ic; raise exc let loadfile_private file_name = + init(); let initial_symtable = Symtable.current_state() and initial_crc = !crc_interfaces in try @@ -250,3 +264,8 @@ let error_message = function "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 diff --git a/debugger/dynlink.mli b/debugger/dynlink.mli index ac5c1a2113..caee291710 100644 --- a/debugger/dynlink.mli +++ b/debugger/dynlink.mli @@ -13,19 +13,20 @@ (* $Id$ *) -(** 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 @@ -37,6 +38,10 @@ val loadfile_private : string -> 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 @@ -68,7 +73,8 @@ val allow_unsafe_modules : bool -> 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} *) @@ -77,7 +83,8 @@ val allow_unsafe_modules : bool -> unit 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 @@ -97,6 +104,12 @@ val clear_available_units : unit -> unit (** 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 = @@ -113,6 +126,7 @@ type 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] diff --git a/debugger/envaux.ml b/debugger/envaux.ml index ba8d6dff59..7f74ecbf7f 100644 --- a/debugger/envaux.ml +++ b/debugger/envaux.ml @@ -23,7 +23,7 @@ type error = 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; @@ -34,45 +34,46 @@ let extract_sig env mty = 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 *) diff --git a/debugger/eval.ml b/debugger/eval.ml index d12dfa8037..abec4291a5 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -13,7 +13,6 @@ (* $Id$ *) -open Debugger_config open Misc open Path open Instruct @@ -42,7 +41,9 @@ let abstract_type = 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 -> @@ -88,8 +89,8 @@ let rec expression event env = function 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 @@ -178,15 +179,14 @@ let report_error ppf = function | 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@ \ diff --git a/debugger/events.ml b/debugger/events.ml index d9229712a0..2521c064db 100644 --- a/debugger/events.ml +++ b/debugger/events.ml @@ -16,8 +16,6 @@ (********************************* Events ******************************) open Instruct -open Primitives -open Checkpoints let get_pos ev = match ev.ev_kind with diff --git a/debugger/frames.ml b/debugger/frames.ml index a2e42087ee..7260f89d53 100644 --- a/debugger/frames.ml +++ b/debugger/frames.ml @@ -16,9 +16,7 @@ (***************************** Frames **********************************) open Instruct -open Primitives open Debugcom -open Checkpoints open Events open Symbols diff --git a/debugger/history.ml b/debugger/history.ml index 31a6e7ad2a..e8c5ed8ff5 100644 --- a/debugger/history.ml +++ b/debugger/history.ml @@ -15,7 +15,6 @@ open Int64ops open Checkpoints -open Misc open Primitives open Debugger_config diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml index dec3f86cc3..f25d474266 100644 --- a/debugger/input_handling.ml +++ b/debugger/input_handling.ml @@ -30,7 +30,7 @@ let add_file file controller = (* 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 = diff --git a/debugger/lexer.mll b/debugger/lexer.mll index 17293f62c4..eea8ed0284 100644 --- a/debugger/lexer.mll +++ b/debugger/lexer.mll @@ -15,7 +15,6 @@ { -open Primitives open Parser } diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 0b2ef03398..07d7b78aeb 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -15,7 +15,6 @@ (* Loading and installation of user-defined printer functions *) open Misc -open Debugger_config open Longident open Path open Types diff --git a/debugger/main.ml b/debugger/main.ml index fda242bc52..9cfcf447ff 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -13,8 +13,6 @@ (* $Id$ *) -open Primitives -open Misc open Input_handling open Question open Command_line @@ -47,12 +45,12 @@ let rec protect ppf restart loop = !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.@."; @@ -62,7 +60,7 @@ let rec protect ppf restart loop = 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...@."; @@ -70,7 +68,7 @@ let rec protect ppf restart loop = 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 = diff --git a/debugger/parameters.ml b/debugger/parameters.ml index 67078b2fc3..9d518e5494 100644 --- a/debugger/parameters.ml +++ b/debugger/parameters.ml @@ -17,7 +17,7 @@ open Primitives open Config -open Misc +open Debugger_config let program_loaded = ref false let program_name = ref "" @@ -31,5 +31,9 @@ let add_path dir = 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 diff --git a/debugger/parameters.mli b/debugger/parameters.mli index c80d39d124..8f750e68a6 100644 --- a/debugger/parameters.mli +++ b/debugger/parameters.mli @@ -21,6 +21,7 @@ val arguments : string ref 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 diff --git a/debugger/parser.mly b/debugger/parser.mly index 6c7b2ddb26..c94182f6b0 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -16,7 +16,6 @@ %{ open Int64ops -open Primitives open Input_handling open Longident open Parser_aux @@ -93,7 +92,7 @@ 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 @@ -101,6 +100,12 @@ open Parser_aux %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 */ @@ -173,7 +178,15 @@ module_path : ; 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 } @@ -220,16 +233,16 @@ break_argument_eol : 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 */ diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli index 7ea63fb8c2..434c14dbcf 100644 --- a/debugger/parser_aux.mli +++ b/debugger/parser_aux.mli @@ -28,7 +28,7 @@ type break_arg = 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 *) diff --git a/debugger/primitives.ml b/debugger/primitives.ml index 1ad27e8a68..d4ba22e5f8 100644 --- a/debugger/primitives.ml +++ b/debugger/primitives.ml @@ -36,26 +36,6 @@ let index a l = | 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 = @@ -87,44 +67,8 @@ let list_replace x y = 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 diff --git a/debugger/primitives.mli b/debugger/primitives.mli index 40effea556..4333128fb6 100644 --- a/debugger/primitives.mli +++ b/debugger/primitives.mli @@ -29,12 +29,6 @@ val except : 'a -> 'a list -> 'a list (* 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 @@ -47,23 +41,8 @@ val list_truncate2 : int -> 'a list -> '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 diff --git a/debugger/printval.ml b/debugger/printval.ml index 4fa3055b04..0e37bad6bb 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -15,8 +15,6 @@ (* To print values *) -open Misc -open Obj open Format open Parser_aux open Path diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index 1a750a2bbc..79577ff4b9 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -16,7 +16,6 @@ (* Program loading *) open Unix -open Misc open Debugger_config open Parameters open Input_handling diff --git a/debugger/program_management.ml b/debugger/program_management.ml index 35f74d6543..cc908b4d6a 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -19,13 +19,10 @@ open Int64ops 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 diff --git a/debugger/show_information.ml b/debugger/show_information.ml index de6817cd2a..15176a1f25 100644 --- a/debugger/show_information.ml +++ b/debugger/show_information.ml @@ -15,7 +15,6 @@ open Instruct open Format -open Primitives open Debugcom open Checkpoints open Events diff --git a/debugger/show_source.ml b/debugger/show_source.ml index b60a1f9e43..3b7a133fe6 100644 --- a/debugger/show_source.ml +++ b/debugger/show_source.ml @@ -15,7 +15,6 @@ open Debugger_config open Instruct -open Misc open Parameters open Primitives open Printf diff --git a/debugger/source.ml b/debugger/source.ml index f1519b438a..8975134ffa 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -23,17 +23,37 @@ let source_extensions = [".ml"] (*** 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 diff --git a/debugger/symbols.ml b/debugger/symbols.ml index 8ed7545c6f..235e2af344 100644 --- a/debugger/symbols.ml +++ b/debugger/symbols.ml @@ -92,7 +92,7 @@ let read_symbols bytecode_file = 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) diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index 4e8e13822d..a4a4c83fa0 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -384,7 +384,7 @@ let kill_all_checkpoints () = (* --- 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 = diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml index 5328a2aadb..9926e05d5a 100644 --- a/debugger/unix_tools.ml +++ b/debugger/unix_tools.ml @@ -22,7 +22,7 @@ open Primitives (*** 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 @@ -90,7 +90,7 @@ let search_in_path name = 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 @@ -121,7 +121,7 @@ let rec expand_path ch = 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 diff --git a/driver/main.ml b/driver/main.ml index eb79f4779a..7553b916e6 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -154,9 +154,13 @@ let main () = 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(); diff --git a/man/ocaml.m b/man/ocaml.m index 466dd30150..07dede7c19 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -54,7 +54,7 @@ exits after the execution of the last phrase. 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 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 0c8c303eb8..84572828ca 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -131,6 +131,7 @@ let ocamlc_solver = "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 @@ -141,7 +142,8 @@ Command.setup_virtual_command_solver "OCAMLC" ocamlc_solver;; 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"];; @@ -341,7 +343,7 @@ copy_rule' "lex/main.byte" "lex/ocamllex";; 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";; diff --git a/ocamlbuild/misc/opentracer.ml b/ocamlbuild/misc/opentracer.ml index 1aa62b98ca..b011f1540b 100644 --- a/ocamlbuild/misc/opentracer.ml +++ b/ocamlbuild/misc/opentracer.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id$ *) + open My_std module type TRACER = sig diff --git a/ocamlbuild/start.sh b/ocamlbuild/start.sh index 662392b5fd..742e81ad9f 100755 --- a/ocamlbuild/start.sh +++ b/ocamlbuild/start.sh @@ -12,7 +12,7 @@ # # ######################################################################### -# $Id$ + set -e set -x diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 9f340ed171..afd7040664 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -146,14 +146,6 @@ odoc_name.cmx: ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ 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 diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index 1709694ee7..cdaf451efa 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -145,6 +145,3 @@ let _ = ) else exit 0 - - -(* eof $Id$ *) diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index c0c820b3b7..c874c5b662 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -35,12 +35,13 @@ type t = string 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 diff --git a/otherlibs/dbm/Makefile b/otherlibs/dbm/Makefile index bb65b6b1c9..099327d691 100644 --- a/otherlibs/dbm/Makefile +++ b/otherlibs/dbm/Makefile @@ -21,6 +21,7 @@ CAMLOBJS=dbm.cmo COBJS=cldbm.o EXTRACFLAGS=$(DBM_INCLUDES) LINKOPTS=$(DBM_LINK) +LDOPTS=-ldopt "$(DBM_LINK)" include ../Makefile diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile index e2fe5f16e9..5aec48c45f 100644 --- a/otherlibs/labltk/lib/Makefile +++ b/otherlibs/labltk/lib/Makefile @@ -32,7 +32,7 @@ $(LIBNAME).cma: $(SUPPORT) ../Widgets.src $(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)\"" @@ -40,7 +40,7 @@ $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src $(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)\"" diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common index 215804826e..56f6fd1377 100644 --- a/otherlibs/labltk/support/Makefile.common +++ b/otherlibs/labltk/support/Makefile.common @@ -13,8 +13,10 @@ INSTALLDIR=$(LIBDIR)/$(LIBNAME) ## 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 diff --git a/otherlibs/labltk/tkanim/Makefile b/otherlibs/labltk/tkanim/Makefile index 574069ea5c..c297438819 100644 --- a/otherlibs/labltk/tkanim/Makefile +++ b/otherlibs/labltk/tkanim/Makefile @@ -14,10 +14,10 @@ OBJS=tkanim.cmo 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) diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index 9465bcd6cc..933721ca52 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -367,8 +367,8 @@ let big_int_of_int64 i = 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 diff --git a/otherlibs/num/test/test_big_ints.ml b/otherlibs/num/test/test_big_ints.ml index e1e4b88b0e..572b868630 100644 --- a/otherlibs/num/test/test_big_ints.ml +++ b/otherlibs/num/test/test_big_ints.ml @@ -750,6 +750,16 @@ test 2 eq_big_int (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";; diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml index bb3231ad72..bbbef0a270 100644 --- a/otherlibs/str/str.ml +++ b/otherlibs/str/str.ml @@ -96,7 +96,7 @@ module Charset = 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 @@ -156,7 +156,7 @@ let displ dest from = dest - from - 1 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 @@ -175,7 +175,7 @@ let rec is_nullable = function 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 @@ -197,12 +197,13 @@ and first_seq = function (* 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 *) @@ -289,9 +290,10 @@ let compile fold_case re = 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) -> @@ -492,10 +494,11 @@ let parse s = 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 @@ -520,8 +523,8 @@ let parse s = (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 diff --git a/otherlibs/systhreads/Tests/Makefile b/otherlibs/systhreads/Tests/Makefile index 0c38dd7e53..5911fafdba 100644 --- a/otherlibs/systhreads/Tests/Makefile +++ b/otherlibs/systhreads/Tests/Makefile @@ -16,7 +16,7 @@ PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ test7.byt test8.byt test9.byt testA.byt sieve.byt \ testio.byt testsocket.byt testsignal.byt testsignal2.byt \ - torture.byt + torture.byt testfork.byt MOREPROGS=testfork.byt diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index 715741fc5b..da45be06cf 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -111,6 +111,9 @@ static pthread_mutex_t caml_runtime_mutex = PTHREAD_MUTEX_INITIALIZER; /* 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; @@ -332,8 +335,6 @@ static void * caml_thread_tick(void * arg) 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) @@ -353,24 +354,21 @@ static void caml_thread_reinitialize(void) 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; @@ -395,6 +393,7 @@ value caml_thread_initialize(value unit) /* ML */ 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 @@ -415,12 +414,6 @@ value caml_thread_initialize(value unit) /* ML */ 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); @@ -488,6 +481,7 @@ value caml_thread_new(value clos) /* ML */ { pthread_attr_t attr; caml_thread_t th; + pthread_t tick_pthread; value mu = Val_unit; value descr; int err; @@ -526,12 +520,12 @@ value caml_thread_new(value clos) /* ML */ 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 @@ -541,6 +535,16 @@ value caml_thread_new(value clos) /* ML */ 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; } diff --git a/otherlibs/threads/Tests/Makefile b/otherlibs/threads/Tests/Makefile index be271f4696..ff4388d14f 100644 --- a/otherlibs/threads/Tests/Makefile +++ b/otherlibs/threads/Tests/Makefile @@ -16,7 +16,7 @@ PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ test7.byt test8.byt test9.byt testA.byt sieve.byt \ testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \ - testsieve.byt token1.byt token2.byt + testsieve.byt token1.byt token2.byt testfork.byt CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../../stdlib -I ../../unix diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index 386864e059..251c31ae3f 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -910,7 +910,8 @@ type socket_domain = 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 *) diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c index 67e3812989..afacd3e17e 100644 --- a/otherlibs/win32unix/pipe.c +++ b/otherlibs/win32unix/pipe.c @@ -19,7 +19,8 @@ #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) { diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c index 313882a52f..79fc3b2eb7 100644 --- a/otherlibs/win32unix/stat.c +++ b/otherlibs/win32unix/stat.c @@ -107,9 +107,5 @@ CAMLprim value unix_fstat_64(value handle) 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); } diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c index b7d4ad92d5..24c4a9e458 100644 --- a/otherlibs/win32unix/unixsupport.c +++ b/otherlibs/win32unix/unixsupport.c @@ -108,6 +108,7 @@ static struct error_entry win_error_table[] = { { 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}, diff --git a/stdlib/format.ml b/stdlib/format.ml index 4e732a818f..62e81b46ee 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -1048,9 +1048,9 @@ let get_buffer_out b = 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 @@ -1319,7 +1319,10 @@ let kbprintf k 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 diff --git a/stdlib/map.mli b/stdlib/map.mli index ca82413036..af1d4d37b7 100644 --- a/stdlib/map.mli +++ b/stdlib/map.mli @@ -73,9 +73,7 @@ module type S = (** [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 diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml index 2b4d93ddb8..44c7fb2715 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -180,9 +180,15 @@ let peek_val env n = 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));; diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 72567af001..b8e0e71def 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -24,6 +24,7 @@ name, without prefixing them by [Pervasives]. *) + (** {6 Exceptions} *) external raise : exn -> 'a = "%raise" @@ -42,7 +43,6 @@ exception Exit (** {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 @@ -100,8 +100,7 @@ val max : 'a -> 'a -> 'a 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 @@ -113,7 +112,6 @@ external ( != ) : 'a -> 'a -> bool = "%noteq" (** {6 Boolean operations} *) - external not : bool -> bool = "%boolnot" (** The boolean negation. *) @@ -186,10 +184,8 @@ val min_int : int (** The smallest representable integer. *) - (** {7 Bitwise operations} *) - external ( land ) : int -> int -> int = "%andint" (** Bitwise logical and. *) @@ -250,10 +246,10 @@ external ( /. ) : float -> float -> float = "%divfloat" (** 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. *) @@ -282,15 +278,15 @@ external tan : float -> float = "caml_tan_float" "tan" "float" (** Tangent. Argument is in radians. *) external acos : float -> float = "caml_acos_float" "acos" "float" -(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. +(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [0.0] and [pi]. *) external asin : float -> float = "caml_asin_float" "asin" "float" -(** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. +(** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [-pi/2] and [pi/2]. *) external atan : float -> float = "caml_atan_float" "atan" "float" -(** Arc tangent. +(** Arc tangent. Result is in radians and is between [-pi/2] and [pi/2]. *) external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" @@ -299,13 +295,13 @@ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" Result is in radians and is between [-pi] and [pi]. *) external cosh : float -> float = "caml_cosh_float" "cosh" "float" -(** Hyperbolic cosine. *) +(** Hyperbolic cosine. Argument is in radians. *) external sinh : float -> float = "caml_sinh_float" "sinh" "float" -(** Hyperbolic sine. *) +(** Hyperbolic sine. Argument is in radians. *) external tanh : float -> float = "caml_tanh_float" "tanh" "float" -(** Hyperbolic tangent. *) +(** Hyperbolic tangent. Argument is in radians. *) external ceil : float -> float = "caml_ceil_float" "ceil" "float" (** Round above to an integer value. @@ -319,7 +315,7 @@ external floor : float -> float = "caml_floor_float" "floor" "float" The result is returned as a float. *) 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 @@ -456,7 +452,6 @@ external float_of_string : string -> float = "caml_float_of_string" if the given string is not a valid representation of a float. *) - (** {6 Pair operations} *) external fst : 'a * 'b -> 'a = "%field0" @@ -558,8 +553,8 @@ val read_float : unit -> float 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. *) @@ -785,6 +780,7 @@ val set_binary_mode_in : in_channel -> bool -> unit 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 : @@ -803,6 +799,7 @@ 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 } @@ -867,7 +864,6 @@ val ( ^^ ) : (** {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, diff --git a/stdlib/printf.ml b/stdlib/printf.ml index ce6ca98f3a..d9bb45335c 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -142,7 +142,8 @@ let extract_format fmt start stop widths = | ('*', []) -> 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 ;; @@ -156,6 +157,15 @@ let extract_format_int conv fmt start stop widths = | _ -> 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 @@ -418,6 +428,31 @@ let get_index spec n = | 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. @@ -486,9 +521,11 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = 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) diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 5ea7abc3fd..da67cb5ba5 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -1280,22 +1280,29 @@ let scanf fmt = bscanf Scanning.stdib fmt;; 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) ;; diff --git a/test/Moretest/Makefile b/test/Moretest/Makefile index 86014fd9ac..5074d8d559 100644 --- a/test/Moretest/Makefile +++ b/test/Moretest/Makefile @@ -14,9 +14,9 @@ include ../../config/Makefile -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib +CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../../otherlibs/unix BYTEFLAGS=-g -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib +CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../../otherlibs/unix OPTFLAGS=-S -g CAMLDEP=../../boot/ocamlrun ../../tools/ocamldep CAMLRUN=../../byterun/ocamlrun @@ -152,6 +152,15 @@ printf: tprintf.byt tprintf.bin ./tprintf.byt ./tprintf.bin +tformat.byt: testing.cmo tformat.cmo + ${CAMLC} -o tformat.byt testing.cmo tformat.cmo +tformat.bin: testing.cmx tformat.cmx + ${CAMLOPT} -o tformat.bin testing.cmx tformat.cmx + +format: tformat.byt tformat.bin + ./tformat.byt + ./tformat.bin + tbuffer.byt: testing.cmo tbuffer.cmo ${CAMLC} -o tbuffer.byt testing.cmo tbuffer.cmo tbuffer.bin: testing.cmx tbuffer.cmx diff --git a/test/Moretest/regexp.ml b/test/Moretest/regexp.ml index 7cb75b8add..bb266a017c 100644 --- a/test/Moretest/regexp.ml +++ b/test/Moretest/regexp.ml @@ -289,6 +289,18 @@ let automated_test() = test_search_forward r n "babababc" [||]; + start_test "Search for /[^a]/"; + let r = Str.regexp "[^a]" in + let n = 0 in + test_search_forward r n "athing" [|"t"|]; + test_search_forward r n "Athing" [|"A"|]; + + start_test "Search for /[^a]/ (case-insensitive)"; + let r = Str.regexp_case_fold "[^a]" in + let n = 0 in + test_search_forward r n "athing" [|"t"|]; + test_search_forward r n "Athing" [|"t"|]; + start_test "Search for /^[]abcde]/"; let r = Str.regexp "^[]abcde]" in let n = 0 in diff --git a/test/Moretest/tformat.ml b/test/Moretest/tformat.ml new file mode 100644 index 0000000000..d02cb2907a --- /dev/null +++ b/test/Moretest/tformat.ml @@ -0,0 +1,33 @@ +(*************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis, projet Estime, INRIA Rocquencourt *) +(* *) +(* Copyright 2009 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$ + +A testbed file for the module Format. + +*) + +open Testing;; + +open Format;; + +(* BR#4769 *) +let test0 () = + let b = Buffer.create 10 in + let msg = "Hello world!" in + Format.bprintf b "%s" msg; + let s = Buffer.contents b in + s = msg +;; + +test (test0 ()) +;; diff --git a/test/Moretest/tscanf.ml b/test/Moretest/tscanf.ml index dd7d2a60bd..34e28d8a96 100644 --- a/test/Moretest/tscanf.ml +++ b/test/Moretest/tscanf.ml @@ -1,8 +1,20 @@ +(*************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 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$ -A testbed file for module Scanf. +A testbed file for the module Scanf. - *) +*) open Testing;; @@ -1165,6 +1177,39 @@ let test56 () = test (test56 ()) ;; +(* Testing the scanning of formats. *) +let test48 () = + (* Testing format_from_string. *) + let test_format_scan s fmt efmt = + format_from_string s fmt = efmt in + (* Test if format %i is indeed read as %i. *) + let s, fmt = " %i ", format_of_string "%i" in + test_format_scan s fmt " %i " && + (* Test if format %i is compatible with %d and indeed read as %i. *) + let s, fmt = "%i", format_of_string "%d" in + test_format_scan s fmt "%i" && + + let s, fmt = + "Read an int %i then a string %s.", + format_of_string "Spec%difi%scation" in + test_format_scan s fmt "Read an int %i then a string %s." && + + let s, fmt = + "Read an int %i then a string \"%s\".", + format_of_string "Spec%difi%Scation" in + test_format_scan s fmt "Read an int %i then a string \"%s\"." && + + let s, fmt = + "Read an int %i then a string \"%s\".", + format_of_string "Spec%difi%scation" in + test_format_scan s fmt "Read an int %i then a string \"%s\"." && + + (* Complex test of scanning a meta format specified in the scanner input + format string and extraction of its specification from a string. *) + sscanf "12 \"%i\"89 " "%i %{%d%}%s %!" + (fun i f s -> i = 12 && f = "%i" && s = "89") +;; + (* To be continued ... (* Trying to scan records. *) let rec scan_fields ib scan_field accu = diff --git a/testlabl/bugs/pr4766.ml b/testlabl/bugs/pr4766.ml new file mode 100644 index 0000000000..c5809c1d93 --- /dev/null +++ b/testlabl/bugs/pr4766.ml @@ -0,0 +1,10 @@ +class virtual ['a] c = +object (s : 'a) + method virtual m : 'b +end + +let o = + object (s :'a) + inherit ['a] c + method m = 42 + end diff --git a/testlabl/bugs/pr4775.ml b/testlabl/bugs/pr4775.ml new file mode 100644 index 0000000000..ef857149ee --- /dev/null +++ b/testlabl/bugs/pr4775.ml @@ -0,0 +1,11 @@ +module type Poly = sig + type 'a t = 'a constraint 'a = [> ] +end + +module Combine (A : Poly) (B : Poly) = struct + type ('a, 'b) t = 'a A.t constraint 'a = 'b B.t +end + +module C = Combine + (struct type 'a t = 'a constraint 'a = [> ] end) + (struct type 'a t = 'a constraint 'a = [> ] end) diff --git a/typing/ctype.ml b/typing/ctype.ml index 3eef9c9d40..3647f89edc 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -385,23 +385,32 @@ let closed_schema ty = 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 @@ -410,15 +419,17 @@ let rec free_vars_rec real ty = 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 @@ -3172,10 +3183,11 @@ let cyclic_abbrev env id ty = 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 @@ -3204,11 +3216,15 @@ let rec normalize_type_rec env ty = 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 | _ -> @@ -3221,12 +3237,11 @@ let rec normalize_type_rec env ty = 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 (*************************) diff --git a/typing/ctype.mli b/typing/ctype.mli index 7fa6a2bcae..32b1b16669 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -224,7 +224,8 @@ val closed_schema: type_expr -> bool (* 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 diff --git a/typing/env.ml b/typing/env.ml index 05f4896130..a654762b14 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -92,19 +92,29 @@ let empty = { 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 *) diff --git a/typing/includeclass.ml b/typing/includeclass.ml index 49e0ce9d2e..007182a3d6 100644 --- a/typing/includeclass.ml +++ b/typing/includeclass.ml @@ -47,7 +47,7 @@ let include_err ppf = 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) -> @@ -58,7 +58,7 @@ let include_err ppf = 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) -> @@ -92,7 +92,7 @@ let include_err ppf = | 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 diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 0cefb85284..15e6d74e34 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -113,13 +113,18 @@ and compats ps qs = match ps,qs with 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" @@ -129,7 +134,7 @@ let rec get_constr tag ty tenv = | {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 = @@ -142,7 +147,7 @@ let rec get_record_labels ty tenv = 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" diff --git a/typing/subst.ml b/typing/subst.ml index 6b1282697a..833b3634aa 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -294,3 +294,12 @@ and signature_component s comp newid = 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 } diff --git a/typing/subst.mli b/typing/subst.mli index d313853251..02ecf2054b 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -52,3 +52,7 @@ val cltype_declaration: t -> cltype_declaration -> cltype_declaration 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 diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 03b3b62171..7f6c1de241 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1574,12 +1574,12 @@ let report_error ppf = function 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") @@ -1589,11 +1589,11 @@ let report_error ppf = function (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 diff --git a/typing/typecore.ml b/typing/typecore.ml index ada6cacf8f..5346c75ba7 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1263,10 +1263,11 @@ let rec type_exp env sexp = 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 @@ -1282,6 +1283,7 @@ let rec type_exp env sexp = 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; | _ -> @@ -2105,7 +2107,7 @@ let report_error ppf = function | 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 @@ -2113,13 +2115,13 @@ let report_error ppf = function 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 -> @@ -2130,15 +2132,15 @@ let report_error ppf = function (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 @@ -2148,7 +2150,7 @@ let report_error 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 -> @@ -2176,14 +2178,14 @@ let report_error ppf = function | 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 -> @@ -2214,8 +2216,8 @@ let report_error ppf = function 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) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 0493b13478..4ebfb4632f 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -509,14 +509,13 @@ let compute_variance_decl env check decl (required, loc) = 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) @@ -535,6 +534,7 @@ let compute_variance_decl env check decl (required, loc) = 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 @@ -848,12 +848,12 @@ let report_error ppf = function (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"; @@ -910,16 +910,24 @@ let report_error ppf = function | (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 -> diff --git a/typing/typetexp.ml b/typing/typetexp.ml index fa3f0c895a..dc9165f751 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -556,7 +556,7 @@ let report_error ppf = function 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 diff --git a/utils/config.mlbuild b/utils/config.mlbuild index 18dbbf32ff..ea10032d7a 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -12,6 +12,16 @@ (* $Id$ *) +(***********************************************************************) +(** **) +(** 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 @@ -40,10 +50,8 @@ let standard_runtime = 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 @@ -54,8 +62,8 @@ let mkmaindll = C.mkmaindll 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" @@ -102,10 +110,8 @@ let print_config oc = 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; diff --git a/utils/config.mlp b/utils/config.mlp index a1e03e82b7..c30254bd55 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -12,6 +12,16 @@ (* $Id$ *) +(***********************************************************************) +(** **) +(** 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 @@ -41,8 +51,8 @@ let mkmaindll = "%%MKMAINDLL%%" 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" diff --git a/utils/tbl.ml b/utils/tbl.ml index 95aa973485..d6689f088d 100644 --- a/utils/tbl.ml +++ b/utils/tbl.ml @@ -95,6 +95,10 @@ let rec iter f = function | 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 = diff --git a/utils/tbl.mli b/utils/tbl.mli index ddeaa79d6a..71c348efae 100644 --- a/utils/tbl.mli +++ b/utils/tbl.mli @@ -23,6 +23,7 @@ val find: 'a -> ('a, 'b) t -> 'b 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 |