diff options
| author | Damien Doligez <damien.doligez-inria.fr> | 2008-01-11 16:13:18 +0000 |
|---|---|---|
| committer | Damien Doligez <damien.doligez-inria.fr> | 2008-01-11 16:13:18 +0000 |
| commit | 9ea5edac9ab0b3860688583a2ff22a9e164be086 (patch) | |
| tree | 353e23e669026900926bbd60cfc791906887ce63 | |
| parent | db2092907f2eddcaf0b72f4bd0f429001364dbe5 (diff) | |
merge changes 3.10.0 -> 3.10.1
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8768 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
112 files changed, 1837 insertions, 1183 deletions
@@ -17,18 +17,110 @@ Compilers: - Check that at most one of -pack, -a, -shared, -c, -output-obj is given on the command line. - Revised -output-obj: the output name must now be provided; its extension must - be one of $(EXT_OBJ), $(EXT_DLL) (or .c for the bytecode compiler). The compilers - can now produce a shared library (with all the needed -ccopts/-ccobjs options) directly. -- The -dllib options recorded in libraries are no longer ignored when -use_runtime or -use_prims is used - (unless -no_auto_link is explicitly used). + be one of $(EXT_OBJ), $(EXT_DLL) (or .c for the bytecode compiler). The + compilers can now produce a shared library (with all the needed + -ccopts/-ccobjs options) directly. +- The -dllib options recorded in libraries are no longer ignored when + -use_runtime or -use_prims is used (unless -no_auto_link is explicitly used). Native-code compiler: -- A new option "-shared" to produce a plugin that can be dynlinked with the native version of Dynlink. -- A new option "-dlcode" to produce code that can be put in a plugin (needed for some platforms only). +- A new option "-shared" to produce a plugin that can be dynlinked with the + native version of Dynlink. +- A new option "-dlcode" to produce code that can be put in a plugin (needed + for some platforms only). Other libraries: -- On some platforms, the dynlink library is now available in native code. A new Boolean - Dynlink.is_native allows the program to know whether it has been compiled in bytecode or in native code. +- On some platforms, the dynlink library is now available in native code. A + new Boolean Dynlink.is_native allows the program to know whether it has + been compiled in bytecode or in native code. + + +Objective Caml 3.10.1: +---------------------- + +Bug fixes: +- PR#3830 small bugs in docs +- PR#4053 compilers: improved compilation time for large variant types +- PR#4174 ocamlopt: fixed ocamlopt -nopervasives +- PR#4199 otherlibs: documented a small problem in Unix.utimes +- PR#4280 camlp4: parsing of identifier (^) +- PR#4281 camlp4: parsing of type constraint +- PR#4285 runtime: cannot compile under AIX +- PR#4286 ocamlbuild: cannot compile under AIX and SunOS +- PR#4288 compilers: including a functor application with side effects +- PR#4295 camlp4 toplevel: synchronization after an error +- PR#4300 ocamlopt: crash with backtrace and illegal array access +- PR#4302 camlp4: list comprehension parsing problem +- PR#4304 ocamlbuild: handle -I correctly +- PR#4305 stdlib: alignment of Arg.Symbol +- PR#4307 camlp4: assertion failure +- PR#4312 camlp4: accept "let _ : int = 1" +- PR#4313 ocamlbuild: -log and missing directories +- PR#4315 camlp4: constraints in classes +- PR#4316 compilers: crash with recursive modules and Lazy +- PR#4318 ocamldoc: installation problem with Cygwin (tentative fix) +- PR#4322 ocamlopt: stack overflow under Windows +- PR#4325 compilers: wrong error message for unused var +- PR#4326 otherlibs: marshal Big_int on win64 +- PR#4327 ocamlbuild: make emacs look for .annot in _build directory +- PR#4328 camlp4: stack overflow with nil nodes +- PR#4331 camlp4: guards on fun expressions +- PR#4332 camlp4: parsing of negative 32/64 bit numbers +- PR#4336 compilers: unsafe recursive modules +- PR#4337 (note) camlp4: invalid character escapes +- PR#4339 ocamlopt: problems on HP-UX (tentative fix) +- PR#4340 camlp4: wrong pretty-printing of optional arguments +- PR#4348 ocamlopt: crash on Mac Intel +- PR#4349 camlp4: bug in private type definitions +- PR#4350 compilers: type errors with records and polymorphic variants +- PR#4352 compilers: terminal recursion under Windows (tentative fix) +- PR#4354 ocamlcp: mismatch with ocaml on polymorphic let +- PR#4358 ocamlopt: float constants wrong on ARM +- PR#4360 ocamldoc: string inside comment +- PR#4365 toplevel: wrong pretty-printing of polymorphic variants +- PR#4373 otherlibs: leaks in win32unix +- PR#4374 otherlibs: threads module not initialized +- PR#4375 configure: fails to build on bytecode-only architectures +- PR#4377 runtime: finalisation of infix pointers +- PR#4378 ocamlbuild: typo in plugin.ml +- PR#4379 ocamlbuild: problem with plugins under Windows +- PR#4382 compilers: typing of polymorphic record fields +- PR#4383 compilers: including module with private type +- PR#4385 stdlib: Int32/Int64.format are unsafe +- PR#4386 otherlibs: wrong signal numbers with Unix.sigprocmask etc. +- PR#4387 ocamlbuild: build directory not used properly +- PR#4392 ocamldep: optional argument of class +- PR#4394 otherlibs: infinite loops in Str +- PR#4397 otherlibs: wrong size for flag arrays in win32unix +- PR#4402 ocamldebug: doesn't work with -rectypes +- PR#4410 ocamlbuild: problem with plugin and -build +- PR#4411 otherlibs: crash with Unix.access under Windows +- PR#4412 stdlib: marshalling broken on 64 bit architectures +- PR#4413 ocamlopt: crash on AMD64 with out-of-bound access and reraise +- PR#4417 camlp4: pretty-printing of unary minus +- PR#4419 camlp4: problem with constraint in type class +- PR#4426 compilers: problem with optional labels +- PR#4427 camlp4: wrong pretty-printing of lists of functions +- PR#4433 ocamlopt: fails to build on MacOSX 10.5 +- PR#4435 compilers: crash with objects +- PR#4439 fails to build on MacOSX 10.5 +- PR#4441 crash when build on sparc64 linux +- PR#4442 stdlib: crash with weak pointers +- PR#4446 configure: fails to detect X11 on MacOSX 10.5 +- PR#4448 runtime: huge page table on 64-bit architectures +- PR#4450 compilers: stack overflow with recursive modules +- PR#4470 compilers: type-checking of recursive modules too restrictive +- PR#4472 configure: autodetection of libX11.so on Fedora x86_64 +- printf: removed (partially implemented) positional specifications +- polymorphic < and <= comparisons: some C compiler optimizations + were causing incorrect results when arguments are incomparable + +New features: +- made configure script work on PlayStation 3 +- ARM port: brought up-to-date for Debian 4.0 (Etch) +- many other small changes and bugfixes in camlp4, ocamlbuild, labltk, + emacs files, + Objective Caml 3.10.0: ---------------------- @@ -2184,4 +2276,8 @@ Caml Special Light 1.06: * First public release. +<<<<<<< Changes +$Id$ +======= $Id$ +>>>>>>> 1.168.2.7 diff --git a/Makefile.nt b/Makefile.nt index 349e2158c..4351e14b7 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -28,7 +28,8 @@ CAMLDEP=boot/ocamlrun tools/ocamldep DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun -INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver -I toplevel +INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ + -I toplevel UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ diff --git a/README.win32 b/README.win32 index c94f30a4a..bfdff2b04 100644 --- a/README.win32 +++ b/README.win32 @@ -89,8 +89,11 @@ THIRD-PARTY SOFTWARE: the Microsoft Windows Server 2003 SP1 Platform SDK, which can be downloaded for free from http://www.microsoft.com/. -[3] MASM version 6.11 or later. MASM can be - downloaded for free from Microsoft's Web site; for directions, see +[3] MASM version 6.11 or later. The full distribution of Visual C++ 2005 + contains MASM version 8. Users of the Express Edition of Visual C++ + 2005 can download MASM version 8 from +http://www.microsoft.com/downloads/details.aspx?FamilyID=7A1C9DA0-0510-44A2-B042-7EF370530C64&displaylang=en + To obtain MASM version 6.11, see http://users.easystreet.com/jkirwan/new/pctools.html. [4] TCL/TK version 8.4. Windows binaries are available as part of the @@ -103,7 +106,7 @@ distribution (ocaml-X.YZ.tar.gz), which also contains the files modified for Windows. You will need the following software components to perform the recompilation: -- Windows NT, 2000, or XP. +- Windows NT, 2000, XP, or Vista. - Items [1], [2], [3] and [4] from the list of recommended software above. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ @@ -205,7 +208,7 @@ environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: -- Windows NT, 2000, or XP. +- Windows NT, 2000, XP, or Vista. - Cygwin: http://sourceware.cygnus.com/cygwin/ - TCL/TK version 8.4 (see above). @@ -1,4 +1,4 @@ -3.11+dev8 Private_abbrevs+natdynlink (2007-12-04) +3.11+dev9 Private_abbrevs+natdynlink (2008-01-10) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 215cec326..ec021ca35 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -36,10 +36,10 @@ let frame_required () = let frame_size () = (* includes return address *) if frame_required() then begin - let sz = + let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) in Misc.align sz 16 - end else + end else !stack_offset + 8 let slot_offset loc cl = @@ -69,7 +69,7 @@ let emit_jump s = let load_symbol_addr s = if !Clflags.dlcode then `movq {emit_symbol s}@GOTPCREL(%rip)` - else if !pic_code + else if !pic_code then `leaq {emit_symbol s}(%rip)` else `movq ${emit_symbol s}` @@ -216,7 +216,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: {emit_jump "caml_ml_array_bound_error"}\n` + `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n` (* Names for instructions *) @@ -360,7 +360,7 @@ let emit_instr fallthrough i = ` jmp {emit_label !tailrec_entry_point}\n` else begin output_epilogue(); - ` {emit_jump s}\n` + ` {emit_jump s}\n` end | Lop(Iextcall(s, alloc)) -> if alloc then begin @@ -417,10 +417,10 @@ let emit_instr fallthrough i = if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; - if !Clflags.dlcode then begin + if !Clflags.dlcode then begin ` {load_symbol_addr "caml_young_limit"}, %rax\n`; ` cmpq (%rax), %r15\n`; - end else + end else ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; let lbl_call_gc = new_label() in let lbl_frame = record_frame_label i.live Debuginfo.none in @@ -534,7 +534,7 @@ let emit_instr fallthrough i = ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in @@ -569,8 +569,22 @@ let emit_instr fallthrough i = | Lswitch jumptbl -> let lbl = new_label() in if !pic_code || !Clflags.dlcode then begin - ` leaq {emit_label lbl}(%rip), %r11\n`; - ` jmp *(%r11, {emit_reg i.arg.(0)}, 8)\n` + (* PR#4424: r11 is known to be clobbered by the Lswitch, + meaning that no variable that is live across the Lswitch + is assigned to r11. However, the argument to Lswitch + can still be assigned to r11, so we need to special-case + this situation. *) + if i.arg.(0).loc = Reg 9 (* ie r11, cf amd64/proc.ml *) then begin + ` salq $3, %r11\n`; + ` pushq %r11\n`; + ` leaq {emit_label lbl}(%rip), %r11\n`; + ` addq 0(%rsp), %r11\n`; + ` addq $8, %rsp\n`; + ` jmp *(%r11)\n` + end else begin + ` leaq {emit_label lbl}(%rip), %r11\n`; + ` jmp *(%r11, {emit_reg i.arg.(0)}, 8)\n` + end end else begin ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n` end; diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 30b046e6d..71b71157b 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -217,7 +217,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp caml_ml_array_bound_error\n` + `{emit_label !bound_error_call}: call caml_ml_array_bound_error\n` (* Names for instructions *) diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index a26aaee61..586d477bd 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -648,9 +648,6 @@ let begin_assembly() = `trap_ptr .req r11\n`; `alloc_ptr .req r8\n`; `alloc_limit .req r9\n`; - `sp .req r13\n`; - `lr .req r14\n`; - `pc .req r15\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .global {emit_symbol lbl_begin}\n`; diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 3066d785d..e34093acb 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -106,7 +106,7 @@ method select_operation op args = | _ -> (Iextcall("__modsi3", false), args) end - | Ccheckbound -> + | Ccheckbound _ -> begin match args with [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 32 && not(is_intconst arg2) -> @@ -116,15 +116,15 @@ method select_operation op args = end | _ -> super#select_operation op args -(* In mul rd, rm, rs, rm and rd must be different. +(* In mul rd, rm, rs, the registers rm and rd must be different. We deal with this by pretending that rm is also a result of the mul operation. *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = if op = Iintop(Imul) then begin - self#insert (Iop op) rs [| rd.(0); rs.(0) |]; rd + self#insert_debug (Iop op) dbg rs [| rd.(0); rs.(0) |]; rd end else - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 8abc43908..e406d35a6 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -163,7 +163,7 @@ let read_file obj_name = let infos = try Compilenv.read_library_info file_name with Compilenv.Error(Not_a_unit_info _) -> - raise(Error(Not_an_object_file file_name)) + raise(Error(Not_an_object_file file_name)) in Library (file_name,infos) end @@ -172,17 +172,17 @@ let read_file obj_name = let scan_file obj_name tolink = match read_file obj_name with | Unit (file_name,info,crc) -> (* This is a .cmx file. It must be linked in any case. - Read the infos to see which modules it requires. *) + Read the infos to see which modules it requires. *) let (info, crc) = Compilenv.read_unit_info file_name in remove_required info.ui_name; List.iter (add_required file_name) info.ui_imports_cmx; (info, file_name, crc) :: tolink | Library (file_name,infos) -> (* This is an archive file. Each unit contained in it will be linked - in only if needed. *) + in only if needed. *) add_ccobjs infos; List.fold_right - (fun (info, crc) reqd -> + (fun (info, crc) reqd -> if info.ui_force_link || !Clflags.link_everything || is_required info.ui_name @@ -194,7 +194,7 @@ let scan_file obj_name tolink = match read_file obj_name with (info, file_name, crc) :: reqd end else reqd) - infos.lib_units tolink + infos.lib_units tolink (* Second pass: generate the startup file and link it with everything else *) @@ -219,8 +219,8 @@ let make_startup_file ppf filename units_list = (List.map (fun (unit,_,crc) -> try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, - crc, - unit.ui_defines) + crc, + unit.ui_defines) with Not_found -> assert false) units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); @@ -278,7 +278,9 @@ let link_shared ppf objfiles output_name = remove_file startup_obj let call_linker file_list startup_file output_name = - let main_dll = !Clflags.output_c_object && Filename.check_suffix output_name Config.ext_dll in + let main_dll = !Clflags.output_c_object + && Filename.check_suffix output_name Config.ext_dll + in let files = startup_file :: (List.rev file_list) in let files, c_lib = if (not !Clflags.output_c_object) || main_dll then diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml index 57a242d70..54208fcc3 100644 --- a/asmcomp/hppa/reload.ml +++ b/asmcomp/hppa/reload.ml @@ -14,5 +14,25 @@ (* Reloading for the HPPA *) + +open Cmm +open Arch +open Reg +open Mach +open Proc + +class reload = object (self) + +inherit Reloadgen.reload_generic as super + +method reload_operation op arg res = + match op with + Iintop(Idiv | Imod) + | Iintop_imm((Idiv | Imod), _) -> (arg, res) + | _ -> super#reload_operation op arg res +end + + + let fundecl f = - (new Reloadgen.reload_generic)#fundecl f + (new reload)#fundecl f diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml index 24db6cd90..6a0e9fe40 100644 --- a/asmcomp/hppa/selection.ml +++ b/asmcomp/hppa/selection.ml @@ -92,17 +92,17 @@ method select_operation op args = (* Deal with register constraints *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = match op with Iintop(Idiv | Imod) -> (* handled via calls to millicode *) let rs' = [|phys_reg 20; phys_reg 19|] (* %r26, %r25 *) and rd' = [|phys_reg 22|] (* %r29 *) in self#insert_moves rs rs'; - self#insert (Iop op) rs' rd'; + self#insert_debug (Iop op) dbg rs' rd'; self#insert_moves rd' rd; rd | _ -> - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index b50ecff27..fe1291e02 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -35,7 +35,7 @@ let stack_offset = ref 0 (* Layout of the stack frame *) let frame_size () = (* includes return address *) - let sz = + let sz = !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 in Misc.align sz stack_alignment @@ -116,12 +116,12 @@ let emit_align = (fun n -> ` .align {emit_int n}\n`) | _ -> (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) - + let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 16 ; emit_label lbl - + (* Output a pseudo-register *) let emit_reg = function @@ -239,7 +239,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + `{emit_label !bound_error_call}: call {emit_symbol "caml_ml_array_bound_error"}\n` (* Names for instructions *) @@ -299,7 +299,7 @@ let name_for_cond_branch = function | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - + (* Output an = 0 or <> 0 test. *) let output_test_zero arg = @@ -737,7 +737,7 @@ let emit_instr fallthrough i = ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index bba42fe88..e4ac9d408 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -206,7 +206,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp _caml_ml_array_bound_error\n` + `{emit_label !bound_error_call}: call _caml_ml_array_bound_error\n` (* Names for instructions *) diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml index fa9d60590..03b5a2f6b 100644 --- a/asmcomp/i386/proc_nt.ml +++ b/asmcomp/i386/proc_nt.ml @@ -88,12 +88,23 @@ let word_addressed = false (* Calling conventions *) +(* To supplement the processor's meagre supply of registers, we also + use some global memory locations to pass arguments beyond the 6th. + These globals are denoted by Incoming and Outgoing stack locations + with negative offsets, starting at -64. + Unlike arguments passed on stack, arguments passed in globals + do not prevent tail-call elimination. The caller stores arguments + in these globals immediately before the call, and the first thing the + callee does is copy them to registers or stack locations. + Neither GC nor thread context switches can occur between these two + times. *) + let calling_conventions first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in - let ofs = ref 0 in + let ofs = ref (-64) in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> @@ -113,7 +124,7 @@ let calling_conventions first_int last_int first_float last_float make_stack ofs := !ofs + size_float end done; - (loc, !ofs) + (loc, max 0 !ofs) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 50af17bb7..0d918b142 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -59,8 +59,8 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) h = Hash_retaddr(pc); while(1) { d = caml_frame_descriptors[h]; + if (d == 0) return; /* can happen if some code not compiled with -g */ if (d->retaddr == pc) break; - if (d->retaddr == 0) return; /* should not happen */ h = (h+1) & caml_frame_descriptors_mask; } /* Skip to next frame */ diff --git a/asmrun/i386.S b/asmrun/i386.S index 9d45f6e97..ce05744a7 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -384,9 +384,17 @@ G(caml_ml_array_bound_error): ffree %st(5) ffree %st(6) ffree %st(7) - /* Branch to [caml_array_bound_error] */ - movl $ G(caml_array_bound_error), %eax - jmp G(caml_c_call) + /* Record lowest stack address and return address */ + movl (%esp), %edx + movl %edx, G(caml_last_return_address) + leal 4(%esp), %edx + movl %edx, G(caml_bottom_of_stack) + /* For MacOS X: re-align the stack */ +#ifdef SYS_macosx + andl $-16, %esp +#endif + /* Branch to [caml_array_bound_error] (never returns) */ + call G(caml_array_bound_error) .data .globl G(caml_system__frametable) diff --git a/asmrun/roots.c b/asmrun/roots.c index 4a4ade47e..46faafc84 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -43,7 +43,7 @@ int caml_frame_descriptors_mask; typedef struct link { void *data; struct link *next; -} link; +} link; static link *cons(void *data, link *tl) { link *lnk = caml_stat_alloc(sizeof(link)); @@ -79,13 +79,13 @@ void caml_init_frame_descriptors(void) link *lnk; static int inited = 0; - + if (!inited) { for (i = 0; caml_frametable[i] != 0; i++) caml_register_frametable(caml_frametable[i]); inited = 1; } - + /* Count the frame descriptors */ num_descr = 0; iter_list(frametables,lnk) { @@ -111,14 +111,14 @@ void caml_init_frame_descriptors(void) for (j = 0; j < len; j++) { h = Hash_retaddr(d->retaddr); while (caml_frame_descriptors[h] != NULL) { - h = (h+1) & caml_frame_descriptors_mask; + h = (h+1) & caml_frame_descriptors_mask; } caml_frame_descriptors[h] = d; nextd = - ((uintnat)d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *); + ((uintnat)d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); if (d->frame_size & 1) nextd += 8; d = (frame_descr *) nextd; } @@ -148,7 +148,11 @@ void caml_oldify_local_roots (void) frame_descr * d; uintnat h; int i, j, n, ofs; +#ifdef Stack_grows_upwards + short * p; /* PR#4339: stack offsets are negative in this case */ +#else unsigned short * p; +#endif value glob; value * root; struct global_root * gr; diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 09dfb4c9e..0ae285f32 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -87,11 +87,12 @@ sigact.sa_flags = SA_SIGINFO #include <sys/ucontext.h> + #include <AvailabilityMacros.h> - #ifdef _STRUCT_X86_EXCEPTION_STATE32 - #define CONTEXT_REG(r) __##r - #else +#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r + #else + #define CONTEXT_REG(r) __##r #endif #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss)) @@ -123,29 +124,30 @@ static void name(int sig, siginfo_t * info, void * context) #include <sys/ucontext.h> - + #include <AvailabilityMacros.h> + #ifdef __LP64__ #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO | SA_64REGSET - + typedef unsigned long long context_reg; - + #define CONTEXT_MCONTEXT (((ucontext64_t *)context)->uc_mcontext64) #else #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO - + typedef unsigned long context_reg; - + #define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext) #endif - - #ifdef _STRUCT_PPC_EXCEPTION_STATE - #define CONTEXT_REG(r) __##r - #else + +#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r + #else + #define CONTEXT_REG(r) __##r #endif #define CONTEXT_STATE (CONTEXT_MCONTEXT->CONTEXT_REG(ss)) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 7aa072450..54149e4c7 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex b959751d1..86a6d5a5b 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex cc2c60604..9eeea0fdf 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/build/buildbot b/build/buildbot index c755852fe..e9b2579eb 100755 --- a/build/buildbot +++ b/build/buildbot @@ -1,5 +1,9 @@ #!/bin/sh +# If you want to help me by participating to the build/test effort: +# http://gallium.inria.fr/~pouillar/ocaml-testing.html +# -- Nicolas Pouillard + usage() { echo "Usage: $0 (make|ocb|ocamlbuild) (win (mingw|msvc|msvc64) | <configure-arg>*)" exit 1 @@ -11,7 +15,7 @@ finish() { curl -s -0 -F "log=@$logfile" \ -F "host=`hostname`" \ -F "mode=$mode-$opt_win-$opt_win2" \ - http://weblog.feydakins.org/dropbox || : + http://buildbot.feydakins.org/dropbox || : } rm -f buildbot.failed diff --git a/build/distclean.sh b/build/distclean.sh index 92ced8862..1a88138d8 100755 --- a/build/distclean.sh +++ b/build/distclean.sh @@ -1,5 +1,19 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 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$ + cd `dirname $0`/.. set -ex (cd byterun && make clean) || : @@ -18,7 +32,7 @@ rm -f driver/main.byte driver/optmain.byte lex/main.byte \ camlp4/build/location.mli \ tools/myocamlbuild_config.ml camlp4/build/linenum.mli \ camlp4/build/linenum.mll \ - camlp4/build/terminfo.mli camlp4/build/terminfo.ml + camlp4/build/terminfo.mli camlp4/build/terminfo.ml # from ocamlbuild bootstrap rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \ diff --git a/build/install.sh b/build/install.sh index 4f1e829d8..6da2745c7 100755 --- a/build/install.sh +++ b/build/install.sh @@ -1,5 +1,19 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 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$ + set -e cd `dirname $0`/.. diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh index 658f065ff..e48f5b0e0 100755 --- a/build/mkmyocamlbuild_config.sh +++ b/build/mkmyocamlbuild_config.sh @@ -1,4 +1,17 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 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$ cd `dirname $0`/.. diff --git a/build/partial-boot.sh b/build/partial-boot.sh index 7a10d5480..ee6676ead 100755 --- a/build/partial-boot.sh +++ b/build/partial-boot.sh @@ -1,5 +1,19 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 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$ + set -ex cd `dirname $0`/.. OCAMLBUILD_PARTIAL="true" diff --git a/build/partial-install.sh b/build/partial-install.sh index f0226e6d9..619976289 100755 --- a/build/partial-install.sh +++ b/build/partial-install.sh @@ -1,4 +1,17 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 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$ ###################################### diff --git a/build/targets.sh b/build/targets.sh index f900f6e68..09e619b62 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -1,4 +1,17 @@ +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 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$ + . config/config.sh . build/otherlibs-targets.sh . build/camlp4-targets.sh diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 184626dfa..f7caf464e 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -2337,8 +2337,8 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with ctx pm | Tpat_variant(lab, _, row) -> compile_test (compile_match repr partial) partial - (divide_variant row) - (combine_variant row arg partial) + (divide_variant !row) + (combine_variant !row arg partial) ctx pm | _ -> assert false end diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 7ea71185e..d186bdebf 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -73,10 +73,10 @@ let transl_val tbl create name = mkappl (oo_prim (if create then "new_variable" else "get_variable"), [Lvar tbl; transl_label name]) -let transl_vals tbl create vals rem = +let transl_vals tbl create strict vals rem = List.fold_right (fun (name, id) rem -> - Llet(StrictOpt, id, transl_val tbl create name, rem)) + Llet(strict, id, transl_val tbl create name, rem)) vals rem let meths_super tbl meths inh_meths = @@ -90,7 +90,7 @@ let meths_super tbl meths inh_meths = inh_meths [] let bind_super tbl (vals, meths) cl_init = - transl_vals tbl false vals + transl_vals tbl false StrictOpt vals (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) meths cl_init) @@ -205,22 +205,22 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let bind_method tbl lab id cl_init = - Llet(StrictOpt, id, mkappl (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), + Llet(Strict, id, mkappl (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), cl_init) let bind_methods tbl meths vals cl_init = let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in let len = List.length methl and nvals = List.length vals in if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else - if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else + if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else let ids = Ident.create "ids" in let i = ref (len + nvals) in let getter, names = if nvals = 0 then "get_method_labels", [] else "new_methods_variables", [transl_meth_list (List.map fst vals)] in - Llet(StrictOpt, ids, + Llet(Strict, ids, mkappl (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right @@ -248,6 +248,8 @@ let rec index a = function | b :: l -> if b = a then 0 else 1 + index a l +let bind_id_as_val (id, _) = ("", id) + let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> @@ -310,16 +312,16 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_apply (cl, exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_constraint (cl, vals, meths, concr_meths) -> let virt_meths = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in @@ -586,6 +588,9 @@ open M Si ids=0 (objet immediat), alors on ne conserve que env_init. *) +let prerr_ids msg ids = + let names = List.map Ident.unique_toplevel_name ids in + prerr_endline (String.concat " " (msg :: names)) let transl_class ids cl_id arity pub_meths cl vflag = (* First check if it is not only a rebind *) @@ -603,10 +608,6 @@ let transl_class ids cl_id arity pub_meths cl vflag = let subst env lam i0 new_ids' = let fv = free_variables lam in let fv = List.fold_right IdentSet.remove !new_ids' fv in - (* IdentSet.iter - (fun id -> - if not (List.mem id new_ids) then prerr_endline (Ident.name id)) - fv; *) let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in (* need to handle methods specially (PR#3576) *) let fm = IdentSet.diff (free_methods lam) meth_ids in diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 9125d8e7e..fc7da7d1a 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -335,7 +335,7 @@ and transl_structure fields cc rootpath = function | id :: ids -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), rebind_idents (pos + 1) (id :: newfields) ids) in - Llet(Alias, mid, transl_module Tcoerce_none None modl, + Llet(Strict, mid, transl_module Tcoerce_none None modl, rebind_idents 0 fields ids) (* Update forward declaration in Translcore *) @@ -539,7 +539,7 @@ let build_ident_map restr idlist = | _ -> fatal_error "Translmod.build_ident_map" -(* Compile an implementation using transl_store_structure +(* Compile an implementation using transl_store_structure (for the native-code compiler). *) let transl_store_gen module_name (str, restr) topl = @@ -549,8 +549,8 @@ let transl_store_gen module_name (str, restr) topl = let (map, prims, size) = build_ident_map restr (defined_idents str) in let f = function | [ Tstr_eval expr ] when topl -> - assert (size = 0); - subst_lambda !transl_store_subst (transl_exp expr) + assert (size = 0); + subst_lambda !transl_store_subst (transl_exp expr) | str -> transl_store_structure module_id map prims str in transl_store_label_init module_id size f str (*size, transl_label_init (transl_store_structure module_id map prims str)*) @@ -665,7 +665,7 @@ let transl_toplevel_definition str = let get_component = function None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, []) + | Some id -> Lprim(Pgetglobal id, []) let transl_package component_names target_name coercion = let components = diff --git a/byterun/compare.c b/byterun/compare.c index 42b1d9d73..35a7f66ce 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -268,14 +268,14 @@ CAMLprim value caml_lessthan(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res - 1 < -1); + return Val_int(res < 0 && res != UNORDERED); } CAMLprim value caml_lessequal(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res - 1 <= -1); + return Val_int(res <= 0 && res != UNORDERED); } CAMLprim value caml_greaterthan(value v1, value v2) diff --git a/byterun/finalise.c b/byterun/finalise.c index dce6edd61..44a5876d2 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -24,6 +24,7 @@ struct final { value fun; value val; + int offset; }; static struct final *final_table = NULL; @@ -67,7 +68,7 @@ void caml_final_update (void) { uintnat i, j, k; uintnat todo_count = 0; - + Assert (young == old); for (i = 0; i < old; i++){ Assert (Is_block (final_table[i].val)); @@ -84,6 +85,7 @@ void caml_final_update (void) Assert (Is_in_heap (final_table[i].val)); if (Is_white_val (final_table[i].val)){ if (Tag_val (final_table[i].val) == Forward_tag){ + Assert (final_table[i].offset == 0); value fv = Forward_val (final_table[i].val); if (Is_block (fv) && Is_in_value_area(fv) && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag @@ -136,7 +138,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); + caml_callback (f.fun, f.val + f.offset); running_finalisation_function = 0; } caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); @@ -159,7 +161,7 @@ void caml_final_do_strong_roots (scanning_action f) Assert (old == young); for (i = 0; i < old; i++) Call_action (f, final_table[i].fun); - + for (todo = to_do_hd; todo != NULL; todo = todo->next){ for (i = 0; i < todo->size; i++){ Call_action (f, todo->item[i].fun); @@ -186,7 +188,7 @@ void caml_final_do_weak_roots (scanning_action f) void caml_final_do_young_roots (scanning_action f) { uintnat i; - + Assert (old <= young); for (i = old; i < young; i++){ Call_action (f, final_table[i].fun); @@ -210,7 +212,7 @@ CAMLprim value caml_final_register (value f, value v) caml_invalid_argument ("Gc.finalise"); } Assert (old <= young); - + if (young >= size){ if (final_table == NULL){ uintnat new_size = 30; @@ -227,8 +229,13 @@ CAMLprim value caml_final_register (value f, value v) } Assert (young < size); final_table[young].fun = f; - if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v); - final_table[young].val = v; + if (Tag_val (v) == Infix_tag){ + final_table[young].offset = Infix_offset_val (v); + final_table[young].val = v - Infix_offset_val (v); + }else{ + final_table[young].offset = 0; + final_table[young].val = v; + } ++ young; return Val_unit; diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 1dce5cb08..5f028c0eb 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -78,7 +78,7 @@ static void check_block (char *hp) mlsize_t i; value v = Val_hp (hp); value f; - + check_head (v); switch (Tag_hp (hp)){ case Abstract_tag: break; @@ -93,7 +93,7 @@ static void check_block (char *hp) case Custom_tag: Assert (!Is_in_heap (Custom_ops_val (v))); break; - + case Infix_tag: Assert (0); break; @@ -102,7 +102,10 @@ static void check_block (char *hp) Assert (Tag_hp (hp) < No_scan_tag); for (i = 0; i < Wosize_hp (hp); i++){ f = Field (v, i); - if (Is_block (f) && Is_in_heap (f)) check_head (f); + if (Is_block (f) && Is_in_heap (f)){ + check_head (f); + Assert (Color_val (f) != Caml_blue); + } } } } diff --git a/byterun/intern.c b/byterun/intern.c index 5f99b5b06..b7acfd4a0 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -76,7 +76,7 @@ static value intern_block; (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) #define read32u() \ (intern_src += 4, \ - (intern_src[-4] << 24) + (intern_src[-3] << 16) + \ + ((uintnat)(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ (intern_src[-2] << 8) + intern_src[-1]) #define read32s() \ (intern_src += 4, \ diff --git a/byterun/ints.c b/byterun/ints.c index 23ee46329..ed18e6f44 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -551,15 +551,21 @@ CAMLprim value caml_int64_of_string(value s) CAMLprim value caml_int64_bits_of_float(value vd) { - union { double d; int64 i; } u; + union { double d; int64 i; int32 h[2]; } u; u.d = Double_val(vd); +#if defined(__arm__) && !defined(__ARM_EABI__) + { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } +#endif return caml_copy_int64(u.i); } CAMLprim value caml_int64_float_of_bits(value vi) { - union { double d; int64 i; } u; + union { double d; int64 i; int32 h[2]; } u; u.i = Int64_val(vi); +#if defined(__arm__) && !defined(__ARM_EABI__) + { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } +#endif return caml_copy_double(u.d); } diff --git a/byterun/io.h b/byterun/io.h index a35124ac9..127c4c1c5 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -52,7 +52,7 @@ struct channel { }; enum { - CHANNEL_FLAG_FROM_SOCKET = 1, /* For Windows */ + CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ }; /* For an output channel: diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 3c903740a..d12982b1a 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -190,23 +190,27 @@ static void mark_slice (intnat work) chunk = caml_heap_start; markhp = chunk; limit = chunk + Chunk_size (chunk); - }else if (caml_gc_subphase == Subphase_main){ - /* The main marking phase is over. Start removing weak pointers to - dead values. */ - caml_gc_subphase = Subphase_weak1; - weak_prev = &caml_weak_list_head; - }else if (caml_gc_subphase == Subphase_weak1){ - value cur, curfield; - mlsize_t sz, i; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); + }else{ + switch (caml_gc_subphase){ + case Subphase_main: { + /* The main marking phase is over. Start removing weak pointers to + dead values. */ + caml_gc_subphase = Subphase_weak1; + weak_prev = &caml_weak_list_head; + } + break; + case Subphase_weak1: { + value cur, curfield; + mlsize_t sz, i; + header_t hd; + + cur = *weak_prev; + if (cur != (value) NULL){ + hd = Hd_val (cur); sz = Wosize_hd (hd); for (i = 1; i < sz; i++){ curfield = Field (cur, i); - weak_again: + weak_again: if (curfield != caml_weak_none && Is_block (curfield) && Is_in_heap (curfield)){ if (Tag_val (curfield) == Forward_tag){ @@ -226,46 +230,53 @@ static void mark_slice (intnat work) } } } - weak_prev = &Field (cur, 0); - work -= Whsize_hd (hd); - }else{ - /* Subphase_weak1 is done. Start removing dead weak arrays. */ - caml_gc_subphase = Subphase_weak2; - weak_prev = &caml_weak_list_head; + weak_prev = &Field (cur, 0); + work -= Whsize_hd (hd); + }else{ + /* Subphase_weak1 is done. Start removing dead weak arrays. */ + caml_gc_subphase = Subphase_weak2; + weak_prev = &caml_weak_list_head; + } } - }else if (caml_gc_subphase == Subphase_weak2){ - value cur; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); - if (Color_hd (hd) == Caml_white){ - /* The whole array is dead, remove it from the list. */ - *weak_prev = Field (cur, 0); + break; + case Subphase_weak2: { + value cur; + header_t hd; + + cur = *weak_prev; + if (cur != (value) NULL){ + hd = Hd_val (cur); + if (Color_hd (hd) == Caml_white){ + /* The whole array is dead, remove it from the list. */ + *weak_prev = Field (cur, 0); + }else{ + weak_prev = &Field (cur, 0); + } + work -= 1; }else{ - weak_prev = &Field (cur, 0); + /* Subphase_weak2 is done. Handle finalised values. */ + gray_vals_cur = gray_vals_ptr; + caml_final_update (); + gray_vals_ptr = gray_vals_cur; + caml_gc_subphase = Subphase_final; } - work -= 1; - }else{ - /* Subphase_weak2 is done. Handle finalised values. */ + } + break; + case Subphase_final: { + /* Initialise the sweep phase. */ gray_vals_cur = gray_vals_ptr; - caml_final_update (); - gray_vals_ptr = gray_vals_cur; - caml_gc_subphase = Subphase_final; + caml_gc_sweep_hp = caml_heap_start; + caml_fl_init_merge (); + caml_gc_phase = Phase_sweep; + chunk = caml_heap_start; + caml_gc_sweep_hp = chunk; + limit = chunk + Chunk_size (chunk); + work = 0; + caml_fl_size_at_phase_change = caml_fl_cur_size; + } + break; + default: Assert (0); } - }else{ - Assert (caml_gc_subphase == Subphase_final); - /* Initialise the sweep phase. */ - gray_vals_cur = gray_vals_ptr; - caml_gc_sweep_hp = caml_heap_start; - caml_fl_init_merge (); - caml_gc_phase = Phase_sweep; - chunk = caml_heap_start; - caml_gc_sweep_hp = chunk; - limit = chunk + Chunk_size (chunk); - work = 0; - caml_fl_size_at_phase_change = caml_fl_cur_size; } } gray_vals_cur = gray_vals_ptr; diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 16526f85e..4288f9e96 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -39,6 +39,10 @@ CAMLexport struct caml_ref_table int caml_in_minor_collection = 0; +#ifdef DEBUG +static unsigned long minor_gc_counter = 0; +#endif + void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) { value **new_table; @@ -248,6 +252,7 @@ void caml_empty_minor_heap (void) for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){ *p = Debug_free_minor; } + ++ minor_gc_counter; } #endif } diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml index 5142b3815..a637dffef 100644 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -321,7 +321,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | [e] -> pp f "[ %a ]" o#under_semi#expr e | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el ]; - method expr_list_cons simple f e = + method expr_list_cons simple f e = let (el, c) = o#mk_expr_list e in match c with [ None -> o#expr_list f el @@ -496,7 +496,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< ( $tup:e$ ) >> -> pp f "@[<1>(%a)@]" o#expr e | <:expr< [| $e$ |] >> -> - pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e + pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e | <:expr< ($e$ :> $t$) >> -> pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t | <:expr< ($e$ : $t1$ :> $t2$) >> -> @@ -903,7 +903,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:class_expr< $ce1$ and $ce2$ >> -> do { o#class_expr f ce1; pp f andsep; o#class_expr f ce2 } | <:class_expr< $ce1$ = fun $p$ -> $ce2$ >> when is_irrefut_patt p -> - pp f "@[<2>%a@ %a" o#class_expr ce1 + pp f "@[<2>%a@ %a" o#class_expr ce1 o#patt_class_expr_fun_args (p, ce2) | <:class_expr< $ce1$ = $ce2$ >> -> pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml index 15a2cfd42..64086607d 100644 --- a/camlp4/Camlp4/Printers/OCamlr.ml +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -147,7 +147,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x ] | p -> super#patt4 f p ]; - method expr_list_cons _ f e = + method expr_list_cons _ f e = let (el, c) = o#mk_expr_list e in match c with [ None -> o#expr_list f el diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml index e96c3e714..253dc4185 100644 --- a/camlp4/Camlp4/Sig.ml +++ b/camlp4/Camlp4/Sig.ml @@ -18,6 +18,8 @@ * - Nicolas Pouillard: refactoring *) +(* $Id$ *) + (** Camlp4 signature repository *) (** {6 Basic signatures} *) @@ -42,7 +44,7 @@ module type Id = sig (** The name of the extension, typically the module name. *) value name : string; - (** The version of the extension, typically $Id$ with a versionning system. *) + (** The version of the extension, typically $ Id$ with a versionning system. *) value version : string; end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 25c30d570..45b65fb64 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -199,7 +199,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct value rec ty_var_list_of_ctyp = fun [ <:ctyp< $t1$ $t2$ >> -> ty_var_list_of_ctyp t1 @ ty_var_list_of_ctyp t2 - | <:ctyp< '$s$ >> -> [s] + | <:ctyp< '$s$ >> -> [s] | _ -> assert False ]; value rec ctyp = @@ -495,7 +495,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) | <:patt@loc< ($p1$, $p2$) >> -> mkpat loc (Ppat_tuple - (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) + (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) @@ -678,7 +678,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e)) | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a [])) | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id)) - | ExObj loc po cfl -> + | ExObj loc po cfl -> let p = match po with [ <:patt<>> -> <:patt@loc< _ >> @@ -716,7 +716,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a [])) | <:expr@loc< ($e1$, $e2$) >> -> - mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) + mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple" | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) | <:expr@loc< () >> -> @@ -920,7 +920,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct error loc "invalid virtual class inside a class type" | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ -> assert False ] - + and class_info_class_expr ci = match ci with [ CeEq _ (CeCon loc vir (IdLid _ name) params) ce -> diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli index b94bad940..922789153 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli @@ -18,7 +18,6 @@ * - Nicolas Pouillard: refactoring *) - (* $Id$ *) module Make (Camlp4Ast : Sig.Camlp4Ast) : sig diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll index a433b606c..6344993a0 100644 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -17,7 +17,6 @@ * - Nicolas Pouillard: refactoring *) - (* $Id$ *) (* The lexer definition *) diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml index 4961c5e07..0fea725a2 100644 --- a/camlp4/Camlp4Bin.ml +++ b/camlp4/Camlp4Bin.ml @@ -49,7 +49,7 @@ value add_to_loaded_modules name = loaded_modules.val := SSet.add name loaded_modules.val; value (objext,libext) = - if DynLoader.is_native then (".cmxs",".cmxs") + if DynLoader.is_native then (".cmxs",".cmxs") else (".cmo",".cma"); value rewrite_and_load n x = @@ -219,7 +219,7 @@ value (task, do_task) = value input_file x = let dyn_loader = dyn_loader.val () in do { - rcall_callback.val (); + rcall_callback.val (); match x with [ Intf file_name -> task (process_intf dyn_loader) file_name | Impl file_name -> task (process_impl dyn_loader) file_name diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml index 3b27a5943..f6d15b51a 100644 --- a/camlp4/Camlp4Top/Rprint.ml +++ b/camlp4/Camlp4Top/Rprint.ml @@ -18,7 +18,6 @@ * - Nicolas Pouillard: refactoring *) - (* $Id$ *) (* There is a few Obj.magic due to the fact that we no longer have compiler diff --git a/config/Makefile.msvc b/config/Makefile.msvc index e888c3a4b..9a4732563 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -80,7 +80,7 @@ BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE BYTECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(BYTECC). (For static linking.) -BYTECCLINKOPTS=/MD +BYTECCLINKOPTS=/MD /F16777216 ### Additional compile-time options for $(BYTECC). (For building a DLL.) DLLCCCOMPOPTS=/Ox /MD @@ -131,7 +131,7 @@ NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS=/MD +NATIVECCLINKOPTS=/MD /F16777216 ### Build partially-linked object file PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 2a06de920..cef571117 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -83,7 +83,7 @@ BYTECCCOMPOPTS=/Ox /MD BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64 ### Additional link-time options for $(BYTECC). (For static linking.) -BYTECCLINKOPTS=/MD +BYTECCLINKOPTS=/MD /F33554432 ### Additional compile-time options for $(BYTECC). (For building a DLL.) DLLCCCOMPOPTS=/Ox /MD @@ -135,7 +135,7 @@ NATIVECC=cl /nologo NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS=/MD +NATIVECCLINKOPTS=/MD /F33554432 ### Build partially-linked object file PACKLD=link /lib /nologo /machine:AMD64 /out:# there must be no space after this '/out:' diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c index a1aa0b7ec..7f06e9711 100644 --- a/config/auto-aux/stackov.c +++ b/config/auto-aux/stackov.c @@ -43,7 +43,7 @@ static void segv_handler(int signo, siginfo_t * info, void * context) int main(int argc, char ** argv) { - struct sigaltstack stk; + stack_t stk; struct sigaction act; stk.ss_sp = sig_alt_stack; @@ -568,7 +568,7 @@ if test $withsharedlibs = "yes"; then dyld=ld if test -f /usr/bin/ld_classic; then # The new linker in Mac OS X 10.5 does not support read_only_relocs - dyld=/usr/bin/ld_classic + # dyld=/usr/bin/ld_classic XXX FIXME incompatible with X11 libs fi mksharedlib="$dyld -bundle -flat_namespace -undefined suppress -read_only_relocs suppress" bytecccompopts="$dl_defs $bytecccompopts" @@ -629,7 +629,7 @@ case "$host" in hppa2.0*-*-hpux*) arch=hppa; system=hpux;; hppa*-*-linux*) arch=hppa; system=linux;; hppa*-*-gnu*) arch=hppa; system=gnu;; - powerpc-*-linux*) arch=power; model=ppc; system=elf;; + powerpc*-*-linux*) arch=power; model=ppc; system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; system=rhapsody @@ -646,6 +646,17 @@ case "$host" in x86_64-*-openbsd*) arch=amd64; system=openbsd;; esac +# Some platforms exist both in 32-bit and 64-bit variants, not distinguished +# by $host. Turn off native code compilation on platforms where 64-bit mode +# is not supported. (PR#4441) + +if $arch64; then + case "$arch,$model" in + sparc,default|mips,default|hppa,default|power,ppc) + arch=none; model=default; system=unknown;; + esac +fi + if test -z "$ccoption"; then case "$arch,$system,$cc" in alpha,digital,gcc*) nativecc=cc;; @@ -1254,6 +1265,7 @@ for dir in \ /usr/x386/lib \ /usr/XFree86/lib/X11 \ \ + /usr/lib64 \ /usr/lib \ /usr/local/lib \ /usr/unsupported/lib \ diff --git a/debugger/main.ml b/debugger/main.ml index d74beaca8..4920d0d79 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -165,6 +165,7 @@ let main () = current_prompt := debugger_prompt; printf "\tObjective Caml Debugger version %s@.@." Config.version; Config.load_path := !default_load_path; + Clflags.recursive_types := true; (* Allow recursive types. *) toplevel_loop (); (* Toplevel. *) kill_program (); exit 0 diff --git a/emacs/README b/emacs/README index f6bf63e84..7ddb362b4 100644 --- a/emacs/README +++ b/emacs/README @@ -63,6 +63,14 @@ For other bindings, see C-h b. Changes log: ----------- +Version 3.10.1: +--------------- +* use caml-font.el from Olivier Andrieu + old version is left as caml-font-old.el for compatibility + +Version 3.07: +------------- +* support for showing type information <Damien Doligez> Version 3.05: ------------- @@ -195,4 +203,4 @@ in other cases may confuse the phrase selection function. Comments and bug reports to - Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp> + Jacques Garrigue <garrigue@math.nagoya-u.ac.jp> diff --git a/emacs/caml-font-old.el b/emacs/caml-font-old.el new file mode 100644 index 000000000..fe5721376 --- /dev/null +++ b/emacs/caml-font-old.el @@ -0,0 +1,141 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Jacques Garrigue and Ian T Zimmerman *) +;(* *) +;(* Copyright 1997 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;; useful colors + +(cond + ((x-display-color-p) + (require 'font-lock) + (cond + ((not (boundp 'font-lock-type-face)) + ; make the necessary faces + (make-face 'Firebrick) + (set-face-foreground 'Firebrick "Firebrick") + (make-face 'RosyBrown) + (set-face-foreground 'RosyBrown "RosyBrown") + (make-face 'Purple) + (set-face-foreground 'Purple "Purple") + (make-face 'MidnightBlue) + (set-face-foreground 'MidnightBlue "MidnightBlue") + (make-face 'DarkGoldenRod) + (set-face-foreground 'DarkGoldenRod "DarkGoldenRod") + (make-face 'DarkOliveGreen) + (set-face-foreground 'DarkOliveGreen "DarkOliveGreen4") + (make-face 'CadetBlue) + (set-face-foreground 'CadetBlue "CadetBlue") + ; assign them as standard faces + (setq font-lock-comment-face 'Firebrick) + (setq font-lock-string-face 'RosyBrown) + (setq font-lock-keyword-face 'Purple) + (setq font-lock-function-name-face 'MidnightBlue) + (setq font-lock-variable-name-face 'DarkGoldenRod) + (setq font-lock-type-face 'DarkOliveGreen) + (setq font-lock-reference-face 'CadetBlue))) + ; extra faces for documention + (make-face 'Stop) + (set-face-foreground 'Stop "White") + (set-face-background 'Stop "Red") + (make-face 'Doc) + (set-face-foreground 'Doc "Red") + (setq font-lock-stop-face 'Stop) + (setq font-lock-doccomment-face 'Doc) +)) + +; The same definition is in caml.el: +; we don't know in which order they will be loaded. +(defvar caml-quote-char "'" + "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") + +(defconst caml-font-lock-keywords + (list +;stop special comments + '("\\(^\\|[^\"]\\)\\((\\*\\*/\\*\\*)\\)" + 2 font-lock-stop-face) +;doccomments + '("\\(^\\|[^\"]\\)\\((\\*\\*[^*]*\\([^)*][^*]*\\*+\\)*)\\)" + 2 font-lock-doccomment-face) +;comments + '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)" + 2 font-lock-comment-face) +;character literals + (cons (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|" + "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char + "\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"") + 'font-lock-string-face) +;modules and constructors + '("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) +;definition + (cons (concat + "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)" + "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?" + "\\|in\\(herit\\|itializer\\)?\\|let" + "\\|m\\(ethod\\|utable\\|odule\\)" + "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type" + "\\|v\\(al\\|irtual\\)\\)\\>") + 'font-lock-type-face) +;blocking + '("\\<\\(begin\\|end\\|object\\|s\\(ig\\|truct\\)\\)\\>" + . font-lock-keyword-face) +;control + (cons (concat + "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)" + "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)" + "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>" + "\\|\|\\|->\\|&\\|#") + 'font-lock-reference-face) + '("\\<raise\\>" . font-lock-comment-face) +;labels (and open) + '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 + font-lock-variable-name-face) + '("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" + . font-lock-variable-name-face))) + +(defconst inferior-caml-font-lock-keywords + (append + (list +;inferior + '("^[#-]" . font-lock-comment-face)) + caml-font-lock-keywords)) + +;; font-lock commands are similar for caml-mode and inferior-caml-mode +(defun caml-mode-font-hook () + (cond + ((fboundp 'global-font-lock-mode) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w"))))) + (t + (setq font-lock-keywords caml-font-lock-keywords))) + (make-local-variable 'font-lock-keywords-only) + (setq font-lock-keywords-only t) + (font-lock-mode 1)) + +(add-hook 'caml-mode-hook 'caml-mode-font-hook) + +(defun inferior-caml-mode-font-hook () + (cond + ((fboundp 'global-font-lock-mode) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(inferior-caml-font-lock-keywords + nil nil ((?' . "w") (?_ . "w"))))) + (t + (setq font-lock-keywords inferior-caml-font-lock-keywords))) + (make-local-variable 'font-lock-keywords-only) + (setq font-lock-keywords-only t) + (font-lock-mode 1)) + +(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-font-hook) + +(provide 'caml-font) diff --git a/emacs/caml-font.el b/emacs/caml-font.el index a04d5c94e..2914fdfda 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -1,140 +1,113 @@ -;(***********************************************************************) -;(* *) -;(* Objective Caml *) -;(* *) -;(* Jacques Garrigue and Ian T Zimmerman *) -;(* *) -;(* Copyright 1997 Institut National de Recherche en Informatique et *) -;(* en Automatique. All rights reserved. This file is distributed *) -;(* under the terms of the GNU General Public License. *) -;(* *) -;(***********************************************************************) +;; caml-font: font-lock support for OCaml files +;; +;; rewrite and clean-up. +;; Changes: +;; - fontify strings and comments using syntactic font lock +;; - define a `font-lock-syntactic-face-function' to fontify ocamldoc comments +;; - fontify infix operators like mod, land, lsl, etc. +;; - fontify line number directives +;; - fontify "failwith" and "invalid_arg" like "raise" +;; - fontify '\x..' character constants +;; - use the regexp-opt function to build regexps (more readable) +;; - use backquote and comma in sexp (more readable) +;; - drop the `caml-quote-char' variable (I don't use caml-light :)) +;; - stop doing weird things with faces -;(* $Id$ *) -;; useful colors +(require 'font-lock) -(cond - ((x-display-color-p) - (require 'font-lock) - (cond - ((not (boundp 'font-lock-type-face)) - ; make the necessary faces - (make-face 'Firebrick) - (set-face-foreground 'Firebrick "Firebrick") - (make-face 'RosyBrown) - (set-face-foreground 'RosyBrown "RosyBrown") - (make-face 'Purple) - (set-face-foreground 'Purple "Purple") - (make-face 'MidnightBlue) - (set-face-foreground 'MidnightBlue "MidnightBlue") - (make-face 'DarkGoldenRod) - (set-face-foreground 'DarkGoldenRod "DarkGoldenRod") - (make-face 'DarkOliveGreen) - (set-face-foreground 'DarkOliveGreen "DarkOliveGreen4") - (make-face 'CadetBlue) - (set-face-foreground 'CadetBlue "CadetBlue") - ; assign them as standard faces - (setq font-lock-comment-face 'Firebrick) - (setq font-lock-string-face 'RosyBrown) - (setq font-lock-keyword-face 'Purple) - (setq font-lock-function-name-face 'MidnightBlue) - (setq font-lock-variable-name-face 'DarkGoldenRod) - (setq font-lock-type-face 'DarkOliveGreen) - (setq font-lock-reference-face 'CadetBlue))) - ; extra faces for documention - (make-face 'Stop) - (set-face-foreground 'Stop "White") - (set-face-background 'Stop "Red") - (make-face 'Doc) - (set-face-foreground 'Doc "Red") - (setq font-lock-stop-face 'Stop) - (setq font-lock-doccomment-face 'Doc) -)) +(defvar caml-font-stop-face + (progn + (make-face 'caml-font-stop-face) + (set-face-foreground 'caml-font-stop-face "White") + (set-face-background 'caml-font-stop-face "Red") + 'caml-font-stop-face)) -; The same definition is in caml.el: -; we don't know in which order they will be loaded. -(defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") +(defvar caml-font-doccomment-face + (progn + (make-face 'caml-font-doccomment-face) + (set-face-foreground 'caml-font-doccomment-face "Red") + 'caml-font-doccomment-face)) + +(unless (facep 'font-lock-preprocessor-face) + (defvar font-lock-preprocessor-face + (copy-face 'font-lock-builtin-face + 'font-lock-preprocessor-face))) (defconst caml-font-lock-keywords - (list -;stop special comments - '("\\(^\\|[^\"]\\)\\((\\*\\*/\\*\\*)\\)" - 2 font-lock-stop-face) -;doccomments - '("\\(^\\|[^\"]\\)\\((\\*\\*[^*]*\\([^)*][^*]*\\*+\\)*)\\)" - 2 font-lock-doccomment-face) -;comments - '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)" - 2 font-lock-comment-face) + `( ;character literals - (cons (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|" - "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char - "\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"") - 'font-lock-string-face) + ("'\\(.\\|\\\\\\([ntbr\"'\\\\]\\|[0-9]\\{3\\}\\|x[0-9A-Fa-f]\\{2\\}\\)\\)'" + . font-lock-string-face) ;modules and constructors - '("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) + ("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) ;definition - (cons (concat - "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)" - "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?" - "\\|in\\(herit\\|itializer\\)?\\|let" - "\\|m\\(ethod\\|utable\\|odule\\)" - "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type" - "\\|v\\(al\\|irtual\\)\\)\\>") - 'font-lock-type-face) + (,(regexp-opt '("and" "as" "constraint" "class" + "exception" "external" "fun" "function" "functor" + "in" "inherit" "initializer" "let" + "method" "mutable" "module" "of" "private" "rec" + "type" "val" "virtual") + 'words) + . font-lock-type-face) ;blocking - '("\\<\\(begin\\|end\\|object\\|s\\(ig\\|truct\\)\\)\\>" - . font-lock-keyword-face) + (,(regexp-opt '("begin" "end" "object" "sig" "struct") 'words) + . font-lock-keyword-face) +;linenums + ("# *[0-9]+" . font-lock-preprocessor-face) +;infix operators + (,(regexp-opt '("asr" "land" "lor" "lsl" "lsr" "lxor" "mod") 'words) + . font-lock-builtin-face) ;control - (cons (concat - "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)" - "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)" - "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>" - "\\|\|\\|->\\|&\\|#") - 'font-lock-reference-face) - '("\\<raise\\>" . font-lock-comment-face) + (,(concat "[|#&]\\|->\\|" + (regexp-opt '("do" "done" "dowto" "else" "for" "if" "ignore" + "lazy" "match" "new" "or" "then" "to" "try" + "when" "while" "with") + 'words)) + . font-lock-constant-face) + ("\\<raise\\|failwith\\|invalid_arg\\>" + . font-lock-comment-face) ;labels (and open) - '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 - font-lock-variable-name-face) - '("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" - . font-lock-variable-name-face))) + ("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" + 1 font-lock-variable-name-face) + ("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" + . font-lock-variable-name-face))) -(defconst inferior-caml-font-lock-keywords - (append - (list -;inferior - '("^[#-]" . font-lock-comment-face)) - caml-font-lock-keywords)) -;; font-lock commands are similar for caml-mode and inferior-caml-mode -(add-hook 'caml-mode-hook - '(lambda () - (cond - ((fboundp 'global-font-lock-mode) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w"))))) - (t - (setq font-lock-keywords caml-font-lock-keywords))) - (make-local-variable 'font-lock-keywords-only) - (setq font-lock-keywords-only t) - (font-lock-mode 1))) +(defun caml-font-syntactic-face (s) + (let ((in-string (nth 3 s)) + (in-comment (nth 4 s)) + (start (nth 8 s))) + (cond + (in-string 'font-lock-string-face) + (in-comment + (goto-char start) + (cond + ((looking-at "(\\*\\*/\\*\\*)") 'caml-font-stop-face) + ((looking-at "(\\*\\*[^*]") 'caml-font-doccomment-face) + (t 'font-lock-comment-face)))))) -(defun inferior-caml-mode-font-hook () - (cond - ((fboundp 'global-font-lock-mode) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(inferior-caml-font-lock-keywords - nil nil ((?' . "w") (?_ . "w"))))) - (t - (setq font-lock-keywords inferior-caml-font-lock-keywords))) - (make-local-variable 'font-lock-keywords-only) - (setq font-lock-keywords-only t) + +;; font-lock commands are similar for caml-mode and inferior-caml-mode +(defun caml-font-set-font-lock () + (setq font-lock-defaults + '(caml-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function . caml-font-syntactic-face))) (font-lock-mode 1)) +(add-hook 'caml-mode-hook 'caml-font-set-font-lock) -(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-font-hook) + + +(defconst inferior-caml-font-lock-keywords + `(("^[#-]" . font-lock-comment-face) + ,@caml-font-lock-keywords)) + +(defun inferior-caml-set-font-lock () + (setq font-lock-defaults + '(inferior-caml-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function . caml-font-syntactic-face))) + (font-lock-mode 1)) +(add-hook 'inferior-caml-mode-hooks 'inferior-caml-set-font-lock) (provide 'caml-font) diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 71d47a54b..763edca7e 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -146,10 +146,8 @@ See `caml-types-location-re' for annotation file format. (target-line (1+ (count-lines (point-min) (caml-line-beginning-position)))) (target-bol (caml-line-beginning-position)) - (target-cnum (point)) - (type-file (concat (file-name-sans-extension (buffer-file-name)) - ".annot"))) - (caml-types-preprocess type-file) + (target-cnum (point))) + (caml-types-preprocess (buffer-file-name)) (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) (node (caml-types-find-location targ-loc "type" () @@ -323,28 +321,47 @@ See `caml-types-location-re' for annotation file format. (delete-overlay caml-types-scope-ovl) ))) -(defun caml-types-preprocess (type-file) - (let* ((type-date (nth 5 (file-attributes type-file))) - (target-file (file-name-nondirectory (buffer-file-name))) +(defun caml-types-preprocess (target-path) + (let* ((type-path (caml-types-locate-type-file target-path)) + (type-date (nth 5 (file-attributes (file-chase-links type-path)))) (target-date (nth 5 (file-attributes target-file)))) (unless (and caml-types-annotation-tree type-date caml-types-annotation-date (not (caml-types-date< caml-types-annotation-date type-date))) (if (and type-date target-date (caml-types-date< type-date target-date)) - (error (format "%s is more recent than %s" target-file type-file))) + (error (format "`%s' is more recent than `%s'" target-path type-path))) (message "Reading annotation file...") - (let* ((type-buf (caml-types-find-file type-file)) + (let* ((type-buf (caml-types-find-file type-path)) (tree (with-current-buffer type-buf (widen) (goto-char (point-min)) - (caml-types-build-tree target-file)))) + (caml-types-build-tree + (file-name-nondirectory target-path))))) (setq caml-types-annotation-tree tree caml-types-annotation-date type-date) (kill-buffer type-buf) (message "done")) ))) +(defun caml-types-locate-type-file (target-path) + (let ((sibling (concat (file-name-sans-extension target-path) ".annot"))) + (if (file-exists-p sibling) + sibling + (defun parent-dir (d) (file-name-directory (directory-file-name d))) + (let ((project-dir (file-name-directory sibling)) + type-path) + (while (not (file-exists-p + (setq type-path + (expand-file-name + (file-relative-name sibling project-dir) + (expand-file-name "_build" project-dir))))) + (if (equal project-dir (parent-dir project-dir)) + (error (concat "No annotation file. " + "You should compile with option \"-dtypes\"."))) + (setq project-dir (parent-dir project-dir))) + type-path)))) + (defun caml-types-date< (date1 date2) (or (< (car date1) (car date2)) (and (= (car date1) (car date2)) @@ -553,7 +570,7 @@ See `caml-types-location-re' for annotation file format. (with-current-buffer buf (toggle-read-only 1)) ) (t - (error "No annotation file. You should compile with option \"-annot\".")) + (error (format "Can't read the annotation file `%s'" name))) ) buf)) @@ -582,8 +599,6 @@ The function uses two overlays. (set-buffer (window-buffer (caml-event-window event))) (let* ((target-buf (current-buffer)) (target-file (file-name-nondirectory (buffer-file-name))) - (type-file (concat (file-name-sans-extension (buffer-file-name)) - ".annot")) (target-line) (target-bol) target-pos Left Right limits cnum node mes type @@ -597,7 +612,7 @@ The function uses two overlays. (select-window window) (unwind-protect (progn - (caml-types-preprocess type-file) + (caml-types-preprocess (buffer-file-name)) (setq target-tree caml-types-annotation-tree) (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) ;; (message "Drag the mouse to explore types") diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 75c17ba97..5a61f2eb0 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,3 +1,17 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Nicolas Pouillard, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 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$ *) + open Ocamlbuild_plugin open Command open Arch @@ -24,7 +38,7 @@ let mkexe out files opts = let mklib out files opts = let s = Command.string_of_command_spec in - Cmd(Sh(C.mklib out (s files) (s opts))) + Cmd(Sh(C.mklib out (s files) (s opts))) let syslib x = A(C.syslib x);; let syscamllib x = @@ -67,7 +81,7 @@ let add_exe_if_exists a = if Pathname.exists exe then exe else a;; let convert_command_for_windows_shell spec = - if not windows then spec else + if not windows then spec else let rec self specs acc = match specs with | N :: specs -> self specs acc @@ -149,7 +163,7 @@ dispatch begin function "toplevel"; "typing"; "utils"] in Ocamlbuild_pack.Configuration.parse_string (sprintf "<{%s}/**>: not_hygienic, -traverse" patt) - + | After_options -> begin Options.ocamlrun := ocamlrun; @@ -563,8 +577,8 @@ rule "The numeric opcodes" ~prod:"bytecomp/opcodes.ml" ~dep:"byterun/instruct.h" ~insert:`top - begin fun _ _ -> - Cmd(Sh "sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \ + begin fun _ _ -> + Cmd(Sh "sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \ awk -f ../tools/make-opcodes > bytecomp/opcodes.ml") end;; @@ -573,9 +587,9 @@ rule "tools/opnames.ml" ~dep:"byterun/instruct.h" begin fun _ _ -> Cmd(Sh"unset LC_ALL || : ; \ - unset LC_CTYPE || : ; \ - unset LC_COLLATE LANG || : ; \ - sed -e '/\\/\\*/d' \ + unset LC_CTYPE || : ; \ + unset LC_COLLATE LANG || : ; \ + sed -e '/\\/\\*/d' \ -e '/^#/d' \ -e 's/enum \\(.*\\) {/let names_of_\\1 = [|/' \ -e 's/};$/ |]/' \ @@ -932,7 +946,7 @@ let builtins = let labltk_support = ["support"; "rawwidget"; "widget"; "protocol"; "textvariable"; "timer"; "fileevent"; "camltkwrap"];; -let labltk_generated_modules = +let labltk_generated_modules = ["place"; "wm"; "imagephoto"; "canvas"; "button"; "text"; "label"; "scrollbar"; "image"; "encoding"; "pixmap"; "palette"; "font"; "message"; "menu"; "entry"; "listbox"; "focus"; "menubutton"; "pack"; "option"; "toplevel"; "frame"; diff --git a/ocamlbuild/examples/example_with_C/_tags b/ocamlbuild/examples/example_with_C/_tags deleted file mode 100644 index 769cb463b..000000000 --- a/ocamlbuild/examples/example_with_C/_tags +++ /dev/null @@ -1 +0,0 @@ -<*caml.o>: output_obj diff --git a/ocamlbuild/examples/example_with_C/fib.ml b/ocamlbuild/examples/example_with_C/fib.ml deleted file mode 100644 index ef6dbd438..000000000 --- a/ocamlbuild/examples/example_with_C/fib.ml +++ /dev/null @@ -1,5 +0,0 @@ -let x = X.x - -let rec fib n = if n <= 1 then 1 else fib (n - 1) + fib (n - 2) - -let () = Callback.register "fib" fib diff --git a/ocamlbuild/examples/example_with_C/fibwrap.c b/ocamlbuild/examples/example_with_C/fibwrap.c deleted file mode 100644 index cc2104b67..000000000 --- a/ocamlbuild/examples/example_with_C/fibwrap.c +++ /dev/null @@ -1,7 +0,0 @@ - /* -*- C -*- */ -#include <caml/mlvalues.h> -#include <caml/callback.h> -int fib(int n) -{ - return Int_val(caml_callback(*caml_named_value("fib"), Val_int(n))); -} diff --git a/ocamlbuild/examples/example_with_C/main.c b/ocamlbuild/examples/example_with_C/main.c deleted file mode 100644 index c7f6bb5d2..000000000 --- a/ocamlbuild/examples/example_with_C/main.c +++ /dev/null @@ -1,10 +0,0 @@ - /* -*- C -*- */ -#include <stdio.h> -#include <caml/callback.h> -extern int fib(int); -int main(int argc, char** argv) -{ - caml_startup(argv); - printf("fib(12) = %d\n", fib(12)); - return 0; -} diff --git a/ocamlbuild/examples/example_with_C/myocamlbuild.ml b/ocamlbuild/examples/example_with_C/myocamlbuild.ml deleted file mode 100644 index f53df7e10..000000000 --- a/ocamlbuild/examples/example_with_C/myocamlbuild.ml +++ /dev/null @@ -1,35 +0,0 @@ -open Ocamlbuild_plugin;; -open Command;; - -let cc = A"cc";; -let ar = A"ar";; - -dispatch begin function -| After_rules -> - let libasmrun = !*Ocamlbuild_pack.Ocaml_utils.stdlib_dir/"libasmrun.a" in - - flag ["ocaml"; "link"; "output_obj"] (A"-output-obj"); - - rule "output C obj" - ~deps:["%.cmx"; "%.o"] - ~prod:"%caml.o" - (Ocamlbuild_pack.Ocaml_compiler.native_link "%.cmx" "%caml.o"); - - rule "build C lib" - ~deps:["%wrap.o"; "%caml.o"] - ~prod:"lib%.a" - begin fun env _ -> - let wrap_o = env "%wrap.o" and caml_o = env "%caml.o" - and lib_a = env "lib%.a" in - Seq[cp libasmrun lib_a; - Cmd(S[ar; A"r"; Px lib_a; P caml_o; P wrap_o])] - end; - rule "build main" - ~deps:["libfib.a"; "main.o"] - ~prod:"main" - begin fun _ _ -> - Cmd(S[cc; P"main.o"; P"libfib.a"; A"-o"; Px"main"]) - end; -| _ -> () -end - diff --git a/ocamlbuild/examples/example_with_C/x.ml b/ocamlbuild/examples/example_with_C/x.ml deleted file mode 100644 index 7fecab12d..000000000 --- a/ocamlbuild/examples/example_with_C/x.ml +++ /dev/null @@ -1 +0,0 @@ -let x = 42 diff --git a/ocamlbuild/start.sh b/ocamlbuild/start.sh index dbbe72c52..662392b5f 100755 --- a/ocamlbuild/start.sh +++ b/ocamlbuild/start.sh @@ -1,4 +1,19 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 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$ + set -e set -x rm -rf _start diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 4e9256b24..14a596763 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -334,7 +334,7 @@ autotest_stdlib: dummy clean:: dummy @rm -f *~ \#*\# - @rm -f $(OCAMLDOC)$(EXE) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o + @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index d935db9a4..fd8aa6091 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -14,7 +14,7 @@ (* $Id$ *) (** Generation of html code to display OCaml code. *) -open Lexing +open Lexing exception Fatal_error @@ -31,17 +31,17 @@ type error = exception Error of error * int * int -let base_escape_strings = [ - ("&", "&") ; - ("<", "<") ; - (">", ">") ; -] +let base_escape_strings = [ + ("&", "&") ; + ("<", "<") ; + (">", ">") ; +] let pre_escape_strings = [ (" ", " ") ; ("\n", "<br>\n") ; ("\t", " ") ; - ] + ] let pre = ref false @@ -49,7 +49,7 @@ let fmt = ref Format.str_formatter (** Escape the strings which would clash with html syntax, and some other strings if we want to get a PRE style.*) -let escape s = +let escape s = List.fold_left (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc) s @@ -64,7 +64,7 @@ let escape_base s = (** The output functions *) -let print ?(esc=true) s = +let print ?(esc=true) s = Format.pp_print_string !fmt (if esc then escape s else s) ;; @@ -81,7 +81,7 @@ let create_hashtable size init = tbl (** The function used to return html code for the given comment body. *) -let html_of_comment = ref +let html_of_comment = ref (fun (s : string) -> "<b>Odoc_ocamlhtml.html_of_comment not initialized</b>") let keyword_table = @@ -160,6 +160,7 @@ let margin = ref 0 let comment_buffer = Buffer.create 32 let reset_comment_buffer () = Buffer.reset comment_buffer let store_comment_char = Buffer.add_char comment_buffer +let add_comment_string = Buffer.add_string comment_buffer let make_margin () = let rec iter n = @@ -171,14 +172,14 @@ let make_margin () = let print_comment () = let s = Buffer.contents comment_buffer in let len = String.length s in - let code = + let code = if len < 1 then "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" else - match s.[0] with - '*' -> + match s.[0] with + '*' -> ( - try + try let html = !html_of_comment (String.sub s 1 (len-1)) in "</code><table><tr><td>"^(make_margin ())^"</td><td>"^ "<span class=\""^comment_class^"\">"^ @@ -199,7 +200,7 @@ let print_comment () = let string_buffer = Buffer.create 32 let reset_string_buffer () = Buffer.reset string_buffer let store_string_char = Buffer.add_char string_buffer -let get_stored_string () = +let get_stored_string () = let s = Buffer.contents string_buffer in String.escaped s @@ -215,7 +216,7 @@ let char_for_backslash = function let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) (** To store the position of the beginning of a string and comment *) @@ -245,7 +246,7 @@ let report_error ppf = function let blank = [' ' '\010' '\013' '\009' '\012'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar = +let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] @@ -258,17 +259,17 @@ let float_literal = rule token = parse blank - { + { let s = Lexing.lexeme lexbuf in ( match s with - " " -> incr margin + " " -> incr margin | "\t" -> margin := !margin + 8 | "\n" -> margin := 0 | _ -> () ); print s; - token lexbuf + token lexbuf } | "_" { print "_" ; token lexbuf } @@ -320,9 +321,9 @@ rule token = parse { print_class string_class (Lexing.lexeme lexbuf ) ; token lexbuf } | "(*" - { + { reset_comment_buffer (); - comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf ; print_comment (); token lexbuf } @@ -335,18 +336,18 @@ rule token = parse } | "*)" { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; - lexbuf.Lexing.lex_curr_p <- + lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 } ; print (Lexing.lexeme lexbuf) ; - token lexbuf + token lexbuf } | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") (* # linenum ... *) - { + { print (Lexing.lexeme lexbuf); - token lexbuf + token lexbuf } | "#" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "&" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } @@ -419,7 +420,7 @@ and comment = parse { match !comment_start_pos with | [] -> assert false | [x] -> comment_start_pos := [] - | _ :: l -> + | _ :: l -> store_comment_char '*'; store_comment_char ')'; comment_start_pos := l; @@ -429,32 +430,33 @@ and comment = parse { reset_string_buffer(); string_start_pos := Lexing.lexeme_start lexbuf; store_comment_char '"'; - begin try string lexbuf - with Error (Unterminated_string, _, _) -> + begin + try string lexbuf; add_comment_string ((get_stored_string()^"\"")) + with Error (Unterminated_string, _, _) -> let st = List.hd !comment_start_pos in raise (Error (Unterminated_string_in_comment, st, st + 2)) end; comment lexbuf } | "''" - { + { store_comment_char '\''; store_comment_char '\''; comment lexbuf } | "'" [^ '\\' '\''] "'" - { + { store_comment_char '\''; store_comment_char (Lexing.lexeme_char lexbuf 1); store_comment_char '\''; comment lexbuf } | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" - { + { store_comment_char '\''; store_comment_char '\\'; store_comment_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)) ; store_comment_char '\''; comment lexbuf } | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - { + { store_comment_char '\''; store_comment_char '\\'; store_comment_char(char_for_decimal_code lexbuf 1); @@ -497,10 +499,10 @@ let html_of_code b ?(with_pre=true) code = fmt := Format.formatter_of_buffer buf ; pre := with_pre; margin := 0; - + let start = "<code class=\""^code_class^"\">" in let ending = "</code>" in - let html = + let html = ( try print ~esc: false start ; @@ -510,8 +512,8 @@ let html_of_code b ?(with_pre=true) code = Format.pp_print_flush !fmt () ; Buffer.contents buf with - _ -> - (* flush str_formatter because we already output + _ -> + (* flush str_formatter because we already output something in it *) Format.pp_print_flush !fmt () ; start^code^ending @@ -527,4 +529,4 @@ let html_of_code b ?(with_pre=true) code = Buffer.add_string b html -} +} diff --git a/otherlibs/labltk/support/tkthread.ml b/otherlibs/labltk/support/tkthread.ml index 04dcc74c5..ecdf61460 100644 --- a/otherlibs/labltk/support/tkthread.ml +++ b/otherlibs/labltk/support/tkthread.ml @@ -20,20 +20,18 @@ let with_jobs f = Mutex.lock m; let y = f jobs in Mutex.unlock m; y let loop_id = ref None -let reset () = loop_id := None -let cannot_sync () = - match !loop_id with None -> true - | Some id -> Thread.id (Thread.self ()) = id - let gui_safe () = !loop_id = Some(Thread.id (Thread.self ())) +let running () = + !loop_id <> None let has_jobs () = not (with_jobs Queue.is_empty) let n_jobs () = with_jobs Queue.length let do_next_job () = with_jobs Queue.take () let async j x = with_jobs (Queue.add (fun () -> j x)) let sync f x = - if cannot_sync () then f x else + if !loop_id = None then failwith "Tkthread.sync"; + if gui_safe () then f x else let m = Mutex.create () in let res = ref None in Mutex.lock m; @@ -62,6 +60,8 @@ let thread_main () = raise exn let start () = - Thread.create thread_main () + let th = Thread.create thread_main () in + loop_id := Some (Thread.id th); + th let top = Widget.default_toplevel diff --git a/otherlibs/labltk/support/tkthread.mli b/otherlibs/labltk/support/tkthread.mli index 88883a5db..7e871d9cd 100644 --- a/otherlibs/labltk/support/tkthread.mli +++ b/otherlibs/labltk/support/tkthread.mli @@ -19,7 +19,7 @@ (** Start the main loop in a new GUI thread. Do not use recursively. *) val start : unit -> Thread.t -(** The actual function executed in the new thread *) +(** The actual function executed in the GUI thread *) val thread_main : unit -> unit (** The toplevel widget (an alias of [Widget.default_toplevel]) *) val top : Widget.toplevel Widget.widget @@ -33,11 +33,14 @@ val top : Widget.toplevel Widget.widget With sync, beware of deadlocks! *) -(** Add an asynchronous job (to do in the main thread) *) +(** Add an asynchronous job (to do in the GUI thread) *) val async : ('a -> unit) -> 'a -> unit -(** Add a synchronous job (to do in the main thread) *) +(** Add a synchronous job (to do in the GUI thread). + Raise [Failure "Tkthread.sync"] if there is no such thread. *) val sync : ('a -> 'b) -> 'a -> 'b (** Whether the current thread is the GUI thread. Note that when using X11 it is generally safe to call most Tk functions from other threads too. *) val gui_safe : unit -> bool +(** Whether a GUI thread is running *) +val running : unit -> bool diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index f5e101548..e41abff17 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -120,7 +120,7 @@ CAMLprim value is_digit_zero(value nat, value ofs) CAMLprim value is_digit_normalized(value nat, value ofs) { return - Val_bool(Digit_val(nat, Long_val(ofs)) & (1L << (BNG_BITS_PER_DIGIT-1))); + Val_bool(Digit_val(nat, Long_val(ofs)) & ((bngdigit)1 << (BNG_BITS_PER_DIGIT-1))); } CAMLprim value is_digit_odd(value nat, value ofs) @@ -341,7 +341,7 @@ static void serialize_nat(value nat, #ifdef ARCH_SIXTYFOUR len = len * 2; /* two 32-bit words per 64-bit digit */ - if (len >= (1L << 32)) + if (len >= ((mlsize_t)1 << 32)) failwith("output_value: nat too big"); #endif serialize_int_4((int32) len); diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml index 31b623284..080efae9f 100644 --- a/otherlibs/str/str.ml +++ b/otherlibs/str/str.ml @@ -669,9 +669,9 @@ and replace_first expr repl text = let search_forward_progress expr text start = let pos = search_forward expr text start in - if match_end() = start && start < String.length text - then search_forward expr text (start + 1) - else pos + if match_end() > start then pos + else if start < String.length text then search_forward expr text (start + 1) + else raise Not_found let bounded_split expr text num = let start = diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index 0e5354241..7c4a572a6 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -801,7 +801,7 @@ static void decode_sigset(value vset, sigset_t * set) { sigemptyset(set); while (vset != Val_int(0)) { - int sig = convert_signal_number(Int_val(Field(vset, 0))); + int sig = caml_convert_signal_number(Int_val(Field(vset, 0))); sigaddset(set, sig); vset = Field(vset, 1); } @@ -818,9 +818,9 @@ static value encode_sigset(sigset_t * set) Begin_root(res) for (i = 1; i < NSIG; i++) - if (sigismember(set, i)) { + if (sigismember(set, i) > 0) { value newcons = alloc_small(2, 0); - Field(newcons, 0) = Val_int(i); + Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i)); Field(newcons, 1) = res; res = newcons; } diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli index af274bfc8..8394a47bc 100644 --- a/otherlibs/systhreads/thread.mli +++ b/otherlibs/systhreads/thread.mli @@ -33,10 +33,10 @@ val create : ('a -> 'b) -> 'a -> t result of the application [funct arg] is discarded and not directly accessible to the parent thread. *) -external self : unit -> t = "caml_thread_self" +val self : unit -> t (** Return the thread currently executing. *) -external id : t -> int = "caml_thread_id" +val id : t -> int (** Return the identifier of the given thread. A thread identifier is an integer that identifies uniquely the thread. It can be used to build data structures indexed by threads. *) @@ -54,7 +54,7 @@ val delay: float -> unit [d] seconds. The other program threads continue to run during this time. *) -external join : t -> unit = "caml_thread_join" +val join : t -> unit (** [join th] suspends the execution of the calling thread until the thread [th] has terminated. *) diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c index d7065c68e..0c0c5fc1a 100644 --- a/otherlibs/unix/access.c +++ b/otherlibs/unix/access.c @@ -31,7 +31,7 @@ # else # define R_OK 4/* test for read permission */ # define W_OK 2/* test for write permission */ -# define X_OK 1/* test for execute (search) permission */ +# define X_OK 4/* test for execute permission - not implemented in Win32 */ # define F_OK 0/* test for presence of file */ # endif #endif diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c index b244f8af6..c388b1393 100644 --- a/otherlibs/unix/signals.c +++ b/otherlibs/unix/signals.c @@ -24,7 +24,7 @@ #include "unixsupport.h" #ifndef NSIG -#define NSIG 32 +#define NSIG 64 #endif #ifdef POSIX_SIGNALS @@ -33,7 +33,7 @@ static void decode_sigset(value vset, sigset_t * set) { sigemptyset(set); while (vset != Val_int(0)) { - int sig = convert_signal_number(Int_val(Field(vset, 0))); + int sig = caml_convert_signal_number(Int_val(Field(vset, 0))); sigaddset(set, sig); vset = Field(vset, 1); } @@ -46,9 +46,9 @@ static value encode_sigset(sigset_t * set) Begin_root(res) for (i = 1; i < NSIG; i++) - if (sigismember(set, i)) { + if (sigismember(set, i) > 0) { value newcons = alloc_small(2, 0); - Field(newcons, 0) = Val_int(i); + Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i)); Field(newcons, 1) = res; res = newcons; } diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index cf73b4835..acc0d74a4 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -758,7 +758,8 @@ val times : unit -> process_times val utimes : string -> float -> float -> unit (** Set the last access time (second arg) and last modification time (third arg) for a file. Times are expressed in seconds from - 00:00:00 GMT, Jan. 1, 1970. *) + 00:00:00 GMT, Jan. 1, 1970. A time of [0.0] is interpreted as the + current time. *) type interval_timer = ITIMER_REAL diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 4ea1f4c86..11fe09350 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -383,7 +383,7 @@ module LargeFile : (** File operations on large files. This sub-module provides 64-bit variants of the functions {!UnixLabels.lseek} (for positioning a file descriptor), - {!UnixLabels.truncate} and {!UnixLabels.ftruncate} + {!UnixLabels.truncate} and {!UnixLabels.ftruncate} (for changing the size of a file), and {!UnixLabels.stat}, {!UnixLabels.lstat} and {!UnixLabels.fstat} (for obtaining information on files). These alternate functions represent @@ -577,23 +577,23 @@ val open_process_full : and standard error of the command. *) val close_process_in : in_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_in}, +(** Close channels opened by {!UnixLabels.open_process_in}, wait for the associated command to terminate, and return its termination status. *) val close_process_out : out_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_out}, +(** Close channels opened by {!UnixLabels.open_process_out}, wait for the associated command to terminate, and return its termination status. *) val close_process : in_channel * out_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process}, +(** Close channels opened by {!UnixLabels.open_process}, wait for the associated command to terminate, and return its termination status. *) val close_process_full : in_channel * out_channel * in_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_full}, +(** Close channels opened by {!UnixLabels.open_process_full}, wait for the associated command to terminate, and return its termination status. *) @@ -675,7 +675,7 @@ val kill : pid:int -> signal:int -> unit (** [kill pid sig] sends signal number [sig] to the process with id [pid]. *) -type sigprocmask_command = Unix.sigprocmask_command = +type sigprocmask_command = Unix.sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK @@ -913,7 +913,7 @@ type socket_type = Unix.socket_type = (** The type of socket kinds, specifying the semantics of communications. *) -type sockaddr = Unix.sockaddr = +type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int (** The type of socket addresses. [ADDR_UNIX name] is a socket @@ -971,11 +971,11 @@ val getsockname : file_descr -> sockaddr val getpeername : file_descr -> sockaddr (** Return the address of the host connected to the given socket. *) -type msg_flag = Unix.msg_flag = +type msg_flag = Unix.msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK -(** The flags for {!UnixLabels.recv}, {!UnixLabels.recvfrom}, +(** The flags for {!UnixLabels.recv}, {!UnixLabels.recvfrom}, {!UnixLabels.send} and {!UnixLabels.sendto}. *) val recv : @@ -1271,7 +1271,7 @@ val tcgetattr : file_descr -> terminal_io (** Return the status of the terminal referred to by the given file descriptor. *) -type setattr_when = Unix.setattr_when = +type setattr_when = Unix.setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH @@ -1295,7 +1295,7 @@ val tcdrain : file_descr -> unit (** Waits until all output written on the given file descriptor has been transmitted. *) -type flush_queue = Unix.flush_queue = +type flush_queue = Unix.flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH @@ -1307,7 +1307,7 @@ val tcflush : file_descr -> mode:flush_queue -> unit [TCOFLUSH] flushes data written but not transmitted, and [TCIOFLUSH] flushes both. *) -type flow_action = Unix.flow_action = +type flow_action = Unix.flow_action = TCOOFF | TCOON | TCIOFF diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c index 8a92d18f0..d91d707b4 100644 --- a/otherlibs/win32unix/createprocess.c +++ b/otherlibs/win32unix/createprocess.c @@ -62,7 +62,7 @@ value win_create_process_native(value cmd, value cmdline, value env, CloseHandle(pi.hThread); /* Return the process handle as pseudo-PID (this is consistent with the wait() emulation in the MSVC C library */ - return Val_int(pi.hProcess); + return Val_long(pi.hProcess); } CAMLprim value win_create_process(value * argv, int argn) diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c index 76e73e3ae..f2f334bbb 100644 --- a/otherlibs/win32unix/open.c +++ b/otherlibs/win32unix/open.c @@ -18,12 +18,13 @@ #include "unixsupport.h" #include <fcntl.h> -static int open_access_flags[8] = { - GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE, 0, 0, 0, 0, 0, +static int open_access_flags[12] = { + GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE, + 0, 0, 0, 0, 0, 0, 0, 0, 0 }; -static int open_create_flags[8] = { - 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL +static int open_create_flags[12] = { + 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0 }; CAMLprim value unix_open(value path, value flags, value perm) diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c index ad510c4b4..895a6926b 100644 --- a/otherlibs/win32unix/winwait.c +++ b/otherlibs/win32unix/winwait.c @@ -63,6 +63,8 @@ CAMLprim value win_waitpid(value vflags, value vpid_req) } if (status == STILL_ACTIVE) return alloc_process_status((HANDLE) 0, 0); - else + else { + CloseHandle(pid_req); return alloc_process_status(pid_req, status); + } } diff --git a/parsing/location.ml b/parsing/location.ml index 1516b16d7..15b074acd 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -70,9 +70,10 @@ let status = ref Terminfo.Uninitialised let num_loc_lines = ref 0 (* number of lines already printed after input *) -(* Highlight the location using standout mode. *) +(* Highlight the locations using standout mode. *) let highlight_terminfo ppf num_lines lb loc1 loc2 = + Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) let pos0 = -lb.lex_abs_pos in (* Do nothing if the buffer does not contain the whole phrase. *) @@ -125,7 +126,7 @@ let highlight_dumb ppf lb loc = Format.fprintf ppf "Characters %i-%i:@." loc.loc_start.pos_cnum loc.loc_end.pos_cnum; (* Print the input, underlining the location *) - print_string " "; + Format.pp_print_string ppf " "; let line = ref 0 in let pos_at_bol = ref 0 in for pos = 0 to end_pos do @@ -133,34 +134,34 @@ let highlight_dumb ppf lb loc = if c <> '\n' then begin if !line = !line_start && !line = !line_end then (* loc is on one line: print whole line *) - print_char c + Format.pp_print_char ppf c else if !line = !line_start then (* first line of multiline loc: print ... before loc_start *) if pos < loc.loc_start.pos_cnum - then print_char '.' - else print_char c + then Format.pp_print_char ppf '.' + else Format.pp_print_char ppf c else if !line = !line_end then (* last line of multiline loc: print ... after loc_end *) if pos < loc.loc_end.pos_cnum - then print_char c - else print_char '.' + then Format.pp_print_char ppf c + else Format.pp_print_char ppf '.' else if !line > !line_start && !line < !line_end then (* intermediate line of multiline loc: print whole line *) - print_char c + Format.pp_print_char ppf c end else begin if !line = !line_start && !line = !line_end then begin (* loc is on one line: underline location *) - print_string "\n "; + Format.fprintf ppf "@. "; for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do - print_char ' ' + Format.pp_print_char ppf ' ' done; for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do - print_char '^' + Format.pp_print_char ppf '^' done end; if !line >= !line_start && !line <= !line_end then begin - print_char '\n'; - if pos < loc.loc_end.pos_cnum then print_string " " + Format.fprintf ppf "@."; + if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " " end; incr line; pos_at_bol := pos + 1; diff --git a/parsing/parser.mly b/parsing/parser.mly index e30a6a3c9..e5f7133d3 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -443,8 +443,8 @@ structure_item: { match $3 with [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp) | _ -> mkstr(Pstr_value($2, List.rev $3)) } - | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mkstr(Pstr_primitive($2, {pval_type = $3; pval_prim = $5})) } + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) } | TYPE type_declarations { mkstr(Pstr_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments @@ -507,10 +507,10 @@ signature: | signature signature_item SEMISEMI { $2 :: $1 } ; signature_item: - VAL val_ident_colon core_type - { mksig(Psig_value($2, {pval_type = $3; pval_prim = []})) } - | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mksig(Psig_value($2, {pval_type = $3; pval_prim = $5})) } + VAL val_ident COLON core_type + { mksig(Psig_value($2, {pval_type = $4; pval_prim = []})) } + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + { mksig(Psig_value($2, {pval_type = $4; pval_prim = $6})) } | TYPE type_declarations { mksig(Psig_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments @@ -666,8 +666,6 @@ concrete_method : { $3, $2, ghexp(Pexp_poly ($4, None)), symbol_rloc () } | METHOD private_flag label COLON poly_type EQUAL seq_expr { $3, $2, ghexp(Pexp_poly($7,Some $5)), symbol_rloc () } - | METHOD private_flag LABEL poly_type EQUAL seq_expr - { $3, $2, ghexp(Pexp_poly($6,Some $4)), symbol_rloc () } ; /* Class types */ @@ -1412,11 +1410,6 @@ val_ident: LIDENT { $1 } | LPAREN operator RPAREN { $2 } ; -val_ident_colon: - LIDENT COLON { $1 } - | LPAREN operator RPAREN COLON { $2 } - | LABEL { $1 } -; operator: PREFIXOP { $1 } | INFIXOP0 { $1 } diff --git a/stdlib/arg.ml b/stdlib/arg.ml index dd6c51753..009e20375 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -65,7 +65,7 @@ let make_symlist prefix sep suffix l = let print_spec buf (key, spec, doc) = match spec with - | Symbol (l, _) -> bprintf buf " %s %s %s\n" key (make_symlist "{" "|" "}" l) + | Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) doc | _ -> bprintf buf " %s %s\n" key doc ;; @@ -225,13 +225,18 @@ let rec second_word s = with Not_found -> len ;; -let max_arg_len cur (kwd, _, doc) = - max cur (String.length kwd + second_word doc) +let max_arg_len cur (kwd, spec, doc) = + match spec with + | Symbol _ -> max cur (String.length kwd) + | _ -> max cur (String.length kwd + second_word doc) ;; let add_padding len ksd = match ksd with - | (_, Symbol _, _) -> ksd + | (kwd, (Symbol (l, _) as spec), msg) -> + let cutcol = second_word msg in + let spaces = String.make (len - cutcol + 3) ' ' in + (kwd, spec, "\n" ^ spaces ^ msg) | (kwd, spec, msg) -> let cutcol = second_word msg in let spaces = String.make (len - String.length kwd - cutcol) ' ' in diff --git a/stdlib/arg.mli b/stdlib/arg.mli index bc33d239f..4e5ed08d1 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -125,7 +125,7 @@ val align: (key * spec * doc) list -> (key * spec * doc) list;; space, according to the length of the keyword. Use a space as the first character in a doc string if you want to align the whole string. The doc strings corresponding to - [Symbol] arguments are not aligned. *) + [Symbol] arguments are aligned on the next line. *) val current : int ref (** Position (in {!Sys.argv}) of the argument being processed. You can diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml index 17419aef5..12a77cc8f 100644 --- a/stdlib/camlinternalMod.ml +++ b/stdlib/camlinternalMod.ml @@ -48,8 +48,16 @@ let rec update_mod shape o n = then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) | Lazy -> - assert (Obj.tag n = Obj.lazy_tag); - overwrite o n + if Obj.tag n = Obj.lazy_tag then + Obj.set_field o 0 (Obj.field n 0) + else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 (Obj.field n 0) + end else begin + (* forwarding pointer was shortcut by GC *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 n + end | Class -> assert (Obj.tag n = 0 && Obj.size n = 4); overwrite o n diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 2205a37fe..2ffa71c0a 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -262,7 +262,7 @@ let new_variable table name = try Vars.find name table.vars with Not_found -> let index = new_slot table in - table.vars <- Vars.add name index table.vars; + if name <> "" then table.vars <- Vars.add name index table.vars; index let to_array arr = diff --git a/stdlib/format.ml b/stdlib/format.ml index 7f6fcc4a4..f0af85a79 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -67,7 +67,9 @@ and tblock = Pp_tbox of int list ref (* Tabulation box *) size is set when the size of the block is known len is the declared length of the token. *) type pp_queue_elem = { - mutable elem_size : size; token : pp_token; length : int + mutable elem_size : size; + token : pp_token; + length : int; };; (* Scan stack: @@ -82,75 +84,80 @@ type pp_scan_elem = Scan_elem of int * pp_queue_elem;; type pp_format_elem = Format_elem of block_type * int;; (* General purpose queues, used in the formatter. *) -type 'a queue_elem = | Nil | Cons of 'a queue_cell -and 'a queue_cell = {mutable head : 'a; mutable tail : 'a queue_elem};; +type 'a queue_elem = + | Nil + | Cons of 'a queue_cell + +and 'a queue_cell = { + mutable head : 'a; + mutable tail : 'a queue_elem; +};; type 'a queue = { - mutable insert : 'a queue_elem; - mutable body : 'a queue_elem + mutable insert : 'a queue_elem; + mutable body : 'a queue_elem; };; (* The formatter specific tag handling functions. *) type formatter_tag_functions = { - mark_open_tag : tag -> string; - mark_close_tag : tag -> string; - print_open_tag : tag -> unit; - print_close_tag : tag -> unit; - + mark_open_tag : tag -> string; + mark_close_tag : tag -> string; + print_open_tag : tag -> unit; + print_close_tag : tag -> unit; };; (* A formatter with all its machinery. *) type formatter = { - mutable pp_scan_stack : pp_scan_elem list; - mutable pp_format_stack : pp_format_elem list; - mutable pp_tbox_stack : tblock list; - mutable pp_tag_stack : tag list; - mutable pp_mark_stack : tag list; - (* Global variables: default initialization is - set_margin 78 - set_min_space_left 0. *) - (* Value of right margin. *) - mutable pp_margin : int; - (* Minimal space left before margin, when opening a block. *) - mutable pp_min_space_left : int; - (* Maximum value of indentation: - no blocks can be opened further. *) - mutable pp_max_indent : int; - (* Space remaining on the current line. *) - mutable pp_space_left : int; - (* Current value of indentation. *) - mutable pp_current_indent : int; - (* True when the line has been broken by the pretty-printer. *) - mutable pp_is_new_line : bool; - (* Total width of tokens already printed. *) - mutable pp_left_total : int; - (* Total width of tokens ever put in queue. *) - mutable pp_right_total : int; - (* Current number of opened blocks. *) - mutable pp_curr_depth : int; - (* Maximum number of blocks which can be simultaneously opened. *) - mutable pp_max_boxes : int; - (* Ellipsis string. *) - mutable pp_ellipsis : string; - (* Output function. *) - mutable pp_output_function : string -> int -> int -> unit; - (* Flushing function. *) - mutable pp_flush_function : unit -> unit; - (* Output of new lines. *) - mutable pp_output_newline : unit -> unit; - (* Output of indentation spaces. *) - mutable pp_output_spaces : int -> unit; - (* Are tags printed ? *) - mutable pp_print_tags : bool; - (* Are tags marked ? *) - mutable pp_mark_tags : bool; - (* Find opening and closing markers of tags. *) - mutable pp_mark_open_tag : tag -> string; - mutable pp_mark_close_tag : tag -> string; - mutable pp_print_open_tag : tag -> unit; - mutable pp_print_close_tag : tag -> unit; - (* The pretty-printer queue. *) - mutable pp_queue : pp_queue_elem queue + mutable pp_scan_stack : pp_scan_elem list; + mutable pp_format_stack : pp_format_elem list; + mutable pp_tbox_stack : tblock list; + mutable pp_tag_stack : tag list; + mutable pp_mark_stack : tag list; + (* Global variables: default initialization is + set_margin 78 + set_min_space_left 0. *) + (* Value of right margin. *) + mutable pp_margin : int; + (* Minimal space left before margin, when opening a block. *) + mutable pp_min_space_left : int; + (* Maximum value of indentation: + no blocks can be opened further. *) + mutable pp_max_indent : int; + (* Space remaining on the current line. *) + mutable pp_space_left : int; + (* Current value of indentation. *) + mutable pp_current_indent : int; + (* True when the line has been broken by the pretty-printer. *) + mutable pp_is_new_line : bool; + (* Total width of tokens already printed. *) + mutable pp_left_total : int; + (* Total width of tokens ever put in queue. *) + mutable pp_right_total : int; + (* Current number of opened blocks. *) + mutable pp_curr_depth : int; + (* Maximum number of blocks which can be simultaneously opened. *) + mutable pp_max_boxes : int; + (* Ellipsis string. *) + mutable pp_ellipsis : string; + (* Output function. *) + mutable pp_output_function : string -> int -> int -> unit; + (* Flushing function. *) + mutable pp_flush_function : unit -> unit; + (* Output of new lines. *) + mutable pp_output_newline : unit -> unit; + (* Output of indentation spaces. *) + mutable pp_output_spaces : int -> unit; + (* Are tags printed ? *) + mutable pp_print_tags : bool; + (* Are tags marked ? *) + mutable pp_mark_tags : bool; + (* Find opening and closing markers of tags. *) + mutable pp_mark_open_tag : tag -> string; + mutable pp_mark_close_tag : tag -> string; + mutable pp_print_open_tag : tag -> unit; + mutable pp_print_close_tag : tag -> unit; + (* The pretty-printer queue. *) + mutable pp_queue : pp_queue_elem queue; };; (************************************************************** @@ -161,38 +168,39 @@ type formatter = { (* Queues auxilliaries. *) -let make_queue () = {insert = Nil; body = Nil};; +let make_queue () = { insert = Nil; body = Nil; };; let clear_queue q = q.insert <- Nil; q.body <- Nil;; let add_queue x q = - let c = Cons {head = x; tail = Nil} in - match q with - | {insert = Cons cell} -> q.insert <- c; cell.tail <- c - (* Invariant: when insert is Nil body should be Nil. *) - | _ -> q.insert <- c; q.body <- c;; + let c = Cons { head = x; tail = Nil; } in + match q with + | { insert = Cons cell } -> + q.insert <- c; cell.tail <- c + (* Invariant: when insert is Nil body should be Nil. *) + | _ -> q.insert <- c; q.body <- c;; exception Empty_queue;; let peek_queue = function - | {body = Cons {head = x}} -> x - | _ -> raise Empty_queue;; + | { body = Cons { head = x; }; } -> x + | _ -> raise Empty_queue;; let take_queue = function - | {body = Cons {head = x; tail = tl}} as q -> + | { body = Cons { head = x; tail = tl; }; } as q -> q.body <- tl; if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *) x - | _ -> raise Empty_queue;; + | _ -> raise Empty_queue;; (* Enter a token in the pretty-printer queue. *) let pp_enqueue state ({length = len} as token) = - state.pp_right_total <- state.pp_right_total + len; - add_queue token state.pp_queue;; + state.pp_right_total <- state.pp_right_total + len; + add_queue token state.pp_queue;; let pp_clear_queue state = - state.pp_left_total <- 1; state.pp_right_total <- 1; - clear_queue state.pp_queue;; + state.pp_left_total <- 1; state.pp_right_total <- 1; + clear_queue state.pp_queue;; (* Pp_infinity: large value for default tokens size. @@ -219,47 +227,48 @@ let pp_infinity = 1000000010;; (* Output functions for the formatter. *) let pp_output_string state s = state.pp_output_function s 0 (String.length s) -and pp_output_newline state = state.pp_output_newline ();; - -let pp_display_blanks state n = state.pp_output_spaces n;; +and pp_output_newline state = state.pp_output_newline () +and pp_display_blanks state n = state.pp_output_spaces n +;; (* To format a break, indenting a new line. *) let break_new_line state offset width = - pp_output_newline state; - state.pp_is_new_line <- true; - let indent = state.pp_margin - width + offset in - (* Don't indent more than pp_max_indent. *) - let real_indent = min state.pp_max_indent indent in - state.pp_current_indent <- real_indent; - state.pp_space_left <- state.pp_margin - state.pp_current_indent; - pp_display_blanks state state.pp_current_indent;; + pp_output_newline state; + state.pp_is_new_line <- true; + let indent = state.pp_margin - width + offset in + (* Don't indent more than pp_max_indent. *) + let real_indent = min state.pp_max_indent indent in + state.pp_current_indent <- real_indent; + state.pp_space_left <- state.pp_margin - state.pp_current_indent; + pp_display_blanks state state.pp_current_indent;; (* To force a line break inside a block: no offset is added. *) let break_line state width = break_new_line state 0 width;; (* To format a break that fits on the current line. *) let break_same_line state width = - state.pp_space_left <- state.pp_space_left - width; - pp_display_blanks state width;; + state.pp_space_left <- state.pp_space_left - width; + pp_display_blanks state width;; (* To indent no more than pp_max_indent, if one tries to open a block beyond pp_max_indent, then the block is rejected on the left by simulating a break. *) let pp_force_break_line state = - match state.pp_format_stack with - | Format_elem (bl_ty, width) :: _ -> - if width > state.pp_space_left then - (match bl_ty with - | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width) - | _ -> pp_output_newline state;; + match state.pp_format_stack with + | Format_elem (bl_ty, width) :: _ -> + if width > state.pp_space_left then + (match bl_ty with + | Pp_fits -> () | Pp_hbox -> () + | _ -> break_line state width) + | _ -> pp_output_newline state;; (* To skip a token, if the previous line has been broken. *) let pp_skip_token state = - (* When calling pp_skip_token the queue cannot be empty. *) - match take_queue state.pp_queue with - {elem_size = size; length = len} -> - state.pp_left_total <- state.pp_left_total - len; - state.pp_space_left <- state.pp_space_left + int_of_size size;; + (* When calling pp_skip_token the queue cannot be empty. *) + match take_queue state.pp_queue with + | { elem_size = size; length = len; } -> + state.pp_left_total <- state.pp_left_total - len; + state.pp_space_left <- state.pp_space_left + int_of_size size;; (************************************************************** @@ -271,115 +280,120 @@ let pp_skip_token state = let format_pp_token state size = function | Pp_text s -> - state.pp_space_left <- state.pp_space_left - size; - pp_output_string state s; - state.pp_is_new_line <- false + state.pp_space_left <- state.pp_space_left - size; + pp_output_string state s; + state.pp_is_new_line <- false | Pp_begin (off, ty) -> - let insertion_point = state.pp_margin - state.pp_space_left in - if insertion_point > state.pp_max_indent then - (* can't open a block right there. *) - begin pp_force_break_line state end; - let offset = state.pp_space_left - off in - let bl_type = - begin match ty with - | Pp_vbox -> Pp_vbox - | _ -> if size > state.pp_space_left then ty else Pp_fits - end in - state.pp_format_stack <- - Format_elem (bl_type, offset) :: state.pp_format_stack + let insertion_point = state.pp_margin - state.pp_space_left in + if insertion_point > state.pp_max_indent then + (* can't open a block right there. *) + begin pp_force_break_line state end; + let offset = state.pp_space_left - off in + let bl_type = + begin match ty with + | Pp_vbox -> Pp_vbox + | _ -> if size > state.pp_space_left then ty else Pp_fits + end in + state.pp_format_stack <- + Format_elem (bl_type, offset) :: state.pp_format_stack | Pp_end -> - begin match state.pp_format_stack with - | x :: (y :: l as ls) -> state.pp_format_stack <- ls - | _ -> () (* No more block to close. *) - end + begin match state.pp_format_stack with + | x :: (y :: l as ls) -> state.pp_format_stack <- ls + | _ -> () (* No more block to close. *) + end | Pp_tbegin (Pp_tbox _ as tbox) -> - state.pp_tbox_stack <- tbox :: state.pp_tbox_stack + state.pp_tbox_stack <- tbox :: state.pp_tbox_stack | Pp_tend -> - begin match state.pp_tbox_stack with - | x :: ls -> state.pp_tbox_stack <- ls - | _ -> () (* No more tabulation block to close. *) - end + begin match state.pp_tbox_stack with + | x :: ls -> state.pp_tbox_stack <- ls + | _ -> () (* No more tabulation block to close. *) + end | Pp_stab -> - begin match state.pp_tbox_stack with - | Pp_tbox tabs :: _ -> - let rec add_tab n = function - | [] -> [n] - | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in - tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs - | _ -> () (* No opened tabulation block. *) - end + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec add_tab n = function + | [] -> [n] + | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in + tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs + | _ -> () (* No opened tabulation block. *) + end | Pp_tbreak (n, off) -> - let insertion_point = state.pp_margin - state.pp_space_left in - begin match state.pp_tbox_stack with - | Pp_tbox tabs :: _ -> - let rec find n = function - | x :: l -> if x >= n then x else find n l - | [] -> raise Not_found in - let tab = - match !tabs with - | x :: l -> - begin try find insertion_point !tabs with Not_found -> x end - | _ -> insertion_point in - let offset = tab - insertion_point in - if offset >= 0 then break_same_line state (offset + n) else - break_new_line state (tab + off) state.pp_margin - | _ -> () (* No opened tabulation block. *) - end + let insertion_point = state.pp_margin - state.pp_space_left in + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec find n = function + | x :: l -> if x >= n then x else find n l + | [] -> raise Not_found in + let tab = + match !tabs with + | x :: l -> + begin + try find insertion_point !tabs with + | Not_found -> x + end + | _ -> insertion_point in + let offset = tab - insertion_point in + if offset >= 0 + then break_same_line state (offset + n) + else break_new_line state (tab + off) state.pp_margin + | _ -> () (* No opened tabulation block. *) + end | Pp_newline -> - begin match state.pp_format_stack with - | Format_elem (_, width) :: _ -> break_line state width - | _ -> pp_output_newline state - end + begin match state.pp_format_stack with + | Format_elem (_, width) :: _ -> break_line state width + | _ -> pp_output_newline state + end | Pp_if_newline -> - if state.pp_current_indent != state.pp_margin - state.pp_space_left - then pp_skip_token state + if state.pp_current_indent != state.pp_margin - state.pp_space_left + then pp_skip_token state | Pp_break (n, off) -> - begin match state.pp_format_stack with - | Format_elem (ty, width) :: _ -> - begin match ty with - | Pp_hovbox -> - if size > state.pp_space_left - then break_new_line state off width - else break_same_line state n - | Pp_box -> - (* Have the line just been broken here ? *) - if state.pp_is_new_line then break_same_line state n else - if size > state.pp_space_left - then break_new_line state off width else - (* break the line here leads to new indentation ? *) - if state.pp_current_indent > state.pp_margin - width + off - then break_new_line state off width - else break_same_line state n - | Pp_hvbox -> break_new_line state off width - | Pp_fits -> break_same_line state n - | Pp_vbox -> break_new_line state off width - | Pp_hbox -> break_same_line state n - end - | _ -> () (* No opened block. *) - end + begin match state.pp_format_stack with + | Format_elem (ty, width) :: _ -> + begin match ty with + | Pp_hovbox -> + if size > state.pp_space_left + then break_new_line state off width + else break_same_line state n + | Pp_box -> + (* Have the line just been broken here ? *) + if state.pp_is_new_line then break_same_line state n else + if size > state.pp_space_left + then break_new_line state off width else + (* break the line here leads to new indentation ? *) + if state.pp_current_indent > state.pp_margin - width + off + then break_new_line state off width + else break_same_line state n + | Pp_hvbox -> break_new_line state off width + | Pp_fits -> break_same_line state n + | Pp_vbox -> break_new_line state off width + | Pp_hbox -> break_same_line state n + end + | _ -> () (* No opened block. *) + end | Pp_open_tag tag_name -> - let marker = state.pp_mark_open_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tag_name :: state.pp_mark_stack + let marker = state.pp_mark_open_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tag_name :: state.pp_mark_stack | Pp_close_tag -> - begin match state.pp_mark_stack with - | tag_name :: tags -> - let marker = state.pp_mark_close_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tags - | _ -> () (* No more tag to close. *) - end;; + begin match state.pp_mark_stack with + | tag_name :: tags -> + let marker = state.pp_mark_close_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tags + | _ -> () (* No more tag to close. *) + end +;; (* Print if token size is known or printing is delayed. Size is known when not negative. @@ -407,7 +421,7 @@ let enqueue_advance state tok = pp_enqueue state tok; advance_left state;; (* To enqueue a string : try to advance. *) let make_queue_elem size tok len = - {elem_size = size; token = tok; length = len};; + { elem_size = size; token = tok; length = len; };; let enqueue_string_as state size s = let len = int_of_size size in @@ -435,89 +449,99 @@ let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; Pattern matching on token in scan stack is also exhaustive, since scan_push is used on breaks and opening of boxes. *) let set_size state ty = - match state.pp_scan_stack with - | Scan_elem - (left_tot, - ({elem_size = size; token = tok} as queue_elem)) :: t -> - let size = int_of_size size in - (* test if scan stack contains any data that is not obsolete. *) - if left_tot < state.pp_left_total then clear_scan_stack state else - begin match tok with - | Pp_break (_, _) | Pp_tbreak (_, _) -> - if ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.pp_scan_stack <- t - end - | Pp_begin (_, _) -> - if not ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.pp_scan_stack <- t - end - | _ -> () (* scan_push is only used for breaks and boxes. *) + match state.pp_scan_stack with + | Scan_elem + (left_tot, + ({elem_size = size; token = tok} as queue_elem)) :: t -> + let size = int_of_size size in + (* test if scan stack contains any data that is not obsolete. *) + if left_tot < state.pp_left_total then clear_scan_stack state else + begin match tok with + | Pp_break (_, _) | Pp_tbreak (_, _) -> + if ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t + end + | Pp_begin (_, _) -> + if not ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t end - | _ -> () (* scan_stack is never empty. *);; + | _ -> () (* scan_push is only used for breaks and boxes. *) + end + | _ -> () (* scan_stack is never empty. *);; (* Push a token on scan stack. If b is true set_size is called. *) let scan_push state b tok = - pp_enqueue state tok; - if b then set_size state true; - state.pp_scan_stack <- - Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack;; + pp_enqueue state tok; + if b then set_size state true; + state.pp_scan_stack <- + Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack;; (* To open a new block : the user may set the depth bound pp_max_boxes any text nested deeper is printed as the ellipsis string. *) let pp_open_box_gen state indent br_ty = - state.pp_curr_depth <- state.pp_curr_depth + 1; - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem - (size_of_int (- state.pp_right_total)) - (Pp_begin (indent, br_ty)) - 0 in - scan_push state false elem else - if state.pp_curr_depth = state.pp_max_boxes - then enqueue_string state state.pp_ellipsis;; + state.pp_curr_depth <- state.pp_curr_depth + 1; + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem + (size_of_int (- state.pp_right_total)) + (Pp_begin (indent, br_ty)) + 0 in + scan_push state false elem else + if state.pp_curr_depth = state.pp_max_boxes + then enqueue_string state state.pp_ellipsis;; (* The box which is always opened. *) let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;; (* Close a block, setting sizes of its sub blocks. *) let pp_close_box state () = - if state.pp_curr_depth > 1 then - begin - if state.pp_curr_depth < state.pp_max_boxes then - begin - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_end; length = 0}; - set_size state true; set_size state false - end; - state.pp_curr_depth <- state.pp_curr_depth - 1; - end;; + if state.pp_curr_depth > 1 then + begin + if state.pp_curr_depth < state.pp_max_boxes then + begin + pp_enqueue state + { elem_size = size_of_int 0; token = Pp_end; length = 0; }; + set_size state true; set_size state false + end; + state.pp_curr_depth <- state.pp_curr_depth - 1; + end;; (* Open a tag, pushing it on the tag stack. *) let pp_open_tag state tag_name = - if state.pp_print_tags then begin - state.pp_tag_stack <- tag_name :: state.pp_tag_stack; - state.pp_print_open_tag tag_name end; - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0};; + if state.pp_print_tags then + begin + state.pp_tag_stack <- tag_name :: state.pp_tag_stack; + state.pp_print_open_tag tag_name + end; + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_open_tag tag_name; + length = 0; + } +;; (* Close a tag, popping it from the tag stack. *) let pp_close_tag state () = - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_close_tag; length = 0}; - if state.pp_print_tags then - begin match state.pp_tag_stack with - | tag_name :: tags -> - state.pp_print_close_tag tag_name; - state.pp_tag_stack <- tags - | _ -> () (* No more tag to close. *) - end;; + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_close_tag; + length = 0; + }; + if state.pp_print_tags then + begin + match state.pp_tag_stack with + | tag_name :: tags -> + state.pp_print_close_tag tag_name; + state.pp_tag_stack <- tags + | _ -> () (* No more tag to close. *) + end;; let pp_set_print_tags state b = state.pp_print_tags <- b;; let pp_set_mark_tags state b = state.pp_mark_tags <- b;; @@ -526,10 +550,10 @@ let pp_get_mark_tags state () = state.pp_mark_tags;; let pp_set_tags state b = pp_set_print_tags state b; pp_set_mark_tags state b;; let pp_get_formatter_tag_functions state () = { - mark_open_tag = state.pp_mark_open_tag; - mark_close_tag = state.pp_mark_close_tag; - print_open_tag = state.pp_print_open_tag; - print_close_tag = state.pp_print_close_tag; + mark_open_tag = state.pp_mark_open_tag; + mark_close_tag = state.pp_mark_close_tag; + print_open_tag = state.pp_print_open_tag; + print_close_tag = state.pp_print_close_tag; };; let pp_set_formatter_tag_functions state { @@ -545,26 +569,26 @@ let pp_set_formatter_tag_functions state { (* Initialize pretty-printer. *) let pp_rinit state = - pp_clear_queue state; - clear_scan_stack state; - state.pp_format_stack <- []; - state.pp_tbox_stack <- []; - state.pp_tag_stack <- []; - state.pp_mark_stack <- []; - state.pp_current_indent <- 0; - state.pp_curr_depth <- 0; - state.pp_space_left <- state.pp_margin; - pp_open_sys_box state;; + pp_clear_queue state; + clear_scan_stack state; + state.pp_format_stack <- []; + state.pp_tbox_stack <- []; + state.pp_tag_stack <- []; + state.pp_mark_stack <- []; + state.pp_current_indent <- 0; + state.pp_curr_depth <- 0; + state.pp_space_left <- state.pp_margin; + pp_open_sys_box state;; (* Flushing pretty-printer queue. *) let pp_flush_queue state b = - while state.pp_curr_depth > 1 do - pp_close_box state () - done; - state.pp_right_total <- pp_infinity; - advance_left state; - if b then pp_output_newline state; - pp_rinit state;; + while state.pp_curr_depth > 1 do + pp_close_box state () + done; + state.pp_right_total <- pp_infinity; + advance_left state; + if b then pp_output_newline state; + pp_rinit state;; (************************************************************** @@ -609,9 +633,9 @@ and pp_open_box state indent = pp_open_box_gen state indent Pp_box;; (* Print a new line after printing all queued text (same for print_flush but without a newline). *) let pp_print_newline state () = - pp_flush_queue state true; state.pp_flush_function () + pp_flush_queue state true; state.pp_flush_function () and pp_print_flush state () = - pp_flush_queue state false; state.pp_flush_function ();; + pp_flush_queue state false; state.pp_flush_function ();; (* To get a newline when one does not want to close the current block. *) let pp_force_newline state () = @@ -649,11 +673,13 @@ let pp_open_tbox state () = (* Close a tabulation block. *) let pp_close_tbox state () = - if state.pp_curr_depth > 1 then begin + if state.pp_curr_depth > 1 then + begin if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in enqueue_advance state elem; - state.pp_curr_depth <- state.pp_curr_depth - 1 end;; + state.pp_curr_depth <- state.pp_curr_depth - 1 + end;; (* Print a tabulation break. *) let pp_print_tbreak state width offset = @@ -714,15 +740,15 @@ let pp_set_margin state n = let n = pp_limit n in state.pp_margin <- n; let new_max_indent = - (* Try to maintain max_indent to its actual value. *) - if state.pp_max_indent <= state.pp_margin - then state.pp_max_indent else - (* If possible maintain pp_min_space_left to its actual value, - if this leads to a too small max_indent, take half of the - new margin, if it is greater than 1. *) - max (max (state.pp_margin - state.pp_min_space_left) - (state.pp_margin / 2)) 1 in - (* Rebuild invariants. *) + (* Try to maintain max_indent to its actual value. *) + if state.pp_max_indent <= state.pp_margin + then state.pp_max_indent else + (* If possible maintain pp_min_space_left to its actual value, + if this leads to a too small max_indent, take half of the + new margin, if it is greater than 1. *) + max (max (state.pp_margin - state.pp_min_space_left) + (state.pp_margin / 2)) 1 in + (* Rebuild invariants. *) pp_set_max_indent state new_max_indent;; let pp_get_margin state () = state.pp_margin;; @@ -758,51 +784,51 @@ let default_pp_print_open_tag s = ();; let default_pp_print_close_tag = default_pp_print_open_tag;; let pp_make_formatter f g h i = - (* The initial state of the formatter contains a dummy box. *) - let pp_q = make_queue () in - let sys_tok = - make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in - add_queue sys_tok pp_q; - let sys_scan_stack = - (Scan_elem (1, sys_tok)) :: scan_stack_bottom in - {pp_scan_stack = sys_scan_stack; - pp_format_stack = []; - pp_tbox_stack = []; - pp_tag_stack = []; - pp_mark_stack = []; - pp_margin = 78; - pp_min_space_left = 10; - pp_max_indent = 78 - 10; - pp_space_left = 78; - pp_current_indent = 0; - pp_is_new_line = true; - pp_left_total = 1; - pp_right_total = 1; - pp_curr_depth = 1; - pp_max_boxes = max_int; - pp_ellipsis = "."; - pp_output_function = f; - pp_flush_function = g; - pp_output_newline = h; - pp_output_spaces = i; - pp_print_tags = false; - pp_mark_tags = false; - pp_mark_open_tag = default_pp_mark_open_tag; - pp_mark_close_tag = default_pp_mark_close_tag; - pp_print_open_tag = default_pp_print_open_tag; - pp_print_close_tag = default_pp_print_close_tag; - pp_queue = pp_q - };; + (* The initial state of the formatter contains a dummy box. *) + let pp_q = make_queue () in + let sys_tok = + make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in + add_queue sys_tok pp_q; + let sys_scan_stack = + (Scan_elem (1, sys_tok)) :: scan_stack_bottom in + {pp_scan_stack = sys_scan_stack; + pp_format_stack = []; + pp_tbox_stack = []; + pp_tag_stack = []; + pp_mark_stack = []; + pp_margin = 78; + pp_min_space_left = 10; + pp_max_indent = 78 - 10; + pp_space_left = 78; + pp_current_indent = 0; + pp_is_new_line = true; + pp_left_total = 1; + pp_right_total = 1; + pp_curr_depth = 1; + pp_max_boxes = max_int; + pp_ellipsis = "."; + pp_output_function = f; + pp_flush_function = g; + pp_output_newline = h; + pp_output_spaces = i; + pp_print_tags = false; + pp_mark_tags = false; + pp_mark_open_tag = default_pp_mark_open_tag; + pp_mark_close_tag = default_pp_mark_close_tag; + pp_print_open_tag = default_pp_print_open_tag; + pp_print_close_tag = default_pp_print_close_tag; + pp_queue = pp_q; + };; (* Default function to output spaces. *) let blank_line = String.make 80 ' ';; let rec display_blanks state n = - if n > 0 then - if n <= 80 then state.pp_output_function blank_line 0 n else - begin - state.pp_output_function blank_line 0 80; - display_blanks state (n - 80) - end;; + if n > 0 then + if n <= 80 then state.pp_output_function blank_line 0 n else + begin + state.pp_output_function blank_line 0 80; + display_blanks state (n - 80) + end;; (* Default function to output new lines. *) let display_newline state () = state.pp_output_function "\n" 0 1;; @@ -823,9 +849,9 @@ let formatter_of_buffer b = let stdbuf = Buffer.create 512;; (* Predefined formatters. *) -let str_formatter = formatter_of_buffer stdbuf;; -let std_formatter = formatter_of_out_channel stdout;; -let err_formatter = formatter_of_out_channel stderr;; +let str_formatter = formatter_of_buffer stdbuf +and std_formatter = formatter_of_out_channel stdout +and err_formatter = formatter_of_out_channel stderr;; let flush_str_formatter () = pp_flush_queue str_formatter false; @@ -882,32 +908,32 @@ and set_ellipsis_text = pp_set_ellipsis_text std_formatter and get_ellipsis_text = pp_get_ellipsis_text std_formatter and set_formatter_out_channel = - pp_set_formatter_out_channel std_formatter + pp_set_formatter_out_channel std_formatter and set_formatter_output_functions = - pp_set_formatter_output_functions std_formatter + pp_set_formatter_output_functions std_formatter and get_formatter_output_functions = - pp_get_formatter_output_functions std_formatter + pp_get_formatter_output_functions std_formatter and set_all_formatter_output_functions = - pp_set_all_formatter_output_functions std_formatter + pp_set_all_formatter_output_functions std_formatter and get_all_formatter_output_functions = - pp_get_all_formatter_output_functions std_formatter + pp_get_all_formatter_output_functions std_formatter and set_formatter_tag_functions = - pp_set_formatter_tag_functions std_formatter + pp_set_formatter_tag_functions std_formatter and get_formatter_tag_functions = - pp_get_formatter_tag_functions std_formatter + pp_get_formatter_tag_functions std_formatter and set_print_tags = - pp_set_print_tags std_formatter + pp_set_print_tags std_formatter and get_print_tags = - pp_get_print_tags std_formatter + pp_get_print_tags std_formatter and set_mark_tags = - pp_set_mark_tags std_formatter + pp_set_mark_tags std_formatter and get_mark_tags = - pp_get_mark_tags std_formatter + pp_get_mark_tags std_formatter and set_tags = - pp_set_tags std_formatter + pp_set_tags std_formatter ;; @@ -949,24 +975,24 @@ let format_int_of_string fmt i s = (* Getting strings out of buffers. *) let get_buffer_out b = - let s = Buffer.contents b in - Buffer.reset b; - s;; + let s = Buffer.contents b in + Buffer.reset 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]. *) let string_out b ppf = - pp_flush_queue ppf false; - get_buffer_out b;; + pp_flush_queue ppf false; + get_buffer_out b;; (* Applies [printer] to a formatter that outputs on a fresh buffer, then returns the resulting material. *) let exstring printer arg = - let b = Buffer.create 512 in - let ppf = formatter_of_buffer b in - printer ppf arg; - string_out b ppf;; + let b = Buffer.create 512 in + let ppf = formatter_of_buffer b in + printer ppf arg; + string_out b ppf;; (* To turn out a character accumulator into the proper string result. *) let implode_rev s0 = function @@ -986,73 +1012,74 @@ let implode_rev s0 = function let mkprintf to_s get_out = let rec kprintf k fmt = + let len = Sformat.length fmt in let kpr fmt v = let ppf = get_out fmt in let print_as = ref None in let pp_print_as_char c = - match !print_as with - | None -> pp_print_char ppf c - | Some size -> - pp_print_as_size ppf size (String.make 1 c); - print_as := None + match !print_as with + | None -> pp_print_char ppf c + | Some size -> + pp_print_as_size ppf size (String.make 1 c); + print_as := None and pp_print_as_string s = - match !print_as with - | None -> pp_print_string ppf s - | Some size -> - pp_print_as_size ppf size s; - print_as := None in + match !print_as with + | None -> pp_print_string ppf s + | Some size -> + pp_print_as_size ppf size s; + print_as := None in let rec doprn n i = if i >= len then Obj.magic (k ppf) else match Sformat.get fmt i with | '%' -> - Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | '@' -> - let i = succ i in - if i >= len then invalid_format fmt i else - begin match Sformat.get fmt i with - | '[' -> - do_pp_open_box ppf n (succ i) - | ']' -> - pp_close_box ppf (); - doprn n (succ i) - | '{' -> - do_pp_open_tag ppf n (succ i) - | '}' -> - pp_close_tag ppf (); - doprn n (succ i) - | ' ' -> - pp_print_space ppf (); - doprn n (succ i) - | ',' -> - pp_print_cut ppf (); - doprn n (succ i) - | '?' -> - pp_print_flush ppf (); - doprn n (succ i) - | '.' -> - pp_print_newline ppf (); - doprn n (succ i) - | '\n' -> - pp_force_newline ppf (); - doprn n (succ i) - | ';' -> - do_pp_break ppf n (succ i) - | '<' -> - let got_size size n i = - print_as := Some size; - doprn n (skip_gt i) in - get_int n (succ i) got_size - | '@' as c -> - pp_print_as_char c; - doprn n (succ i) - | c -> invalid_format fmt i - end + let i = succ i in + if i >= len then invalid_format fmt i else + begin match Sformat.get fmt i with + | '[' -> + do_pp_open_box ppf n (succ i) + | ']' -> + pp_close_box ppf (); + doprn n (succ i) + | '{' -> + do_pp_open_tag ppf n (succ i) + | '}' -> + pp_close_tag ppf (); + doprn n (succ i) + | ' ' -> + pp_print_space ppf (); + doprn n (succ i) + | ',' -> + pp_print_cut ppf (); + doprn n (succ i) + | '?' -> + pp_print_flush ppf (); + doprn n (succ i) + | '.' -> + pp_print_newline ppf (); + doprn n (succ i) + | '\n' -> + pp_force_newline ppf (); + doprn n (succ i) + | ';' -> + do_pp_break ppf n (succ i) + | '<' -> + let got_size size n i = + print_as := Some size; + doprn n (skip_gt i) in + get_int n (succ i) got_size + | '@' as c -> + pp_print_as_char c; + doprn n (succ i) + | c -> invalid_format fmt i + end | c -> - pp_print_as_char c; - doprn n (succ i) + pp_print_as_char c; + doprn n (succ i) and cont_s n s i = pp_print_as_string s; doprn n i @@ -1074,129 +1101,131 @@ let mkprintf to_s get_out = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt and get_int n i c = - if i >= len then invalid_integer fmt i else - match Sformat.get fmt i with - | ' ' -> get_int n (succ i) c - | '%' -> + if i >= len then invalid_integer fmt i else + match Sformat.get fmt i with + | ' ' -> get_int n (succ i) c + | '%' -> let cont_s n s i = c (format_int_of_string fmt i s) n i and cont_a n printer arg i = invalid_integer fmt i and cont_t n printer i = invalid_integer fmt i and cont_f n i = invalid_integer fmt i and cont_m n sfmt i = invalid_integer fmt i in Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | _ -> + | _ -> let rec get j = - if j >= len then invalid_integer fmt j else - match Sformat.get fmt j with - | '0' .. '9' | '-' -> get (succ j) - | _ -> - let size = - if j = i then size_of_int 0 else + if j >= len then invalid_integer fmt j else + match Sformat.get fmt j with + | '0' .. '9' | '-' -> get (succ j) + | _ -> + let size = + if j = i then size_of_int 0 else let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in format_int_of_string fmt j s in - c size n j in + c size n j in get i and skip_gt i = - if i >= len then invalid_format fmt i else - match Sformat.get fmt i with - | ' ' -> skip_gt (succ i) - | '>' -> succ i - | _ -> invalid_format fmt i + if i >= len then invalid_format fmt i else + match Sformat.get fmt i with + | ' ' -> skip_gt (succ i) + | '>' -> succ i + | _ -> invalid_format fmt i and get_box_kind i = - if i >= len then Pp_box, i else - match Sformat.get fmt i with - | 'h' -> - let i = succ i in - if i >= len then Pp_hbox, i else - begin match Sformat.get fmt i with - | 'o' -> + if i >= len then Pp_box, i else + match Sformat.get fmt i with + | 'h' -> + let i = succ i in + if i >= len then Pp_hbox, i else + begin match Sformat.get fmt i with + | 'o' -> let i = succ i in if i >= len then format_invalid_arg "bad box format" fmt i else begin match Sformat.get fmt i with | 'v' -> Pp_hovbox, succ i | c -> - format_invalid_arg - ("bad box name ho" ^ String.make 1 c) fmt i end - | 'v' -> Pp_hvbox, succ i - | c -> Pp_hbox, i - end - | 'b' -> Pp_box, succ i - | 'v' -> Pp_vbox, succ i - | _ -> Pp_box, i + format_invalid_arg + ("bad box name ho" ^ String.make 1 c) fmt i + end + | 'v' -> Pp_hvbox, succ i + | c -> Pp_hbox, i + end + | 'b' -> Pp_box, succ i + | 'v' -> Pp_vbox, succ i + | _ -> Pp_box, i and get_tag_name n i c = - let rec get accu n i j = - if j >= len then - c (implode_rev - (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) - accu) - n j else - match Sformat.get fmt j with - | '>' -> - c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) - accu) - n j - | '%' -> - let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in - let cont_s n s i = get (s :: s0 :: accu) n i i - and cont_a n printer arg i = - let s = - if to_s - then (Obj.magic printer : unit -> _ -> string) () arg - else exstring printer arg in - get (s :: s0 :: accu) n i i - and cont_t n printer i = - let s = - if to_s - then (Obj.magic printer : unit -> string) () - else exstring (fun ppf () -> printer ppf) () in - get (s :: s0 :: accu) n i i - and cont_f n i = - format_invalid_arg "bad tag name specification" fmt i - and cont_m n sfmt i = - format_invalid_arg "bad tag name specification" fmt i in - Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m - | c -> get accu n i (succ j) in - get [] n i i + let rec get accu n i j = + if j >= len then + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j else + match Sformat.get fmt j with + | '>' -> + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j + | '%' -> + let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in + let cont_s n s i = get (s :: s0 :: accu) n i i + and cont_a n printer arg i = + let s = + if to_s + then (Obj.magic printer : unit -> _ -> string) () arg + else exstring printer arg in + get (s :: s0 :: accu) n i i + and cont_t n printer i = + let s = + if to_s + then (Obj.magic printer : unit -> string) () + else exstring (fun ppf () -> printer ppf) () in + get (s :: s0 :: accu) n i i + and cont_f n i = + format_invalid_arg "bad tag name specification" fmt i + and cont_m n sfmt i = + format_invalid_arg "bad tag name specification" fmt i in + Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m + | c -> get accu n i (succ j) in + get [] n i i and do_pp_break ppf n i = - if i >= len then begin pp_print_space ppf (); doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_print_space ppf (); doprn n i end else + match Sformat.get fmt i with + | '<' -> let rec got_nspaces nspaces n i = get_int n i (got_offset nspaces) and got_offset nspaces offset n i = pp_print_break ppf (int_of_size nspaces) (int_of_size offset); doprn n (skip_gt i) in get_int n (succ i) got_nspaces - | c -> pp_print_space ppf (); doprn n i + | c -> pp_print_space ppf (); doprn n i and do_pp_open_box ppf n i = - if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else + match Sformat.get fmt i with + | '<' -> let kind, i = get_box_kind (succ i) in let got_size size n i = pp_open_box_gen ppf (int_of_size size) kind; doprn n (skip_gt i) in get_int n i got_size - | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i + | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i and do_pp_open_tag ppf n i = - if i >= len then begin pp_open_tag ppf ""; doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_tag ppf ""; doprn n i end else + match Sformat.get fmt i with + | '<' -> let got_name tag_name n i = pp_open_tag ppf tag_name; doprn n (skip_gt i) in get_tag_name n (succ i) got_name - | c -> pp_open_tag ppf ""; doprn n i in + | c -> pp_open_tag ppf ""; doprn n i in doprn (Sformat.index_of_int 0) 0 in - Tformat.kapr kpr fmt in + Tformat.kapr kpr fmt in kprintf;; diff --git a/stdlib/int32.mli b/stdlib/int32.mli index dc733ec9f..eeafb1a2f 100644 --- a/stdlib/int32.mli +++ b/stdlib/int32.mli @@ -160,9 +160,5 @@ val compare: t -> t -> int (** {6 Deprecated functions} *) external format : string -> int32 -> string = "caml_int32_format" -(** [Int32.format fmt n] return the string representation of the - 32-bit integer [n] in the format specified by [fmt]. - [fmt] is a [Printf]-style format consisting of exactly - one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. - This function is deprecated; use {!Printf.sprintf} with a [%lx] format - instead. *) +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%l...] format. *) diff --git a/stdlib/int64.mli b/stdlib/int64.mli index 7bc39e612..3b641338e 100644 --- a/stdlib/int64.mli +++ b/stdlib/int64.mli @@ -182,9 +182,5 @@ val compare: t -> t -> int (** {6 Deprecated functions} *) external format : string -> int64 -> string = "caml_int64_format" -(** [Int64.format fmt n] return the string representation of the - 64-bit integer [n] in the format specified by [fmt]. - [fmt] is a {!Printf}-style format consisting of exactly one - [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. - This function is deprecated; use {!Printf.sprintf} with a [%Lx] format - instead. *) +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%L...] format. *) diff --git a/stdlib/printf.mli b/stdlib/printf.mli index e8bd7d6c9..6bd692d0b 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -27,7 +27,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a Conversion specifications have the following form: - [% \[positional specifier\] \[flags\] \[width\] \[.precision\] type] + [% \[flags\] \[width\] \[.precision\] type] In short, a conversion specification consists in the [%] character, followed by optional modifiers and a type which is made of one or @@ -79,10 +79,6 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a - [!]: take no argument and flush the output. - [%]: take no argument and output one [%] character. - The optional [positional specifier] consists of an integer followed - by a [$]; the integer indicates which argument to use, the first - argument being denoted by 1. - The optional [flags] are: - [-]: left-justify the output (default is right justification). - [0]: for numerical conversions, pad with zeroes instead of spaces. @@ -102,10 +98,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a The integer in a [width] or [precision] can also be specified as [*], in which case an extra integer argument is taken to specify the corresponding [width] or [precision]. This integer argument - precedes immediately the argument to print, unless an optional - [positional specifier] is given to indicates which argument to - use. For instance, [%.*3$f] prints a [float] with as many fractional - digits as the value of the third argument. *) + precedes immediately the argument to print. + For instance, [%.*f] prints a [float] with as many fractional + digits as the value of the argument given before the float. *) val printf : ('a, out_channel, unit) format -> 'a (** Same as {!Printf.fprintf}, but output on [stdout]. *) diff --git a/test/Moretest/recmod.ml b/test/Moretest/recmod.ml index 1573ef01b..e4c6751c5 100644 --- a/test/Moretest/recmod.ml +++ b/test/Moretest/recmod.ml @@ -62,13 +62,6 @@ let _ = (* Early application *) -(* -module rec Bad - : sig val f : int -> int end - = struct let f = let y = Bad.f 5 in fun x -> x+y end -;; -*) - let _ = let res = try @@ -84,6 +77,8 @@ let _ = test 30 res true ;; +(* Early strict evaluation *) + (* module rec Cyclic : sig val x : int end @@ -156,6 +151,24 @@ module rec PolyRec end ;; +(* Wrong LHS signatures (PR#4336) *) + +(* +module type ASig = sig type a val a:a val print:a -> unit end +module type BSig = sig type b val b:b val print:b -> unit end + +module A = struct type a = int let a = 0 let print = print_int end +module B = struct type b = float let b = 0.0 let print = print_float end + +module MakeA (Empty:sig end) : ASig = A +module MakeB (Empty:sig end) : BSig = B + +module + rec NewA : ASig = MakeA (struct end) + and NewB : BSig with type b = NewA.a = MakeB (struct end);; + +*) + (* Expressions and bindings *) module StringSet = Set.Make(String);; @@ -458,6 +471,124 @@ let _ = test 100 (F.f (F.X 1)) false; test 101 (F.f (F.Y 2)) true +(* PR#4316 *) +module G(S : sig val x : int Lazy.t end) = struct include S end + +module M1 = struct let x = lazy 3 end + +let _ = Lazy.force M1.x + +module rec M2 : sig val x : int Lazy.t end = G(M1) + +let _ = + test 102 (Lazy.force M2.x) 3 + +let _ = Gc.full_major() (* will shortcut forwarding in M1.x *) + +module rec M3 : sig val x : int Lazy.t end = G(M1) + +let _ = + test 103 (Lazy.force M3.x) 3 + +(* PR#4450 *) + +module PR_4450_1 = struct + module type MyT = sig type 'a t = Succ of 'a t end + module MyMap(X : MyT) = X + module rec MyList : MyT = MyMap(MyList) +end;; + +module PR_4450_2 = struct + module type MyT = sig + type 'a wrap = My of 'a t + and 'a t = private < map : 'b. ('a -> 'b) ->'b wrap; .. > + val create : 'a list -> 'a t + end + module MyMap(X : MyT) = struct + include X + class ['a] c l = object (self) + method map : 'b. ('a -> 'b) -> 'b wrap = + fun f -> My (create (List.map f l)) + end + end + module rec MyList : sig + type 'a wrap = My of 'a t + and 'a t = < map : 'b. ('a -> 'b) ->'b wrap > + val create : 'a list -> 'a t + end = struct + include MyMap(MyList) + let create l = new c l + end +end;; + +(* A synthetic example of bootstrapped data structure + (suggested by J-C Filliatre) *) + +module type ORD = sig + type t + val compare : t -> t -> int +end + +module type SET = sig + type elt + type t + val iter : (elt -> unit) -> t -> unit +end + +type 'a tree = E | N of 'a tree * 'a * 'a tree + +module Bootstrap2 + (MakeDiet : functor (X: ORD) -> SET with type t = X.t tree and type elt = X.t) + : SET with type elt = int = +struct + + type elt = int + + module rec Elt : sig + type t = I of int * int | D of int * Diet.t * int + val compare : t -> t -> int + val iter : (int -> unit) -> t -> unit + end = + struct + type t = I of int * int | D of int * Diet.t * int + let compare x1 x2 = 0 + let rec iter f = function + | I (l, r) -> for i = l to r do f i done + | D (_, d, _) -> Diet.iter (iter f) d + end + + and Diet : SET with type t = Elt.t tree and type elt = Elt.t = MakeDiet(Elt) + + type t = Diet.t + let iter f = Diet.iter (Elt.iter f) +end + +(* PR 4470: simplified from OMake's sources *) + +module rec DirElt + : sig + type t = DirRoot | DirSub of DirHash.t + end + = struct + type t = DirRoot | DirSub of DirHash.t + end + +and DirCompare + : sig + type t = DirElt.t + end + = struct + type t = DirElt.t + end + +and DirHash + : sig + type t = DirElt.t list + end + = struct + type t = DirCompare.t list + end + (** Ill-formed type abbreviations. *) (** diff --git a/testlabl/bugs/pr4435.ml b/testlabl/bugs/pr4435.ml new file mode 100644 index 000000000..c9e1d4997 --- /dev/null +++ b/testlabl/bugs/pr4435.ml @@ -0,0 +1,11 @@ +(* Two v's in the same class *) +class c v = object initializer print_endline v val v = 42 end;; +new c "42";; + +(* Two hidden v's in the same class! *) +class c (v : int) = + object + method v0 = v + inherit ((fun v -> object method v : string = v end) "42") + end;; +(new c 42)#v0;; diff --git a/tools/depend.ml b/tools/depend.ml index c39002516..a89508502 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -268,8 +268,8 @@ and add_class_expr bv ce = add bv l; List.iter (add_type bv) tyl | Pcl_structure(pat, fieldl) -> add_pattern bv pat; List.iter (add_class_field bv) fieldl - | Pcl_fun(_, _, pat, ce) -> - add_pattern bv pat; add_class_expr bv ce + | Pcl_fun(_, opte, pat, ce) -> + add_opt add_expr bv opte; add_pattern bv pat; add_class_expr bv ce | Pcl_apply(ce, exprl) -> add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl | Pcl_let(_, pel, ce) -> diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 1e483685b..39e3908e0 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -18,8 +18,8 @@ cd package-macosx rm -rf ocaml.pkg ocaml-rw.dmg VERSION=`head -1 ../VERSION` -VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION -VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION +VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION` +VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION` cat >Description.plist <<EOF <?xml version="1.0" encoding="UTF-8"?> @@ -86,8 +86,8 @@ mkdir -p resources # stop here -> | cat >resources/ReadMe.txt <<EOF This package installs Objective Caml version ${VERSION}. -You need Mac OS X 10.4.x (Tiger), with the -XCode tools (v2.4) installed (and optionally X11). +You need Mac OS X 10.5.x (Jaguar), with the +XCode tools (v3.x) installed (and optionally X11). Files will be installed in the following directories: diff --git a/typing/btype.ml b/typing/btype.ml index 290d43e58..84f21f791 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -176,8 +176,7 @@ let rec iter_row f row = match (repr row.row_more).desc with Tvariant row -> iter_row f row | Tvar | Tunivar | Tsubst _ | Tconstr _ -> - Misc.may (fun (_,l) -> List.iter f l) row.row_name; - List.iter f row.row_bound + Misc.may (fun (_,l) -> List.iter f l) row.row_name | _ -> assert false let iter_type_expr f ty = @@ -203,7 +202,6 @@ let rec iter_abbrev f = function | Mlink rem -> iter_abbrev f !rem let copy_row f fixed row keep more = - let bound = ref [] in let fields = List.map (fun (l, fi) -> l, match row_field_repr fi with @@ -212,10 +210,6 @@ let copy_row f fixed row keep more = let e = if keep then e else ref None in let m = if row.row_fixed then fixed else m in let tl = List.map f tl in - bound := List.filter - (function {desc=Tconstr(_,[],_)} -> false | _ -> true) - (List.map repr tl) - @ !bound; Reither(c, tl, m, e) | _ -> fi) row.row_fields in @@ -223,7 +217,7 @@ let copy_row f fixed row keep more = match row.row_name with None -> None | Some (path, tl) -> Some (path, List.map f tl) in { row_fields = fields; row_more = more; - row_bound = !bound; row_fixed = row.row_fixed && fixed; + row_bound = (); row_fixed = row.row_fixed && fixed; row_closed = row.row_closed; row_name = name; } let rec copy_kind = function diff --git a/typing/ctype.ml b/typing/ctype.ml index 8451598ce..9f4ed9048 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -322,17 +322,21 @@ let rec class_type_arity = let sort_row_fields = Sort.list (fun (p,_) (q,_) -> p < q) +let rec merge_rf r1 r2 pairs fi1 fi2 = + match fi1, fi2 with + (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> + if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else + if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else + merge_rf r1 (p2::r2) pairs fi1 fi2' + | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) + | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) + let merge_row_fields fi1 fi2 = - let rec merge r1 r2 pairs fi1 fi2 = - match fi1, fi2 with - (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> - if l1 = l2 then merge r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else - if l1 < l2 then merge (p1::r1) r2 pairs fi1' fi2 else - merge r1 (p2::r2) pairs fi1 fi2' - | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) - | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) - in - merge [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) + match fi1, fi2 with + [], _ | _, [] -> (fi1, fi2, []) + | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) + | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) + | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) let rec filter_row_fields erase = function [] -> [] @@ -364,7 +368,7 @@ let rec closed_schema_rec ty = closed_schema_rec t2 | Tvariant row -> let row = row_repr row in - iter_row closed_schema_rec {row with row_bound = []}; + iter_row closed_schema_rec row; if not (static_row row) then closed_schema_rec row.row_more | _ -> iter_type_expr closed_schema_rec ty @@ -401,7 +405,7 @@ let rec free_vars_rec real ty = free_vars_rec true ty1; free_vars_rec false ty2 | Tvariant row -> let row = row_repr row in - iter_row (free_vars_rec true) {row with row_bound = []}; + iter_row (free_vars_rec true) row; if not (static_row row) then free_vars_rec false row.row_more | _ -> iter_type_expr (free_vars_rec true) ty @@ -1460,7 +1464,7 @@ let mkvariant fields closed = newgenty (Tvariant {row_fields = fields; row_closed = closed; row_more = newvar(); - row_bound = []; row_fixed = false; row_name = None }) + row_bound = (); row_fixed = false; row_name = None }) (**** Unification ****) @@ -1764,8 +1768,7 @@ and unify_row env row1 row2 = then row2.row_name else None in - let bound = row1.row_bound @ row2.row_bound in - let row0 = {row_fields = []; row_more = more; row_bound = bound; + let row0 = {row_fields = []; row_more = more; row_bound = (); row_closed = closed; row_fixed = fixed; row_name = name} in let set_more row rest = let rest = @@ -2827,7 +2830,6 @@ let rec build_subtype env visited loops posi level t = let level' = pred_enlarge level in let visited = t :: if level' < level then [] else filter_visited visited in - let bound = ref row.row_bound in let fields = filter_row_fields false row.row_fields in let fields = List.map @@ -2839,18 +2841,18 @@ let rec build_subtype env visited loops posi level t = orig, Unchanged | Rpresent(Some t) -> let (t', c) = build_subtype env visited loops posi level' t in - if posi && level > 0 then begin - bound := t' :: !bound; - (l, Reither(false, [t'], false, ref None)), c - end else - (l, Rpresent(Some t')), c + let f = + if posi && level > 0 + then Reither(false, [t'], false, ref None) + else Rpresent(Some t') + in (l, f), c | _ -> assert false) fields in let c = collect fields in let row = { row_fields = List.map fst fields; row_more = newvar(); - row_bound = !bound; row_closed = posi; row_fixed = false; + row_bound = (); row_closed = posi; row_fixed = false; row_name = if c > Unchanged then None else row.row_name } in (newty (Tvariant row), Changed) @@ -3174,13 +3176,9 @@ let rec normalize_type_rec env ty = row.row_fields in let fields = List.sort (fun (p,_) (q,_) -> compare p q) - (List.filter (fun (_,fi) -> fi <> Rabsent) fields) - and bound = List.fold_left - (fun tyl ty -> if List.memq ty tyl then tyl else ty :: tyl) - [] (List.map repr row.row_bound) - in + (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in log_type ty; - ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound} + ty.desc <- Tvariant {row with row_fields = fields} | Tobject (fi, nm) -> begin match !nm with | None -> () diff --git a/typing/includemod.ml b/typing/includemod.ml index 3f75546ea..610025e5d 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -208,8 +208,9 @@ and signatures env subst sig1 sig2 = | item2 :: rem -> let (id2, name2) = item_ident_name item2 in let name2, report = - match name2 with - Field_type s when let l = String.length s in + match item2, name2 with + Tsig_type (_, {type_manifest=None}, _), Field_type s + when let l = String.length s in l >= 4 && String.sub s (l-4) 4 = "#row" -> (* Do not report in case of failure, as the main type will generate an error *) diff --git a/typing/oprint.ml b/typing/oprint.ml index 139daadc2..819489750 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -75,7 +75,7 @@ let print_out_value ppf tree = fprintf ppf "@[<1>%a@ (%a)@]" print_ident name (print_tree_list print_tree_1 ",") params | Oval_variant (name, Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param + fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param | tree -> print_simple_tree ppf tree and print_constr_param ppf = function | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 3624fcc79..b9673a075 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -45,7 +45,7 @@ let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty (* p and q compatible means, there exists V that matches both *) -let is_absent tag row = Btype.row_field tag row = Rabsent +let is_absent tag row = Btype.row_field tag !row = Rabsent let is_absent_pat p = match p.pat_desc with | Tpat_variant (tag, _, row) -> is_absent tag row @@ -585,24 +585,29 @@ let close_variant env row = row_closed = true; row_name = nm})) end +let row_of_pat pat = + match Ctype.expand_head pat.pat_env pat.pat_type with + {desc = Tvariant row} -> Btype.row_repr row + | _ -> assert false + (* Check whether the first column of env makes up a complete signature or not. -*) +*) let full_match closing env = match env with | ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> false | ({pat_desc = Tpat_construct(c,_)},_) :: _ -> List.length env = c.cstr_consts + c.cstr_nonconsts -| ({pat_desc = Tpat_variant(_,_,row)},_) :: _ -> +| ({pat_desc = Tpat_variant _} as p,_) :: _ -> let fields = List.map (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag | _ -> assert false) env in - let row = Btype.row_repr row in + let row = row_of_pat p in if closing && not row.row_fixed then (* closing=true, we are considering the variant as closed *) List.for_all @@ -738,17 +743,17 @@ let build_other ext env = match env with let all_tags = List.map (fun (p,_) -> get_tag p) env in pat_of_constrs p (complete_constrs p all_tags) end -| ({pat_desc = Tpat_variant(_,_,row)} as p,_) :: _ -> +| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ -> let tags = List.map (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag | _ -> assert false) env in - let row = Btype.row_repr row in + let row = row_of_pat p in let make_other_pat tag const = let arg = if const then None else Some omega in - make_pat (Tpat_variant(tag, arg, row)) p.pat_type p.pat_env in + make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in begin match List.fold_left (fun others (tag,f) -> @@ -999,8 +1004,8 @@ let rec pressure_variants tdefs = function else try_non_omega (filter_all q0 (mark_partial pss)) in begin match constrs, tdefs with - ({pat_desc=Tpat_variant(_,_,row)},_):: _, Some env -> - let row = Btype.row_repr row in + ({pat_desc=Tpat_variant _} as p,_):: _, Some env -> + let row = row_of_pat p in if row.row_fixed || pressure_variants None (filter_extra pss) then () else close_variant env row diff --git a/typing/printtyp.ml b/typing/printtyp.ml index c6aec4fc8..5f4d5d0b4 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -246,7 +246,7 @@ let rec mark_loops_rec visited ty = | Some(p, tyl) when namable_row row -> List.iter (mark_loops_rec visited) tyl | _ -> - iter_row (mark_loops_rec visited) {row with row_bound = []} + iter_row (mark_loops_rec visited) row end | Tobject (fi, nm) -> if List.memq px !visited_objects then add_alias px else diff --git a/typing/subst.ml b/typing/subst.ml index f959f8af3..6b1282697 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -124,8 +124,6 @@ let rec typexp s ty = (* Return a new copy *) let row = copy_row (typexp s) true row (not dup) more' in - let row = - if s.for_saving then {row with row_bound = []} else row in match row.row_name with Some (p, tl) -> Tvariant {row with row_name = Some (type_path s p, tl)} diff --git a/typing/subst.mli b/typing/subst.mli index b2220bb49..d31385325 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -38,6 +38,9 @@ val add_modtype: Ident.t -> module_type -> t -> t val for_saving: t -> t val reset_for_saving: unit -> unit +val module_path: t -> Path.t -> Path.t +val type_path: t -> Path.t -> Path.t + val type_expr: t -> type_expr -> type_expr val class_type: t -> class_type -> class_type val value_description: t -> value_description -> value_description diff --git a/typing/typeclass.ml b/typing/typeclass.ml index a7ed236f3..a30b2a469 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -673,7 +673,8 @@ and class_structure cl_num final val_env met_env loc (spat, str) = Vars.fold (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) sign.cty_vars [] in - if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals))); + if mets <> [] || vals <> [] then + raise(Error(loc, Virtual_class(true, mets, vals))); let self_methods = List.fold_right (fun (lab,kind,ty) rem -> @@ -782,7 +783,7 @@ and class_expr cl_num val_env met_env scl = class_expr cl_num val_env met_env sfun | Pcl_fun (l, None, spat, scl') -> if !Clflags.principal then Ctype.begin_def (); - let (pat, pv, val_env, met_env) = + let (pat, pv, val_env', met_env) = Typecore.type_class_arg_pattern cl_num val_env met_env l spat in if !Clflags.principal then begin @@ -793,7 +794,7 @@ and class_expr cl_num val_env met_env scl = List.map (function (id, id', ty) -> (id, - Typecore.type_exp val_env + Typecore.type_exp val_env' {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id)); pexp_loc = Location.none})) pv @@ -810,7 +811,7 @@ and class_expr cl_num val_env met_env scl = exp_type = Ctype.none; exp_env = Env.empty }] in Ctype.raise_nongen_level (); - let cl = class_expr cl_num val_env met_env scl' in + let cl = class_expr cl_num val_env' met_env scl' in Ctype.end_def (); if Btype.is_optional l && not_function cl.cl_type then Location.prerr_warning pat.pat_loc diff --git a/typing/typecore.ml b/typing/typecore.ml index 5865d31ce..2c3a64ec6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -30,7 +30,7 @@ type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list - | Multiply_bound_variable + | Multiply_bound_variable of string | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr @@ -152,10 +152,13 @@ let unify_pat env pat expected_ty = (* make all Reither present in open variants *) let finalize_variant pat = match pat.pat_desc with - Tpat_variant(tag, opat, row) -> - let row = row_repr row in - let field = row_field tag row in - begin match field with + Tpat_variant(tag, opat, r) -> + let row = + match expand_head pat.pat_env pat.pat_type with + {desc = Tvariant row} -> r := row; row_repr row + | _ -> assert false + in + begin match row_field tag row with | Rabsent -> assert false | Reither (true, [], _, e) when not row.row_closed -> set_row_field e (Rpresent None) @@ -168,10 +171,10 @@ let finalize_variant pat = set_row_field e (Reither (c, [], false, ref None)) | _ -> () end; - (* Force check of well-formedness *) - unify_pat pat.pat_env pat + (* Force check of well-formedness WHY? *) + (* unify_pat pat.pat_env pat (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; - row_bound=[]; row_fixed=false; row_name=None})); + row_bound=(); row_fixed=false; row_name=None})); *) | _ -> () let rec iter_pattern f p = @@ -199,7 +202,7 @@ let reset_pattern scope = let enter_variable loc name ty = if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables - then raise(Error(loc, Multiply_bound_variable)); + then raise(Error(loc, Multiply_bound_variable name)); let id = Ident.create name in pattern_variables := (id, ty, loc) :: !pattern_variables; begin match !pattern_scope with @@ -258,7 +261,7 @@ let rec build_as_type env p = | Tpat_variant(l, p', _) -> let ty = may_map (build_as_type env) p' in newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); - row_bound=[]; row_name=None; + row_bound=(); row_name=None; row_fixed=false; row_closed=false}) | Tpat_record lpl -> let lbl = fst(List.hd lpl) in @@ -268,7 +271,10 @@ let rec build_as_type env p = let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in unify_pat env {p with pat_type = ty} ty_res; - if lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl then begin + let refinable = + lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && + match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in + if refinable then begin let arg = List.assoc lbl.lbl_pos ppl in unify_pat env {arg with pat_type = build_as_type env arg} ty_arg end else begin @@ -278,20 +284,16 @@ let rec build_as_type env p = end in Array.iter do_label lbl.lbl_all; ty - | Tpat_or(p1, p2, path) -> - let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in - unify_pat env {p2 with pat_type = ty2} ty1; - begin match path with None -> () - | Some path -> - let td = try Env.find_type path env with Not_found -> assert false in - let params = List.map (fun _ -> newvar()) td.type_params in - match expand_head env (newty (Tconstr (path, params, ref Mnil))) - with {desc=Tvariant row} when static_row row -> - unify_pat env {p1 with pat_type = ty1} - (newty (Tvariant{row with row_closed=false; row_more=newvar()})) - | _ -> () - end; - ty1 + | Tpat_or(p1, p2, row) -> + begin match row with + None -> + let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in + unify_pat env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + let row = row_repr row in + newty (Tvariant{row with row_closed=false; row_more=newvar()}) + end | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type let build_or_pat env loc lid = @@ -301,14 +303,12 @@ let build_or_pat env loc lid = raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid)) in let tyl = List.map (fun _ -> newvar()) decl.type_params in - let fields = + let row0 = let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in match ty.desc with - Tvariant row when static_row row -> - (row_repr row).row_fields + Tvariant row when static_row row -> row | _ -> raise(Error(loc, Not_a_variant_type lid)) in - let bound = ref [] in let pats, fields = List.fold_left (fun (pats,fields) (l,f) -> @@ -317,21 +317,21 @@ let build_or_pat env loc lid = (l,None) :: pats, (l, Reither(true,[], true, ref None)) :: fields | Rpresent (Some ty) -> - bound := ty :: !bound; (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; pat_type=ty}) :: pats, (l, Reither(false, [ty], true, ref None)) :: fields | _ -> pats, fields) - ([],[]) fields in + ([],[]) (row_repr row0).row_fields in let row = - { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound; + { row_fields = List.rev fields; row_more = newvar(); row_bound = (); row_closed = false; row_fixed = false; row_name = Some (path, tyl) } in let ty = newty (Tvariant row) in let gloc = {loc with Location.loc_ghost=true} in + let row' = ref {row with row_more=newvar()} in let pats = - List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row); pat_loc=gloc; + List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; pat_env=env; pat_type=ty}) pats in @@ -340,7 +340,7 @@ let build_or_pat env loc lid = | pat :: pats -> let r = List.fold_left - (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path); + (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_loc=gloc; pat_env=env; pat_type=ty}) pat pats in rp { r with pat_loc = loc } @@ -432,13 +432,13 @@ let rec type_pat env sp = let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in let row = { row_fields = [l, Reither(arg = None, arg_type, true, ref None)]; - row_bound = arg_type; + row_bound = (); row_closed = false; row_more = newvar (); row_fixed = false; row_name = None } in rp { - pat_desc = Tpat_variant(l, arg, row); + pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); pat_loc = sp.ppat_loc; pat_type = newty (Tvariant row); pat_env = env } @@ -594,8 +594,11 @@ let delayed_checks = ref [] let reset_delayed_checks () = delayed_checks := [] let add_delayed_check f = delayed_checks := f :: !delayed_checks let force_delayed_checks () = + (* checks may change type levels *) + let snap = Btype.snapshot () in List.iter (fun f -> f ()) (List.rev !delayed_checks); - reset_delayed_checks () + reset_delayed_checks (); + Btype.backtrack snap (* Generalization criterion for expressions *) @@ -624,6 +627,7 @@ let rec is_nonexpansive exp = | Texp_array [] -> true | Texp_ifthenelse(cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot + | Texp_sequence (e1, e2) -> is_nonexpansive e2 (* PR#4354 *) | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> true (* Note: nonexpansive only means no _observable_ side effects *) @@ -1028,7 +1032,7 @@ let rec type_exp env sexp = exp_loc = sexp.pexp_loc; exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; row_more = newvar (); - row_bound = []; + row_bound = (); row_closed = false; row_fixed = false; row_name = None}); @@ -2067,8 +2071,8 @@ let report_error ppf = function fprintf ppf "This pattern matches values of type") (function ppf -> fprintf ppf "but is here used to match values of type") - | Multiply_bound_variable -> - fprintf ppf "This variable is bound several times in this matching" + | Multiply_bound_variable name -> + fprintf ppf "Variable %s is bound several times in this matching" name | Orpat_vars id -> fprintf ppf "Variable %s must occur on both sides of this | pattern" (Ident.name id) diff --git a/typing/typecore.mli b/typing/typecore.mli index d860f0a85..65ae12b17 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -70,7 +70,7 @@ type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list - | Multiply_bound_variable + | Multiply_bound_variable of string | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 942b4ce00..6f5f5d40b 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -33,10 +33,10 @@ and pattern_desc = | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of constructor_description * pattern list - | Tpat_variant of label * pattern option * row_desc + | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list - | Tpat_or of pattern * pattern * Path.t option + | Tpat_or of pattern * pattern * row_desc option type partial = Partial | Total type optional = Required | Optional diff --git a/typing/typedtree.mli b/typing/typedtree.mli index ebf8aba70..af8b1a6ef 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -32,10 +32,10 @@ and pattern_desc = | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of constructor_description * pattern list - | Tpat_variant of label * pattern option * row_desc + | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list - | Tpat_or of pattern * pattern * Path.t option + | Tpat_or of pattern * pattern * row_desc option type partial = Partial | Total type optional = Required | Optional diff --git a/typing/typemod.ml b/typing/typemod.ml index 70037182c..0552204e0 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -411,11 +411,19 @@ and transl_recmodule_modtypes loc env sdecls = (fun (name, smty) -> (Ident.create name, approx_modtype transl_modtype env smty)) sdecls in - let first = transition (make_env init) init in - let final_env = make_env first in - let final_decl = transition final_env init in - check_recmod_typedecls final_env sdecls final_decl; - (final_decl, final_env) + let env0 = make_env init in + let dcl1 = transition env0 init in + let env1 = make_env dcl1 in + let dcl2 = transition env1 dcl1 in + let env2 = make_env dcl2 in + check_recmod_typedecls env2 sdecls dcl2; +(* + List.iter + (fun (id, mty) -> + Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) + dcl2; +*) + (dcl2, env2) (* Try to convert a module expression to a module path. *) @@ -493,6 +501,79 @@ let enrich_module_type anchor name mty env = None -> mty | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty +let check_recmodule_inclusion env bindings = + (* PR#4450, PR#4470: consider + module rec X : DECL = MOD where MOD has inferred type ACTUAL + The "natural" typing condition + E, X: ACTUAL |- ACTUAL <: DECL + leads to circularities through manifest types. + Instead, we "unroll away" the potential circularities a finite number + of times. The (weaker) condition we implement is: + E, X: DECL, + X1: ACTUAL, + X2: ACTUAL{X <- X1}/X1 + ... + Xn: ACTUAL{X <- X(n-1)}/X(n-1) + |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn} + so that manifest types rooted at X(n+1) are expanded in terms of X(n), + avoiding circularities. The strengthenings ensure that + Xn.t = X(n-1).t = ... = X2.t = X1.t. + N can be chosen arbitrarily; larger values of N result in more + recursive definitions being accepted. A good choice appears to be + the number of mutually recursive declarations. *) + + let subst_and_strengthen env s id mty = + Mtype.strengthen env (Subst.modtype s mty) + (Subst.module_path s (Pident id)) in + + let rec check_incl first_time n env s = + if n > 0 then begin + (* Generate fresh names Y_i for the rec. bound module idents X_i *) + let bindings1 = + List.map + (fun (id, mty_decl, modl, mty_actual) -> + (id, Ident.rename id, mty_actual)) + bindings in + (* Enter the Y_i in the environment with their actual types substituted + by the input substitution s *) + let env' = + List.fold_left + (fun env (id, id', mty_actual) -> + let mty_actual' = + if first_time + then mty_actual + else subst_and_strengthen env s id mty_actual in + Env.add_module id' mty_actual' env) + env bindings1 in + (* Build the output substitution Y_i <- X_i *) + let s' = + List.fold_left + (fun s (id, id', mty_actual) -> + Subst.add_module id (Pident id') s) + Subst.identity bindings1 in + (* Recurse with env' and s' *) + check_incl false (n-1) env' s' + end else begin + (* Base case: check inclusion of s(mty_actual) in s(mty_decl) + and insert coercion if needed *) + let check_inclusion (id, mty_decl, modl, mty_actual) = + let mty_decl' = Subst.modtype s mty_decl + and mty_actual' = subst_and_strengthen env s id mty_actual in + let coercion = + try + Includemod.modtypes env mty_actual' mty_decl' + with Includemod.Error msg -> + raise(Error(modl.mod_loc, Not_included msg)) in + let modl' = + { mod_desc = Tmod_constraint(modl, mty_decl, coercion); + mod_type = mty_decl; + mod_env = env; + mod_loc = modl.mod_loc } in + (id, modl') in + List.map check_inclusion bindings + end + in check_incl true (List.length bindings) env Subst.identity + (* Type a module value expression *) let rec type_module anchor env smod = @@ -641,27 +722,21 @@ and type_structure anchor env sstr scope = let (decls, newenv) = transl_recmodule_modtypes loc env (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in - let type_recmodule_binding (id, mty) (name, smty, smodl) = - let modl = - type_module (anchor_recmodule id anchor) newenv smodl in - let coercion = - try - Includemod.modtypes newenv - (Mtype.strengthen env modl.mod_type (Pident id)) - mty - with Includemod.Error msg -> - raise(Error(smodl.pmod_loc, Not_included msg)) in - let modl' = - { mod_desc = Tmod_constraint(modl, mty, coercion); - mod_type = mty; - mod_env = newenv; - mod_loc = smodl.pmod_loc } in - (id, modl') in - let bind = List.map2 type_recmodule_binding decls sbind in + let bindings1 = + List.map2 + (fun (id, mty) (name, smty, smodl) -> + let modl = + type_module (anchor_recmodule id anchor) newenv smodl in + let mty' = + enrich_module_type anchor (Ident.name id) modl.mod_type newenv in + (id, mty, modl, mty')) + decls sbind in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_recmodule bind :: str_rem, + (Tstr_recmodule bindings2 :: str_rem, map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs)) - bind sig_rem, + bindings2 sig_rem, final_env) | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem -> check "module type" loc modtype_names name; diff --git a/typing/types.ml b/typing/types.ml index fe876760f..0a6e652ec 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -41,7 +41,7 @@ and type_desc = and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; - row_bound: type_expr list; + row_bound: unit; row_closed: bool; row_fixed: bool; row_name: (Path.t * type_expr list) option } diff --git a/typing/types.mli b/typing/types.mli index 05d205267..26f429496 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -40,7 +40,7 @@ and type_desc = and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; - row_bound: type_expr list; + row_bound: unit; (* kept for compatibility *) row_closed: bool; row_fixed: bool; row_name: (Path.t * type_expr list) option } diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 4f615abbd..33583af50 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -202,14 +202,12 @@ let rec transl_type env policy styp = (fun l -> if not (List.mem_assoc l row.row_fields) then raise(Error(styp.ptyp_loc, Present_has_no_type l))) present; - let bound = ref row.row_bound in let fields = List.map (fun (l,f) -> l, if List.mem l present then f else match Btype.row_field_repr f with | Rpresent (Some ty) -> - bound := ty :: !bound; Reither(false, [ty], false, ref None) | Rpresent None -> Reither (true, [], false, ref None) @@ -217,7 +215,7 @@ let rec transl_type env policy styp = row.row_fields in let row = { row_closed = true; row_fields = fields; - row_bound = !bound; row_name = Some (path, args); + row_bound = (); row_name = Some (path, args); row_fixed = false; row_more = newvar () } in let static = Btype.static_row row in let row = @@ -262,28 +260,31 @@ let rec transl_type env policy styp = instance t end | Ptyp_variant(fields, closed, present) -> - let bound = ref [] and name = ref None in + let name = ref None in let mkfield l f = newty (Tvariant {row_fields=[l,f]; row_more=newvar(); - row_bound=[]; row_closed=true; + row_bound=(); row_closed=true; row_fixed=false; row_name=None}) in - let add_typed_field loc l f fields = + let hfields = Hashtbl.create 17 in + let add_typed_field loc l f = + let h = Btype.hash_variant l in try - let f' = List.assoc l fields in + let (l',f') = Hashtbl.find hfields h in + (* Check for tag conflicts *) + if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l'))); let ty = mkfield l f and ty' = mkfield l f' in - if equal env false [ty] [ty'] then fields else - try unify env ty ty'; fields + if equal env false [ty] [ty'] then () else + try unify env ty ty' with Unify trace -> raise(Error(loc, Constructor_mismatch (ty,ty'))) with Not_found -> - (l, f) :: fields + Hashtbl.add hfields h (l,f) in - let rec add_field fields = function + let rec add_field = function Rtag (l, c, stl) -> name := None; let f = match present with Some present when not (List.mem l present) -> let tl = List.map (transl_type env policy) stl in - bound := tl @ !bound; Reither(c, tl, false, ref None) | _ -> if List.length stl > 1 || c && stl <> [] then @@ -291,7 +292,7 @@ let rec transl_type env policy styp = match stl with [] -> Rpresent None | st :: _ -> Rpresent (Some(transl_type env policy st)) in - add_typed_field styp.ptyp_loc l f fields + add_typed_field styp.ptyp_loc l f | Rinherit sty -> let ty = transl_type env policy sty in let nm = @@ -299,7 +300,14 @@ let rec transl_type env policy styp = {desc=Tconstr(p, tl, _)} -> Some(p, tl) | _ -> None in - name := if fields = [] then nm else None; + begin try + (* Set name if there are no fields yet *) + Hashtbl.iter (fun _ _ -> raise Exit) hfields; + name := nm + with Exit -> + (* Unset it otherwise *) + name := None + end; let fl = match expand_head env ty, nm with {desc=Tvariant row}, _ when Btype.static_row row -> let row = Btype.row_repr row in @@ -309,13 +317,12 @@ let rec transl_type env policy styp = | _ -> raise(Error(sty.ptyp_loc, Not_a_variant ty)) in - List.fold_left - (fun fields (l, f) -> + List.iter + (fun (l, f) -> let f = match present with Some present when not (List.mem l present) -> begin match f with Rpresent(Some ty) -> - bound := ty :: !bound; Reither(false, [ty], false, ref None) | Rpresent None -> Reither(true, [], false, ref None) @@ -324,10 +331,11 @@ let rec transl_type env policy styp = end | _ -> f in - add_typed_field sty.ptyp_loc l f fields) - fields fl + add_typed_field sty.ptyp_loc l f) + fl in - let fields = List.fold_left add_field [] fields in + List.iter add_field fields; + let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in begin match present with None -> () | Some present -> List.iter @@ -335,25 +343,18 @@ let rec transl_type env policy styp = raise(Error(styp.ptyp_loc, Present_has_no_type l))) present end; - (* Check for tag conflicts *) - let ht = Hashtbl.create (List.length fields + 1) in - List.iter - (fun (l,_) -> - let h = Btype.hash_variant l in - try - let l' = Hashtbl.find ht h in - if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l'))) - with Not_found -> - Hashtbl.add ht h l) - fields; let row = { row_fields = List.rev fields; row_more = newvar (); - row_bound = !bound; row_closed = closed; + row_bound = (); row_closed = closed; row_fixed = false; row_name = !name } in let static = Btype.static_row row in let row = - if static || policy <> Univars then row - else { row with row_more = new_pre_univar () } + if static then row else + match policy with + Fixed -> + raise (Error (styp.ptyp_loc, Unbound_type_variable "..")) + | Extensible -> row + | Univars -> { row with row_more = new_pre_univar () } in newty (Tvariant row) | Ptyp_poly(vars, st) -> diff --git a/utils/ccomp.ml b/utils/ccomp.ml index 02d6f8835..3cb192e31 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -46,6 +46,10 @@ let quote_prefixed pr lst = let lst = List.map (fun f -> pr ^ f) lst in quote_files lst +let quote_optfile = function + | None -> "" + | Some f -> Filename.quote f + let compile_file name = command (Printf.sprintf diff --git a/utils/ccomp.mli b/utils/ccomp.mli index 2ffb30383..72ae71314 100644 --- a/utils/ccomp.mli +++ b/utils/ccomp.mli @@ -20,6 +20,7 @@ val compile_file: string -> int val create_archive: string -> string list -> int val expand_libname: string -> string val quote_files: string list -> string +val quote_optfile: string option -> string (*val make_link_options: string list -> string*) type link_mode = |