Merge from diff ocaml3100/ocaml3102: cvs update -j ocaml3100 -j ocaml3102 -kkcducetrunk

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/cducetrunk@8864 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

121 files changed, 2733 insertions, 1728 deletions

diff --git a/Changes b/Changes
index 797b223b93..75987b0623 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,106 @@
+Objective Caml 3.10.2:
+----------------------
+
+Bug fixes:
+- PR#1217 (partial) Typo in ocamldep man page
+- PR#3952 (partial) ocamlopt: allocation problems on ARM
+- PR#4339 (continued) ocamlopt: problems on HPPA
+- PR#4455 str.mli not installed under Windows
+- PR#4473 crash when accessing float array with polymorphic method
+- PR#4480 runtime would not compile without gcc extensions
+- PR#4481 wrong typing of exceptions with object arguments
+- PR#4490 typo in error message
+- Random crash on 32-bit when major_heap_increment >= 2^22
+- Big performance bug in Weak hashtables
+- Small bugs in the make-package-macosx script
+- Bug in typing of polymorphic variants (reported on caml-list)
+
+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:
 ----------------------
 
diff --git a/Makefile b/Makefile
index 925af6793c..0e3d542677 100644
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,6 @@
 # Build the OCamlDuce tools using an existing OCaml installation
 
-VERSION=3.10.0.1
+VERSION=3.10.2
 
 OCAMLDUCELIBDIR=$(shell ocamlfind printconf destdir)/ocamlduce
 
diff --git a/Makefile.nt b/Makefile.nt
index ec8b91b1bd..ff1816bad8 100644
--- a/Makefile.nt
+++ b/Makefile.nt
@@ -200,7 +200,7 @@ cleanboot:
 	rm -rf boot/Saved/Saved.prev/*
 
 # Compile the native-code compiler
-opt: runtimeopt ocamlopt libraryopt otherlibrariesopt
+opt: runtimeopt ocamlopt libraryopt otherlibrariesopt ocamlbuildlib.native
 
 # Native-code versions of the tools
 opt.opt: ocamlc.opt ocamlopt.opt ocamllex.opt ocamltoolsopt.opt \
@@ -577,6 +577,9 @@ ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot
 	./build/ocamlbuild-byte-only.sh
 ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot
 	./build/ocamlbuild-native-only.sh
+ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot
+	./build/ocamlbuildlib-native-only.sh
+
 
 .PHONY: ocamlbuild-partial-boot
 ocamlbuild-partial-boot:
diff --git a/README.win32 b/README.win32
index 2ab75a6fab..bfdff2b04a 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/
 
@@ -131,7 +134,7 @@ Finally, use "make -f Makefile.nt" to build the system, e.g.
         make -f Makefile.nt opt.opt
         make -f Makefile.nt install
 
-Alternatively you can use the experimental build procdure using ocamlbuild:
+Alternatively you can use the experimental build procedure using ocamlbuild:
 
         ./build/fastworld.sh
         ./build/install.sh
@@ -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).
 
diff --git a/VERSION b/VERSION
index 871a3ca972..fe9afdf21e 100644
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-3.10.0.1
+3.10.2
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli
diff --git a/_tags b/_tags
index 6dd67f0e10..322973a98e 100644
--- a/_tags
+++ b/_tags
@@ -16,8 +16,8 @@ true: debug
 # By default everything we link needs the stdlib
 true: use_stdlib
 
-# The stdlib don't require the stdlib
-<stdlib/**>: -use_stdlib
+# The stdlib neither requires the stdlib nor debug information
+<stdlib/**>: -use_stdlib, -debug
 
 <**/*.ml*>: warn_Alez
 
@@ -30,7 +30,8 @@ true: use_stdlib
 "ocamldoc/odoc_opt.native": use_unix, use_str
 
 <camlp4/**/*.ml*>: camlp4boot, -warn_Alez, warn_Ale
-<camlp4/Camlp4_config.ml*>: -camlp4boot
+<camlp4/Camlp4_{config,import}.ml*>: -camlp4boot
+"camlp4/Camlp4_import.ml": -warn_Ale
 <camlp4/build/*> or <camlp4/boot/*> or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Ale, warn_a
 "camlp4/Camlp4Bin.byte" or "camlp4/mkcamlp4.byte" or "camlp4/camlp4lib.cma": use_dynlink
 "camlp4/Camlp4/Printers/OCaml.ml" or "camlp4/Camlp4/Printers/OCamlr.ml": warn_Alezv
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 4f2d54d172..7b5565b497 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -197,7 +197,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 *)
 
@@ -549,8 +549,22 @@ let emit_instr fallthrough i =
     | Lswitch jumptbl ->
         let lbl = new_label() in
         if !pic_code 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 30b046e6de..71b71157b8 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 a26aaee618..586d477bd1 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 3066d785d9..e34093acbd 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 6727e3226c..21cb88a6d1 100644
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -229,8 +229,8 @@ let call_linker file_list startup_file output_name =
     else "libasmrun" ^ ext_lib in
   let runtime_lib =
     try
-      if !Clflags.nopervasives then ""
-      else find_in_path !load_path libname
+      if !Clflags.nopervasives then None
+      else Some(find_in_path !load_path libname)
     with Not_found ->
       raise(Error(File_not_found libname)) in
   let c_lib =
@@ -251,7 +251,7 @@ let call_linker file_list startup_file output_name =
               (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir)
                         !load_path))
             (Ccomp.quote_files (List.rev !Clflags.ccobjs))
-            (Filename.quote runtime_lib)
+            (Ccomp.quote_optfile runtime_lib)
             c_lib
         else
           Printf.sprintf "%s -o %s %s %s"
@@ -271,7 +271,7 @@ let call_linker file_list startup_file output_name =
             (Ccomp.quote_files (List.rev file_list))
             (Ccomp.quote_files 
               (List.rev_map Ccomp.expand_libname !Clflags.ccobjs))
-            (Filename.quote runtime_lib)
+            (Ccomp.quote_optfile runtime_lib)
             c_lib
             (Ccomp.make_link_options !Clflags.ccopts) in
         if Ccomp.command cmd <> 0 then raise(Error Linking_error);
diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml
index 57a242d707..54208fcc33 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 24db6cd900..6a0e9fe409 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 b50ecff27f..c009ad6fef 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -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 *)
 
diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp
index bba42fe88f..e4ac9d408d 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 554b6c55b6..4c91c9acfa 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/.depend b/asmrun/.depend
index b9e29856f6..2e7c20d1c4 100644
--- a/asmrun/.depend
+++ b/asmrun/.depend
@@ -138,7 +138,7 @@ minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/fail.h \
   ../byterun/minor_gc.h ../byterun/gc.h ../byterun/gc_ctrl.h \
   ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \
   ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \
-  ../byterun/signals.h
+  ../byterun/signals.h ../byterun/weak.h
 misc.o: misc.c ../byterun/config.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
   ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
@@ -340,7 +340,7 @@ minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/fail.h \
   ../byterun/minor_gc.h ../byterun/gc.h ../byterun/gc_ctrl.h \
   ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \
   ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \
-  ../byterun/signals.h
+  ../byterun/signals.h ../byterun/weak.h
 misc.d.o: misc.c ../byterun/config.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
   ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
@@ -542,7 +542,7 @@ minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/fail.h \
   ../byterun/minor_gc.h ../byterun/gc.h ../byterun/gc_ctrl.h \
   ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \
   ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \
-  ../byterun/signals.h
+  ../byterun/signals.h ../byterun/weak.h
 misc.p.o: misc.c ../byterun/config.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
   ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
diff --git a/asmrun/arm.S b/asmrun/arm.S
index c32b4b6674..98fdfcfe32 100644
--- a/asmrun/arm.S
+++ b/asmrun/arm.S
@@ -91,11 +91,13 @@ caml_allocN:
     /* Record return address and desired size */
         ldr     alloc_limit, .Lcaml_last_return_address
         str     lr, [alloc_limit, #0]
-        str     r10, .Lcaml_requested_size
+        ldr     alloc_limit, .LLcaml_requested_size
+        str     r10, [alloc_limit, #0]
     /* Invoke GC */
         bl      .Linvoke_gc
     /* Try again */
-        ldr     r10, .Lcaml_requested_size
+        ldr     r10, .LLcaml_requested_size
+        ldr     r10, [r10, #0]
         b       caml_allocN
 
 /* Shared code to invoke the GC */
@@ -323,9 +325,12 @@ caml_ml_array_bound_error:
 .LLtrap_handler:                .word .Ltrap_handler
 .Lcaml_apply2:                  .word caml_apply2
 .Lcaml_apply3:                  .word caml_apply3
-.Lcaml_requested_size:          .word 0
+.LLcaml_requested_size:         .word .Lcaml_requested_size
 .Lcaml_array_bound_error:       .word caml_array_bound_error
 
+.data
+.Lcaml_requested_size:          .word 0
+
 /* GC roots for callback */
 
         .data
diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
index 50af17bb73..0d918b142e 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 9d45f6e974..ce05744a79 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 f5ff1591e8..c1d3db003a 100644
--- a/asmrun/roots.c
+++ b/asmrun/roots.c
@@ -100,7 +100,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;
@@ -229,7 +233,11 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack,
   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 * root;
   struct caml__roots_block *lr;
 
diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c
index f333540513..b55561265f 100644
--- a/asmrun/signals_asm.c
+++ b/asmrun/signals_asm.c
@@ -238,7 +238,7 @@ void caml_init_signals(void)
   /* Stack overflow handling */
 #ifdef HAS_STACK_OVERFLOW_DETECTION
   {
-    struct sigaltstack stk;
+    stack_t stk;
     struct sigaction act;
     stk.ss_sp = sig_alt_stack;
     stk.ss_size = SIGSTKSZ;
diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h
index f34863b39b..ceefc7161f 100644
--- a/asmrun/signals_osdep.h
+++ b/asmrun/signals_osdep.h
@@ -87,9 +87,16 @@
      sigact.sa_flags = SA_SIGINFO
 
   #include <sys/ucontext.h>
+  #include <AvailabilityMacros.h>
 
-  #define CONTEXT_STATE (((struct ucontext *)context)->uc_mcontext->ss)
-  #define CONTEXT_PC (CONTEXT_STATE.eip)
+#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))
+  #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(eip))
   #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
 
 /****************** MIPS, all OS */
@@ -113,106 +120,43 @@
 
 #elif defined(TARGET_power) && defined(SYS_rhapsody)
 
-#ifdef __ppc64__
-
   #define DECLARE_SIGNAL_HANDLER(name) \
      static void name(int sig, siginfo_t * info, void * context)
 
-  #define SET_SIGACT(sigact,name) \
-     sigact.sa_sigaction = (name); \
-     sigact.sa_flags = SA_SIGINFO | SA_64REGSET
-
-  typedef unsigned long long context_reg;
-
   #include <sys/ucontext.h>
-
-  #define CONTEXT_STATE (((struct ucontext64 *)context)->uc_mcontext64->ss)
-
-  #define CONTEXT_PC (CONTEXT_STATE.srr0)
-  #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.r29)
-  #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.r30)
-  #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.r31)
-  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
-  #define CONTEXT_SP (CONTEXT_STATE.r1)
-
-#else
-
-  #include <sys/utsname.h>
-
-  #define DECLARE_SIGNAL_HANDLER(name) \
-     static void name(int sig, siginfo_t * info, void * context)
-
-  #define SET_SIGACT(sigact,name) \
-     sigact.sa_handler = (void (*)(int)) (name); \
-     sigact.sa_flags = SA_SIGINFO
-
-  typedef unsigned long context_reg;
-
-  #define CONTEXT_PC (*context_gpr_p(context, -2))
-  #define CONTEXT_EXCEPTION_POINTER (*context_gpr_p(context, 29))
-  #define CONTEXT_YOUNG_LIMIT (*context_gpr_p(context, 30))
-  #define CONTEXT_YOUNG_PTR (*context_gpr_p(context, 31))
-  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
-  #define CONTEXT_SP (*context_gpr_p(context, 1))
-
-  static int ctx_version = 0;
-  static void init_ctx (void)
-  {
-    struct utsname name;
-    if (uname (&name) == 0){
-      if (name.release[1] == '.' && name.release[0] <= '5'){
-        ctx_version = 1;
-      }else{
-        ctx_version = 2;
-      }
-    }else{
-      caml_fatal_error ("cannot determine SIGCONTEXT format");
-    }
-  }
-
-  #ifdef DARWIN_VERSION_6
-    #include <sys/ucontext.h>
-    static unsigned long *context_gpr_p (void *ctx, int regno)
-    {
-      unsigned long *regs;
-      if (ctx_version == 0) init_ctx ();
-      if (ctx_version == 1){
-        /* old-style context (10.0 and 10.1) */
-        regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs);
-      }else{
-        Assert (ctx_version == 2);
-        /* new-style context (10.2) */
-        regs = (unsigned long *)&(((struct ucontext *)ctx)->uc_mcontext->ss);
-      }
-      return &(regs[2 + regno]);
-    }
+  #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 SA_SIGINFO 0x0040
-    struct ucontext {
-      int       uc_onstack;
-      sigset_t  uc_sigmask;
-      struct sigaltstack uc_stack;
-      struct ucontext   *uc_link;
-      size_t    uc_mcsize;
-      unsigned long     *uc_mcontext;
-    };
-    static unsigned long *context_gpr_p (void *ctx, int regno)
-    {
-      unsigned long *regs;
-      if (ctx_version == 0) init_ctx ();
-      if (ctx_version == 1){
-        /* old-style context (10.0 and 10.1) */
-        regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs);
-      }else{
-        Assert (ctx_version == 2);
-        /* new-style context (10.2) */
-        regs = (unsigned long *)((struct ucontext *)ctx)->uc_mcontext + 8;
-      }
-      return &(regs[2 + regno]);
-    }
+    #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
+  
+#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
 
-#endif
+  #define CONTEXT_STATE (CONTEXT_MCONTEXT->CONTEXT_REG(ss))
+  #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(srr0))
+  #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r29))
+  #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.CONTEXT_REG(r30))
+  #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r31))
+  #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(r1))
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
 
 /****************** PowerPC, ELF (Linux) */
 
diff --git a/boot/myocamlbuild.boot b/boot/myocamlbuild.boot
index 3187433c94..c97932a1db 100755
--- a/boot/myocamlbuild.boot
+++ b/boot/myocamlbuild.boot
diff --git a/boot/ocamlc b/boot/ocamlc
index bccf3072ed..29b8cdeb46 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 85d7bddff3..b5c48aa177 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index ab895f363f..2897bf2a92 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 184626dfa6..f7caf464e7 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 fd2b91de08..8bad09eb39 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -71,10 +71,10 @@ let transl_val tbl create name =
   Lapply (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 =
@@ -88,7 +88,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)
 
@@ -203,22 +203,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, Lapply (oo_prim "get_method_label",
-                              [Lvar tbl; transl_label lab]),
+  Llet(Strict, id, Lapply (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,
        Lapply (oo_prim getter,
                [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
        List.fold_right
@@ -246,6 +246,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 ->
@@ -308,16 +310,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
@@ -583,6 +585,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 *)
@@ -600,10 +605,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 f34047b3bd..a2a221eaf1 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -333,7 +333,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 *)
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index 8838145468..6e8075a3a0 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -52,7 +52,7 @@ let maybe_pointer exp =
 let array_element_kind env ty =
   let ty = Ctype.repr (Ctype.expand_head env ty) in
   match ty.desc with
-    Tvar ->
+    Tvar | Tunivar ->
       Pgenarray
   | Tconstr(p, args, abbrev) ->
       if Path.same p Predef.path_int || Path.same p Predef.path_char then
diff --git a/byterun/.depend b/byterun/.depend
index 43277c13ee..3ce28b106e 100644
--- a/byterun/.depend
+++ b/byterun/.depend
@@ -87,7 +87,7 @@ meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h
 minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \
   compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \
-  gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h
+  gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h
 misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \
   misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h
 obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \
@@ -224,7 +224,7 @@ meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h
 minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \
   compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \
-  gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h
+  gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h
 misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \
   misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h
 obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \
diff --git a/byterun/compare.c b/byterun/compare.c
index 4cd6df29ea..c83f7d12f3 100644
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -269,14 +269,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/compatibility.h b/byterun/compatibility.h
index 78860756dd..6b7d4f01b4 100644
--- a/byterun/compatibility.h
+++ b/byterun/compatibility.h
@@ -237,8 +237,7 @@
 #define young_end caml_young_end
 #define young_ptr caml_young_ptr
 #define young_limit caml_young_limit
-#define ref_table_ptr caml_ref_table_ptr
-#define ref_table_limit caml_ref_table_limit
+#define ref_table caml_ref_table
 #define minor_collection caml_minor_collection
 #define check_urgent_gc caml_check_urgent_gc
 
diff --git a/byterun/finalise.c b/byterun/finalise.c
index e411311489..5a9c0c07f6 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,7 +85,9 @@ 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){
-          value fv = Forward_val (final_table[i].val);
+          value fv;
+          Assert (final_table[i].offset == 0);
+          fv = Forward_val (final_table[i].val);
           if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv))
               && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag
                   || Tag_val (fv) == Double_tag)){
@@ -136,7 +139,7 @@ void caml_final_do_calls (void)
       -- to_do_hd->size;
       f = to_do_hd->item[to_do_hd->size];
       running_finalisation_function = 1;
-      caml_callback (f.fun, f.val);
+      caml_callback (f.fun, f.val + f.offset);
       running_finalisation_function = 0;
     }
     caml_gc_message (0x80, "Done calling finalisation functions.\n", 0);
@@ -159,7 +162,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 +189,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 +213,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 +230,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/freelist.c b/byterun/freelist.c
index c463d91f79..e263072559 100644
--- a/byterun/freelist.c
+++ b/byterun/freelist.c
@@ -63,7 +63,11 @@ static void fl_check (void)
     size_found += Whsize_bp (cur);
     Assert (Is_in_heap (cur));
     if (cur == fl_prev) prev_found = 1;
-    if (cur == caml_fl_merge) merge_found = 1;
+    if (cur == caml_fl_merge){
+      merge_found = 1;
+      Assert (cur <= caml_gc_sweep_hp);
+      Assert (Next (cur) == NULL || Next (cur) > caml_gc_sweep_hp);
+    }
     prev = cur;
     cur = Next (prev);
   }
@@ -71,6 +75,7 @@ static void fl_check (void)
   Assert (merge_found || caml_fl_merge == Fl_head);
   Assert (size_found == caml_fl_cur_size);
 }
+
 #endif
 
 /* [allocate_block] is called by [caml_fl_allocate].  Given a suitable free
@@ -109,7 +114,7 @@ static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur)
   }
   fl_prev = prev;
   return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
-}  
+}
 
 /* [caml_fl_allocate] does not set the header of the newly allocated block.
    The calling function must do it before any GC function gets called.
@@ -175,14 +180,9 @@ char *caml_fl_merge_block (char *bp)
   mlsize_t prev_wosz;
 
   caml_fl_cur_size += Whsize_hd (hd);
-  
+
 #ifdef DEBUG
-  {
-    mlsize_t i;
-    for (i = 0; i < Wosize_hd (hd); i++){
-      Field (Val_bp (bp), i) = Debug_free_major;
-    }
-  }
+  caml_set_fields (bp, 0, Debug_free_major);
 #endif
   prev = caml_fl_merge;
   cur = Next (prev);
@@ -249,29 +249,26 @@ char *caml_fl_merge_block (char *bp)
 
 /* This is a heap extension.  We have to insert it in the right place
    in the free-list.
-   [caml_fl_add_block] can only be called right after a call to
+   [caml_fl_add_blocks] can only be called right after a call to
    [caml_fl_allocate] that returned NULL.
    Most of the heap extensions are expected to be at the end of the
    free list.  (This depends on the implementation of [malloc].)
+
+   [bp] must point to a list of blocks chained by their field 0,
+   terminated by NULL, and field 1 of the first block must point to
+   the last block.
 */
-void caml_fl_add_block (char *bp)
+void caml_fl_add_blocks (char *bp)
 {
                                                    Assert (fl_last != NULL);
                                             Assert (Next (fl_last) == NULL);
-#ifdef DEBUG
-  {
-    mlsize_t i;
-    for (i = 0; i < Wosize_bp (bp); i++){
-      Field (Val_bp (bp), i) = Debug_free_major;
-    }
-  }
-#endif
-
   caml_fl_cur_size += Whsize_bp (bp);
 
   if (bp > fl_last){
     Next (fl_last) = bp;
-    Next (bp) = NULL;
+    if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp){
+      caml_fl_merge = (char *) Field (bp, 1);
+    }
   }else{
     char *cur, *prev;
 
@@ -282,12 +279,14 @@ void caml_fl_add_block (char *bp)
       cur = Next (prev);
     }                                  Assert (prev < bp || prev == Fl_head);
                                             Assert (cur > bp || cur == NULL);
-    Next (bp) = cur;
+    Next (Field (bp, 1)) = cur;
     Next (prev) = bp;
-    /* When inserting a block between [caml_fl_merge] and [caml_gc_sweep_hp],
+    /* When inserting blocks between [caml_fl_merge] and [caml_gc_sweep_hp],
        we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge]
        is always the last free-list block before [caml_gc_sweep_hp]. */
-    if (prev == caml_fl_merge && bp <= caml_gc_sweep_hp) caml_fl_merge = bp;
+    if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){
+      caml_fl_merge = (char *) Field (bp, 1);
+    }
   }
 }
 
diff --git a/byterun/freelist.h b/byterun/freelist.h
index ea03ad9869..823748548f 100644
--- a/byterun/freelist.h
+++ b/byterun/freelist.h
@@ -28,7 +28,7 @@ char *caml_fl_allocate (mlsize_t);
 void caml_fl_init_merge (void);
 void caml_fl_reset (void);
 char *caml_fl_merge_block (char *);
-void caml_fl_add_block (char *);
+void caml_fl_add_blocks (char *);
 void caml_make_free_blocks (value *, mlsize_t, int);
 
 
diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index 12bfc9b0a1..6e593389d5 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);
+      }
     }
   }
 }
@@ -454,10 +457,6 @@ void caml_init_gc (uintnat minor_size, uintnat major_size,
 {
   uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size));
 
-#ifdef DEBUG
-  caml_gc_message (-1, "### O'Caml runtime: debug mode ###\n", 0);
-#endif
-
   caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
   caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr));
   caml_percent_free = norm_pfree (percent_fr);
diff --git a/byterun/intern.c b/byterun/intern.c
index 5f99b5b063..b7acfd4a06 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 23ee463296..ed18e6f446 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 a35124ac9f..127c4c1c5e 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/main.c b/byterun/main.c
index 3454ffcd0c..e6afb1b326 100644
--- a/byterun/main.c
+++ b/byterun/main.c
@@ -28,6 +28,27 @@ CAMLextern void caml_expand_command_line (int *, char ***);
 
 int main(int argc, char **argv)
 {
+#ifdef DEBUG
+  {
+    char *ocp;
+    char *cp;
+    int i;
+
+    caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
+#if 0
+    caml_gc_message (-1, "### command line:", 0);
+    for (i = 0; i < argc; i++){
+      caml_gc_message (-1, " %s", argv[i]);
+    }
+    caml_gc_message (-1, "\n", 0);
+    ocp = getenv ("OCAMLRUNPARAM");
+    caml_gc_message (-1, "### OCAMLRUNPARAM=%s\n", ocp == NULL ? "" : ocp);
+    cp = getenv ("CAMLRUNPARAM");
+    caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp);
+    caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0));
+#endif
+  }
+#endif
 #ifdef _WIN32
   /* Expand wildcards and diversions in command line */
   caml_expand_command_line(&argc, &argv);
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index 54759b26f5..c6feeee293 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -50,12 +50,13 @@ extern char *caml_fl_merge;  /* Defined in freelist.c. */
 
 static char *markhp, *chunk, *limit;
 
-static int gc_subphase;     /* Subphase_main, Subphase_weak, Subphase_final */
-#define Subphase_main 10
-#define Subphase_weak 11
-#define Subphase_final 12
+int caml_gc_subphase;     /* Subphase_{main,weak1,weak2,final} */
 static value *weak_prev;
 
+#ifdef DEBUG
+static unsigned long major_gc_counter = 0;
+#endif
+
 static void realloc_gray_vals (void)
 {
   value *new;
@@ -113,9 +114,10 @@ static void start_cycle (void)
   caml_gc_message (0x01, "Starting new major GC cycle\n", 0);
   caml_darken_all_roots();
   caml_gc_phase = Phase_mark;
-  gc_subphase = Subphase_main;
+  caml_gc_subphase = Subphase_main;
   markhp = NULL;
 #ifdef DEBUG
+  ++ major_gc_counter;
   caml_heap_check ();
 #endif
 }
@@ -128,6 +130,7 @@ static void mark_slice (intnat work)
   mlsize_t size, i;
 
   caml_gc_message (0x40, "Marking %ld words\n", work);
+  caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
   gray_vals_ptr = gray_vals_cur;
   while (work > 0){
     if (gray_vals_ptr > gray_vals){
@@ -189,27 +192,27 @@ static void mark_slice (intnat work)
       chunk = caml_heap_start;
       markhp = chunk;
       limit = chunk + Chunk_size (chunk);
-    }else if (gc_subphase == Subphase_main){
-      /* The main marking phase is over.  Start removing weak pointers to
-         dead values. */
-      gc_subphase = Subphase_weak;
-      weak_prev = &caml_weak_list_head;
-    }else if (gc_subphase == Subphase_weak){
-      value cur, curfield;
-      mlsize_t sz, i;
-      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{
+    }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){
@@ -230,27 +233,52 @@ 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;
         }
-        work -= Whsize_hd (hd);
-      }else{
-        /* Subphase_weak is done.  Handle finalised values. */
+      }
+        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{
+          /* 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;
+        }
+      }
+        break;
+      case Subphase_final: {
+        /* Initialise the sweep phase. */
         gray_vals_cur = gray_vals_ptr;
-        caml_final_update ();
-        gray_vals_ptr = gray_vals_cur;
-        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 (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;
@@ -354,7 +382,7 @@ intnat caml_major_collection_slice (intnat howmuch)
   if (p < dp) p = dp;
   if (p < caml_extra_heap_resources) p = caml_extra_heap_resources;
 
-  caml_gc_message (0x40, "allocated_words = %" 
+  caml_gc_message (0x40, "allocated_words = %"
                          ARCH_INTNAT_PRINTF_FORMAT "u\n",
                    caml_allocated_words);
   caml_gc_message (0x40, "extra_heap_resources = %"
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 47aa5e59f7..66885e6700 100644
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -33,6 +33,7 @@ typedef struct {
 #define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block
 
 extern int caml_gc_phase;
+extern int caml_gc_subphase;
 extern uintnat caml_allocated_words;
 extern double caml_extra_heap_resources;
 extern uintnat caml_dependent_size, caml_dependent_allocated;
@@ -41,6 +42,10 @@ extern uintnat caml_fl_size_at_phase_change;
 #define Phase_mark 0
 #define Phase_sweep 1
 #define Phase_idle 2
+#define Subphase_main 10
+#define Subphase_weak1 11
+#define Subphase_weak2 12
+#define Subphase_final 13
 
 #ifdef __alpha
 typedef int page_table_entry;
diff --git a/byterun/memory.c b/byterun/memory.c
index 03d7286937..11521f55ca 100644
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -27,6 +27,8 @@
 #include "mlvalues.h"
 #include "signals.h"
 
+extern uintnat caml_percent_free;                   /* major_gc.c */
+
 #ifdef USE_MMAP_INSTEAD_OF_MALLOC
 extern char * caml_aligned_mmap (asize_t size, int modulo, void ** block);
 extern void caml_aligned_munmap (char * addr, asize_t size);
@@ -96,7 +98,7 @@ int caml_add_to_heap (char *m)
     page_table_entry *block, *new_page_table;
     asize_t new_page_low = Page (m);
     asize_t new_size = caml_page_high - new_page_low;
-    
+
     caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size);
     block = malloc (new_size * sizeof (page_table_entry));
     if (block == NULL){
@@ -118,7 +120,7 @@ int caml_add_to_heap (char *m)
     page_table_entry *block, *new_page_table;
     asize_t new_page_high = Page (m + Chunk_size (m));
     asize_t new_size = new_page_high - caml_page_low;
-    
+
     caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size);
     block = malloc (new_size * sizeof (page_table_entry));
     if (block == NULL){
@@ -169,25 +171,52 @@ int caml_add_to_heap (char *m)
 }
 
 /* Allocate more memory from malloc for the heap.
-   Return a blue block of at least the requested size (in words).
-   The caller must insert the block into the free list.
+   Return a blue block of at least the requested size.
+   The blue block is chained to a sequence of blue blocks (through their
+   field 0); the last block of the chain is pointed by field 1 of the
+   first.  There may be a fragment after the last block.
+   The caller must insert the blocks into the free list.
    The request must be less than or equal to Max_wosize.
    Return NULL when out of memory.
 */
 static char *expand_heap (mlsize_t request)
 {
-  char *mem;
-  asize_t malloc_request;
+  char *mem, *hp, *prev;
+  asize_t over_request, malloc_request, remain;
 
-  malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (request));
+  Assert (request <= Max_wosize);
+  over_request = request + request / 100 * caml_percent_free;
+  malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request));
   mem = caml_alloc_for_heap (malloc_request);
   if (mem == NULL){
     caml_gc_message (0x04, "No room for growing heap\n", 0);
     return NULL;
   }
-  Assert (Wosize_bhsize (malloc_request) >= request);
-  Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Caml_blue);
-
+  remain = malloc_request;
+  prev = hp = mem;
+  /* XXX find a way to do this with a call to caml_make_free_blocks */
+  while (Wosize_bhsize (remain) > Max_wosize){
+    Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue);
+#ifdef DEBUG
+    caml_set_fields (Bp_hp (hp), 0, Debug_free_major);
+#endif
+    hp += Bhsize_wosize (Max_wosize);
+    remain -= Bhsize_wosize (Max_wosize);
+    Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp);
+    prev = hp;
+  }
+  if (remain > 1){
+    Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue);
+#ifdef DEBUG
+    caml_set_fields (Bp_hp (hp), 0, Debug_free_major);
+#endif
+    Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp);
+    Field (Op_hp (hp), 0) = (value) NULL;
+  }else{
+    Field (Op_hp (prev), 0) = (value) NULL;
+    if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white);
+  }
+  Assert (Wosize_hp (mem) >= request);
   if (caml_add_to_heap (mem) != 0){
     caml_free_for_heap (mem);
     return NULL;
@@ -267,7 +296,7 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
       else
         caml_raise_out_of_memory ();
     }
-    caml_fl_add_block (new_block);
+    caml_fl_add_blocks (new_block);
     hp = caml_fl_allocate (wosize);
   }
 
@@ -358,10 +387,10 @@ void caml_initialize (value *fp, value val)
 {
   *fp = val;
   if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){
-    *caml_ref_table_ptr++ = fp;
-    if (caml_ref_table_ptr >= caml_ref_table_limit){
-      caml_realloc_ref_table ();
+    if (caml_ref_table.ptr >= caml_ref_table.limit){
+      caml_realloc_ref_table (&caml_ref_table);
     }
+    *caml_ref_table.ptr++ = fp;
   }
 }
 
diff --git a/byterun/memory.h b/byterun/memory.h
index d3962bfa5e..d369b14b92 100644
--- a/byterun/memory.h
+++ b/byterun/memory.h
@@ -94,11 +94,11 @@ color_t caml_allocation_color (void *hp);
     if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL);             \
     if (Is_block (val) && Is_young (val)                                    \
         && ! (Is_block (_old_) && Is_young (_old_))){                       \
-      *caml_ref_table_ptr++ = (fp);                                         \
-      if (caml_ref_table_ptr >= caml_ref_table_limit){                      \
-        CAMLassert (caml_ref_table_ptr == caml_ref_table_limit);            \
-        caml_realloc_ref_table ();                                          \
+      if (caml_ref_table.ptr >= caml_ref_table.limit){                      \
+        CAMLassert (caml_ref_table.ptr == caml_ref_table.limit);            \
+        caml_realloc_ref_table (&caml_ref_table);                           \
       }                                                                     \
+      *caml_ref_table.ptr++ = (fp);                                         \
     }                                                                       \
   }                                                                         \
 }while(0)
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index f4958939b1..f16579c481 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -26,19 +26,55 @@
 #include "mlvalues.h"
 #include "roots.h"
 #include "signals.h"
+#include "weak.h"
 
 asize_t caml_minor_heap_size;
 CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL;
 CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL;
-static value **ref_table = NULL, **ref_table_end, **ref_table_threshold;
-CAMLexport value **caml_ref_table_ptr = NULL, **caml_ref_table_limit;
-static asize_t ref_table_size, ref_table_reserve;
+
+CAMLexport struct caml_ref_table
+  caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
+  caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
+
 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;
+
+  tbl->size = sz;
+  tbl->reserve = rsv;
+  new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve)
+                                          * sizeof (value *));
+  if (tbl->base != NULL) caml_stat_free (tbl->base);
+  tbl->base = new_table;
+  tbl->ptr = tbl->base;
+  tbl->threshold = tbl->base + tbl->size;
+  tbl->limit = tbl->threshold;
+  tbl->end = tbl->base + tbl->size + tbl->reserve;
+}
+
+static void reset_table (struct caml_ref_table *tbl)
+{
+  tbl->size = 0;
+  tbl->reserve = 0;
+  if (tbl->base != NULL) caml_stat_free (tbl->base);
+  tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL;
+}
+
+static void clear_table (struct caml_ref_table *tbl)
+{
+    tbl->ptr = tbl->base;
+    tbl->limit = tbl->threshold;
+}
+
 void caml_set_minor_heap_size (asize_t size)
 {
   char *new_heap;
-  value **new_table;
 
   Assert (size >= Minor_heap_min);
   Assert (size <= Minor_heap_max);
@@ -55,16 +91,8 @@ void caml_set_minor_heap_size (asize_t size)
   caml_young_ptr = caml_young_end;
   caml_minor_heap_size = size;
 
-  ref_table_size = caml_minor_heap_size / sizeof (value) / 8;
-  ref_table_reserve = 256;
-  new_table = (value **) caml_stat_alloc ((ref_table_size + ref_table_reserve)
-                                          * sizeof (value *));
-  if (ref_table != NULL) caml_stat_free (ref_table);
-  ref_table = new_table;
-  caml_ref_table_ptr = ref_table;
-  ref_table_threshold = ref_table + ref_table_size;
-  caml_ref_table_limit = ref_table_threshold;
-  ref_table_end = ref_table + ref_table_size + ref_table_reserve;
+  reset_table (&caml_ref_table);
+  reset_table (&caml_weak_ref_table);
 }
 
 static value oldify_todo_list = 0;
@@ -187,16 +215,25 @@ void caml_empty_minor_heap (void)
     caml_in_minor_collection = 1;
     caml_gc_message (0x02, "<", 0);
     caml_oldify_local_roots();
-    for (r = ref_table; r < caml_ref_table_ptr; r++){
+    for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){
       caml_oldify_one (**r, *r);
     }
     caml_oldify_mopup ();
+    for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){
+      if (Is_block (**r) && Is_young (**r)){
+        if (Hd_val (**r) == 0){
+          **r = Field (**r, 0);
+        }else{
+          **r = caml_weak_none;
+        }
+      }
+    }
     if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start;
     caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr);
     caml_young_ptr = caml_young_end;
     caml_young_limit = caml_young_start;
-    caml_ref_table_ptr = ref_table;
-    caml_ref_table_limit = ref_table_threshold;
+    clear_table (&caml_ref_table);
+    clear_table (&caml_weak_ref_table);
     caml_gc_message (0x02, ">", 0);
     caml_in_minor_collection = 0;
   }
@@ -207,6 +244,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
 }
@@ -238,32 +276,34 @@ CAMLexport value caml_check_urgent_gc (value extra_root)
   CAMLreturn (extra_root);
 }
 
-void caml_realloc_ref_table (void)
-{                       Assert (caml_ref_table_ptr == caml_ref_table_limit);
-                             Assert (caml_ref_table_limit <= ref_table_end);
-                       Assert (caml_ref_table_limit >= ref_table_threshold);
+void caml_realloc_ref_table (struct caml_ref_table *tbl)
+{                                           Assert (tbl->ptr == tbl->limit);
+                                            Assert (tbl->limit <= tbl->end);
+                                      Assert (tbl->limit >= tbl->threshold);
 
-  if (caml_ref_table_limit == ref_table_threshold){
+  if (tbl->base == NULL){
+    caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256);
+  }else if (tbl->limit == tbl->threshold){
     caml_gc_message (0x08, "ref_table threshold crossed\n", 0);
-    caml_ref_table_limit = ref_table_end;
+    tbl->limit = tbl->end;
     caml_urge_major_slice ();
   }else{ /* This will almost never happen with the bytecode interpreter. */
     asize_t sz;
-    asize_t cur_ptr = caml_ref_table_ptr - ref_table;
+    asize_t cur_ptr = tbl->ptr - tbl->base;
                                              Assert (caml_force_major_slice);
 
-    ref_table_size *= 2;
-    sz = (ref_table_size + ref_table_reserve) * sizeof (value *);
-    caml_gc_message (0x08, "Growing ref_table to %" 
+    tbl->size *= 2;
+    sz = (tbl->size + tbl->reserve) * sizeof (value *);
+    caml_gc_message (0x08, "Growing ref_table to %"
                            ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
                      (intnat) sz/1024);
-    ref_table = (value **) realloc ((char *) ref_table, sz);
-    if (ref_table == NULL){
+    tbl->base = (value **) realloc ((char *) tbl->base, sz);
+    if (tbl->base == NULL){
       caml_fatal_error ("Fatal error: ref_table overflow\n");
     }
-    ref_table_end = ref_table + ref_table_size + ref_table_reserve;
-    ref_table_threshold = ref_table + ref_table_size;
-    caml_ref_table_ptr = ref_table + cur_ptr;
-    caml_ref_table_limit = ref_table_end;
+    tbl->end = tbl->base + tbl->size + tbl->reserve;
+    tbl->threshold = tbl->base + tbl->size;
+    tbl->ptr = tbl->base + cur_ptr;
+    tbl->limit = tbl->end;
   }
 }
diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h
index a569d3a907..8e834129bf 100644
--- a/byterun/minor_gc.h
+++ b/byterun/minor_gc.h
@@ -21,10 +21,20 @@
 
 CAMLextern char *caml_young_start, *caml_young_ptr;
 CAMLextern char *caml_young_end, *caml_young_limit;
-CAMLextern value **caml_ref_table_ptr, **caml_ref_table_limit;
 extern asize_t caml_minor_heap_size;
 extern int caml_in_minor_collection;
 
+struct caml_ref_table {
+  value **base;
+  value **end;
+  value **threshold;
+  value **ptr;
+  value **limit;
+  asize_t size;
+  asize_t reserve;
+};
+CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table;
+
 #define Is_young(val) \
   (Assert (Is_block (val)), \
    (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start)
@@ -33,7 +43,8 @@ extern void caml_set_minor_heap_size (asize_t);
 extern void caml_empty_minor_heap (void);
 CAMLextern void caml_minor_collection (void);
 CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */
-extern void caml_realloc_ref_table (void);
+extern void caml_realloc_ref_table (struct caml_ref_table *);
+extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t);
 extern void caml_oldify_one (value, value *);
 extern void caml_oldify_mopup (void);
 
diff --git a/byterun/misc.c b/byterun/misc.c
index 2a660219c4..e8597ee38c 100644
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -29,6 +29,14 @@ int caml_failed_assert (char * expr, char * file, int line)
   return 1; /* not reached */
 }
 
+void caml_set_fields (char *bp, unsigned long start, unsigned long filler)
+{
+  mlsize_t i;
+  for (i = start; i < Wosize_bp (bp); i++){
+    Field (Val_bp (bp), i) = (value) filler;
+  }
+}
+
 #endif /* DEBUG */
 
 uintnat caml_verb_gc = 0;
@@ -54,7 +62,7 @@ CAMLexport void caml_fatal_error_arg (char *fmt, char *arg)
 }
 
 CAMLexport void caml_fatal_error_arg2 (char *fmt1, char *arg1,
-				       char *fmt2, char *arg2)
+                                       char *fmt2, char *arg2)
 {
   fprintf (stderr, fmt1, arg1);
   fprintf (stderr, fmt2, arg2);
diff --git a/byterun/misc.h b/byterun/misc.h
index a1b2b92607..7fe2cbfe35 100644
--- a/byterun/misc.h
+++ b/byterun/misc.h
@@ -132,6 +132,8 @@ char *caml_aligned_malloc (asize_t, int, void **);
 #define Debug_filler_align   Debug_tag (0x85)
 
 #define Debug_uninit_stat    0xD7
+
+extern void caml_set_fields (char *, unsigned long, unsigned long);
 #endif /* DEBUG */
 
 
diff --git a/byterun/unix.c b/byterun/unix.c
index 7d3f857883..dc07109eac 100644
--- a/byterun/unix.c
+++ b/byterun/unix.c
@@ -350,10 +350,13 @@ char *caml_aligned_mmap (asize_t size, int modulo, void **block)
 {
   char *raw_mem;
   uintnat aligned_mem;
+  static char * last_addr = NULL; /* hint, see PR#4448 */
+
   Assert (modulo < Page_size);
-  raw_mem = (char *) mmap(NULL, size + Page_size, PROT_READ | PROT_WRITE,
+  raw_mem = (char *) mmap(last_addr, size + Page_size, PROT_READ | PROT_WRITE,
                           MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
   if (raw_mem == MAP_FAILED) return NULL;
+  last_addr = raw_mem + size + 2 * Page_size;
   *block = raw_mem;
   raw_mem += modulo;                /* Address to be aligned */
   aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size);
diff --git a/byterun/weak.c b/byterun/weak.c
index 0cea2a6dc3..5673faef56 100644
--- a/byterun/weak.c
+++ b/byterun/weak.c
@@ -45,6 +45,24 @@ CAMLprim value caml_weak_create (value len)
 #define None_val (Val_int(0))
 #define Some_tag 0
 
+static void do_set (value ar, mlsize_t offset, value v)
+{
+  if (Is_block (v) && Is_young (v)){
+    /* modified version of Modify */
+    value old = Field (ar, offset);
+    Field (ar, offset) = v;
+    if (!(Is_block (old) && Is_young (old))){
+      if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){
+        CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit);
+        caml_realloc_ref_table (&caml_weak_ref_table);
+      }
+      *caml_weak_ref_table.ptr++ = &Field (ar, offset);
+    }
+  }else{
+    Field (ar, offset) = v;
+  }
+}
+
 CAMLprim value caml_weak_set (value ar, value n, value el)
 {
   mlsize_t offset = Long_val (n) + 1;
@@ -52,15 +70,11 @@ CAMLprim value caml_weak_set (value ar, value n, value el)
   if (offset < 1 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.set");
   }
-  Field (ar, offset) = caml_weak_none;
   if (el != None_val){
-    value v;                                  Assert (Wosize_val (el) == 1);
-    v = Field (el, 0);
-    if (Is_block (v) && (Is_young (v) || Is_in_heap (v))){
-      Modify (&Field (ar, offset), v);
-    }else{
-      Field (ar, offset) = v;
-    }
+                                              Assert (Wosize_val (el) == 1);
+    do_set (ar, offset, Field (el, 0));
+  }else{
+    Field (ar, offset) = caml_weak_none;
   }
   return Val_unit;
 }
@@ -141,3 +155,39 @@ CAMLprim value caml_weak_check (value ar, value n)
   }
   return Val_bool (Field (ar, offset) != caml_weak_none);
 }
+
+CAMLprim value caml_weak_blit (value ars, value ofs,
+                               value ard, value ofd, value len)
+{
+  mlsize_t offset_s = Long_val (ofs) + 1;
+  mlsize_t offset_d = Long_val (ofd) + 1;
+  mlsize_t length = Long_val (len);
+  long i;
+                                                   Assert (Is_in_heap (ars));
+                                                   Assert (Is_in_heap (ard));
+  if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
+    caml_invalid_argument ("Weak.blit");
+  }
+  if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
+    caml_invalid_argument ("Weak.blit");
+  }
+  if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){
+    for (i = 0; i < length; i++){
+      value v = Field (ars, offset_s + i);
+      if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
+          && Is_white_val (v)){
+        Field (ars, offset_s + i) = caml_weak_none;
+      }
+    }
+  }
+  if (offset_d < offset_s){
+    for (i = 0; i < length; i++){
+      do_set (ard, offset_d + i, Field (ars, offset_s + i));
+    }
+  }else{
+    for (i = length - 1; i >= 0; i--){
+      do_set (ard, offset_d + i,  Field (ars, offset_s + i));
+    }
+  }
+  return Val_unit;
+}
diff --git a/config/Makefile.msvc b/config/Makefile.msvc
index 6825586d83..43121ce4c3 100644
--- a/config/Makefile.msvc
+++ b/config/Makefile.msvc
@@ -80,7 +80,7 @@ BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE
 BYTECCCOMPOPTS=/Ox /MT
 
 ### Additional link-time options for $(BYTECC).  (For static linking.)
-BYTECCLINKOPTS=/MT
+BYTECCLINKOPTS=/MT /F16777216
 
 ### Additional compile-time options for $(BYTECC).  (For building a DLL.)
 DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL
@@ -139,7 +139,7 @@ NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE
 NATIVECCCOMPOPTS=/Ox /MT
 
 ### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=/MT
+NATIVECCLINKOPTS=/MT /F16777216
 
 ### Build partially-linked object file
 PARTIALLD=link /lib /nologo
diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64
index f6f3e81e45..508ec0aef5 100644
--- a/config/Makefile.msvc64
+++ b/config/Makefile.msvc64
@@ -83,7 +83,7 @@ BYTECCCOMPOPTS=/Ox /MT
 BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64
 
 ### Additional link-time options for $(BYTECC).  (For static linking.)
-BYTECCLINKOPTS=/MT
+BYTECCLINKOPTS=/MT /F33554432
 
 ### Additional compile-time options for $(BYTECC).  (For building a DLL.)
 DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL
@@ -139,7 +139,7 @@ NATIVECC=cl /nologo
 NATIVECCCOMPOPTS=/Ox /MT
 
 ### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=/MT
+NATIVECCLINKOPTS=/MT /F33554432
 
 ### Build partially-linked object file
 PARTIALLD=link /lib /nologo /machine:AMD64
diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c
index a1aa0b7ecf..7f06e9711f 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;
diff --git a/configure b/configure
index 83c93205c3..92288be073 100755
--- a/configure
+++ b/configure
@@ -553,7 +553,7 @@ fi
 # Further machine-specific hacks
 
 case "$host" in
-  ia64-*-linux*|alpha*-*-linux*|x86_64-*-linux*)
+  ia64-*-linux*|alpha*-*-linux*|x86_64-*-linux*|sparc64-*-linux*)
     echo "Will use mmap() instead of malloc() for allocation of major heap chunks."
     echo "#define USE_MMAP_INSTEAD_OF_MALLOC" >> s.h;;
 esac
@@ -589,7 +589,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
@@ -606,6 +606,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;;
@@ -635,25 +646,25 @@ case "$arch,$nativecc,$system,$host_type" in
 esac
 
 asflags=''
-aspp='$(AS)'
+aspp=''
 asppflags=''
 asppprofflags='-DPROFILING'
 
 case "$arch,$model,$system" in
-  alpha,*,digital)  asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)';
+  alpha,*,digital)  aspp='as'; asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)';
                     asppprofflags='-pg -DPROFILING';;
   alpha,*,linux)    aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   alpha,*,gnu)      aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   alpha,*,freebsd)  aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   alpha,*,netbsd)   aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   alpha,*,openbsd)  aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
-  mips,*,irix)      asflags='-n32 -O2'; asppflags="$asflags";;
+  mips,*,irix)      aspp='as'; asflags='-n32 -O2'; asppflags="$asflags";;
   sparc,*,bsd)      aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   sparc,*,linux)    aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   sparc,*,gnu)      aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   sparc,*,*)        case "$cc" in
                       gcc*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
-                         *) asppflags='-P -DSYS_$(SYSTEM)';;
+                         *) aspp='as'; asppflags='-P -DSYS_$(SYSTEM)';;
                     esac;;
   i386,*,solaris)   aspp='/usr/ccs/bin/as'; asppflags='-P -DSYS_$(SYSTEM)';;
   i386,*,*)         aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
@@ -1207,6 +1218,7 @@ for dir in \
     /usr/x386/lib         \
     /usr/XFree86/lib/X11  \
                           \
+    /usr/lib64            \
     /usr/lib              \
     /usr/local/lib        \
     /usr/unsupported/lib  \
@@ -1221,6 +1233,7 @@ do
   if test -f $dir/libX11.a || \
      test -f $dir/libX11.so || \
      test -f $dir/libX11.dll.a || \
+     test -f $dir/libX11.dylib || \
      test -f $dir/libX11.sa; then
     if test $dir = /usr/lib; then
       x11_link="-lX11"
diff --git a/debugger/.depend b/debugger/.depend
index 07a35e5464..3c219b63a5 100644
--- a/debugger/.depend
+++ b/debugger/.depend
@@ -111,12 +111,12 @@ main.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi time_travel.cmi \
     show_information.cmi program_management.cmi primitives.cmi parameters.cmi \
     ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \
     ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \
-    command_line.cmi checkpoints.cmi 
+    command_line.cmi ../utils/clflags.cmi checkpoints.cmi 
 main.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx time_travel.cmx \
     show_information.cmx program_management.cmx primitives.cmx parameters.cmx \
     ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \
     ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \
-    command_line.cmx checkpoints.cmx 
+    command_line.cmx ../utils/clflags.cmx checkpoints.cmx 
 parameters.cmo: primitives.cmi ../utils/misc.cmi envaux.cmi \
     ../utils/config.cmi parameters.cmi 
 parameters.cmx: primitives.cmx ../utils/misc.cmx envaux.cmx \
diff --git a/debugger/main.ml b/debugger/main.ml
index 90f9e89842..624492b28c 100644
--- a/debugger/main.ml
+++ b/debugger/main.ml
@@ -128,6 +128,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 f6bf63e842..7ddb362b4e 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.el b/emacs/caml-font.el
index a04d5c94ec..2914fdfda0 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 74ec5be9e1..06f57fa35e 100644
--- a/emacs/caml-types.el
+++ b/emacs/caml-types.el
@@ -124,10 +124,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 ()
@@ -154,28 +152,47 @@ See `caml-types-location-re' for annotation file format.
       (delete-overlay caml-types-expr-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 ""))
       )))
 
+(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))
@@ -377,7 +394,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 \"-dtypes\"."))
+    (error (format "Can't read the annotation file `%s'" name)))
     )
   buf))
 
@@ -406,8 +423,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
@@ -421,7 +436,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/man/ocamldep.m b/man/ocamldep.m
index 4fa557bde9..7b24082afe 100644
--- a/man/ocamldep.m
+++ b/man/ocamldep.m
@@ -50,7 +50,7 @@ compilation unit Bar, a dependency on that unit's interface
 bar.cmi is generated only if the source for bar is found in the
 current directory or in one of the directories specified with 
 .BR -I .
-Otherwise, Bar is assumed to be a module form the standard library,
+Otherwise, Bar is assumed to be a module from the standard library,
 and no dependencies are generated. For programs that span multiple
 directories, it is recommended to pass 
 .BR ocamldep (1)
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 0e522f0e25..6b0ab371dd 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -198,7 +198,8 @@ let add_extensions extensions modules =
 
 flag ["ocaml"; "pp"; "camlp4boot"] (convert_command_for_windows_shell (S[ocamlrun; P hot_camlp4boot]));;
 flag ["ocaml"; "pp"; "camlp4boot"; "native"] (S[A"-D"; A"OPT"]);;
-flag ["ocaml"; "pp"; "camlp4boot"; "ocamldep"] (S[A"-D"; A"OPT"]);;
+flag ["ocaml"; "pp"; "camlp4boot"; "pp:dep"] (S[A"-D"; A"OPT"]);;
+flag ["ocaml"; "pp"; "camlp4boot"; "pp:doc"] (S[A"-printer"; A"o"]);;
 let exn_tracer = Pathname.pwd/"camlp4"/"boot"/"Camlp4ExceptionTracer.cmo" in
 if Pathname.exists exn_tracer then
   flag ["ocaml"; "pp"; "camlp4boot"; "exntracer"] (P exn_tracer);
@@ -239,8 +240,6 @@ let setup_arch arch =
 let camlp4_arch =
   dir "" [
     dir "stdlib" [];
-    dir "utils" [];
-    dir "parsing" [];
     dir "camlp4" [
       dir "build" [];
       dir_pack "Camlp4" [
@@ -257,12 +256,13 @@ setup_arch camlp4_arch;;
 
 Pathname.define_context "" ["stdlib"];;
 Pathname.define_context "utils" [Pathname.current_dir_name; "stdlib"];;
-Pathname.define_context "camlp4" ["camlp4/build"; "utils"; "stdlib"];;
-Pathname.define_context "camlp4/boot" ["camlp4/build"; "utils"; "parsing"; "camlp4"; "stdlib"];;
-Pathname.define_context "camlp4/Camlp4Parsers" ["camlp4"; "camlp4/build"; "stdlib"];;
-Pathname.define_context "camlp4/Camlp4Printers" ["camlp4"; "camlp4/build"; "stdlib"];;
-Pathname.define_context "camlp4/Camlp4Filters" ["camlp4"; "camlp4/build"; "stdlib"];;
-Pathname.define_context "camlp4/Camlp4Top" ["typing"; "stdlib"];;
+Pathname.define_context "camlp4" ["camlp4"; "stdlib"];;
+Pathname.define_context "camlp4/boot" ["camlp4"; "stdlib"];;
+Pathname.define_context "camlp4/Camlp4Parsers" ["camlp4"; "stdlib"];;
+Pathname.define_context "camlp4/Camlp4Printers" ["camlp4"; "stdlib"];;
+Pathname.define_context "camlp4/Camlp4Filters" ["camlp4"; "stdlib"];;
+Pathname.define_context "camlp4/Camlp4Top" ["camlp4"; "stdlib"];;
+Pathname.define_context "parsing" ["parsing"; "utils"; "stdlib"];;
 Pathname.define_context "typing" ["typing"; "parsing"; "utils"; "stdlib"];;
 Pathname.define_context "ocamldoc" ["typing"; "parsing"; "utils"; "tools"; "bytecomp"; "stdlib"];;
 Pathname.define_context "bytecomp" ["bytecomp"; "parsing"; "typing"; "utils"; "stdlib"];;
@@ -350,7 +350,7 @@ let import_stdlib_contents build exts =
 ;;
 
 rule "byte stdlib in partial mode"
-  ~prod:"byte_stdlib_partial_mode"
+  ~stamp:"byte_stdlib_partial_mode"
   ~deps:["stdlib/stdlib.mllib"; "stdlib/stdlib.cma";
          "stdlib/std_exit.cmo"; "stdlib/libcamlrun"-.-C.a;
          "stdlib/camlheader"; "stdlib/camlheader_ur"]
@@ -360,11 +360,11 @@ rule "byte stdlib in partial mode"
         "stdlib/stdlib.mllib" "stdlib/stdlib.cma" env build
     in
     import_stdlib_contents build ["cmi"];
-    touch "byte_stdlib_partial_mode"
+    Nop
   end;;
 
 rule "native stdlib in partial mode"
-  ~prod:"native_stdlib_partial_mode"
+  ~stamp:"native_stdlib_partial_mode"
   ~deps:["stdlib/stdlib.mllib"; "stdlib/stdlib.cmxa";
          "stdlib/stdlib"-.-C.a; "stdlib/std_exit.cmx";
          "stdlib/std_exit"-.-C.o; "stdlib/libasmrun"-.-C.a;
@@ -375,7 +375,7 @@ rule "native stdlib in partial mode"
         "stdlib/stdlib.mllib" "stdlib/stdlib.cmxa" env build
     in
     import_stdlib_contents build ["cmi"];
-    touch "native_stdlib_partial_mode"
+    Nop
   end;;
 
 rule "C files"
@@ -436,6 +436,7 @@ let stdlib_mlis =
      "otherlibs/bigarray/bigarray.mli"; "otherlibs/num/num.mli"] in
 rule "Standard library manual"
   ~prod:"ocamldoc/stdlib_man/Pervasives.3o"
+  ~stamp:"ocamldoc/stdlib_man.stamp" (* Depend on this file if you want to depends on all files of stdlib_man/* *)
   ~deps:stdlib_mlis
   begin fun _ _ ->
     Seq[Cmd(S[A"mkdir"; A"-p"; P"ocamldoc/stdlib_man"]);
@@ -707,9 +708,38 @@ let camlp4Profiler = p4 "Camlp4Profiler"
 
 let camlp4lib_cma = p4 "camlp4lib.cma"
 let camlp4lib_cmxa = p4 "camlp4lib.cmxa"
+let camlp4lib_lib = p4 ("camlp4lib"-.-C.a)
 
 let special_modules =
   if Sys.file_exists "./boot/Profiler.cmo" then [camlp4Profiler] else []
+;;
+
+let camlp4_import_list =
+    ["utils/misc.ml";
+     "utils/terminfo.ml";
+     "parsing/linenum.ml";
+     "utils/warnings.ml";
+     "parsing/location.ml";
+     "parsing/longident.ml";
+     "parsing/asttypes.mli";
+     "parsing/parsetree.mli";
+     "typing/outcometree.mli";
+     "myocamlbuild_config.ml";
+     "utils/config.mlbuild"]
+;;
+
+rule "camlp4/Camlp4_import.ml"
+  ~deps:camlp4_import_list
+  ~prod:"camlp4/Camlp4_import.ml"
+  begin fun _ _ ->
+    Echo begin
+      List.fold_right begin fun path acc ->
+        let modname = module_name_of_pathname path in
+        "module " :: modname :: " = struct\n" :: Pathname.read path :: "\nend;;\n" :: acc
+      end camlp4_import_list [],
+      "camlp4/Camlp4_import.ml"
+    end
+  end;;
 
 let mk_camlp4_top_lib name modules =
   let name = "camlp4"/name in
@@ -730,12 +760,20 @@ let mk_camlp4_bin name ?unix:(link_unix=true) modules =
   let byte = name-.-"byte" in
   let native = name-.-"native" in
   let unix_cma, unix_cmxa, include_unix =
-    if link_unix then A"unix.cma", A"unix.cmxa", S[A"-I"; P unix_dir] else N,N,N in
+    if link_unix
+    then A"unix.cma", A"unix.cmxa", S[A"-I"; P unix_dir]
+    else N,N,N in
+  let dep_unix_byte, dep_unix_native =
+    if link_unix && not partial
+    then [unix_dir/"unix.cma"],
+         [unix_dir/"unix.cmxa"; unix_dir/"unix"-.-C.a]
+    else [],[] in
   let deps = special_modules @ modules @ [camlp4_bin] in
   let cmos = add_extensions ["cmo"] deps in
   let cmxs = add_extensions ["cmx"] deps in
+  let objs = add_extensions [C.o] deps in
   rule byte
-    ~deps:(camlp4lib_cma::cmos)
+    ~deps:(camlp4lib_cma::cmos @ dep_unix_byte)
     ~prod:(add_exe byte)
     ~insert:(`before "ocaml: cmo* -> byte")
     begin fun _ _ ->
@@ -743,7 +781,7 @@ let mk_camlp4_bin name ?unix:(link_unix=true) modules =
             P camlp4lib_cma; A"-linkall"; atomize cmos; A"-o"; Px (add_exe byte)])
     end;
   rule native
-    ~deps:(camlp4lib_cmxa::cmxs)
+    ~deps:(camlp4lib_cmxa :: camlp4lib_lib :: (cmxs @ objs @ dep_unix_native))
     ~prod:(add_exe native)
     ~insert:(`before "ocaml: cmx* & o* -> native")
     begin fun _ _ ->
@@ -795,6 +833,9 @@ module Camlp4deps = struct
     List.iter Outcome.ignore_good (build (List.map (fun i -> [i]) includes));
 end;;
 
+dep ["ocaml"; "file:camlp4/Camlp4/Sig.ml"]
+    ["camlp4/Camlp4/Camlp4Ast.partial.ml"];;
+
 rule "camlp4: ml4 -> ml"
   ~prod:"%.ml"
   ~dep:"%.ml4"
@@ -858,14 +899,14 @@ Pathname.define_context "otherlibs/labltk/tkanim"
 Pathname.define_context "otherlibs/labltk/browser"
   ["otherlibs/labltk/browser"; "otherlibs/labltk/labltk"; "otherlibs/labltk/support"; "parsing"; "utils"; "typing"; "stdlib"];;
 
-file_rule "otherlibs/labltk/compiler/copyright"
+rule "otherlibs/labltk/compiler/copyright"
   ~dep:"otherlibs/labltk/compiler/copyright"
   ~prod:"otherlibs/labltk/compiler/copyright.ml"
-  ~cache:(fun _ _ -> "0.1")
-  begin fun _ oc ->
-    Printf.fprintf oc "let copyright = \"%a\";;\n\
-                       let write ~w = w copyright;;"
-      fp_cat "otherlibs/labltk/compiler/copyright"
+  begin fun _ _ ->
+    Echo(["let copyright = \"";
+          Pathname.read "otherlibs/labltk/compiler/copyright";
+          "\";;\nlet write ~w = w copyright;;"],
+          "otherlibs/labltk/compiler/copyright.ml")
   end;;
 
 copy_rule "labltk tkcompiler" "otherlibs/labltk/compiler/maincompile.byte" "otherlibs/labltk/compiler/tkcompiler";;
@@ -1034,13 +1075,12 @@ rule "labltktop"
   end;;
 
 let labltk_installdir = C.libdir/"labltk" in
-file_rule "labltk"
+rule "labltk"
   ~prod:"otherlibs/labltk/lib/labltk"
-  ~cache:(fun _ _ -> labltk_installdir)
-  begin fun _ oc ->
-    Printf.fprintf oc
-      "#!/bin/sh\n\
-       exec %s -I %s $*\n" (labltk_installdir/"labltktop") labltk_installdir
+  begin fun _ _ ->
+    Echo(["#!/bin/sh\n";
+          Printf.sprintf "exec %s -I %s $*\n" (labltk_installdir/"labltktop") labltk_installdir],
+         "otherlibs/labltk/lib/labltk")
   end;;
 
 use_lib "otherlibs/labltk/browser/main" "toplevel/toplevellib";;
diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
index f865b94237..c6750de477 100644
--- a/ocamldoc/Makefile
+++ b/ocamldoc/Makefile
@@ -264,7 +264,7 @@ install: dummy
 	if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi
 	if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi
 	if test -d $(INSTALL_CUSTOMDIR); then : ; else $(MKDIR) $(INSTALL_CUSTOMDIR); fi
-	$(CP) $(OCAMLDOC)$(EXE) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)
+	$(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)
 	$(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR)
 	$(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
 	if test -d $(INSTALL_MANODIR); then : ; else $(MKDIR) $(INSTALL_MANODIR); fi
@@ -337,7 +337,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 d935db9a48..fd8aa6091e 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 = [ 
-    ("&", "&amp;") ; 
-    ("<", "&lt;") ; 
-    (">", "&gt;") ; 
-] 
+let base_escape_strings = [
+    ("&", "&amp;") ;
+    ("<", "&lt;") ;
+    (">", "&gt;") ;
+]
 
 let pre_escape_strings = [
   (" ", "&nbsp;") ;
   ("\n", "<br>\n") ;
   ("\t", "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;") ;
-  ] 
+  ]
 
 
 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/graph/.depend b/otherlibs/graph/.depend
index 3d8fa25a44..32bfc3239e 100644
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -1,85 +1,149 @@
-color.o: color.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+color.o: color.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h /usr/X11R6/include/X11/Xatom.h
-draw.o: draw.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h
+draw.o: draw.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h
-dump_img.o: dump_img.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h
+dump_img.o: dump_img.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h image.h ../../byterun/alloc.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h
-events.o: events.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h image.h ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h ../../byterun/memory.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \
+  ../../byterun/mlvalues.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \
+  ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \
+  ../../byterun/misc.h ../../byterun/mlvalues.h
+events.o: events.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/signals.h
-fill.o: fill.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h ../../byterun/signals.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h
+fill.o: fill.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h
-image.o: image.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../byterun/memory.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \
+  ../../byterun/mlvalues.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \
+  ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \
+  ../../byterun/misc.h ../../byterun/mlvalues.h
+image.o: image.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h image.h ../../byterun/alloc.h \
-  ../../byterun/custom.h
-make_img.o: make_img.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h image.h ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h ../../byterun/custom.h \
+  ../../byterun/compatibility.h ../../byterun/mlvalues.h
+make_img.o: make_img.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h image.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h
-open.o: open.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h image.h ../../byterun/memory.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \
+  ../../byterun/mlvalues.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \
+  ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \
+  ../../byterun/misc.h ../../byterun/mlvalues.h
+open.o: open.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/callback.h \
-  ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h
-point_col.o: point_col.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h ../../byterun/callback.h \
+  ../../byterun/compatibility.h ../../byterun/mlvalues.h \
+  ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h ../../byterun/memory.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \
+  ../../byterun/mlvalues.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \
+  ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \
+  ../../byterun/misc.h ../../byterun/mlvalues.h
+point_col.o: point_col.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h
-sound.o: sound.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h
+sound.o: sound.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h
-subwindow.o: subwindow.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h
+subwindow.o: subwindow.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h
-text.o: text.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
-  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
-  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h
+text.o: text.c libgraph.h \
+  \
+  \
+  \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h
+  ../../byterun/config.h ../../byterun/../config/m.h \
+  ../../byterun/../config/s.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/mlvalues.h
 graphics.cmo: graphics.cmi 
 graphics.cmx: graphics.cmi 
 graphicsX11.cmo: graphics.cmi graphicsX11.cmi 
diff --git a/otherlibs/labltk/support/tkthread.ml b/otherlibs/labltk/support/tkthread.ml
index 0336afe3c0..8a77eb49e3 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 () =
-  not (Sys.os_type = "Win32") || !loop_id = Some(Thread.id (Thread.self ()))
+  !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 ae031e3a47..52b1a76ceb 100644
--- a/otherlibs/labltk/support/tkthread.mli
+++ b/otherlibs/labltk/support/tkthread.mli
@@ -18,7 +18,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
@@ -32,10 +32,13 @@ 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 it is safe to call most Tk functions directly from
     the current thread *)
 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 ad3e8b25b9..4a5b64b929 100644
--- a/otherlibs/num/nat_stubs.c
+++ b/otherlibs/num/nat_stubs.c
@@ -109,7 +109,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)
@@ -330,8 +330,8 @@ static void serialize_nat(value nat,
 
 #ifdef ARCH_SIXTYFOUR
   len = len * 2; /* two 32-bit words per 64-bit digit  */
-  if (len >= (1L << 32))
-    caml_failwith("output_value: nat too big");
+  if (len >= ((mlsize_t)1 << 32))
+    failwith("output_value: nat too big");
 #endif
   caml_serialize_int_4((int32) len);
 #if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
index 3d65d19f00..087f54e9ac 100644
--- a/otherlibs/str/Makefile.nt
+++ b/otherlibs/str/Makefile.nt
@@ -53,7 +53,7 @@ clean: partialclean
 install:
 	cp dllstr.dll $(STUBLIBDIR)/dllstr.dll
 	cp libstr.$(A) $(LIBDIR)/libstr.$(A)
-	cp str.cma str.cmi $(LIBDIR)
+	cp str.cma str.cmi str.mli $(LIBDIR)
 
 installopt:
 	cp str.cmx str.cmxa str.$(A) $(LIBDIR)
diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
index 31b6232841..080efae9ff 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 fcd0f505d9..872ef1e588 100644
--- a/otherlibs/systhreads/posix.c
+++ b/otherlibs/systhreads/posix.c
@@ -809,7 +809,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);
   }
@@ -826,9 +826,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 af274bfc8b..8394a47bc6 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/threads/.depend b/otherlibs/threads/.depend
index b9ebac4703..676b0429e7 100644
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -8,21 +8,19 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \
   ../../byterun/printexc.h ../../byterun/roots.h ../../byterun/signals.h \
   ../../byterun/stacks.h ../../byterun/sys.h
 condition.cmi: mutex.cmi 
-thread.cmi: unix.cmi 
-threadUnix.cmi: unix.cmi 
+thread.cmi: unix.cmo 
+threadUnix.cmi: unix.cmo 
 condition.cmo: thread.cmi mutex.cmi condition.cmi 
 condition.cmx: thread.cmx mutex.cmx condition.cmi 
 event.cmo: mutex.cmi condition.cmi event.cmi 
 event.cmx: mutex.cmx condition.cmx event.cmi 
-marshal.cmo: pervasives.cmi marshal.cmi 
-marshal.cmx: pervasives.cmx marshal.cmi 
+marshal.cmo: pervasives.cmo 
+marshal.cmx: pervasives.cmx 
 mutex.cmo: thread.cmi mutex.cmi 
 mutex.cmx: thread.cmx mutex.cmi 
-pervasives.cmo: unix.cmi pervasives.cmi 
-pervasives.cmx: unix.cmx pervasives.cmi 
-thread.cmo: unix.cmi thread.cmi 
+pervasives.cmo: unix.cmo 
+pervasives.cmx: unix.cmx 
+thread.cmo: unix.cmo thread.cmi 
 thread.cmx: unix.cmx thread.cmi 
-threadUnix.cmo: unix.cmi thread.cmi threadUnix.cmi 
+threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi 
 threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi 
-unix.cmo: unix.cmi 
-unix.cmx: unix.cmi 
diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c
index d7065c68ee..0c0c5fc1a3 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 b244f8af64..c388b13936 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 daa3c9d9de..c131ab114e 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -755,7 +755,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 1f081c81fc..4209739753 100644
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -385,7 +385,7 @@ module LargeFile :
   end
 (** 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
@@ -578,23 +578,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. *)
 
@@ -664,9 +664,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
@@ -970,11 +968,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 :
@@ -1311,8 +1309,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 8a92d18f03..d91d707b47 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 76e73e3aef..f2f334bbb4 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 0a68076b4a..c02df80861 100644
--- a/otherlibs/win32unix/winwait.c
+++ b/otherlibs/win32unix/winwait.c
@@ -57,6 +57,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 b1ec04e006..9921053e6a 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 cb6b65f94d..01f49f3d51 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -597,8 +597,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
@@ -663,10 +663,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
@@ -824,8 +824,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 */
@@ -1583,11 +1581,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 dd6c517532..009e203753 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 bc33d239fd..4e5ed08d1c 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 17419aef5f..12a77cc8fb 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 2205a37fec..2ffa71c0a2 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 ca31832e89..6debd39d04 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -64,7 +64,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:
@@ -79,75 +81,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;
 };;
 
 (**************************************************************
@@ -158,38 +165,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.
 
@@ -216,47 +224,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;;
 
 (**************************************************************
 
@@ -268,141 +277,147 @@ 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.
    Printing is delayed when the text waiting in the queue requires
    more room to format than exists on the current line. *)
 let rec advance_left state =
-    try
-     match peek_queue state.pp_queue with
-      {elem_size = size; token = tok; length = len} ->
-       let size = int_of_size size in
-       if not
-        (size < 0 &&
-         (state.pp_right_total - state.pp_left_total < state.pp_space_left))
-        then begin
-         ignore(take_queue state.pp_queue);
-         format_pp_token state (if size < 0 then pp_infinity else size) tok;
-         state.pp_left_total <- len + state.pp_left_total;
-         advance_left state
-        end
-    with Empty_queue -> ();;
+  try
+    match peek_queue state.pp_queue with
+    | { elem_size = size; token = tok; length = len; } ->
+      let size = int_of_size size in
+      if not
+       (size < 0 &&
+        (state.pp_right_total - state.pp_left_total <
+         state.pp_space_left)) then
+      begin
+        ignore(take_queue state.pp_queue);
+        format_pp_token state (if size < 0 then pp_infinity else size) tok;
+        state.pp_left_total <- len + state.pp_left_total;
+        advance_left state
+      end with
+  | Empty_queue -> ();;
 
 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
@@ -430,89 +445,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 subblocks. *)
 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;;
@@ -521,10 +546,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 {
@@ -540,26 +565,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;;
 
 (**************************************************************
 
@@ -604,9 +629,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 () =
@@ -644,11 +669,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 =
@@ -709,15 +736,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;;
@@ -753,51 +780,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;;
@@ -816,9 +843,9 @@ let formatter_of_buffer b =
 
 let stdbuf = Buffer.create 512;;
 
-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;
@@ -875,32 +902,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
 ;;
 
 
@@ -942,24 +969,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
@@ -979,73 +1006,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
@@ -1067,123 +1095,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/gc.mli b/stdlib/gc.mli
index 4d36a29f2e..736e324f3f 100644
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -86,7 +86,7 @@ type control =
 
     mutable major_heap_increment : int;
     (** The minimum number of words to add to the
-       major heap when increasing it.  Default: 62k. *)
+       major heap when increasing it.  Default: 60k. *)
 
     mutable space_overhead : int;
     (** The major GC speed is computed from this parameter.
diff --git a/stdlib/int32.mli b/stdlib/int32.mli
index dc733ec9fc..eeafb1a2fc 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 7bc39e6123..3b641338e7 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.ml b/stdlib/printf.ml
index f4a27ca521..9652b14606 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -36,8 +36,6 @@ module Sformat = struct
 
   let add_int_index i idx = index_of_int (i + int_of_index idx);;
   let succ_index = add_int_index 1;;
-  (* Litteral position are one-based (hence pred p instead of p). *)
-  let index_of_litteral_position p = index_of_int (pred p);;
 
   external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int
     = "%string_length";;
@@ -102,17 +100,7 @@ let format_string sfmt s =
    '*' in the format are replaced by integers taken from the [widths] list.
    extract_format returns a string. *)
 let extract_format fmt start stop widths =
-  let skip_positional_spec start =
-    match Sformat.unsafe_get fmt start with
-    | '0'..'9' ->
-      let rec skip_int_litteral i =
-        match Sformat.unsafe_get fmt i with
-        | '0'..'9' -> skip_int_litteral (succ i)
-        | '$' -> succ i
-        | _ -> start in
-      skip_int_litteral (succ start)
-    | _ -> start in
-  let start = skip_positional_spec (succ start) in
+  let start = succ start in
   let b = Buffer.create (stop - start + 10) in
   Buffer.add_char b '%';
   let rec fill_format i widths =
@@ -120,7 +108,7 @@ let extract_format fmt start stop widths =
       match (Sformat.unsafe_get fmt i, widths) with
       | ('*', h :: t) ->
         Buffer.add_string b (string_of_int h);
-        let i = skip_positional_spec (succ i) in
+        let i = succ i in
         fill_format i t
       | ('*', []) ->
         assert false (* should not happen *)
@@ -175,7 +163,6 @@ let iter_on_format_args fmt add_conv add_char =
     if i > lim then incomplete_format fmt else
     match Sformat.unsafe_get fmt i with
     | '*' -> scan_flags skip (add_conv skip i 'i')
-    | '$' -> scan_flags skip (succ i)
     | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i)
     | '_' -> scan_flags true (succ i)
     | '0'..'9'
@@ -324,47 +311,8 @@ let kapr kpr fmt =
       else Obj.magic (fun x -> loop (succ i) (x :: args)) in
     loop 0 [];;
 
-type positional_specification =
-   | Spec_none | Spec_index of Sformat.index;; 
-
-(* To scan an optional positional parameter specification,
-   i.e. an integer followed by a [$].
-   We do not support [*$] specifications, since this would lead to type checking
-   problems: the type of the specified [*$] parameter would be the type of the
-   corresponding argument to [printf], hence the type of the $n$-th argument to
-   [printf] with $n$ being the {\em value} of the integer argument defining
-   [*]; this means type dependency, which is out of scope of the Caml type
-   algebra. *)
-let scan_positional_spec fmt got_spec n i =
-  match Sformat.unsafe_get fmt i with
-  | '0'..'9' as d ->
-    let rec get_int_litteral accu j =
-      match Sformat.unsafe_get fmt j with
-      | '0'..'9' as d ->
-        get_int_litteral (10 * accu + (int_of_char d - 48)) (succ j)
-      | '$' ->
-        if accu = 0
-          then failwith "printf: bad positional specification (0)." else
-        got_spec (Spec_index (Sformat.index_of_litteral_position accu)) (succ j)
-      (* Not a positional specification. *)
-      | _ -> got_spec Spec_none i in
-    get_int_litteral (int_of_char d - 48) (succ i)
-  (* No positional specification. *)
-  | _ -> got_spec Spec_none i;;
-
-(* Get the position of the next argument to printf, according to the given
-   positional specification. *)
-let next_index spec n =
-  match spec with
-  | Spec_none -> Sformat.succ_index n
-  | Spec_index _ -> n;;
-
-(* Get the position of the actual argument to printf, according to its
-   optional positional specification. *)
-let get_index spec n =
-  match spec with
-  | Spec_none -> n
-  | Spec_index p -> p;;
+(* Get the index of the next argument to printf. *)
+let next_index n = Sformat.succ_index n;;
 
 (* Decode a format string and act on it.
    [fmt] is the printf format string, and [pos] points to a [%] character.
@@ -388,67 +336,58 @@ let get_index spec n =
    Don't do this at home, kids. *)
 let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
 
-  let get_arg spec n =
-    Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in
-
-  let rec scan_positional n widths i =
-    let got_spec spec i = scan_flags spec n widths i in
-    scan_positional_spec fmt got_spec n i
+  let get_arg n =
+    Obj.magic (args.(Sformat.int_of_index n)) in
 
-  and scan_flags spec n widths i =
+  let rec scan_flags n widths i =
     match Sformat.unsafe_get fmt i with
     | '*' ->
-      let got_spec wspec i =
-        let (width : int) = get_arg wspec n in
-        scan_flags spec (next_index wspec n) (width :: widths) i in
-      scan_positional_spec fmt got_spec n (succ i)
+      let (width : int) = get_arg n in
+      scan_flags (next_index n) (width :: widths) (succ i)
     | '0'..'9'
-    | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i)
-    | _ -> scan_conv spec n widths i
+    | '.' | '#' | '-' | ' ' | '+' -> scan_flags n widths (succ i)
+    | _ -> scan_conv n widths i
 
-  and scan_conv spec n widths i =
+  and scan_conv n widths i =
     match Sformat.unsafe_get fmt i with
     | '%' ->
       cont_s n "%" (succ i)
     | 's' | 'S' as conv ->
-      let (x : string) = get_arg spec n in
+      let (x : string) = get_arg n in
       let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in
       let s =
         (* optimize for common case %s *)
         if i = succ pos then x else
         format_string (extract_format fmt pos i widths) x in
-      cont_s (next_index spec n) s (succ i)
+      cont_s (next_index n) s (succ i)
     | 'c' | 'C' as conv ->
-      let (x : char) = get_arg spec n in
+      let (x : char) = get_arg n in
       let s =
         if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in
-      cont_s (next_index spec n) s (succ i)
+      cont_s (next_index n) s (succ i)
     | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv ->
-      let (x : int) = get_arg spec n in
+      let (x : int) = get_arg n in
       let s =
         format_int (extract_format_int conv fmt pos i widths) x in
-      cont_s (next_index spec n) s (succ i)
+      cont_s (next_index n) s (succ i)
     | 'f' | 'e' | 'E' | 'g' | 'G' ->
-      let (x : float) = get_arg spec n in
+      let (x : float) = get_arg n in
       let s = format_float (extract_format fmt pos i widths) x in
-      cont_s (next_index spec n) s (succ i)
+      cont_s (next_index n) s (succ i)
     | 'F' ->
-      let (x : float) = get_arg spec n in
-      cont_s (next_index spec n) (string_of_float x) (succ i)
+      let (x : float) = get_arg n in
+      cont_s (next_index n) (string_of_float x) (succ i)
     | 'B' | 'b' ->
-      let (x : bool) = get_arg spec n in
-      cont_s (next_index spec n) (string_of_bool x) (succ i)
+      let (x : bool) = get_arg n in
+      cont_s (next_index n) (string_of_bool x) (succ i)
     | 'a' ->
-      let printer = get_arg spec n in
-      (* If the printer spec is Spec_none, go on as usual.
-         If the printer spec is Spec_index p,
-         printer's argument spec is Spec_index (succ_index p). *)
-      let n = Sformat.succ_index (get_index spec n) in
-      let arg = get_arg Spec_none n in
-      cont_a (next_index spec n) printer arg (succ i)
+      let printer = get_arg n in
+      let n = Sformat.succ_index n in
+      let arg = get_arg n in
+      cont_a (next_index n) printer arg (succ i)
     | 't' ->
-      let printer = get_arg spec n in
-      cont_t (next_index spec n) printer (succ i)
+      let printer = get_arg n in
+      cont_t (next_index n) printer (succ i)
     | 'l' | 'n' | 'L' as conv ->
       begin match Sformat.unsafe_get fmt (succ i) with
       | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
@@ -456,39 +395,39 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
         let s =
           match conv with
           | 'l' ->
-            let (x : int32) = get_arg spec n in
+            let (x : int32) = get_arg n in
             format_int32 (extract_format fmt pos i widths) x
           | 'n' ->
-            let (x : nativeint) = get_arg spec n in
+            let (x : nativeint) = get_arg n in
             format_nativeint (extract_format fmt pos i widths) x
           | _ ->
-            let (x : int64) = get_arg spec n in
+            let (x : int64) = get_arg n in
             format_int64 (extract_format fmt pos i widths) x in
-        cont_s (next_index spec n) s (succ i)
+        cont_s (next_index n) s (succ i)
       | _ ->
-        let (x : int) = get_arg spec n in
+        let (x : int) = get_arg n in
         let s = format_int (extract_format_int 'n' fmt pos i widths) x in
-        cont_s (next_index spec n) s (succ i)
+        cont_s (next_index n) s (succ i)
       end
     | '!' -> cont_f n (succ i)
     | '{' | '(' as conv (* ')' '}' *) ->
-      let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in
+      let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg n in
       let i = succ i in
       let j = sub_format_for_printf conv fmt i in
       if conv = '{' (* '}' *) then
         (* Just print the format argument as a specification. *)
         cont_s
-          (next_index spec n)
+          (next_index n)
           (summarize_format_type xf)
           j else
         (* Use the format argument instead of the format specification. *)
-        cont_m (next_index spec n) xf j
+        cont_m (next_index n) xf j
     | (* '(' *) ')' ->
       cont_s n "" (succ i)
     | conv ->
       bad_conversion_format fmt i conv in
 
-  scan_positional n [] (succ pos);;
+  scan_flags n [] (succ pos);;
 
 let mkprintf to_s get_out outc outs flush k fmt =
 
@@ -505,27 +444,27 @@ let mkprintf to_s get_out outc outs flush k fmt =
        match Sformat.unsafe_get fmt i with
        | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
        |  c  -> outc out c; doprn n (succ i)
-     and cont_s n s i =
-       outs out s; doprn n i
-     and cont_a n printer arg i =
-       if to_s then
-         outs out ((Obj.magic printer : unit -> _ -> string) () arg)
-       else
-         printer out arg;
-       doprn n i
-     and cont_t n printer i =
-       if to_s then
-         outs out ((Obj.magic printer : unit -> string) ())
-       else
-         printer out;
-       doprn n i
-     and cont_f n i =
-       flush out; doprn n i
-     and cont_m n xf i =
-       let m = Sformat.add_int_index (count_arguments_of_format xf) n in
-       pr (Obj.magic (fun _ -> doprn m i)) n xf v in
-
-     doprn n 0 in
+    and cont_s n s i =
+      outs out s; doprn n i
+    and cont_a n printer arg i =
+      if to_s then
+        outs out ((Obj.magic printer : unit -> _ -> string) () arg)
+      else
+        printer out arg;
+      doprn n i
+    and cont_t n printer i =
+      if to_s then
+        outs out ((Obj.magic printer : unit -> string) ())
+      else
+        printer out;
+      doprn n i
+    and cont_f n i =
+      flush out; doprn n i
+    and cont_m n xf i =
+      let m = Sformat.add_int_index (count_arguments_of_format xf) n in
+      pr (Obj.magic (fun _ -> doprn m i)) n xf v in
+
+    doprn n 0 in
 
   let kpr = pr k (Sformat.index_of_int 0) in
 
diff --git a/stdlib/printf.mli b/stdlib/printf.mli
index e8bd7d6c92..6bd692d0b9 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/stdlib/weak.ml b/stdlib/weak.ml
index 317c3729f8..de5f85286b 100644
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -26,6 +26,8 @@ external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";;
 external get: 'a t -> int -> 'a option = "caml_weak_get";;
 external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";;
 external check: 'a t -> int -> bool = "caml_weak_check";;
+external blit: 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";;
+(* blit: src srcoff dst dstoff len *)
 
 let fill ar ofs len x =
   if ofs < 0 || len < 0 || ofs + len > length ar
@@ -37,23 +39,6 @@ let fill ar ofs len x =
   end
 ;;
 
-let blit ar1 of1 ar2 of2 len =
-  if of1 < 0 || of1 + len > length ar1 || of2 < 0 || of2 + len > length ar2
-  then raise (Invalid_argument "Weak.blit")
-  else begin
-    if of2 > of1 then begin
-      for i = 0 to len - 1 do
-        set ar2 (of2 + i) (get ar1 (of1 + i))
-      done
-    end else begin
-      for i = len - 1 downto 0 do
-        set ar2 (of2 + i) (get ar1 (of1 + i))
-      done
-    end
-  end
-;;
-
-
 (** Weak hash tables *)
 
 module type S = sig
@@ -83,27 +68,35 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
 
   type t = {
     mutable table : data weak_t array;
-    mutable totsize : int;             (* sum of the bucket sizes *)
-    mutable limit : int;               (* max ratio totsize/table length *)
+    mutable hashes : int array array;
+    mutable limit : int;               (* bucket size limit *)
+    mutable oversize : int;            (* number of oversize buckets *)
+    mutable rover : int;               (* for internal bookkeeping *)
   };;
 
-  let get_index t d = (H.hash d land max_int) mod (Array.length t.table);;
+  let get_index t h = (h land max_int) mod (Array.length t.table);;
+
+  let limit = 7;;
+  let over_limit = 2;;
 
   let create sz =
     let sz = if sz < 7 then 7 else sz in
     let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
     {
       table = Array.create sz emptybucket;
-      totsize = 0;
-      limit = 3;
+      hashes = Array.create sz [| |];
+      limit = limit;
+      oversize = 0;
+      rover = 0;
     };;
 
   let clear t =
     for i = 0 to Array.length t.table - 1 do
       t.table.(i) <- emptybucket;
+      t.hashes.(i) <- [| |];
     done;
-    t.totsize <- 0;
-    t.limit <- 3;
+    t.limit <- limit;
+    t.oversize <- 0;
   ;;
 
   let fold f t init =
@@ -126,85 +119,155 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
     Array.iter (iter_bucket 0) t.table
   ;;
 
-  let count t =
-    let rec count_bucket i b accu =
-      if i >= length b then accu else
-      count_bucket (i+1) b (accu + (if check b i then 1 else 0))
+  let iter_weak f t =
+    let rec iter_bucket i j b =
+      if i >= length b then () else
+      match check b i with
+      | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b
+      | false -> iter_bucket (i+1) j b
     in
+    Array.iteri (iter_bucket 0) t.table
+  ;;
+
+  let rec count_bucket i b accu =
+    if i >= length b then accu else
+    count_bucket (i+1) b (accu + (if check b i then 1 else 0))
+  ;;
+
+  let count t =
     Array.fold_right (count_bucket 0) t.table 0
   ;;
 
-  let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1);;
+  let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;;
+  let prev_sz n = ((n - 3) * 2 + 2) / 3;;
+
+  let test_shrink_bucket t =
+    let bucket = t.table.(t.rover) in
+    let hbucket = t.hashes.(t.rover) in
+    let len = length bucket in
+    let prev_len = prev_sz len in
+    let live = count_bucket 0 bucket 0 in
+    if live <= prev_len then begin
+      let rec loop i j =
+        if j >= prev_len then begin
+          if check bucket i then loop (i + 1) j
+          else if check bucket j then begin
+            blit bucket j bucket i 1;
+            hbucket.(i) <- hbucket.(j);
+            loop (i + 1) (j - 1);
+          end else loop i (j - 1);
+        end;
+      in
+      loop 0 (length bucket - 1);
+      if prev_len = 0 then begin
+        t.table.(t.rover) <- emptybucket;
+        t.hashes.(t.rover) <- [| |];
+      end else begin
+        Obj.truncate (Obj.repr bucket) (prev_len + 1);
+        Obj.truncate (Obj.repr hbucket) prev_len;
+      end;
+      if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
+    end;
+    t.rover <- (t.rover + 1) mod (Array.length t.table);
+  ;;
 
   let rec resize t =
     let oldlen = Array.length t.table in
     let newlen = next_sz oldlen in
     if newlen > oldlen then begin
       let newt = create newlen in
-      newt.limit <- t.limit + 100;          (* prevent resizing of newt *)
-      fold (fun d () -> add newt d) t ();
-   (* assert Array.length newt.table = newlen; *)
+      let add_weak ob oh oi =
+        let setter nb ni _ = blit ob oi nb ni 1 in
+        let h = oh.(oi) in
+        add_aux newt setter None h (get_index newt h);
+      in
+      iter_weak add_weak t;
       t.table <- newt.table;
-   (* t.limit <- t.limit + 2; -- performance bug *)
+      t.hashes <- newt.hashes;
+      t.limit <- newt.limit;
+      t.oversize <- newt.oversize;
+      t.rover <- t.rover mod Array.length newt.table;
+    end else begin
+      t.limit <- max_int;             (* maximum size already reached *)
+      t.oversize <- 0;
     end
 
-  and add_aux t d index =
+  and add_aux t setter d h index =
     let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
     let sz = length bucket in
     let rec loop i =
       if i >= sz then begin
-        let newsz = min (sz + 3) (Sys.max_array_length - 1) in
-        if newsz <= sz then failwith "Weak.Make : hash bucket cannot grow more";
+        let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in
+        if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
         let newbucket = weak_create newsz in
+        let newhashes = Array.make newsz 0 in
         blit bucket 0 newbucket 0 sz;
-        set newbucket i (Some d);
+        Array.blit hashes 0 newhashes 0 sz;
+        setter newbucket sz d;
+        newhashes.(sz) <- h;
         t.table.(index) <- newbucket;
-        t.totsize <- t.totsize + (newsz - sz);
-        if t.totsize > t.limit * Array.length t.table then resize t;
+        t.hashes.(index) <- newhashes;
+        if sz <= t.limit && newsz > t.limit then begin
+          t.oversize <- t.oversize + 1;
+          for i = 0 to over_limit do test_shrink_bucket t done;
+        end;
+        if t.oversize > Array.length t.table / over_limit then resize t;
+      end else if check bucket i then begin
+        loop (i + 1)
       end else begin
-        if check bucket i
-        then loop (i+1)
-        else set bucket i (Some d)
-      end
+        setter bucket i d;
+        hashes.(i) <- h;
+      end;
     in
     loop 0;
+  ;;
 
-  and add t d = add_aux t d (get_index t d)
+  let add t d =
+    let h = H.hash d in
+    add_aux t set (Some d) h (get_index t h);
   ;;
 
   let find_or t d ifnotfound =
-    let index = get_index t d in
+    let h = H.hash d in
+    let index = get_index t h in
     let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
     let sz = length bucket in
     let rec loop i =
-      if i >= sz then ifnotfound index
-      else begin
+      if i >= sz then ifnotfound h index
+      else if h = hashes.(i) then begin
         match get_copy bucket i with
         | Some v when H.equal v d
            -> begin match get bucket i with
               | Some v -> v
-              | None -> loop (i+1)
+              | None -> loop (i + 1)
               end
-        | _ -> loop (i+1)
-      end
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
     in
     loop 0
   ;;
 
-  let merge t d = find_or t d (fun index -> add_aux t d index; d);;
+  let merge t d =
+    find_or t d (fun h index -> add_aux t set (Some d) h index; d)
+  ;;
 
-  let find t d = find_or t d (fun index -> raise Not_found);;
+  let find t d = find_or t d (fun h index -> raise Not_found);;
 
   let find_shadow t d iffound ifnotfound =
-    let index = get_index t d in
+    let h = H.hash d in
+    let index = get_index t h in
     let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
     let sz = length bucket in
     let rec loop i =
-      if i >= sz then ifnotfound else begin
+      if i >= sz then ifnotfound
+      else if h = hashes.(i) then begin
         match get_copy bucket i with
         | Some v when H.equal v d -> iffound bucket i
-        | _ -> loop (i+1)
-      end
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
     in
     loop 0
   ;;
@@ -214,20 +277,22 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
   let mem t d = find_shadow t d (fun w i -> true) false;;
 
   let find_all t d =
-    let index = get_index t d in
+    let h = H.hash d in
+    let index = get_index t h in
     let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
     let sz = length bucket in
     let rec loop i accu =
       if i >= sz then accu
-      else begin
+      else if h = hashes.(i) then begin
         match get_copy bucket i with
         | Some v when H.equal v d
            -> begin match get bucket i with
-              | Some v -> loop (i+1) (v::accu)
-              | None -> loop (i+1) accu
+              | Some v -> loop (i + 1) (v :: accu)
+              | None -> loop (i + 1) accu
               end
-        | _ -> loop (i+1) accu
-      end
+        | _ -> loop (i + 1) accu
+      end else loop (i + 1) accu
     in
     loop 0 []
   ;;
diff --git a/test/Makefile b/test/Makefile
index f8219eeb5b..46fb2acb88 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -28,7 +28,7 @@ CODERUNPARAMS=OCAMLRUNPARAM='o=100'
 BYTE_EXE=fib.byt takc.byt taku.byt sieve.byt quicksort.byt quicksort.fast.byt \
   fft.byt fft.fast.byt soli.byt soli.fast.byt boyer.byt kb.byt \
   nucleic.byt bdd.byt hamming.byt sorts.byt \
-  almabench.byt almabench.fast.byt
+  almabench.byt almabench.fast.byt weaktest.byt
 
 CODE_EXE=$(BYTE_EXE:.byt=.out)
 
diff --git a/test/Moretest/recmod.ml b/test/Moretest/recmod.ml
index 1573ef01b4..e4c6751c56 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/test/weaktest.ml b/test/weaktest.ml
index 92ab5576d3..a4e0b45760 100644
--- a/test/weaktest.ml
+++ b/test/weaktest.ml
@@ -1,73 +1,370 @@
 (* $Id$ *)
 
-let debug = false;;
+let ( =%= ) = ( = );;
+let ( = ) = ();;
 
-open Printf;;
+type expr =
+  | LL of private_info * string list * expr
+  | VV of private_info * string
+  | AA of private_info * string * expr list
 
-module Hashed = struct
-  type t = string list;;
-  let equal x y =
-    eprintf "equal: %s / %s\n" (List.hd x) (List.hd y);
-    x = y
+and private_info = {
+  hash : int;
+  skel_hash : int;
+  vars_hash : (string * int) list;
+  size : int;
+};;
+
+
+(************************)
+(* small sets of formulas (represented as lists) *)
+
+let rec diff l1 l2 =
+  match l1 with
+  | [] -> []
+  | e::t -> if List.exists ((==) e) l2
+            then diff t l2
+            else e :: (diff t l2)
+;;
+
+let union l1 l2 = List.rev_append (diff l1 l2) l2;;
+
+let rec disjoint l1 l2 =
+  match l1 with
+  | [] -> true
+  | h::t -> if List.exists ((==) h) l2
+            then false
+            else disjoint t l2
+;;
+
+(*******************)
+
+let k0 = 0x798764da;;
+let k1 = 0x6f75849b;;
+let k2 = 0x4c14862c;;
+let k3 = 0x72a7baf3;;
+let k4 = 0x7542122c;;
+let k5 = 0x74a318d5;;
+let k6 = 0x7eb1b2dc;;
+let k7 = 0x4bea2543;;
+let k8 = 0x297e236d;;
+let k9 = 0x47c6ad26;;
+
+let combine k h1 h2 =
+  let x = k lxor h1 in
+  x + (x lsl 1) + (x lsl 8) + (x lsr 16) + h2
+;;
+
+let mkhash skel vars =
+  let cmb accu (v, h) = combine k0 accu (combine k0 (Hashtbl.hash v) h) in
+  List.fold_left cmb skel vars
+;;
+
+let mkpriv skel vars sz = {
+  hash = mkhash skel vars;
+  skel_hash = skel;
+  vars_hash = vars;
+  size = sz;
+};;
+
+let get_priv = function
+  | LL (h, _, _) -> h
+  | VV (h, _) -> h
+  | AA (h, _, _) -> h
+;;
+
+let get_hash e = (get_priv e).hash;;
+let get_skel e = (get_priv e).skel_hash;;
+let get_vars e = (get_priv e).vars_hash;;
+let get_size e = (get_priv e).size;;
+
+let rec str_union l1 l2 =
+  match l1, l2 with
+  | [], _ -> l2
+  | _, [] -> l1
+  | h::t, _ when List.exists ((=%=) h) l2 -> str_union t l2
+  | h::t, _ -> str_union t (h :: l2)
+;;
+
+let rec str_remove x l =
+  match x, l with
+  | _, [] -> []
+  | v, h::t when v =%= h -> t
+  | _, h::t -> h :: (str_remove x t)
+;;
+
+let is_const s =
+  match s.[0] with
+  | 'A' .. 'Z' | 'a' .. 'z' | '_' -> false
+  | _ -> true
+;;
+
+let priv_var s =
+  if is_const s
+  then mkpriv (Hashtbl.hash s) [] 1
+  else mkpriv k1 [(s, k2)] 1
+;;
+
+let rec comb_vars accu (cur, v1) v2 =
+  match v1, v2 with
+  | [], [] -> (combine k3 cur 0, List.rev accu)
+  | (x1, h1) :: t1, [] ->
+      comb_vars ((x1, combine k3 h1 0) :: accu) (cur, t1) []
+  | (x1, h1) :: t1, (x2, h2) :: t2 when x1 < x2 ->
+      comb_vars ((x1, combine k3 h1 0) :: accu) (cur, t1) v2
+  | [], (x2, h2) :: t2 ->
+      comb_vars ((x2, combine k3 cur h2) :: accu) (cur, []) t2
+  | (x1, h1) :: t1, (x2, h2) :: t2 when x1 > x2 ->
+      comb_vars ((x2, combine k3 cur h2) :: accu) (cur, v1) t2
+  | (x1, h1) :: t1, (x2, h2) :: t2 ->
+      assert (x1 =%= x2);
+      comb_vars ((x1, combine k3 h1 h2) :: accu) (cur, t1) t2
+;;
+
+let priv_app s args =
+  let (skel_base, vars_base) =
+    if is_const s
+    then (Hashtbl.hash s, [])
+    else (0, [(s, k5)])
+  in
+  let comb_skel accu e = combine k4 accu (get_skel e) in
+  let skel = List.fold_left comb_skel skel_base args in
+  let arg_vars = List.map get_vars args in
+  let (_, vars) = List.fold_left (comb_vars []) (0, vars_base) arg_vars in
+  let sz = List.fold_left (fun a e -> a + get_size e) 1 args in
+  mkpriv skel vars sz
+;;
+
+let rec remove accu vs evars =
+  match vs, evars with
+  | [], l -> List.rev_append accu l
+  | l, [] -> List.rev accu
+  | v1 :: t1, (v2, h2) :: t2 when v1 < v2 -> remove accu t1 evars
+  | v1 :: t1, ((v2, h2) as vh) :: t2 when v1 > v2 -> remove (vh :: accu) vs t2
+  | v1 :: t1, (v2, h2) :: t2 -> remove accu t1 t2
+;;
+
+let rec assoc0 key l =
+  match l with
+  | [] -> 0
+  | (s, h) :: t when s =%= key -> h
+  | _ :: t -> assoc0 key t
+;;
+
+let priv_lam vs e =
+  assert (not (List.exists is_const vs));
+  let evars = get_vars e in
+  let vars = remove [] (List.sort compare vs) evars in
+  let cmb accu v = combine k6 accu (assoc0 v evars) in
+  let skel = List.fold_left cmb (get_skel e) vs in
+  mkpriv skel vars (1 + get_size e)
+;;
+
+
+module HashedExpr = struct
+  type t = expr;;
+
+  let hash = get_hash;;
+
+  type binding = Bound of int | Free of string;;
+
+  let get_binding env v =
+    let rec index i v env =
+      match env with
+      | x :: _ when x =%= v -> Bound i
+      | _ :: t -> index (i+1) v t
+      | [] -> Free v
+    in
+    index 0 v env
+  ;;
+
+  let same_binding env1 v1 env2 v2 =
+    match (get_binding env1 v1), (get_binding env2 v2) with
+    | Bound i1, Bound i2 -> i1 =%= i2
+    | Free w1, Free w2 -> w1 =%= w2
+    | _, _ -> false
+  ;;
+
+  let var_name v =
+    match v with
+    | VV (name, _) -> name
+    | _ -> assert false
+  ;;
+
+  let rec equal_in_env env1 env2 e1 e2 =
+    match e1, e2 with
+    | VV (_, s1), VV (_, s2) -> same_binding env1 s1 env2 s2
+    | AA (_, f1, args1), AA (_, f2, args2) ->
+        f1 =%= f2 && List.length args1 =%= List.length args2
+        && List.for_all2 (equal_in_env env1 env2) args1 args2
+    | LL (_, vs1, b1), LL (_, vs2, b2) ->
+        List.length vs1 =%= List.length vs2
+        && equal_in_env (vs1 @ env1) (vs2 @ env2) b1 b2
+    | _, _ -> false
+  ;;
+
+  let equal e1 e2 =
+    match e1, e2 with
+    | VV (_, v1), VV (_, v2) -> v1 =%= v2
+    | AA (_, f1, args1), AA (_, f2, args2) ->
+        f1 =%= f2 && List.length args1 =%= List.length args2
+        && List.for_all2 (==) args1 args2
+    | LL (_, v1, b1), LL (_, v2, b2)
+      -> v1 =%= v2 && b1 == b2
+         || List.length v1 =%= List.length v2 && equal_in_env v1 v2 b1 b2
+    | _, _ -> false
   ;;
-  let hash x = Hashtbl.hash (List.hd x);;
 end;;
 
-module HT = Weak.Make (Hashed);;
+module HE = Weak.Make (HashedExpr);;
+let tbl = HE.create 7;;
 
-let tbl = HT.create 7;;
+let generated = ref 0;;
+let he_merge tbl x =
+  begin try HE.find tbl x
+  with Not_found ->
+    HE.add tbl x;
+    incr generated;
+    x
+  end
 
-let r = ref [];;
+let vv (s) = he_merge tbl (VV (priv_var s, s));;
+let aa (f, args) = he_merge tbl (AA (priv_app f args, f, args));;
+let ll (v, e) = he_merge tbl (LL (priv_lam v e, v, e));;
 
-let bunch =
-  if Array.length Sys.argv < 2
-  then 10000
-  else int_of_string Sys.argv.(1)
+module Expr = struct
+  type t = expr;;
+  let hash = get_hash;;
+  let equal = (==);;
+  let compare x y =
+    match compare (hash x) (hash y) with
+    | 0 -> if equal x y then 0 else Pervasives.compare x y
+    | x when x < 0 -> -1
+    | _ -> 1
+  ;;
+end;;
+
+(************************)
+
+let buflen = 20;;
+let small = 5;;
+let iter1 = 1000;;
+let iter2 = 1000;;
+
+let buffer = Array.make buflen (vv "x");;
+let live = ref [];;
+
+let rnd_small () =
+  let rec log x = if x =%= 0 then 0 else 1 + log (x / 2) in
+  small - log (Random.int (1 lsl (small-1)))
 ;;
 
-Random.init 314;;
+let rnd_list gen =
+  let rec loop i = if i =%= 0 then [] else gen () :: loop (i - 1) in
+  loop (rnd_small ())
+;;
 
-let random_string n =
-  let result = String.create n in
-  for i = 0 to n - 1 do
-    result.[i] <- Char.chr (32 + Random.int 95);
-  done;
+let rnd_var () = String.make 1 (Char.chr (Char.code 'a' + Random.int 26));;
+
+let rec rm_dup l =
+  match l with
+  | [] | [ _ ] -> l
+  | x :: t -> if List.mem x t then rm_dup t else x :: (rm_dup t)
+;;
+
+let rnd_expr () =
+  let result =
+    match Random.int 3 with
+    | 0 ->
+        let vars = rm_dup (rnd_list rnd_var) in
+        let body = buffer.(Random.int buflen) in
+        ll (vars, body)
+    | 1 -> vv (rnd_var ())
+    | _ ->
+        let f = rnd_var () in
+        let args = rnd_list (fun () -> buffer.(Random.int buflen)) in
+        aa (f, args)
+  in
+  buffer.(Random.int buflen) <- result;
   result
 ;;
 
-let added = ref 0;;
-let mistakes = ref 0;;
-
-let print_status () =
-  let (len, entries, sumbuck, buckmin, buckmed, buckmax) = HT.stats tbl in
-  if entries > bunch * (!added + 1) then begin
-    if debug then begin
-      printf "\n===================\n";
-      printf "len = %d\n" len;
-      printf "entries = %d\n" entries;
-      printf "sum of bucket sizes = %d\n" sumbuck;
-      printf "min bucket = %d\n" buckmin;
-      printf "med bucket = %d\n" buckmed;
-      printf "max bucket = %d\n" buckmax;
-      printf "GC count = %d\n" (Gc.quick_stat ()).Gc.major_collections;
-      flush stdout;
-    end;
-    incr mistakes;
+module H = Hashtbl.Make (Expr);;
+
+let seen = H.create 7;;
+
+let rec count e =
+  if H.mem seen e then begin
+    (*Printf.eprintf "shared\n"; flush stderr;*)
+  end else begin
+    H.add seen e ();
+    match e with
+    | LL (_, _, b) -> count b;
+    | VV (_, _) -> ()
+    | AA (_, _, args) -> List.iter count args;
   end;
-  added := 0;
 ;;
 
-Gc.create_alarm print_status;;
+let rec check e =
+  HE.mem tbl e && (
+    match e with
+    | LL (_, _, b) -> check b
+    | VV (_, _) -> true
+    | AA (_, _, args) -> List.for_all check args
+  )
+;;
+
+let gen2 = ref 0;;
+
+let main seed =
+
+  Random.init seed;
 
-for j = 0 to 99 do
-  r := [];
-  incr added;
+  let at_gc () =
+    gen2 := !generated;
+    generated := 0;
+    (*Printf.eprintf "gen2 = %d\n" !gen2; flush stderr;*)
+  in
+  ignore (Gc.create_alarm at_gc);
 
-  for i = 1 to bunch do
-    let c = random_string 7 in
-    r := c :: !r;
-    HT.add tbl !r;
+  for i = 1 to iter1 do
+    for j = 1 to iter2 do
+      ignore (rnd_expr ());
+    done;
+    live := rnd_expr () :: !live;
   done;
-done;;
 
-if !mistakes < 5 then printf "pass\n" else printf "fail\n";;
+  H.clear seen;
+  List.iter count !live;
+  Array.iter count buffer;
+  let max_live = H.length seen + !generated + !gen2 in
+
+  let table_size = HE.count tbl in
+
+  let chk x e = x && check e in
+  let l1 = List.fold_left chk true !live in
+  let l2 = Array.fold_left chk true buffer in
+  let all_alive = l1 && l2 in
+
+  if not all_alive then begin
+    Printf.printf "fail: not all alive\n";
+    raise Exit;
+  end else if table_size > max_live then begin
+    Printf.printf "fail: too many alive\n";
+    raise Exit;
+  end else begin
+    Printf.printf "pass\n";
+  end;
+;;
+
+let seed =
+  if Array.length Sys.argv < 2
+  then (Random.self_init (); Random.bits ())
+  else int_of_string Sys.argv.(1)
+;;
+
+try main seed
+with e ->
+  Printf.printf "TEST FAILED [%d]\n" seed;
+  raise e;
+;;
diff --git a/testlabl/poly.exp b/testlabl/poly.exp
index cc124b6581..ecd8cad5d4 100644
--- a/testlabl/poly.exp
+++ b/testlabl/poly.exp
@@ -1,4 +1,4 @@
-        Objective Caml version 3.10+dev1 (2005-10-26)
+        Objective Caml version 3.10.1+dev0 (2007-05-21)
 
 #   * * *       #   type 'a t = { t : 'a; }
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
@@ -219,9 +219,7 @@ This field value has type 'a option ref which is less general than
 This field value has type 'a option ref option which is less general than
   'b. 'b option ref option
 #       val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = <fun>
-# val f :
-  < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
-  (< p : int * 'c > as 'c) -> unit = <fun>
+# val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = <fun>
 #       type 'a t = [ `A of 'a ]
 #       class c : object method m : ([> 'a t ] as 'a) -> unit end
 #         class c : object method m : ([> 'a t ] as 'a) -> unit end
@@ -294,7 +292,7 @@ Constraints are not satisfied in this type.
 Type
 ([> `B of 'a ], 'a) b as 'a
 should be an instance of
-(('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
+(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
 #                             class type ['a, 'b] a =
   object
     constraint 'a = ('a, 'b) #a
@@ -332,11 +330,11 @@ val f : unit -> < m : int; n : int > = <fun>
 # Characters 11-56:
 This object is expected to have type c but has actually type
   < m : int; n : 'a >
-Only the second object type has a method n
+The first object type has no method n
 # Characters 11-69:
 This object is expected to have type < n : int > but has actually type
   < m : 'a >
-Only the first object type has a method n
+The second object type has no method n
 #         Characters 66-124:
 This object is expected to have type < x : int; .. > but has actually type
   < x : int >
@@ -405,7 +403,6 @@ is not included in
 # - : u -> v = <fun>
 # Characters 9-21:
 Type v = [> `A | `B ] is not a subtype of type u = [< `A | `B ] 
-These two variant types have no intersection
 # type v = private [< t ]
 # Characters 9-21:
 Type u = [< `A | `B ] is not a subtype of type v = [< `A | `B ] 
@@ -426,7 +423,7 @@ is not a subtype of type < m : 'a. (< p : < a : int >; .. > as 'a) -> int >
 # Characters 11-55:
 Type < p : < a : int; b : int >; .. > is not a subtype of type
   < p : < a : int >; .. > 
-Only the first object type has a method b
+The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
   < m : 'a. [< `A of <  > ] as 'a > = <fun>
@@ -439,4 +436,4 @@ Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of type
 # val f : c -> 'a -> 'a = <fun>
 #     val g : c -> 'a -> 'a = <fun>
 #     val h : < id : 'a; .. > -> 'a = <fun>
-# 
+#     * * * * * * * * * * * * * * * * * * *   
diff --git a/testlabl/poly.exp2 b/testlabl/poly.exp2
index 0a81678120..6a2405bd2d 100644
--- a/testlabl/poly.exp2
+++ b/testlabl/poly.exp2
@@ -1,4 +1,4 @@
-        Objective Caml version 3.10+dev1 (2005-10-26)
+        Objective Caml version 3.10.1+dev0 (2007-05-21)
 
 #   * * *       #   type 'a t = { t : 'a; }
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
@@ -343,11 +343,11 @@ val f : unit -> < m : int; n : int > = <fun>
 # Characters 11-56:
 This object is expected to have type c but has actually type
   < m : int; n : 'a >
-Only the second object type has a method n
+The first object type has no method n
 # Characters 11-69:
 This object is expected to have type < n : int > but has actually type
   < m : 'a >
-Only the first object type has a method n
+The second object type has no method n
 #         Characters 66-124:
 This object is expected to have type < x : int; .. > but has actually type
   < x : int >
@@ -416,7 +416,6 @@ is not included in
 # - : u -> v = <fun>
 # Characters 9-21:
 Type v = [> `A | `B ] is not a subtype of type u = [< `A | `B ] 
-These two variant types have no intersection
 # type v = private [< t ]
 # Characters 9-21:
 Type u = [< `A | `B ] is not a subtype of type v = [< `A | `B ] 
@@ -437,7 +436,7 @@ is not a subtype of type < m : 'a. (< p : < a : int >; .. > as 'a) -> int >
 # Characters 11-55:
 Type < p : < a : int; b : int >; .. > is not a subtype of type
   < p : < a : int >; .. > 
-Only the first object type has a method b
+The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
   < m : 'a. [< `A of <  > ] as 'a > = <fun>
@@ -450,4 +449,4 @@ Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of type
 # val f : c -> 'a -> 'a = <fun>
 #     val g : c -> 'a -> 'a = <fun>
 #     val h : < id : 'a; .. > -> 'a = <fun>
-# 
+#     * * * * * * * * * * * * * * * * * * *   
diff --git a/testlabl/varunion.ml b/testlabl/varunion.ml
index b91bab137c..30a410f22a 100644
--- a/testlabl/varunion.ml
+++ b/testlabl/varunion.ml
@@ -25,37 +25,45 @@ module Mix(X: sig type t = private [> `A of int ] end)
     (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
   struct type t = [X.t | Y.t] end;;
 
-(* ok *)
-module Mix(X: sig type t = private [> `A of int ] ~ [`B of bool] end)
-    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] end;;
+type 'a t = private [> `L of 'a] ~ [`L];;
 
 (* ok *)
-module Mix(X: sig type t = private [> `A of int ] ~ [~`B] end)
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
     (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
   struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
 
-module Mix(X: sig type t = private [> `A of int ] ~ [~`B] end)
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
     (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
   struct
     type t = [X.t | Y.t]
     let which = function #X.t -> `X | #Y.t -> `Y
   end;;
 
+module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
+    (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
+    (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
+  struct
+    type t = [X.t | Y.t]
+    let which = function #X.t -> `X | #Y.t -> `Y
+  end;;
+
 (* ok *)
 module M =
-  Mix(struct type t = [`A of int | `C of char] end)
+  Mix(struct type t = [`C of char] end)
+    (struct type t = [`A of int | `C of char] end)
     (struct type t = [`B of bool | `C of char] end);;
 
 (* bad *)
 module M =
-  Mix(struct type t = [`A of int | `B of bool] end)
+  Mix(struct type t = [`B of bool] end)
+    (struct type t = [`A of int | `B of bool] end)
     (struct type t = [`B of bool | `C of char] end);;
 
 (* ok *)
 module M1 = struct type t = [`A of int | `C of char] end
 module M2 = struct type t = [`B of bool | `C of char] end
-module M = Mix(M1)(M2) ;;
+module I = struct type t = [`C of char] end
+module M = Mix(I)(M1)(M2) ;;
 
 let c = (`C 'c' : M.t) ;;
 
@@ -66,7 +74,7 @@ module M(X : sig type t = private [> `A] end) =
 type t = private [> `A ] ~ [`B];;
 match `B with #t -> 1 | `B -> 2;;
 
-module M : sig type t = private [> `A of int | `B] ~ [~`C] end =
+module M : sig type t = private [> `A of int | `B] ~ [`C] end =
   struct type t = [`A of int | `B | `D of bool] end;;
 let f = function (`C | #M.t) -> 1+1 ;;
 let f = function (`A _ | `B #M.t) -> 1+1 ;;
@@ -103,29 +111,9 @@ module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
 module M = Mix(EStr)(EInt);;
 
 (* deep *)
-module M : sig type t = private [> ] ~ [`A] end = struct type t = [`A] end
+module M : sig type t = private [> `A] end = struct type t = [`A] end
 module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
 
-(* parameters *)
-module type T = sig
-  type t = private [> ] ~ [ `A of int ]
-  type ('a,'b) u = private [> ] ~ [ `A of 'a; `A of 'b; `B of 'b ]
-  type v = private [> ] ~ [ `A of int; `A of bool ]
-end
-module F(X:T) = struct
-  let h = function
-      `A _ -> true
-    | #X.t -> false
-  let f = function
-      `A _ | `B _ -> true
-    | #X.u -> false
-  let g = function
-      `A _ -> true
-    | #X.v -> false
-end
-
-(* ... *)
-
 (* bad *)
 type t = private [> ]
 type u = private [> `A of int] ~ [t] ;;
@@ -135,9 +123,9 @@ type t = private [> `A of int]
 type u = private [> `A of int] ~ [t] ;;
 
 module F(X: sig
-  type t = private [> ] ~ [~`A;~`B;~`C;~`D]
+  type t = private [> ] ~ [`A;`B;`C;`D]
   type u = private [> `A|`B|`C] ~ [t; `D]
-end) : sig type v = private [> ] ~ [X.t; X.u] end = struct
+end) : sig type v = private [< X.t | X.u | `D] end = struct
   open X
   let f = function #u -> 1 | #t -> 2 | `D -> 3
   let g = function #u|#t|`D -> 2 
@@ -153,7 +141,7 @@ module type T = sig type t = private [> ] ~ [`A] end;;
 module type T' = T with type t = private [> `A];;
 
 (* ok *)
-type t = private [> ] ~ [`A of int]
+type t = private [> ] ~ [`A]
 let f = function `A x -> x | #t -> 0
 type t' = private [< `A of int | t];;
 
@@ -177,6 +165,15 @@ let f = function #t -> 1 | _ -> 2;;
 module N : sig type t = private [> ] end =
   struct type t = [F(String).t | M.u] end;;
 
+(* compatibility improvement *)
+type a = [`A of int | `B]
+type b = [`A of bool | `B]
+type c = private [> ] ~ [a;b]
+let f = function #c -> 1 | `A x -> truncate x
+type d = private [> ] ~ [a]
+let g = function #d -> 1 | `A x -> truncate x;;
+
+
 (* Expression Problem: functorial form *)
 
 type num = [ `Num of int ]
@@ -223,7 +220,7 @@ end
 module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
   module type S =
     sig
-      type t = private [> ] ~ [ ~ X.t ]
+      type t = private [> ] ~ [ X.t ]
       val eval : t -> Y.t
       val show : t -> string
     end
@@ -270,9 +267,19 @@ module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
   end
 
 (* Do functor applications in Mix *)
-module type T = sig type t = private [> num] end
+module type T = sig type t = private [> ] end
+module type Tnum = sig type t = private [> num] end
 
-module Ext(E : T)(X : sig type t = private [> ] end) = struct
+module Ext(E : Tnum) = struct
+  module type S = functor (Y : Exp with type t = E.t) ->
+    sig
+      type t = private [> num]
+      val eval : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Ext'(E : Tnum)(X : T) = struct
   module type S = functor (Y : Exp with type t = E.t) ->
     sig
       type t = private [> ] ~ [ X.t ]
@@ -281,7 +288,7 @@ module Ext(E : T)(X : sig type t = private [> ] end) = struct
     end
 end
 
-module Mix(E : Exp)(F1 : Ext(E)(E).S)(F2 : Ext(E)(F1(E)).S) =
+module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
   struct
     module E1 = F1(E)
     module E2 = F2(E)
@@ -294,7 +301,7 @@ module Mix(E : Exp)(F1 : Ext(E)(E).S)(F2 : Ext(E)(F1(E)).S) =
       | #E2.t as x -> E2.show x
   end
 
-module Join(E : Exp)(F1 : Ext(E)(E).S)(F2 : Ext(E)(F1(E)).S)
+module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
     (E' : Exp with type t = E.t) =
   Mix(E)(F1)(F2)
 
@@ -308,15 +315,15 @@ module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
   Mix(E)(Join(E)(Num)(Add))(Mul)
 
 (* Linear extension by the end: not so nice *)
-module LExt(X : sig type t = private [> ] end) = struct
+module LExt(X : T) = struct
   module type S =
     sig
-      type t = private [> ] ~ [X.t]
+      type t
       val eval : t -> X.t
       val show : t -> string
     end
 end
-module LNum(E: Exp)(X : LExt(E).S) =
+module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
   struct
     type t = [num | X.t]
     let show = function
@@ -327,29 +334,29 @@ module LNum(E: Exp)(X : LExt(E).S) =
       | #X.t as x -> X.eval x
   end
 module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
-    (X : LExt(E).S) =
-  LNum(E)
-    (struct
-      type t = [E.t add | X.t]
-      let show = function
-          `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
-        | #X.t as x -> X.show x
-      let eval = function
-          `Add(e1,e2) ->
-            let e1 = E.eval e1 and e2 = E.eval e2 in
-            begin match e1, e2 with
-              `Num n1, `Num n2 -> `Num (n1+n2)
-            | `Num 0, e | e, `Num 0 -> e
-            | e12 -> `Add e12
-            end
-        | #X.t as x -> X.eval x
-    end)
+    (X : LExt(E).S with type t = private [> ] ~ [add]) =
+  struct
+    type t = [E.t add | X.t]
+    let show = function
+        `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
+      | #X.t as x -> X.show x
+    let eval = function
+        `Add(e1,e2) ->
+          let e1 = E.eval e1 and e2 = E.eval e2 in
+          begin match e1, e2 with
+            `Num n1, `Num n2 -> `Num (n1+n2)
+          | `Num 0, e | e, `Num 0 -> e
+          | e12 -> `Add e12
+          end
+      | #X.t as x -> X.eval x
+  end
 module LEnd = struct
   type t = [`Dummy]
   let show `Dummy = ""
   let eval `Dummy = `Dummy
 end
-module rec L : Exp with type t = [num | L.t add | `Dummy] = LAdd(L)(LEnd)
+module rec L : Exp with type t = [num | L.t add | `Dummy] =
+    LAdd(L)(LNum(L)(LEnd))
 
 (* Back to first form, but add map *)
 
@@ -393,7 +400,7 @@ module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
     end
 end
 
-module Mix(E : Exp)(E1 : Ext(E)(E).S)(E2 : Ext(E1)(E).S) =
+module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
   struct
     type t = [E1.t | E2.t]
     let map f = function
diff --git a/tools/depend.ml b/tools/depend.ml
index a1a95c63d9..e5a20d248c 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -281,8 +281,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 1839c52c61..d20657d87e 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`
 
 # Worked in 10.2:
 
@@ -101,8 +101,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 X11 and the
-XCode tools (v2.4) installed.
+You need Mac OS X 10.5.x (Leopard), with X11 and the
+XCode tools (v3.x) installed.
 
 Files will be installed in the following directories:
 
@@ -112,7 +112,7 @@ Files will be installed in the following directories:
 EOF
 
 chmod -R g-w root
-sudo chown -R root:admin root
+sudo chown -R root:wheel root
 
 /Developer/Applications/Utilities/PackageMaker.app/Contents/MacOS/PackageMaker \
   -build -p "`pwd`/ocaml.pkg" -f "`pwd`/root" -i "`pwd`/Info.plist" \
@@ -123,18 +123,20 @@ size=`expr $size + 8192`
 
 hdiutil create -sectors $size ocaml-rw.dmg
 name=`hdid -nomount ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
-newfs_hfs -v 'Objective Caml' $name
+volname="Objective Caml ${VERSION}"
+newfs_hfs -v "$volname" $name
 hdiutil detach $name
 
 name=`hdid ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
-if test -d '/Volumes/Objective Caml'; then
-  ditto -rsrcFork ocaml.pkg "/Volumes/Objective Caml/ocaml.pkg"
-  cp resources/ReadMe.txt "/Volumes/Objective Caml/"
+if test -d "/Volumes/$volname"; then
+  ditto -rsrcFork ocaml.pkg "/Volumes/$volname/ocaml.pkg"
+  cp resources/ReadMe.txt "/Volumes/$volname/"
 else
-  echo 'Unable to mount the disk image as "/Volumes/Objective Caml"' >&2
+  echo "Unable to mount the disk image as \"/Volumes/$volname\"" >&2
   exit 3
 fi
-open "/Volumes/Objective Caml"
+open "/Volumes/$volname"
+sleep 2
 hdiutil detach $name
 
 rm -rf "ocaml-${VERSION}.dmg"
diff --git a/typing/btype.ml b/typing/btype.ml
index baa1f00158..1151d9d276 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 =
@@ -204,7 +203,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
@@ -213,10 +211,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
@@ -224,7 +218,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 b566d130d3..2f3c59b9e0 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -338,17 +338,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
     [] -> []
@@ -380,7 +384,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
@@ -417,7 +421,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
@@ -1445,7 +1449,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 =
@@ -1987,6 +1990,10 @@ let moregen_occur env level ty =
   occur_univar env ty;
   update_level env level ty
 
+let may_instantiate inst_nongen t1 =
+  if inst_nongen then t1.level <> generic_level - 1
+                 else t1.level =  generic_level
+
 let rec moregen inst_nongen type_pairs env t1 t2 =
   if t1 == t2 then () else
   let t1 = repr t1 in
@@ -1997,8 +2004,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
     match (t1.desc, t2.desc) with
       (Tunivar, Tunivar) ->
         unify_univar t1 t2 !univar_pairs
-    | (Tvar, _) when if inst_nongen then t1.level <> generic_level - 1
-                                    else t1.level =  generic_level ->
+    | (Tvar, _) when may_instantiate inst_nongen t1 ->
         moregen_occur env t1.level t2;
         occur env t1 t2;
         link_type t1 t2
@@ -2015,8 +2021,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
         with Not_found ->
           TypePairs.add type_pairs (t1', t2') ();
           match (t1'.desc, t2'.desc) with
-            (Tvar, _) when if inst_nongen then t1'.level <> generic_level - 1
-                                          else t1'.level =  generic_level ->
+            (Tvar, _) when may_instantiate inst_nongen t1 ->
               moregen_occur env t1'.level t2;
               link_type t1' t2
 	  | (Text e1, Text e2) ->
@@ -2080,33 +2085,36 @@ and moregen_kind k1 k2 =
 
 and moregen_row inst_nongen type_pairs env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
+  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
+  if rm1 == rm2 then () else
+  let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   let r1, r2 =
     if row2.row_closed then
-      filter_row_fields true r1, filter_row_fields false r2
+      filter_row_fields may_inst r1, filter_row_fields false r2
     else r1, r2
   in
   if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
   then raise (Unify []);
-  let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
-  let univ =
-    match rm1.desc, rm2.desc with
-      Tunivar, Tunivar ->
-        unify_univar rm1 rm2 !univar_pairs;
-        true
-    | Tunivar, _ | _, Tunivar ->
-        raise (Unify [])
-    | _ ->
-        if not (static_row row2) then moregen_occur env rm1.level rm2;
-        let ext =
-          if r2 = [] then rm2 else
-          let row_ext = {row2 with row_fields = r2} in
-          iter_row (moregen_occur env rm1.level) row_ext;
-          newty2 rm1.level (Tvariant row_ext)
-        in
-        if ext != rm1 then link_type rm1 ext;
-        false
-  in
+  begin match rm1.desc, rm2.desc with
+    Tunivar, Tunivar ->
+      unify_univar rm1 rm2 !univar_pairs
+  | Tunivar, _ | _, Tunivar ->
+      raise (Unify [])
+  | _ when static_row row1 -> ()
+  | _ when may_inst ->
+      if not (static_row row2) then moregen_occur env rm1.level rm2;
+      let ext =
+        if r2 = [] then rm2 else
+        let row_ext = {row2 with row_fields = r2} in
+        iter_row (moregen_occur env rm1.level) row_ext;
+        newty2 rm1.level (Tvariant row_ext)
+      in
+      link_type rm1 ext
+  | Tconstr _, Tconstr _ ->
+      moregen inst_nongen type_pairs env rm1 rm2
+  | _ -> raise (Unify [])
+  end;
   List.iter
     (fun (l,f1,f2) ->
       let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
@@ -2115,7 +2123,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
         Rpresent(Some t1), Rpresent(Some t2) ->
           moregen inst_nongen type_pairs env t1 t2
       | Rpresent None, Rpresent None -> ()
-      | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ ->
+      | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst ->
           set_row_field e1 f2;
           List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
       | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
@@ -2131,9 +2139,9 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
             | [] ->
                 if tl1 <> [] then raise (Unify [])
           end
-      | Reither(true, [], _, e1), Rpresent None when not univ ->
+      | Reither(true, [], _, e1), Rpresent None when may_inst ->
           set_row_field e1 f2
-      | Reither(_, _, _, e1), Rabsent when not univ ->
+      | Reither(_, _, _, e1), Rabsent when may_inst ->
           set_row_field e1 f2
       | Rabsent, Rabsent -> ()
       | _ -> raise (Unify []))
@@ -2833,7 +2841,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
@@ -2845,18 +2852,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)
@@ -3176,13 +3183,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 3f75546ea6..610025e5d0 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 139daadc2d..8194897507 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 8c7b965814..307b7d3292 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 fd0e1024bf..ac9c58cdd3 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -248,7 +248,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 1fda8bac85..91ea13a3f0 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -128,8 +128,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 1b328ebbeb..e6436fa59e 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 947f4271a3..972333455d 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
@@ -1475,16 +1476,16 @@ let report_error ppf = function
         "This pattern cannot match self: it only matches values of type"
         Printtyp.type_expr ty
   | Unbound_class cl ->
-      fprintf ppf "Unbound class@ %a"
+      fprintf ppf "@[Unbound class@ %a@]"
       Printtyp.longident cl
   | Unbound_class_2 cl ->
-      fprintf ppf "The class@ %a@ is not yet completely defined"
+      fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
       Printtyp.longident cl
   | Unbound_class_type cl ->
-      fprintf ppf "Unbound class type@ %a"
+      fprintf ppf "@[Unbound class type@ %a@]"
       Printtyp.longident cl
   | Unbound_class_type_2 cl ->
-      fprintf ppf "The class type@ %a@ is not yet completely defined"
+      fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
       Printtyp.longident cl
   | Abbrev_type_clash (abbrev, actual, expected) ->
       (* XXX Afficher une trace ? *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index c1e74b7d20..56c7b24645 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 =
@@ -196,7 +199,7 @@ let reset_pattern () =
 
 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) :: !pattern_variables;
   id
@@ -251,7 +254,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
@@ -261,7 +264,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
@@ -271,20 +277,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 =
@@ -294,14 +296,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) ->
@@ -310,21 +310,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
@@ -333,7 +333,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 }
@@ -425,13 +425,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 }
@@ -585,8 +585,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 *)
@@ -615,6 +618,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 *)
@@ -1012,7 +1016,7 @@ and real_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});
@@ -2061,8 +2065,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 ac8b5ebb6a..12433193c1 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -68,7 +68,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 53180a8065..ce217eee46 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 ce3925be84..3cec8c3224 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 1ac399a2ba..3b9ceb69f3 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -413,11 +413,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)
 
 let transl_signature env sg =
   Ctype.extmode := false;
@@ -499,6 +507,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 =
@@ -636,27 +717,21 @@ and type_structure anchor env sstr =
         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 2f1729d6cb..112e4b51fa 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -52,7 +52,7 @@ and ext_atom =
 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 39e360fa09..a136da2a4c 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -51,7 +51,7 @@ and ext_atom =
 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 23fc13241f..ae97abaaad 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) ->
@@ -387,8 +388,12 @@ and transl_fields env policy =
   function
     [] ->
       newty Tnil
-  | {pfield_desc = Pfield_var}::_ ->
-      if policy = Univars then new_pre_univar () else newvar ()
+  | ({pfield_desc = Pfield_var} as pf)::_ ->
+      begin match policy with
+        Fixed -> raise (Error (pf.pfield_loc, Unbound_type_variable ".."))
+      | Extensible -> newvar ()
+      | Univars -> new_pre_univar ()
+      end
   | {pfield_desc = Pfield(s, e)}::l ->
       let ty1 = transl_type env policy e in
       let ty2 = transl_fields env policy l in
diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index c44bb64c3f..ec90acecfc 100644
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -46,6 +46,10 @@ let quote_files lst =
   then build_diversion lst
   else s
 
+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 22bc2e8d69..afdee3a42b 100644
--- a/utils/ccomp.mli
+++ b/utils/ccomp.mli
@@ -20,5 +20,6 @@ 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
 val merge_manifest: string -> int