merge branch 4.02 from release 4.02.0 to release 4.02.1

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

.depend

@@ -537,20 +537,20 @@ bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \
     typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \
     bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi
-bytecomp/translcore.cmo : utils/warnings.cmi typing/types.cmi \
+bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \
-    bytecomp/typeopt.cmi typing/typedtree.cmi bytecomp/translobj.cmi \
+    typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \
-    typing/primitive.cmi typing/predef.cmi typing/path.cmi \
+    typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \
-    typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \
+    bytecomp/matching.cmi parsing/longident.cmi parsing/location.cmi \
-    parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
-    typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
-    typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi
+    bytecomp/translcore.cmi
-bytecomp/translcore.cmx : utils/warnings.cmx typing/types.cmx \
+bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \
-    bytecomp/typeopt.cmx typing/typedtree.cmx bytecomp/translobj.cmx \
+    typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \
-    typing/primitive.cmx typing/predef.cmx typing/path.cmx \
+    typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \
-    typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \
+    bytecomp/matching.cmx parsing/longident.cmx parsing/location.cmx \
-    parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
+    bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
-    typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
-    typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
+    bytecomp/translcore.cmi
 bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \
     bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \

Changes

@@ -22,22 +22,76 @@ Type system:
   This is done by adding equations to submodules when expanding aliases.
   In theory this may be incompatible is some corner cases defining a module
   type through inference, but no breakage known on published code.
-- PR#6593: Functor application in tests/basic-modules fails after commit 15405  
+- PR#6593: Functor application in tests/basic-modules fails after commit 15405
 
 OCaml 4.02.1:
 -------------
 
-- PR#4099: Bug in Makefile.nt: won't stop on error (George Necula)
+(Changes that can break existing programs are marked with a "*")
-- PR#6181: Improve MSVC build (Chen Gang)
+
+Standard library:
+* Add optional argument ?limit to Arg.align.
+
+- PR#4099: Bug in Makefile.nt: won't stop on error
+  (George Necula)
+- PR#6181: Improve MSVC build
+  (Chen Gang)
+- PR#6207: Configure doesn't detect features correctly on Haiku
+  (Jessica Hamilton)
 - PR#6466: Non-exhaustive matching warning message for open types is confusing
+  (Peter Zotov)
 - PR#6529: fix quadratic-time algorithm in Consistbl.extract.
-  (Xavier Leroy)
+  (Xavier Leroy, Alain Frisch, relase-worthy report by Jacques-Pascal Deplaix)
-- PR#6554: fix race condition when retrieving backtraces (Jérémie Dimino,
+- PR#6530: Add stack overflow handling for native code (OpenBSD i386 and amd64)
-  Mark Shinwell).
+  (Cristopher Zimmermann)
+- PR#6533: broken semantics of %(%) when substitued by a box
+  (Benoît Vaugon, report by Boris Yakobowski)
+- PR#6534: legacy support for %.10s
+  (Benoît Vaugon, Gabriel Scherer, report by Nick Chapman)
+- PR#6536: better documentation of flag # in format strings
+  (Damien Doligez, report by Nick Chapman)
+- PR#6544: Bytes and CamlinternalFormat missing from threads stdlib.cma
+  (Christopher Zimmermann)
+- PR#6546: -dsource omits parens for `List ((`String "A")::[]) in patterns
+  (Gabriel Scherer, report by Peter Zotov)
+- PR#6547: __MODULE__ aborts the compiler if the module name cannot be inferred
+  (Jacques Garrigue, report by Kaustuv Chaudhuri)
+- PR#6549: Debug section is sometimes not readable when using -pack
+  (Hugo Heuzard, review by Gabriel Scherer)
+- PR#6553: Missing command line options for ocamldoc
+  (Maxence Guesdon)
+- PR#6554: fix race condition when retrieving backtraces
+  (Jérémie Dimino, Mark Shinwell).
+- PR#6557: String.sub throws Invalid_argument("Bytes.sub")
+  (Damien Doligez, report by Oliver Bandel)
+- PR#6562: Fix ocamldebug module source lookup
+  (Leo White)
+- PR#6563: Inclusion of packs failing to run module initializers
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6564: infinite loop in Mtype.remove_aliases
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6565: compilation fails with Env.Error(_)
+  (Jacques Garrigue and Mark Shinwell)
+- PR#6566: -short-paths and signature inclusion errors
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6572: Fatal error with recursive modules
+  (Jacques Garrigue, report by Quentin Stievenart)
+- PR#6578: Recursive module containing alias causes Segmentation fault
+  (Jacques Garrigue)
+- PR#6581: Some bugs in generative functors
+  (Jacques Garrigue, report by Mark Shinwell)
+- PR#6584: ocamldep support for "-open M"
+  (Gabriel Scherer, review by Damien Doligez, report by Hezekiah M. Carty)
 - PR#6588: Code generation errors for ARM
   (Mark Shinwell, Xavier Leroy)
 - PR#6590: Improve Windows (MSVC and mingw) build
   (Chen Gang)
+- PR#6599: ocamlbuild: add -bin-annot when using -pack
+  (Christopher Zimmermann)
+- PR#6602: Fatal error when tracing a function with abstract type
+  (Jacques Garrigue, report by Hugo Herbelin)
+- ocamlbuild: add an -ocamlmklib option to change the ocamlmklib command
+  (Jérôme Vouillon)
 
 Ocaml 4.02.0:
 -------------
@@ -148,7 +202,7 @@ Runtime system:
 - Fixed bug in native code version of [caml_raise_with_string] that could
   potentially lead to heap corruption.
   (Mark Shinwell)
-- Blocks initialized by [CAMLlocal*] and [caml_alloc] are now filled with
+* Blocks initialized by [CAMLlocal*] and [caml_alloc] are now filled with
   [Val_unit] rather than zero.
   (Mark Shinwell)
 - Fixed a major performance problem on large heaps (~1GB) by making heap

Makefile

@@ -367,6 +367,13 @@ installoptopt:
 	cd $(INSTALL_COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \
 	   ocamloptcomp.a
 
+# Run all tests
+
+tests: opt.opt
+	cd testsuite; $(MAKE) clean && $(MAKE) all
+
+# The clean target
+
 clean:: partialclean
 
 # Shared parts of the system

VERSION

@@ -1,4 +1,4 @@
-4.03.0+dev4-2014-09-26
+4.03.0+dev5-2014-10-15
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

asmrun/signals_osdep.h

@@ -130,6 +130,22 @@
   #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
   #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
 
+/****************** AMD64, OpenBSD */
+
+#elif defined(TARGET_amd64) && defined (SYS_openbsd)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, struct sigcontext * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ #define CONTEXT_PC (context->sc_rip)
+ #define CONTEXT_EXCEPTION_POINTER (context->sc_r14)
+ #define CONTEXT_YOUNG_PTR (context->sc_r15)
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
 /****************** I386, Linux */
 
 #elif defined(TARGET_i386) && defined(SYS_linux_elf)
@@ -143,6 +159,20 @@
 
   #define CONTEXT_FAULTING_ADDRESS ((char *) context.cr2)
 
+/****************** I386, BSD_ELF */
+
+#elif defined(TARGET_i386) && defined(SYS_bsd_elf)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, struct sigcontext * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ #define CONTEXT_PC (context->sc_eip)
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
 /****************** I386, BSD */
 
 #elif defined(TARGET_i386) && defined(SYS_bsd)

bytecomp/bytegen.ml

@@ -445,7 +445,6 @@ let rec comp_expr env exp sz cont =
         let ofs = Ident.find_same id env.ce_rec in
         Koffsetclosure(ofs) :: cont
       with Not_found ->
-        Format.eprintf "%a@." Ident.print id;
         fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id)
       end
   | Lconst cst ->

bytecomp/bytepackager.ml

@@ -222,9 +222,10 @@ let package_object_files ppf files targetfile targetname coercion =
                                           targetname Subst.identity members in
     build_global_target oc targetname members mapping ofs coercion;
     let pos_debug = pos_out oc in
-    if !Clflags.debug && !events <> [] then
+    if !Clflags.debug && !events <> [] then begin
       output_value oc (List.rev !events);
       output_value oc (StringSet.elements !debug_dirs);
+    end;
     let pos_final = pos_out oc in
     let imports =
       List.filter

bytecomp/emitcode.ml

@@ -143,6 +143,7 @@ let record_event ev =
   let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in
   let abspath = Location.absolute_path path in
   debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs;
+  if Filename.is_relative path then debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs;
   ev.ev_pos <- !out_position;
   events := ev :: !events
 

bytecomp/lambda.ml

@@ -537,9 +537,12 @@ let lam_of_loc kind loc =
           Const_base (Const_int enum);
         ]))
   | Loc_FILE -> Lconst (Const_immstring file)
-  | Loc_MODULE -> Lconst (Const_immstring
+  | Loc_MODULE ->
-                      (String.capitalize
+    let filename = Filename.basename file in
-                         (Filename.chop_extension (Filename.basename file))))
+    let module_name =
+      try String.capitalize (Filename.chop_extension filename)
+      with Invalid_argument _ -> "//"^filename^"//"
+    in Lconst (Const_immstring module_name)
   | Loc_LOC ->
     let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
         file lnum cnum enum in

bytecomp/translcore.ml

@@ -669,7 +669,7 @@ and transl_exp0 e =
             transl_function e.exp_loc !Clflags.native_code repr partial pl)
       in
       Lfunction(kind, params, body)
-  | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})} as fn,
+  | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})},
                oargs)
     when List.length oargs >= p.prim_arity
     && List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
@@ -695,12 +695,6 @@ and transl_exp0 e =
           wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
         | _ -> assert false
       else begin
-        if p.prim_name = "%sequand" && Path.last path = "&" then
-          Location.prerr_warning fn.exp_loc
-            (Warnings.Deprecated "operator (&); you should use (&&) instead");
-        if p.prim_name = "%sequor" && Path.last path = "or" then
-          Location.prerr_warning fn.exp_loc
-            (Warnings.Deprecated "operator (or); you should use (||) instead");
         let prim = transl_prim e.exp_loc p args in
         match (prim, args) with
           (Praise k, [arg1]) ->

bytecomp/translmod.ml

@@ -83,21 +83,12 @@ let rec apply_coercion strict restr arg =
       arg
   | Tcoerce_structure(pos_cc_list, id_pos_list) ->
       name_lambda strict arg (fun id ->
+        let get_field pos = Lprim(Pfield pos,[Lvar id]) in
         let lam =
           Lprim(Pmakeblock(0, Immutable),
-                List.map (apply_coercion_field id) pos_cc_list) in
+                List.map (apply_coercion_field get_field) pos_cc_list)
-        let fv = free_variables lam in
-        let (lam,s) =
-          List.fold_left (fun (lam,s) (id',pos,c) ->
-            if IdentSet.mem id' fv then
-              let id'' = Ident.create (Ident.name id') in
-              (Llet(Alias,id'',
-                    apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam),
-               Ident.add id' (Lvar id'') s)
-            else (lam,s))
-            (lam, Ident.empty) id_pos_list
         in
-        if s == Ident.empty then lam else subst_lambda s lam)
+        wrap_id_pos_list id_pos_list get_field lam)
   | Tcoerce_functor(cc_arg, cc_res) ->
       let param = Ident.create "funarg" in
       name_lambda strict arg (fun id ->
@@ -111,8 +102,26 @@ let rec apply_coercion strict restr arg =
       name_lambda strict arg
         (fun id -> apply_coercion Alias cc (transl_normal_path path))
 
-and apply_coercion_field id (pos, cc) =
+and apply_coercion_field get_field (pos, cc) =
-  apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id]))
+  apply_coercion Alias cc (get_field pos)
+
+and wrap_id_pos_list id_pos_list get_field lam =
+  let fv = free_variables lam in
+  (*Format.eprintf "%a@." Printlambda.lambda lam;
+  IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
+  Format.eprintf "@.";*)
+  let (lam,s) =
+    List.fold_left (fun (lam,s) (id',pos,c) ->
+      if IdentSet.mem id' fv then
+        let id'' = Ident.create (Ident.name id') in
+        (Llet(Alias,id'',
+              apply_coercion Alias c (get_field pos),lam),
+         Ident.add id' (Lvar id'') s)
+      else (lam,s))
+      (lam, Ident.empty) id_pos_list
+  in
+  if s == Ident.empty then lam else subst_lambda s lam
+  
 
 (* Compose two coercions
    apply_coercion c1 (apply_coercion c2 e) behaves like
@@ -154,7 +163,7 @@ let compose_coercions c1 c2 =
   let c3 = compose_coercions c1 c2 in
   let open Includemod in
   Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@."
-    print_coercion c1 print_coercion c2 print_coercion c2;
+    print_coercion c1 print_coercion c2 print_coercion c3;
   c3
 *)
 
@@ -322,7 +331,7 @@ let rec transl_module cc rootpath mexp =
   | _ ->
   match mexp.mod_desc with
     Tmod_ident (path,_) ->
-      apply_coercion StrictOpt cc
+      apply_coercion Strict cc
         (transl_path ~loc:mexp.mod_loc mexp.mod_env path)
   | Tmod_structure str ->
       transl_struct [] cc rootpath str
@@ -362,18 +371,26 @@ and transl_structure fields cc rootpath = function
           Lprim(Pmakeblock(0, Immutable),
                 List.map (fun id -> Lvar id) (List.rev fields))
       | Tcoerce_structure(pos_cc_list, id_pos_list) ->
-              (* ignore id_pos_list as the ids are already bound *)
+              (* Do not ignore id_pos_list ! *)
+          (*Format.eprintf "%a@.@[" Includemod.print_coercion cc;
+          List.iter (fun l -> Format.eprintf "%a@ " Ident.print l)
+            fields;
+          Format.eprintf "@]@.";*)
           let v = Array.of_list (List.rev fields) in
-          (*List.fold_left
+          let get_field pos = Lvar v.(pos)
-            (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*)
+          and ids = List.fold_right IdentSet.add fields IdentSet.empty in
+          let lam =
             (Lprim(Pmakeblock(0, Immutable),
                 List.map
                   (fun (pos, cc) ->
                     match cc with
                       Tcoerce_primitive p -> transl_primitive Location.none p
-                    | _ -> apply_coercion Strict cc (Lvar v.(pos)))
+                    | _ -> apply_coercion Strict cc (get_field pos))
                   pos_cc_list))
-            (*id_pos_list*)
+          and id_pos_list =
+            List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) id_pos_list
+          in
+          wrap_id_pos_list id_pos_list get_field lam
       | _ ->
           fatal_error "Translmod.transl_structure"
       end

config/s-nt.h

@@ -30,3 +30,4 @@
 #define HAS_LOCALE
 #define HAS_BROKEN_PRINTF
 #define HAS_IPV6
+#define HAS_NICE

config/s-templ.h

@@ -212,3 +212,7 @@
    The value of this symbol is the number of arguments of
    gethostbyaddr_r(): either 7 or 8 depending on prototype.
    (7 is the Solaris version, 8 is the Linux version). */
+
+#define HAS_NICE
+
+/* Define HAS_NICE if you have nice(). */

configure

@@ -333,6 +333,10 @@ case "$bytecc,$target" in
     echo "#ifndef __PIC__" >> m.h
     echo "#  define ARCH_CODE32" >> m.h
     echo "#endif" >> m.h;;
+  *,*-*-haiku*)
+    bytecccompopts="-fno-defer-pop $gcc_warnings"
+    # No -lm library
+    mathlib="";;
   *,*-*-beos*)
     bytecccompopts="-fno-defer-pop $gcc_warnings"
     # No -lm library
@@ -635,7 +639,7 @@ if test $with_sharedlibs = "yes"; then
       mksharedlib="$flexlink"
       mkmaindll="$flexlink -maindll"
       shared_libraries_supported=true;;
-    *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*)
+    *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*|*-*-haiku*)
       sharedcccompopts="-fPIC"
       mksharedlib="$bytecc -shared"
       bytecclinkopts="$bytecclinkopts -Wl,-E"
@@ -747,6 +751,7 @@ if test $with_sharedlibs = "yes"; then
     i[3456]86-*-netbsd*)          natdynlink=true;;
     x86_64-*-netbsd*)             natdynlink=true;;
     i386-*-gnu0.3)                natdynlink=true;;
+    i[3456]86-*-haiku*)           natdynlink=true;;
     arm*-*-linux*)                natdynlink=true;;
     arm*-*-freebsd*)              natdynlink=true;;
     aarch64-*-linux*)             natdynlink=true;;
@@ -779,6 +784,7 @@ case "$target" in
                                 else
                                   arch=i386; system=solaris
                                 fi;;
+  i[3456]86-*-haiku*)           arch=i386; system=beos;;
   i[3456]86-*-beos*)            arch=i386; system=beos;;
   i[3456]86-*-cygwin*)          arch=i386; system=cygwin;;
   i[3456]86-*-darwin*)          if $arch64; then
@@ -1026,11 +1032,17 @@ if sh ./hasgot socket socketpair bind listen accept connect; then
   inf "You have BSD sockets."
   echo "#define HAS_SOCKETS" >> s.h
   has_sockets=yes
-elif sh ./hasgot -lnsl -lsocket socket socketpair bind listen accept connect; then
+elif sh ./hasgot -lnsl -lsocket socket socketpair bind listen accept connect
+then
   inf "You have BSD sockets (with libraries '-lnsl -lsocket')"
   cclibs="$cclibs -lnsl -lsocket"
   echo "#define HAS_SOCKETS" >> s.h
   has_sockets=yes
+elif sh ./hasgot -lnetwork socket socketpair bind listen accept connect; then
+  echo "You have BSD sockets (with library '-lnetwork')"
+  cclibs="$cclibs -lnetwork"
+  echo "#define HAS_SOCKETS" >> s.h
+  has_sockets=yes
 else
   case "$target" in
     *-*-mingw*)
@@ -1294,6 +1306,11 @@ if sh ./hasgot mkstemp; then
   echo "#define HAS_MKSTEMP" >> s.h
 fi
 
+if sh ./hasgot nice; then
+  inf "nice() found"
+  echo "#define HAS_NICE" >> s.h
+fi
+
 # Determine if the debugger is supported
 
 if test -n "$with_debugger"; then
@@ -1309,7 +1326,8 @@ fi
 # Determine if system stack overflows can be detected
 
 case "$arch,$system" in
-  i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx)
+  i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx \
+  |amd64,openbsd|i386,bsd_elf)
     inf "System stack overflow can be detected."
     echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;;
   *)
@@ -1345,6 +1363,8 @@ if test "$pthread_wanted" = "yes"; then
                    pthread_caml_link="-cclib -pthread";;
     *-*-openbsd*)  pthread_link="-pthread"
                    pthread_caml_link="-cclib -pthread";;
+    *-*-haiku*)    pthread_link=""
+                   pthread_caml_link="";;
     *)             pthread_link="-lpthread"
                    pthread_caml_link="-cclib -lpthread";;
   esac
@@ -1375,7 +1395,8 @@ if test "$pthread_wanted" = "yes"; then
 else
   pthread_link=""
 fi
-echo "PTHREAD_LINK=$pthread_caml_link" >> Makefile
+echo "PTHREAD_LINK=$pthread_link" >> Makefile
+echo "PTHREAD_CAML_LINK=$pthread_caml_link" >> Makefile
 
 # Determine if the bytecode thread library is supported
 

debugger/source.ml

@@ -50,10 +50,10 @@ let source_of_module pos mdle =
           try find_in_path_uncap path (innermost_module ^ ext)
           with Not_found -> loop exts
     in loop source_extensions
-  else   if Filename.is_implicit fname then
+  else if Filename.is_relative fname then
-    find_in_path path fname
+    find_in_path_rel path fname
-  else
+  else if Sys.file_exists fname then fname
-    fname
+  else raise Not_found
 
 (*** Buffer cache ***)
 

driver/main_args.ml

@@ -501,7 +501,7 @@ module type Common_options = sig
   val anonymous : string -> unit
 end;;
 
-module type Compiler_options =  sig
+module type Compiler_options = sig
   val _a : unit -> unit
   val _annot : unit -> unit
   val _binannot : unit -> unit
@@ -608,6 +608,22 @@ module type Opttop_options = sig
   val _stdin : unit -> unit
 end;;
 
+module type Ocamldoc_options = sig
+  include Common_options
+  val _impl : string -> unit
+  val _intf : string -> unit
+  val _intf_suffix : string -> unit
+  val _pp : string -> unit
+  val _principal : unit -> unit
+  val _rectypes : unit -> unit
+  val _safe_string : unit -> unit
+  val _short_paths : unit -> unit
+  val _thread : unit -> unit
+  val _v : unit -> unit
+  val _verbose : unit -> unit
+  val _vmthread : unit -> unit
+end;;
+
 module type Arg_list = sig
     val list : (string * Arg.spec * string) list
 end;;
@@ -874,3 +890,40 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_dstartup F._dstartup;
   ]
 end;;
+
+module Make_ocamldoc_options (F : Ocamldoc_options) =
+struct
+  let list = [
+    mk_absname F._absname;
+    mk_I F._I;
+    mk_impl F._impl;
+    mk_intf F._intf;
+    mk_intf_suffix F._intf_suffix;
+    mk_intf_suffix_2 F._intf_suffix;
+    mk_labels F._labels;
+    mk_modern F._labels;
+    mk_no_alias_deps F._no_alias_deps;
+    mk_no_app_funct F._no_app_funct;
+    mk_noassert F._noassert;
+    mk_nolabels F._nolabels;
+    mk_nostdlib F._nostdlib;
+    mk_open F._open;
+    mk_pp F._pp;
+    mk_ppx F._ppx;
+    mk_principal F._principal;
+    mk_rectypes F._rectypes;
+    mk_safe_string F._safe_string;
+    mk_short_paths F._short_paths;
+    mk_strict_sequence F._strict_sequence;
+    mk_strict_formats F._strict_formats;
+    mk_thread F._thread;
+    mk_unsafe_string F._unsafe_string;
+    mk_v F._v;
+    mk_verbose F._verbose;
+    mk_version F._version;
+    mk_vmthread F._vmthread;
+    mk_vnum F._vnum;
+    mk_w F._w;
+    mk__ F.anonymous;
+  ]
+end;;

driver/main_args.mli

@@ -10,6 +10,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* ATTENTION ! When you add or modify a parsing or typing option, do not forget
+  to update ocamldoc options too, in odoc_args.ml. *)
+
 module type Common_options = sig
   val _absname : unit -> unit
   val _I : string -> unit
@@ -152,6 +155,22 @@ module type Opttop_options = sig
   val _stdin : unit -> unit
 end;;
 
+module type Ocamldoc_options =  sig
+  include Common_options
+  val _impl : string -> unit
+  val _intf : string -> unit
+  val _intf_suffix : string -> unit
+  val _pp : string -> unit
+  val _principal : unit -> unit
+  val _rectypes : unit -> unit
+  val _safe_string : unit -> unit
+  val _short_paths : unit -> unit
+  val _thread : unit -> unit
+  val _v : unit -> unit
+  val _verbose : unit -> unit
+  val _vmthread : unit -> unit
+end
+
 module type Arg_list = sig
     val list : (string * Arg.spec * string) list
 end;;
@@ -160,3 +179,4 @@ module Make_bytecomp_options (F : Bytecomp_options) : Arg_list;;
 module Make_bytetop_options (F : Bytetop_options) : Arg_list;;
 module Make_optcomp_options (F : Optcomp_options) : Arg_list;;
 module Make_opttop_options (F : Opttop_options) : Arg_list;;
+module Make_ocamldoc_options (F : Ocamldoc_options) : Arg_list;;

emacs/caml-types.el

@@ -113,9 +113,9 @@ type call ident"
 (make-variable-buffer-local 'caml-types-annotation-date)
 
 (defvar caml-types-buffer-name "*caml-types*"
-  "Name of buffer for diplaying caml types")
+  "Name of buffer for displaying caml types")
 (defvar caml-types-buffer nil
-  "buffer for diplaying caml types")
+  "buffer for displaying caml types")
 
 (defun caml-types-show-type (arg)
   "Show the type of expression or pattern at point.

ocamlbuild/ocaml_specific.ml

@@ -670,7 +670,9 @@ flag ["ocaml"; "link"; "native"; "output_obj"] (A"-output-obj");;
 flag ["ocaml"; "link"; "byte"; "output_obj"] (A"-output-obj");;
 flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");;
 flag ["ocaml"; "annot"; "compile"] (A "-annot");;
+flag ["ocaml"; "annot"; "pack"] (A "-annot");;
 flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot");;
+flag ["ocaml"; "bin_annot"; "pack"] (A "-bin-annot");;
 flag ["ocaml"; "safe_string"; "compile"] (A "-safe-string");;
 flag ["ocaml"; "safe_string"; "infer_interface"] (A "-safe-string");;
 flag ["ocaml"; "unsafe_string"; "compile"] (A "-unsafe-string");;

ocamlbuild/options.ml

@@ -238,8 +238,7 @@ let spec = ref (
    "-ocamlyacc", set_cmd ocamlyacc, "<command> Set the ocamlyacc tool";
    "-menhir", set_cmd ocamlyacc, "<command> Set the menhir tool (use it after -use-menhir)";
    "-ocamllex", set_cmd ocamllex, "<command> Set the ocamllex tool";
-   (* Not set since we perhaps want to replace ocamlmklib *)
+   "-ocamlmklib", set_cmd ocamlmklib, "<command> Set the ocamlmklib tool";
-   (* "-ocamlmklib", set_cmd ocamlmklib, "<command> Set the ocamlmklib tool"; *)
    "-ocamlmktop", set_cmd ocamlmktop, "<command> Set the ocamlmktop tool";
    "-ocamlrun", set_cmd ocamlrun, "<command> Set the ocamlrun tool";
 
@@ -316,6 +315,7 @@ let init () =
       "ocamlopt", ocamlopt;
       "ocamldep", ocamldep;
       "ocamldoc", ocamldoc;
+      "ocamlmklib", ocamlmklib;
       "ocamlmktop", ocamlmktop;
     ]
   end;

ocamldoc/.depend

@@ -22,12 +22,18 @@ odoc_analyse.cmx : ../utils/warnings.cmx ../typing/types.cmx \
     odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../utils/misc.cmx \
     ../parsing/location.cmx ../typing/env.cmx ../utils/config.cmx \
     ../utils/clflags.cmx odoc_analyse.cmi
-odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \
+odoc_args.cmo : ../utils/warnings.cmi odoc_types.cmi odoc_texi.cmo \
-    odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \
+    odoc_messages.cmo odoc_man.cmo odoc_latex.cmo odoc_html.cmo \
-    odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi
+    odoc_global.cmi odoc_gen.cmi odoc_dot.cmo odoc_config.cmi \
-odoc_args.cmx : odoc_types.cmx odoc_texi.cmx odoc_messages.cmx odoc_man.cmx \
+    ../utils/misc.cmi ../driver/main_args.cmi ../parsing/location.cmi \
-    odoc_latex.cmx odoc_html.cmx odoc_global.cmx odoc_gen.cmx odoc_dot.cmx \
+    ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi \
-    odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx odoc_args.cmi
+    odoc_args.cmi
+odoc_args.cmx : ../utils/warnings.cmx odoc_types.cmx odoc_texi.cmx \
+    odoc_messages.cmx odoc_man.cmx odoc_latex.cmx odoc_html.cmx \
+    odoc_global.cmx odoc_gen.cmx odoc_dot.cmx odoc_config.cmx \
+    ../utils/misc.cmx ../driver/main_args.cmx ../parsing/location.cmx \
+    ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx \
+    odoc_args.cmi
 odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \
     ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \
     odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \

ocamldoc/odoc_args.ml

@@ -172,29 +172,73 @@ let add_hidden_modules s =
 
 let set_generator (g : Odoc_gen.generator) = current_generator := Some g
 
+let anonymous f =
+  let sf =
+    if Filename.check_suffix f "ml" then
+      Odoc_global.Impl_file f
+    else
+        if Filename.check_suffix f !Config.interface_suffix then
+        Odoc_global.Intf_file f
+      else
+        if Filename.check_suffix f "txt" then
+          Odoc_global.Text_file f
+        else
+          failwith (Odoc_messages.unknown_extension f)
+  in
+  Odoc_global.files := !Odoc_global.files @ [sf]
+
+module Options = Main_args.Make_ocamldoc_options(struct
+  let set r () = r := true
+  let unset r () = r := false
+  let _absname = set Location.absname
+  let _I s = Odoc_global.include_dirs :=
+       (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs
+  let _impl s = Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]
+  let _intf s = Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s]
+  let _intf_suffix s = Config.interface_suffix := s
+  let _labels = unset Clflags.classic
+  let _no_alias_deps = set Clflags.transparent_modules
+  let _no_app_funct = unset Clflags.applicative_functors
+  let _noassert = set Clflags.noassert
+  let _nolabels = set Clflags.classic
+  let _nostdlib = set Clflags.no_std_include
+  let _open s = Clflags.open_modules := s :: !Clflags.open_modules
+  let _pp s = Clflags.preprocessor := Some s
+  let _ppx s = Clflags.all_ppx := s :: !Clflags.all_ppx
+  let _principal = set Clflags.principal
+  let _rectypes = set Clflags.recursive_types
+  let _safe_string = unset Clflags.unsafe_string
+  let _short_paths = unset Clflags.real_paths
+  let _strict_sequence = set Clflags.strict_sequence
+  let _strict_formats = set Clflags.strict_formats
+  let _thread = set Clflags.use_threads
+  let _vmthread = set Clflags.use_vmthreads
+  let _unsafe () = assert false
+  let _unsafe_string = set Clflags.unsafe_string
+  let _v () = Compenv.print_version_and_library "documentation generator"
+  let _version = Compenv.print_version_string
+  let _vnum = Compenv.print_version_string
+  let _w = (Warnings.parse_options false)
+  let _warn_error _ = assert false
+  let _warn_help _ = assert false
+  let _where = Compenv.print_standard_library
+  let _verbose = set Clflags.verbose
+  let _nopervasives = set Clflags.nopervasives
+  let _dsource = set Clflags.dump_source
+  let _dparsetree = set Clflags.dump_parsetree
+  let _dtypedtree = set Clflags.dump_typedtree
+  let _drawlambda = set Clflags.dump_rawlambda
+  let _dlambda = set Clflags.dump_lambda
+  let _dinstr = set Clflags.dump_instr
+  let anonymous = anonymous
+end)
+
 (** The default option list *)
-let default_options = [
+let default_options = Options.list @
-  "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ;
+[
-  "-vnum", Arg.Unit (fun () -> print_string M.config_version ;
-                               print_newline () ; exit 0) , M.option_version ;
-  "-v", Arg.Unit (fun () -> Odoc_global.verbose := true), M.verbose_mode ;
-  "-I", Arg.String (fun s ->
-       Odoc_global.include_dirs :=
-         (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs),
-    M.include_dirs ;
-  "-pp", Arg.String (fun s -> Odoc_global.preprocessor := Some s), M.preprocess ;
-  "-ppx", Arg.String (fun s -> Odoc_global.ppx := s :: !Odoc_global.ppx), M.ppx ;
-  "-impl", Arg.String (fun s ->
-       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]),
-    M.option_impl ;
-    "-intf", Arg.String (fun s ->
-       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s]),
-    M.option_intf ;
   "-text", Arg.String (fun s ->
        Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]),
     M.option_text ;
-  "-rectypes", Arg.Set Odoc_global.recursive_types, M.rectypes ;
-  "-nolabels", Arg.Unit (fun () -> Odoc_global.classic := true), M.nolabels ;
   "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ;
   "-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ;
   "-o", Arg.String (fun s -> Odoc_global.out_file := s), M.out_file ;
@@ -338,24 +382,9 @@ let add_option o =
   options := iter !options
 
 let parse () =
-  let anonymous f =
-    let sf =
-      if Filename.check_suffix f "ml" then
-        Odoc_global.Impl_file f
-      else
-        if Filename.check_suffix f "mli" then
-          Odoc_global.Intf_file f
-        else
-          if Filename.check_suffix f "txt" then
-            Odoc_global.Text_file f
-          else
-            failwith (Odoc_messages.unknown_extension f)
-    in
-    Odoc_global.files := !Odoc_global.files @ [sf]
-  in
   if modified_options () then append_last_doc "\n";
   let options = !options @ !help_options in
-  let _ = Arg.parse options
+  let _ = Arg.parse (Arg.align ~limit:13 options)
       anonymous
       (M.usage^M.options_are)
   in

ocamldoc/odoc_global.ml

@@ -40,13 +40,6 @@ let dump = ref (None : string option)
 
 let load = ref ([] : string list)
 
-(** Allow arbitrary recursive types. *)
-let recursive_types = Clflags.recursive_types
-
-(** Optional preprocessor command. *)
-let preprocessor = Clflags.preprocessor
-let ppx = Clflags.all_ppx
-
 let sort_modules = ref false
 
 let no_custom_tags = ref false
@@ -65,11 +58,9 @@ let hidden_modules = ref ([] : string list)
 
 let files = ref []
 
-
-
 let out_file = ref Odoc_messages.default_out_file
 
-let verbose = ref false
+let verbose = Clflags.verbose
 
 let target_dir = ref Filename.current_dir_name
 

ocamldoc/odoc_global.mli

@@ -21,13 +21,6 @@ type source_file =
 (** The include_dirs in the OCaml compiler. *)
 val include_dirs : string list ref
 
-(** Optional preprocessor command to pass to ocaml compiler. *)
-val preprocessor : string option ref (* -pp *)
-val ppx : string list ref (* -ppx *)
-
-(** Recursive types flag to passe to ocaml compiler. *)
-val recursive_types : bool ref
-
 (** The merge options to be used. *)
 val merge_options : Odoc_types.merge_option list ref
 

ocamldoc/odoc_messages.ml

@@ -16,13 +16,11 @@ let ok = "Ok"
 let software = "OCamldoc"
 let config_version = Config.version
 let magic = config_version^""
-let message_version = software^" "^config_version
 
 (** Messages for command line *)
 
 let usage = "Usage: "^(Sys.argv.(0))^" [options] <files>\n"
 let options_are = "Options are:"
-let option_version = "\tPrint version and exit"
 let latex_only = "(LaTeX only)"
 let texi_only = "(TeXinfo only)"
 let latex_texi_only = "(LaTeX and TeXinfo only)"
@@ -30,51 +28,45 @@ let html_only = "(HTML only)"
 let html_latex_only = "(HTML and LaTeX only)"
 let html_latex_texi_only = "(HTML, LaTeX and TeXinfo only)"
 let man_only = "(man only)"
-let verbose_mode = "\t\tverbose mode"
+let option_impl ="<file> Consider <file> as a .ml file"
-let include_dirs = "<dir>\tAdd <dir> to the list of include directories"
+let option_intf ="<file> Consider <file> as a .mli file"
-let rectypes = "\tAllow arbitrary recursive types"
+let option_text ="<file> Consider <file> as a .txt file"
-let preprocess = "<command>\tPipe sources through preprocessor <command>"
+let display_custom_generators_dir = "Display custom generators standard directory and exit"
-let ppx = "<command>\n\t\tPipe abstract syntax tree through preprocessor <command>"
+let add_load_dir = "<dir> Add the given directory to the search path for custom\n"^
-let option_impl ="<file>\tConsider <file> as a .ml file"
-let option_intf ="<file>\tConsider <file> as a .mli file"
-let option_text ="<file>\tConsider <file> as a .txt file"
-let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit"
-let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^
   "\t\tgenerators"
-let load_file = "<file.cm[o|a|xs]>\n\t\tLoad file defining a new documentation generator"
+let load_file = "<file.cm[o|a|xs]> Load file defining a new documentation generator"
-let nolabels = "\tIgnore non-optional labels in types"
+let werr = " Treat ocamldoc warnings as errors"
-let werr = "\tTreat ocamldoc warnings as errors"
+let hide_warnings = " do not print ocamldoc warnings"
-let hide_warnings = "\n\t\tdo not print ocamldoc warnings"
+let target_dir = "<dir> Generate files in directory <dir>, rather than in current\n"^
-let target_dir = "<dir>\tGenerate files in directory <dir>, rather than in current\n"^
   "\t\tdirectory (for man and HTML generators)"
-let dump = "<file>\tDump collected information into <file>"
+let dump = "<file> Dump collected information into <file>"
-let load = "<file>\tLoad information from <file> ; may be used several times"
+let load = "<file> Load information from <file> ; may be used several times"
-let css_style = "<file>\n\t\tUse content of <file> as CSS style definition "^html_only
+let css_style = "<file> Use content of <file> as CSS style definition "^html_only
-let index_only = "\tGenerate index files only "^html_only
+let index_only = " Generate index files only "^html_only
-let colorize_code = "\n\t\tColorize code even in documentation pages "^html_only
+let colorize_code = " Colorize code even in documentation pages "^html_only
-let html_short_functors = "\n\t\tUse short form to display functor types "^html_only
+let html_short_functors = " Use short form to display functor types "^html_only
 let charset c = Printf.sprintf
-  "<s>\n\t\tAdd information about character encoding being s\n\t\t(default is %s)"
+  "<s> Add information about character encoding being s\n\t\t(default is %s)"
   c
-let generate_html = "\tGenerate HTML documentation"
+let generate_html = " Generate HTML documentation"
-let generate_latex = "\tGenerate LaTeX documentation"
+let generate_latex = " Generate LaTeX documentation"
-let generate_texinfo = "\tGenerate TeXinfo documentation"
+let generate_texinfo = " Generate TeXinfo documentation"
-let generate_man = "\t\tGenerate man pages"
+let generate_man = " Generate man pages"
-let generate_dot = "\t\tGenerate dot code of top modules dependencies"
+let generate_dot = " Generate dot code of top modules dependencies"
 
 let option_not_in_native_code op = "Option "^op^" not available in native code version."
 
 let default_out_file = "ocamldoc.out"
 let out_file =
-  "<file>\tSet the output file name, used by texi, latex and dot generators\n"^
+  "<file> Set the output file name, used by texi, latex and dot generators\n"^
   "\t\t(default is "^default_out_file^")\n"^
   "\t\tor the prefix of index files for the HTML generator\n"^
   "\t\t(default is index)"
 
 let dot_include_all =
-  "\n\t\tInclude all modules in the dot output, not only the\n"^
+  " Include all modules in the dot output, not only the\n"^
   "\t\tmodules given on the command line"
-let dot_types = "\tGenerate dependency graph for types instead of modules"
+let dot_types = " Generate dependency graph for types instead of modules"
 let default_dot_colors =
   [ [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; ] ;
     [ "magenta" ; "yellow" ; "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ] ;
@@ -82,36 +74,37 @@ let default_dot_colors =
   ]
 
 let dot_colors =
-  "<c1,c2,...,cn>\n\t\tUse colors c1,c1,...,cn in the dot output\n"^
+  " <c1,c2,...,cn>\n"^
+  "\t\tUse colors c1,c1,...,cn in the dot output\n"^
   "\t\t(default list is "^
   (String.concat ",\n\t\t" (List.map (String.concat ",") default_dot_colors))^")"
 
 let dot_reduce =
-  "\tPerform a transitive reduction on the selected dependency graph\n"^
+  " Perform a transitive reduction on the selected dependency graph\n"^
   "\t\tbefore the dot output"
 
-let man_mini = "\tGenerate man pages only for modules, module types, classes\n"^
+let man_mini = " Generate man pages only for modules, module types, classes\n"^
   "\t\tand class types "^man_only
 let default_man_section = "3"
-let man_section = "<section>\n\t\tUse <section> in man page files "^
+let man_section = "<section> Use <section> in man page files "^
   "(default is "^default_man_section^") "^man_only^"\n"
 
 let default_man_suffix = default_man_section^"o"
-let man_suffix = "<suffix>\n\t\tUse <suffix> for man page files "^
+let man_suffix = "<suffix> Use <suffix> for man page files "^
   "(default is "^default_man_suffix^") "^man_only^"\n"
 
-let option_title = "<title>\tUse <title> as title for the generated documentation"
+let option_title = "<title> Use <title> as title for the generated documentation"
 let option_intro =
-  "<file>\tUse content of <file> as ocamldoc text to use as introduction\n"^
+  "<file> Use content of <file> as ocamldoc text to use as introduction\n"^
   "\t\t"^(html_latex_texi_only)
-let with_parameter_list = "\tDisplay the complete list of parameters for functions and\n"^
+let with_parameter_list = " Display the complete list of parameters for functions and\n"^
   "\t\tmethods "^html_only
-let hide_modules = "<M1,M2.M3,...>\n\t\tHide the given complete module names in generated doc"
+let hide_modules = "<M1,M2.M3,...> Hide the given complete module names in generated doc"
-let no_header = "\tSuppress header in generated documentation\n\t\t"^latex_texi_only
+let no_header = " Suppress header in generated documentation\n\t\t"^latex_texi_only
-let no_trailer = "\tSuppress trailer in generated documentation\n\t\t"^latex_texi_only
+let no_trailer = " Suppress trailer in generated documentation\n\t\t"^latex_texi_only
-let separate_files = "\tGenerate one file per toplevel module "^latex_only
+let separate_files = " Generate one file per toplevel module "^latex_only
 let latex_title ref_titles =
-  "n,style\n\t\tAssociate {n } to the given sectionning style\n"^
+  "n,style Associate {n } to the given sectionning style\n"^
   "\t\t(e.g. 'section') in the latex output "^latex_only^"\n"^
   "\t\tDefault sectionning is:\n\t\t"^
   (String.concat "\n\t\t"
@@ -119,67 +112,78 @@ let latex_title ref_titles =
 
 let default_latex_value_prefix = "val:"
 let latex_value_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of values.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of values.\n"^
   "\t\t(default is \""^default_latex_value_prefix^"\")"
 
 let default_latex_type_prefix = "type:"
 let latex_type_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of types.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of types.\n"^
   "\t\t(default is \""^default_latex_type_prefix^"\")"
 
 let default_latex_type_elt_prefix = "typeelt:"
 let latex_type_elt_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^
   "\t\t(default is \""^default_latex_type_elt_prefix^"\")"
 
 let default_latex_extension_prefix = "extension:"
 let latex_extension_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of extensions.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of extensions.\n"^
   "\t\t(default is \""^default_latex_extension_prefix^"\")"
 
 let default_latex_exception_prefix = "exception:"
 let latex_exception_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^
   "\t\t(default is \""^default_latex_exception_prefix^"\")"
 
 let default_latex_module_prefix = "module:"
 let latex_module_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^
   "\t\t(default is \""^default_latex_module_prefix^"\")"
 
 let default_latex_module_type_prefix = "moduletype:"
 let latex_module_type_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^
   "\t\t(default is \""^default_latex_module_type_prefix^"\")"
 
 let default_latex_class_prefix = "class:"
 let latex_class_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^
   "\t\t(default is \""^default_latex_class_prefix^"\")"
 
 let default_latex_class_type_prefix = "classtype:"
 let latex_class_type_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^
   "\t\t(default is \""^default_latex_class_type_prefix^"\")"
 
 let default_latex_attribute_prefix = "val:"
 let latex_attribute_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^
   "\t\t(default is \""^default_latex_attribute_prefix^"\")"
 
 let default_latex_method_prefix = "method:"
 let latex_method_prefix =
-  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^
+  "<string>\n"^
+  "\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^
   "\t\t(default is \""^default_latex_method_prefix^"\")"
 
-let no_toc = "\tDo not generate table of contents "^latex_only
+let no_toc = " Do not generate table of contents "^latex_only
-let sort_modules = "\tSort the list of top modules before generating the documentation"
+let sort_modules = " Sort the list of top modules before generating the documentation"
-let no_stop = "\tDo not stop at (**/**) comments"
+let no_stop = " Do not stop at (**/**) comments"
-let no_custom_tags = "\n\t\tDo not allow custom @-tags"
+let no_custom_tags = " Do not allow custom @-tags"
-let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'"
+let remove_stars = " Remove beginning blanks of comment lines, until the first '*'"
-let keep_code = "\tAlways keep code when available"
+let keep_code = " Always keep code when available"
-let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging"
+let inverse_merge_ml_mli = " Inverse implementations and interfaces when merging"
-let no_filter_with_module_constraints = "\n\t\tDo not filter module elements using module type constraints"
+let no_filter_with_module_constraints = "Do not filter module elements using module type constraints"
 let merge_description = ('d', "merge description")
 let merge_author = ('a', "merge @author")
 let merge_version = ('v', "merge @version")
@@ -193,10 +197,10 @@ let merge_return_value = ('r', "merge @return")
 let merge_custom = ('c', "merge custom @-tags")
 let merge_all = ('A', "merge all")
 
-let no_index = "\tDo not build index for Info files "^texi_only
+let no_index = " Do not build index for Info files "^texi_only
-let esc_8bits = "\tEscape accentuated characters in Info files "^texi_only
+let esc_8bits = " Escape accentuated characters in Info files "^texi_only
-let info_section = "Specify section of Info directory "^texi_only
+let info_section = " Specify section of Info directory "^texi_only
-let info_entry = "\tSpecify Info directory entry "^texi_only
+let info_entry = " Specify Info directory entry "^texi_only
 
 let options_can_be = "<options> can be one or more of the following characters:"
 let string_of_options_list l =
@@ -205,7 +209,7 @@ let string_of_options_list l =
     l
 
 let merge_options =
-  "<options>\tspecify merge options between .mli and .ml\n\t\t"^
+  "<options> specify merge options between .mli and .ml\n\t\t"^
   options_can_be^
   (string_of_options_list
      [ merge_description ;
@@ -222,7 +226,7 @@ let merge_options =
        merge_all ]
   )
 
-let help = "\t\tDisplay this list of options"
+let help = " Display this list of options"
 
 
 (** Error and warning messages *)

otherlibs/systhreads/Makefile

@@ -31,7 +31,7 @@ all: libthreads.a threads.cma
 allopt: libthreadsnat.a threads.cmxa
 
 libthreads.a: $(BYTECODE_C_OBJS)
-	$(MKLIB) -o threads $(BYTECODE_C_OBJS) -lpthread
+	$(MKLIB) -o threads $(BYTECODE_C_OBJS) $(PTHREAD_LINK)
 
 st_stubs_b.o: st_stubs.c st_posix.h
 	$(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
@@ -51,12 +51,12 @@ st_stubs_n.o: st_stubs.c st_posix.h
 
 threads.cma: $(THREAD_OBJS)
 	$(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \
-	  -cclib -lunix $(PTHREAD_LINK)
+	  -cclib -lunix $(PTHREAD_CAML_LINK)
 
 # See remark above: force static linking of libthreadsnat.a
 threads.cmxa: $(THREAD_OBJS:.cmo=.cmx)
 	$(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \
-	  -cclib -lthreadsnat $(PTHREAD_LINK)
+	  -cclib -lthreadsnat $(PTHREAD_CAML_LINK)
 
 # Note: I removed "-cclib -lunix" from the line above.
 # Indeed, if we link threads.cmxa, then we must also link unix.cmxa,

otherlibs/threads/Makefile

@@ -27,21 +27,21 @@ CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
 
 LIB=../../stdlib
 
-LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \
+LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo		\
-  $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo        \
+  $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/bytes.cmo	\
-  $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo $(LIB)/obj.cmo                 \
+  $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo $(LIB)/marshal.cmo	\
-  $(LIB)/int32.cmo $(LIB)/int64.cmo $(LIB)/nativeint.cmo                    \
+  $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo			\
-  $(LIB)/lexing.cmo $(LIB)/parsing.cmo $(LIB)/set.cmo $(LIB)/map.cmo        \
+  $(LIB)/nativeint.cmo $(LIB)/lexing.cmo $(LIB)/parsing.cmo		\
-  $(LIB)/stack.cmo $(LIB)/queue.cmo $(LIB)/camlinternalLazy.cmo             \
+  $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo	\
-  $(LIB)/lazy.cmo $(LIB)/stream.cmo $(LIB)/buffer.cmo                       \
+  $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo $(LIB)/stream.cmo		\
-  $(LIB)/printf.cmo $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo        \
+  $(LIB)/buffer.cmo $(LIB)/camlinternalFormat.cmo $(LIB)/printf.cmo	\
-  $(LIB)/digest.cmo $(LIB)/random.cmo $(LIB)/hashtbl.cmo                    \
+  $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo	\
-  $(LIB)/format.cmo $(LIB)/scanf.cmo $(LIB)/callback.cmo \
+  $(LIB)/random.cmo $(LIB)/hashtbl.cmo $(LIB)/format.cmo		\
-  $(LIB)/camlinternalOO.cmo              \
+  $(LIB)/scanf.cmo $(LIB)/callback.cmo $(LIB)/camlinternalOO.cmo	\
-  $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo                \
+  $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo		\
-  $(LIB)/weak.cmo $(LIB)/filename.cmo                   \
+  $(LIB)/weak.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo		\
-  $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo           \
+  $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/bytesLabels.cmo	\
-  $(LIB)/stringLabels.cmo $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo
+  $(LIB)/stringLabels.cmo $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo
 
 UNIXLIB=../unix
 

otherlibs/unix/nice.c

@@ -22,7 +22,11 @@ CAMLprim value unix_nice(value incr)
 {
   int ret;
   errno = 0;
+#ifdef HAS_NICE
   ret = nice(Int_val(incr));
+#else
+  ret = 0;
+#endif
   if (ret == -1 && errno != 0) uerror("nice", Nothing);
   return Val_int(ret);
 }

parsing/location.ml

@@ -363,10 +363,15 @@ let () =
     )
 
 
-let report_exception ppf exn =
+let rec report_exception_rec n ppf exn =
-  match error_of_exn exn with
+  try match error_of_exn exn with
-  | Some err -> fprintf ppf "@[%a@]@." report_error err
+  | Some err ->
+      fprintf ppf "@[%a@]@." report_error err
   | None -> raise exn
+  with exn when n > 0 ->
+    report_exception_rec (n-1) ppf exn
+
+let report_exception ppf exn = report_exception_rec 5 ppf exn
 
 
 exception Error of error

parsing/parser.mly

@@ -547,7 +547,7 @@ parse_pattern:
 
 functor_arg:
     LPAREN RPAREN
-      { mkrhs "()" 2, None }
+      { mkrhs "*" 2, None }
   | LPAREN functor_arg_name COLON module_type RPAREN
       { mkrhs $2 2, Some $4 }
 ;
@@ -776,7 +776,7 @@ module_declaration:
   | LPAREN UIDENT COLON module_type RPAREN module_declaration
       { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) }
   | LPAREN RPAREN module_declaration
-      { mkmty(Pmty_functor(mkrhs "()" 1, None, $3)) }
+      { mkmty(Pmty_functor(mkrhs "*" 1, None, $3)) }
 ;
 module_rec_declarations:
     module_rec_declaration                              { [$1] }

parsing/pprintast.ml

@@ -351,7 +351,7 @@ class printer  ()= object(self:'self)
       | p -> self#pattern1 f p in
     if x.ppat_attributes <> [] then self#pattern f x
     else match x.ppat_desc with
-    | Ppat_variant (l, Some p) ->  pp f "@[<2>`%s@;%a@]" l self#pattern1 p (*RA*)
+    | Ppat_variant (l, Some p) ->  pp f "@[<2>`%s@;%a@]" l self#simple_pattern p
     | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> self#simple_pattern f x
     | Ppat_construct (({txt;_} as li), po) -> (* FIXME The third field always false *)
         if txt = Lident "::" then

stdlib/arg.ml

@@ -255,18 +255,24 @@ let add_padding len ksd =
       ksd
   | (kwd, (Symbol (l, _) as spec), msg) ->
       let cutcol = second_word msg in
-      let spaces = String.make (len - cutcol + 3) ' ' in
+      let spaces = String.make ((max 0 (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
+      let kwd_len = String.length kwd in
-      let prefix = String.sub msg 0 cutcol in
+      let diff = len - kwd_len - cutcol in
-      let suffix = String.sub msg cutcol (String.length msg - cutcol) in
+      if diff <= 0 then
-      (kwd, spec, prefix ^ spaces ^ suffix)
+        (kwd, spec, msg)
+      else
+        let spaces = String.make diff ' ' in
+        let prefix = String.sub msg 0 cutcol in
+        let suffix = String.sub msg cutcol (String.length msg - cutcol) in
+        (kwd, spec, prefix ^ spaces ^ suffix)
 ;;
 
-let align speclist =
+let align ?(limit=max_int) speclist =
   let completed = add_help speclist in
   let len = List.fold_left max_arg_len 0 completed in
+  let len = min len limit in
   List.map (add_padding len) completed
 ;;

stdlib/arg.mli

@@ -140,12 +140,15 @@ val usage_string : (key * spec * doc) list -> usage_msg -> string
 (** Returns the message that would have been printed by {!Arg.usage},
     if provided with the same parameters. *)
 
-val align: (key * spec * doc) list -> (key * spec * doc) list;;
+val align: ?limit: int -> (key * spec * doc) list -> (key * spec * doc) list;;
 (** Align the documentation strings by inserting spaces at the first
     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 aligned on the next line. *)
+    [Symbol] arguments are aligned on the next line.
+    @param limit options with keyword and message longer than
+    [limit] will not be used to compute the alignement.
+*)
 
 val current : int ref
 (** Position (in {!Sys.argv}) of the argument being processed.  You can

stdlib/array.mli

@@ -47,7 +47,7 @@ external make : int -> 'a -> 'a array = "caml_make_vect"
    size is only [Sys.max_array_length / 2].*)
 
 external create : int -> 'a -> 'a array = "caml_make_vect"
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use Array.make instead."]
 (** @deprecated [Array.create] is an alias for {!Array.make}. *)
 
 val init : int -> (int -> 'a) -> 'a array
@@ -74,7 +74,7 @@ val make_matrix : int -> int -> 'a -> 'a array array
    size is only [Sys.max_array_length / 2]. *)
 
 val create_matrix : int -> int -> 'a -> 'a array array
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use Array.make_matrix instead."]
 (** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *)
 
 val append : 'a array -> 'a array -> 'a array

stdlib/arrayLabels.mli

@@ -47,7 +47,7 @@ external make : int -> 'a -> 'a array = "caml_make_vect"
    size is only [Sys.max_array_length / 2].*)
 
 external create : int -> 'a -> 'a array = "caml_make_vect"
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use ArrayLabels.make instead."]
 (** @deprecated [ArrayLabels.create] is an alias for {!ArrayLabels.make}. *)
 
 val init : int -> f:(int -> 'a) -> 'a array
@@ -74,7 +74,7 @@ val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
    size is only [Sys.max_array_length / 2]. *)
 
 val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use ArrayLabels.make_matrix instead."]
 (** @deprecated [ArrayLabels.create_matrix] is an alias for
    {!ArrayLabels.make_matrix}. *)
 

stdlib/bytes.ml

@@ -55,7 +55,7 @@ let of_string s = copy (unsafe_of_string s)
 
 let sub s ofs len =
   if ofs < 0 || len < 0 || ofs > length s - len
-  then invalid_arg "Bytes.sub"
+  then invalid_arg "String.sub / Bytes.sub"
   else begin
     let r = create len in
     unsafe_blit s ofs r 0 len;
@@ -74,7 +74,7 @@ let extend s left right =
 
 let fill s ofs len c =
   if ofs < 0 || len < 0 || ofs > length s - len
-  then invalid_arg "Bytes.fill"
+  then invalid_arg "String.fill / Bytes.fill"
   else unsafe_fill s ofs len c
 
 let blit s1 ofs1 s2 ofs2 len =
@@ -86,7 +86,7 @@ let blit s1 ofs1 s2 ofs2 len =
 let blit_string s1 ofs1 s2 ofs2 len =
   if len < 0 || ofs1 < 0 || ofs1 > string_length s1 - len
              || ofs2 < 0 || ofs2 > length s2 - len
-  then invalid_arg "Bytes.blit_string"
+  then invalid_arg "String.blit / Bytes.blit_string"
   else unsafe_blit_string s1 ofs1 s2 ofs2 len
 
 let iter f a =
@@ -224,7 +224,7 @@ let index s c = index_rec s (length s) 0 c;;
 
 let index_from s i c =
   let l = length s in
-  if i < 0 || i > l then invalid_arg "Bytes.index_from" else
+  if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
   index_rec s l i c;;
 
 let rec rindex_rec s i c =
@@ -234,19 +234,28 @@ let rec rindex_rec s i c =
 let rindex s c = rindex_rec s (length s - 1) c;;
 
 let rindex_from s i c =
-  if i < -1 || i >= length s then invalid_arg "Bytes.rindex_from" else
+  if i < -1 || i >= length s then
-  rindex_rec s i c;;
+    invalid_arg "String.rindex_from / Bytes.rindex_from"
+  else
+    rindex_rec s i c
+;;
 
 let contains_from s i c =
   let l = length s in
-  if i < 0 || i > l then invalid_arg "Bytes.contains_from" else
+  if i < 0 || i > l then
-  try ignore (index_rec s l i c); true with Not_found -> false;;
+    invalid_arg "String.contains_from / Bytes.contains_from"
+  else
+    try ignore (index_rec s l i c); true with Not_found -> false
+;;
 
 let contains s c = contains_from s 0 c;;
 
 let rcontains_from s i c =
-  if i < 0 || i >= length s then invalid_arg "Bytes.rcontains_from" else
+  if i < 0 || i >= length s then
-  try ignore (rindex_rec s i c); true with Not_found -> false;;
+    invalid_arg "String.rcontains_from / Bytes.rcontains_from"
+  else
+    try ignore (rindex_rec s i c); true with Not_found -> false
+;;
 
 type t = bytes
 

stdlib/camlinternalFormat.ml

@@ -94,6 +94,8 @@ fun ign fmt -> match ign with
     Param_format_EBB (Scan_char_set (width_opt, char_set, fmt))
   | Ignored_scan_get_counter counter ->
     Param_format_EBB (Scan_get_counter (counter, fmt))
+  | Ignored_scan_next_char ->
+    Param_format_EBB (Scan_next_char fmt)
 
 
 (******************************************************************************)
@@ -568,6 +570,10 @@ let bprint_fmt buf fmt =
       buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
       buffer_add_char buf (char_of_counter counter);
       fmtiter rest false;
+    | Scan_next_char rest ->
+      buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+      bprint_string_literal buf "0c"; fmtiter rest false;
+
     | Ignored_param (ign, rest) ->
       let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in
       fmtiter fmt' true;
@@ -842,6 +848,7 @@ fun fmtty -> match fmtty with
 
   | Scan_char_set (_, _, rest) -> String_ty (fmtty_of_fmt rest)
   | Scan_get_counter (_, rest) -> Int_ty (fmtty_of_fmt rest)
+  | Scan_next_char rest        -> Char_ty (fmtty_of_fmt rest)
   | Ignored_param (ign, rest)  -> fmtty_of_ignored_format ign rest
   | Formatting_lit (_, rest)   -> fmtty_of_fmt rest
   | Formatting_gen (fmting_gen, rest)  ->
@@ -871,6 +878,7 @@ fun ign fmt -> match ign with
   | Ignored_reader                  -> Ignored_reader_ty (fmtty_of_fmt fmt)
   | Ignored_scan_char_set _         -> fmtty_of_fmt fmt
   | Ignored_scan_get_counter _      -> fmtty_of_fmt fmt
+  | Ignored_scan_next_char          -> fmtty_of_fmt fmt
 
 (* Add an Int_ty node if padding is taken as an extra argument (ex: "%*s"). *)
 and fmtty_of_padding_fmtty : type x a b c d e f .
@@ -1067,7 +1075,7 @@ fun formatting_gen fmt0 fmtty0 -> match formatting_gen with
   | Open_box (Format (fmt1, str)) ->
     let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in
     let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in
-    Fmt_fmtty_EBB (Formatting_gen (Open_tag (Format (fmt2, str)), fmt3), fmtty3)
+    Fmt_fmtty_EBB (Formatting_gen (Open_box (Format (fmt2, str)), fmt3), fmtty3)
 
 (* Type an Ignored_param node according to an fmtty. *)
 and type_ignored_param : type p q x y z t u v a b c d e f .
@@ -1088,6 +1096,7 @@ fun ign fmt fmtty -> match ign with
   | Ignored_bool               as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_scan_char_set _    as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_scan_get_counter _ as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_scan_next_char     as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_format_arg (pad_opt, sub_fmtty) ->
     type_ignored_param_one (Ignored_format_arg (pad_opt, sub_fmtty)) fmt fmtty
   | Ignored_format_subst (pad_opt, sub_fmtty) ->
@@ -1229,6 +1238,18 @@ let recast :
 (* Add padding spaces arround a string. *)
 let fix_padding padty width str =
   let len = String.length str in
+  let width, padty =
+    abs width,
+    (* while literal padding widths are always non-negative,
+       dynamically-set widths (Arg_padding, eg. %*d) may be negative;
+       we interpret those as specifying a padding-to-the-left; this
+       means that '0' may get dropped even if it was explicitly set,
+       but:
+       - this is what the legacy implementation does, and
+         we preserve compatibility if possible
+       - we could only signal this issue by failing at runtime,
+         which is not very nice... *)
+    if width < 0 then Left else padty in
   if width <= len then str else
     let res = Bytes.make width (if padty = Zeros then '0' else ' ') in
     begin match padty with
@@ -1247,22 +1268,25 @@ let fix_padding padty width str =
 
 (* Add '0' padding to int, int32, nativeint or int64 string representation. *)
 let fix_int_precision prec str =
+  let prec = abs prec in
   let len = String.length str in
-  if prec <= len then str else
+  match str.[0] with
-    let res = Bytes.make prec '0' in
+  | ('+' | '-' | ' ') as c when prec + 1 > len ->
-    begin match str.[0] with
+    let res = Bytes.make (prec + 1) '0' in
-    | ('+' | '-' | ' ') as c ->
+    Bytes.set res 0 c;
-      Bytes.set res 0 c;
+    String.blit str 1 res (prec - len + 2) (len - 1);
-      String.blit str 1 res (prec - len + 1) (len - 1);
-    | '0' when len > 1 && (str.[1] = 'x' || str.[1] = 'X') ->
-      Bytes.set res 1 str.[1];
-      String.blit str 2 res (prec - len + 2) (len - 2);
-    | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
-      String.blit str 0 res (prec - len) len;
-    | _ ->
-      assert false
-    end;
     Bytes.unsafe_to_string res
+  | '0' when prec + 2 > len && len > 1 && (str.[1] = 'x' || str.[1] = 'X') ->
+    let res = Bytes.make (prec + 2) '0' in
+    Bytes.set res 1 str.[1];
+    String.blit str 2 res (prec - len + 4) (len - 2);
+    Bytes.unsafe_to_string res
+  | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' when prec > len ->
+    let res = Bytes.make prec '0' in
+    String.blit str 0 res (prec - len) len;
+    Bytes.unsafe_to_string res
+  | _ ->
+    str
 
 (* Escape a string according to the OCaml lexing convention. *)
 let string_to_caml_string str =
@@ -1308,6 +1332,7 @@ let format_of_iconvn = function
 
 (* Generate the format_float first argument form a float_conv. *)
 let format_of_fconv fconv prec =
+  let prec = abs prec in
   let symb = if fconv = Float_F then 'g' else char_of_fconv fconv in
   let buf = buffer_create 16 in
   buffer_add_char buf '%';
@@ -1326,6 +1351,7 @@ let convert_int64 iconv n = format_int64 (format_of_iconvL iconv) n
 (* Convert a float to string. *)
 (* Fix special case of "OCaml float format". *)
 let convert_float fconv prec x =
+  let prec = abs prec in
   let str = format_float (format_of_fconv fconv prec) x in
   if fconv <> Float_F then str else
     let len = String.length str in
@@ -1435,6 +1461,10 @@ fun k o acc fmt -> match fmt with
     fun n ->
       let new_acc = Acc_data_string (acc, format_int "%u" n) in
       make_printf k o new_acc rest
+  | Scan_next_char rest ->
+    fun c ->
+      let new_acc = Acc_data_char (acc, c) in
+      make_printf k o new_acc rest
   | Ignored_param (ign, rest) ->
     make_ignored_param k o acc ign rest
 
@@ -1474,6 +1504,7 @@ fun k o acc ign fmt -> match ign with
   | Ignored_reader                  -> assert false
   | Ignored_scan_char_set _         -> make_invalid_arg k o acc fmt
   | Ignored_scan_get_counter _      -> make_invalid_arg k o acc fmt
+  | Ignored_scan_next_char          -> make_invalid_arg k o acc fmt
 
 
 (* Special case of printf "%_(". *)
@@ -1810,26 +1841,39 @@ let fmt_ebb_of_string ?legacy_behavior str =
   in
 
   (* Raise a Failure with a friendly error message. *)
+  let invalid_format_message str_ind msg =
+    failwith_message
+      "invalid format %S: at character number %d, %s"
+      str str_ind msg;
+  in
+
   (* Used when the end of the format (or the current sub-format) was encoutered
       unexpectedly. *)
   let unexpected_end_of_format end_ind =
-    failwith_message
+    invalid_format_message end_ind
-      "invalid format %S: at character number %d, unexpected end of format"
+      "unexpected end of format"
-      str end_ind;
+  in
 
+  (* Used for %0c: no other widths are implemented *)
+  let invalid_nonnull_char_width str_ind =
+    invalid_format_message str_ind
+      "non-zero widths are unsupported for %c conversions"
+  in
   (* Raise Failure with a friendly error message about an option dependencie
      problem. *)
-  and invalid_format_without str_ind c s =
+  let invalid_format_without str_ind c s =
     failwith_message
       "invalid format %S: at character number %d, '%c' without %s"
       str str_ind c s
+  in
 
   (* Raise Failure with a friendly error message about an unexpected
      character. *)
-  and expected_character str_ind expected read =
+  let expected_character str_ind expected read =
     failwith_message
      "invalid format %S: at character number %d, %s expected, read %C"
-      str str_ind expected read in
+      str str_ind expected read
+  in
 
   (* Parse the string from beg_ind (included) to end_ind (excluded). *)
   let rec parse : type e f . int -> int -> (_, _, e, f) fmt_ebb =
@@ -1904,52 +1948,56 @@ let fmt_ebb_of_string ?legacy_behavior str =
     match str.[str_ind] with
     | '0' .. '9' ->
       let new_ind, width = parse_positive str_ind end_ind 0 in
-      parse_after_padding pct_ind new_ind end_ind plus sharp space ign
+      parse_after_padding pct_ind new_ind end_ind minus plus sharp space ign
         (Lit_padding (padty, width))
     | '*' ->
-      parse_after_padding pct_ind (str_ind + 1) end_ind plus sharp space ign
+      parse_after_padding pct_ind (str_ind + 1) end_ind minus plus sharp space
-        (Arg_padding padty)
+        ign (Arg_padding padty)
     | _ ->
-      if legacy_behavior then
+      begin match padty with
-        parse_after_padding pct_ind str_ind end_ind plus sharp space ign
-          No_padding
-      else begin match padty with
       | Left  ->
-        invalid_format_without (str_ind - 1) '-' "padding"
+        if not legacy_behavior then
+          invalid_format_without (str_ind - 1) '-' "padding";
+        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+          No_padding
       | Zeros ->
-        invalid_format_without (str_ind - 1) '0' "padding"
+         (* a '0' padding indication not followed by anything should
+           be interpreted as a Right padding of width 0. This is used
+           by scanning conversions %0s and %0c *)
+        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+          (Lit_padding (Right, 0))
       | Right ->
-        parse_after_padding pct_ind str_ind end_ind plus sharp space ign
+        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
           No_padding
       end
 
   (* Is precision defined? *)
   and parse_after_padding : type x e f .
-      int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding ->
+      int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
-        (_, _, e, f) fmt_ebb =
+        (x, _) padding -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind plus sharp space ign pad ->
+  fun pct_ind str_ind end_ind minus plus sharp space ign pad ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     match str.[str_ind] with
     | '.' ->
-      parse_precision pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+      parse_precision pct_ind (str_ind + 1) end_ind minus plus sharp space ign
+        pad
     | symb ->
       parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad
-        No_precision symb
+        No_precision pad symb
 
   (* Read the digital or '*' precision. *)
   and parse_precision : type x e f .
-      int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding ->
+      int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
-        (_, _, e, f) fmt_ebb =
+        (x, _) padding -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind plus sharp space ign pad ->
+  fun pct_ind str_ind end_ind minus plus sharp space ign pad ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
-    let parse_literal str_ind =
+    let parse_literal minus str_ind =
       let new_ind, prec = parse_positive str_ind end_ind 0 in
-      if new_ind = end_ind then unexpected_end_of_format end_ind;
+      parse_after_precision pct_ind new_ind end_ind minus plus sharp space ign
-      parse_conversion pct_ind (new_ind + 1) end_ind plus sharp space ign pad
+        pad (Lit_precision prec) in
-        (Lit_precision prec) str.[new_ind] in
     match str.[str_ind] with
-    | '0' .. '9' -> parse_literal str_ind
+    | '0' .. '9' -> parse_literal minus str_ind
-    | ('+' | '-') when legacy_behavior ->
+    | ('+' | '-') as symb when legacy_behavior ->
       (* Legacy mode would accept and ignore '+' or '-' before the
          integer describing the desired precision; not that this
          cannot happen for padding width, as '+' and '-' already have
@@ -1958,47 +2006,67 @@ let fmt_ebb_of_string ?legacy_behavior str =
          That said, the idea (supported by this tweak) that width and
          precision literals are "integer literals" in the OCaml sense is
          still blatantly wrong, as 123_456 or 0xFF are rejected. *)
-      parse_literal (str_ind + 1)
+      parse_literal (minus || symb = '-') (str_ind + 1)
     | '*' ->
-      parse_after_precision pct_ind (str_ind + 1) end_ind plus sharp space ign
+      parse_after_precision pct_ind (str_ind + 1) end_ind minus plus sharp space
-        pad Arg_precision
+        ign pad Arg_precision
     | _ ->
       if legacy_behavior then
         (* note that legacy implementation did not ignore '.' without
            a number (as it does for padding indications), but
            interprets it as '.0' *)
-        parse_after_precision pct_ind str_ind end_ind plus sharp space ign pad (Lit_precision 0) else
+        parse_after_precision pct_ind str_ind end_ind minus plus sharp space ign
-      invalid_format_without (str_ind - 1) '.' "precision"
+          pad (Lit_precision 0)
+      else
+        invalid_format_without (str_ind - 1) '.' "precision"
 
   (* Try to read the conversion. *)
-  and parse_after_precision : type x z e f .
+  and parse_after_precision : type x y z t e f .
-      int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding ->
+      int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
-        (z, _) precision -> (_, _, e, f) fmt_ebb =
+        (x, y) padding -> (z, t) precision -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind plus sharp space ign pad prec ->
+  fun pct_ind str_ind end_ind minus plus sharp space ign pad prec ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
-    parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad prec
+    let parse_conv (type u) (type v) (padprec : (u, v) padding) =
-      str.[str_ind]
+      parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+        prec padprec str.[str_ind] in
+    (* in legacy mode, some formats (%s and %S) accept a weird mix of
+       padding and precision, which is merged as a single padding
+       information. For example, in %.10s the precision is implicitly
+       understood as padding %10s, but the left-padding component may
+       be specified either as a left padding or a negative precision:
+       %-.3s and %.-3s are equivalent to %-3s *)
+    match pad with
+    | No_padding -> (
+      match minus, prec with
+        | _, No_precision -> parse_conv No_padding
+        | false, Lit_precision n -> parse_conv (Lit_padding (Right, n))
+        | true, Lit_precision n -> parse_conv (Lit_padding (Left, n))
+        | false, Arg_precision -> parse_conv (Arg_padding Right)
+        | true, Arg_precision -> parse_conv (Arg_padding Left)
+    )
+    | pad -> parse_conv pad
 
   (* Case analysis on conversion. *)
-  and parse_conversion : type x y z t e f .
+  and parse_conversion : type x y z t u v e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> (x, y) padding ->
-        (z, t) precision -> char -> (_, _, e, f) fmt_ebb =
+        (z, t) precision -> (u, v) padding -> char -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind plus sharp space ign pad prec symb ->
+  fun pct_ind str_ind end_ind plus sharp space ign pad prec padprec symb ->
     (* Flags used to check option usages/compatibilities. *)
     let plus_used  = ref false and sharp_used = ref false
     and space_used = ref false and ign_used   = ref false
     and pad_used   = ref false and prec_used  = ref false in
 
     (* Access to options, update flags. *)
-    let get_plus  () = plus_used  := true; plus
+    let get_plus    () = plus_used  := true; plus
-    and get_sharp () = sharp_used := true; sharp
+    and get_sharp   () = sharp_used := true; sharp
-    and get_space () = space_used := true; space
+    and get_space   () = space_used := true; space
-    and get_ign   () = ign_used   := true; ign
+    and get_ign     () = ign_used   := true; ign
-    and get_pad   () = pad_used   := true; pad
+    and get_pad     () = pad_used   := true; pad
-    and get_prec  () = prec_used  := true; prec in
+    and get_prec    () = prec_used  := true; prec
+    and get_padprec () = pad_used   := true; padprec in
 
     (* Check that padty <> Zeros. *)
-    let check_no_0 symb (type a) (type b) (pad : (a,b) padding) =
+    let check_no_0 symb (type a) (type b) (pad : (a, b) padding) =
       match pad with
       | No_padding -> pad
       | Lit_padding ((Left | Right), _) -> pad
@@ -2014,7 +2082,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     (* Get padding as a pad_option (see "%_", "%{", "%(" and "%[").
        (no need for legacy mode tweaking, those were rejected by the
        legacy parser as well) *)
-    let get_pad_opt c = match get_pad () with
+    let opt_of_pad c (type a) (type b) (pad : (a, b) padding) = match pad with
       | No_padding -> None
       | Lit_padding (Right, width) -> Some width
       | Lit_padding (Zeros, width) ->
@@ -2023,8 +2091,10 @@ let fmt_ebb_of_string ?legacy_behavior str =
       | Lit_padding (Left, width) ->
         if legacy_behavior then Some width
         else incompatible_flag pct_ind str_ind c "'-'"
-      | Arg_padding _          -> incompatible_flag pct_ind str_ind c "'*'"
+      | Arg_padding _ -> incompatible_flag pct_ind str_ind c "'*'"
     in
+    let get_pad_opt c = opt_of_pad c (get_pad ()) in
+    let get_padprec_opt c = opt_of_pad c (get_padprec ()) in
 
     (* Get precision as a prec_option (see "%_f").
        (no need for legacy mode tweaking, those were rejected by the
@@ -2039,28 +2109,44 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | ',' ->
       parse str_ind end_ind
     | 'c' ->
+      let char_format fmt_rest = (* %c *)
+        if get_ign ()
+        then Fmt_EBB (Ignored_param (Ignored_char, fmt_rest))
+        else Fmt_EBB (Char fmt_rest)
+      in
+      let scan_format fmt_rest = (* %0c *)
+        if get_ign ()
+        then Fmt_EBB (Ignored_param (Ignored_scan_next_char, fmt_rest))
+        else Fmt_EBB (Scan_next_char fmt_rest)
+      in
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
-      if get_ign () then Fmt_EBB (Ignored_param (Ignored_char, fmt_rest))
+      begin match get_pad_opt 'c' with
-      else Fmt_EBB (Char fmt_rest)
+        | None -> char_format fmt_rest
+        | Some 0 -> scan_format fmt_rest
+        | Some _n ->
+	   if not legacy_behavior
+	   then invalid_nonnull_char_width str_ind
+	   else (* legacy ignores %c widths *) char_format fmt_rest
+      end
     | 'C' ->
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
       if get_ign () then Fmt_EBB (Ignored_param (Ignored_caml_char,fmt_rest))
       else Fmt_EBB (Caml_char fmt_rest)
     | 's' ->
-      let pad = check_no_0 symb (get_pad ()) in
+      let pad = check_no_0 symb (get_padprec ()) in
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
       if get_ign () then
-        let ignored = Ignored_string (get_pad_opt '_') in
+        let ignored = Ignored_string (get_padprec_opt '_') in
         Fmt_EBB (Ignored_param (ignored, fmt_rest))
       else
         let Padding_fmt_EBB (pad', fmt_rest') =
           make_padding_fmt_ebb pad fmt_rest in
         Fmt_EBB (String (pad', fmt_rest'))
     | 'S' ->
-      let pad = check_no_0 symb (get_pad ()) in
+      let pad = check_no_0 symb (get_padprec ()) in
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
       if get_ign () then
-        let ignored = Ignored_caml_string (get_pad_opt '_') in
+        let ignored = Ignored_caml_string (get_padprec_opt '_') in
         Fmt_EBB (Ignored_param (ignored, fmt_rest))
       else
         let Padding_fmt_EBB (pad', fmt_rest') =
@@ -2074,8 +2160,31 @@ let fmt_ebb_of_string ?legacy_behavior str =
         let ignored = Ignored_int (iconv, get_pad_opt '_') in
         Fmt_EBB (Ignored_param (ignored, fmt_rest))
       else
+	(* %5.3d is accepted and meaningful: pad to length 5 with
+	   spaces, but first pad with zeros upto length 3 (0-padding
+	   is the interpretation of "precision" for integer formats).
+
+           %05.3d is redundant: pad to length 5 *with zeros*, but
+           first pad with zeros... To add insult to the injury, the
+           legacy implementation ignores the 0-padding indication and
+           does the 5 padding with spaces instead. We reuse this
+           interpretation for compatiblity, but statically reject this
+           format when the legacy mode is disabled, to protect strict
+           users from this corner case.
+	 *)
+        let pad = match get_pad (), get_prec () with
+          | pad, No_precision -> pad
+          | No_padding, _     -> No_padding
+          | Lit_padding (Zeros, n), _ ->
+            if legacy_behavior then Lit_padding (Right, n)
+            else incompatible_flag pct_ind str_ind '0' "precision"
+          | Arg_padding Zeros, _ ->
+            if legacy_behavior then Arg_padding Right
+            else incompatible_flag pct_ind str_ind '0' "precision"
+          | Lit_padding _ as pad, _ -> pad
+          | Arg_padding _ as pad, _ -> pad in
         let Padprec_fmt_EBB (pad', prec', fmt_rest') =
-          make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
+          make_padprec_fmt_ebb pad (get_prec ()) fmt_rest in
         Fmt_EBB (Int (iconv, pad', prec', fmt_rest'))
     | 'N' ->
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
@@ -2315,7 +2424,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
   fun str_ind end_ind ->
     let next_ind, formatting_lit =
       try
-        if str_ind = end_ind || str.[str_ind] <> '<' then raise Not_found; 
+        if str_ind = end_ind || str.[str_ind] <> '<' then raise Not_found;
         let str_ind_1 = parse_spaces (str_ind + 1) end_ind in
         match str.[str_ind_1] with
         | '0' .. '9' | '-' -> (
@@ -2563,24 +2672,24 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | _, true, _, 'x' when legacy_behavior -> Int_Cx
     | _, true, _, 'X' when legacy_behavior -> Int_CX
     | _, true, _, 'o' when legacy_behavior -> Int_Co
-    | _, true, _, _ ->
+    | _, true, _, ('d' | 'i' | 'u') ->
       if legacy_behavior then (* ignore *)
         compute_int_conv pct_ind str_ind plus false space symb
       else incompatible_flag pct_ind str_ind symb "'#'"
-    | true, false, true, _ ->
+    | true, _, true, _ ->
       if legacy_behavior then
         (* plus and space: legacy implementation prefers plus *)
         compute_int_conv pct_ind str_ind plus sharp false symb
       else incompatible_flag pct_ind str_ind ' ' "'+'"
-    | false, false, true, _    ->
+    | false, _, true, _    ->
       if legacy_behavior then (* ignore *)
         compute_int_conv pct_ind str_ind plus sharp false symb
       else incompatible_flag pct_ind str_ind symb "' '"
-    | true, false, false, _    ->
+    | true, _, false, _    ->
       if legacy_behavior then (* ignore *)
         compute_int_conv pct_ind str_ind false sharp space symb
       else incompatible_flag pct_ind str_ind symb "'+'"
-    | false, false, false, _ -> assert false
+    | false, _, false, _ -> assert false
 
   (* Convert (plus, symb) to its associated float_conv. *)
   and compute_float_conv pct_ind str_ind plus space symb =

stdlib/camlinternalFormatBasics.ml

@@ -410,6 +410,9 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
   | Scan_get_counter :                                       (* %[nlNL] *)
       counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
         (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  | Scan_next_char :                                         (* %0c *)
+      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
   | Ignored_param :                                          (* %_ *)
       ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt ->
         ('a, 'b, 'c, 'd, 'e, 'f) fmt
@@ -453,6 +456,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
       pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
   | Ignored_scan_get_counter :                               (* %_[nlNL] *)
       counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_scan_next_char :                                 (* %_0c *)
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
 
 and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
   Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
@@ -602,6 +607,8 @@ fun fmt1 fmt2 -> match fmt1 with
     Scan_char_set (width_opt, char_set, concat_fmt rest fmt2)
   | Scan_get_counter (counter, rest) ->
     Scan_get_counter (counter, concat_fmt rest fmt2)
+  | Scan_next_char (rest) ->
+    Scan_next_char (concat_fmt rest fmt2)
   | Ignored_param (ign, rest) ->
     Ignored_param (ign, concat_fmt rest fmt2)
 

stdlib/camlinternalFormatBasics.mli

@@ -225,6 +225,11 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
 | Scan_get_counter :                                       (* %[nlNL] *)
     counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
       (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+| Scan_next_char :                                         (* %0c *)
+    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+    (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+  (* %0c behaves as %c for printing, but when scanning it does not
+     consume the character from the input stream *)
 | Ignored_param :                                          (* %_ *)
     ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt ->
       ('a, 'b, 'c, 'd, 'e, 'f) fmt
@@ -265,6 +270,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
       pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
   | Ignored_scan_get_counter :
       counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+  | Ignored_scan_next_char :
+      ('a, 'b, 'c, 'd, 'd, 'a) ignored
 
 and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
   Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string

stdlib/camlinternalMod.ml

@@ -67,5 +67,4 @@ let rec update_mod shape o n =
       for i = 0 to Array.length comps - 1 do
         update_mod comps.(i) (Obj.field o i) (Obj.field n i)
       done
-  | Value v ->
+  | Value v -> () (* the value is already there *)
-      overwrite o n

stdlib/filename.mli

@@ -117,7 +117,8 @@ val set_temp_dir_name : string -> unit
     @since 4.00.0
 *)
 
-val temp_dir_name : string [@@ocaml.deprecated]
+val temp_dir_name : string
+  [@@ocaml.deprecated "Use Filename.get_temp_dir_name instead"]
 (** The name of the initial temporary directory:
     Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
     if the variable is not set.

stdlib/format.mli

@@ -724,7 +724,7 @@ val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a
   use regular calls to [Format.fprintf] on formatter [to_b]. *)
 
 val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use Format.ksprintf instead."]
 ;;
 (** @deprecated An alias for [ksprintf]. *)
 
@@ -734,7 +734,7 @@ val set_all_formatter_output_functions :
   newline:(unit -> unit) ->
   spaces:(int -> unit) ->
   unit
-[@@ocaml.deprecated]
+[@@ocaml.deprecated "Use Format.set_formatter_out_functions instead."]
 ;;
 (** @deprecated Subsumed by [set_formatter_out_functions].
 *)
@@ -745,14 +745,14 @@ val get_all_formatter_output_functions :
   (unit -> unit) *
   (unit -> unit) *
   (int -> unit)
-[@@ocaml.deprecated]
+[@@ocaml.deprecated "Use Format.get_formatter_out_functions instead."]
 ;;
 (** @deprecated Subsumed by [get_formatter_out_functions].
 *)
 val pp_set_all_formatter_output_functions :
   formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
   newline:(unit -> unit) -> spaces:(int -> unit) -> unit
-[@@ocaml.deprecated]
+[@@ocaml.deprecated "Use Format.pp_set_formatter_out_functions instead."]
 ;;
 (** @deprecated Subsumed by [pp_set_formatter_out_functions].
 *)
@@ -761,7 +761,7 @@ val pp_get_all_formatter_output_functions :
   formatter -> unit ->
   (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
   (int -> unit)
-[@@ocaml.deprecated]
+[@@ocaml.deprecated "Use Format.pp_get_formatter_out_functions instead."]
 ;;
 (** @deprecated Subsumed by [pp_get_formatter_out_functions].
 *)

stdlib/lazy.mli

@@ -75,11 +75,14 @@ val is_val : 'a t -> bool;;
     did not raise an exception.
     @since 4.00.0 *)
 
-val lazy_from_fun : (unit -> 'a) -> 'a t [@@ocaml.deprecated];;
+val lazy_from_fun : (unit -> 'a) -> 'a t
+  [@@ocaml.deprecated "Use Lazy.from_fun instead."];;
 (** @deprecated synonym for [from_fun]. *)
 
-val lazy_from_val : 'a -> 'a t [@@ocaml.deprecated];;
+val lazy_from_val : 'a -> 'a t
+  [@@ocaml.deprecated "Use Lazy.from_val instead."];;
 (** @deprecated synonym for [from_val]. *)
 
-val lazy_is_val : 'a t -> bool [@@ocaml.deprecated];;
+val lazy_is_val : 'a t -> bool
+  [@@ocaml.deprecated "Use Lazy.is_val instead."];;
 (** @deprecated synonym for [is_val]. *)

stdlib/obj.mli

@@ -47,7 +47,8 @@ val string_tag : int   (* both [string] and [bytes] *)
 val double_tag : int
 val double_array_tag : int
 val custom_tag : int
-val final_tag : int [@@ocaml.deprecated]
+val final_tag : int
+  [@@ocaml.deprecated "Replaced by custom_tag."]
 
 val int_tag : int
 val out_of_heap_tag : int
@@ -60,5 +61,7 @@ val extension_slot : 'a -> t
 (** The following two functions are deprecated.  Use module {!Marshal}
     instead. *)
 
-val marshal : t -> bytes [@@ocaml.deprecated]
+val marshal : t -> bytes
-val unmarshal : bytes -> int -> t * int [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use Marshal.to_bytes instead."]
+val unmarshal : bytes -> int -> t * int
+  [@@ocaml.deprecated "Use Marshal.from_bytes and Marshal.total_size instead."]

stdlib/pervasives.mli

@@ -130,7 +130,7 @@ external ( && ) : bool -> bool -> bool = "%sequand"
    [e2] is not evaluated at all. *)
 
 external ( & ) : bool -> bool -> bool = "%sequand"
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use (&&) instead."]
 (** @deprecated {!Pervasives.( && )} should be used instead. *)
 
 external ( || ) : bool -> bool -> bool = "%sequor"
@@ -139,7 +139,7 @@ external ( || ) : bool -> bool -> bool = "%sequor"
    [e2] is not evaluated at all. *)
 
 external ( or ) : bool -> bool -> bool = "%sequor"
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use (||) instead."]
 (** @deprecated {!Pervasives.( || )} should be used instead.*)
 
 (** {6 Debugging} *)

stdlib/printf.mli

@@ -92,7 +92,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
      sign if positive.
    - space: for signed numerical conversions, prefix number with a
      space if positive.
-   - [#]: request an alternate formatting style for numbers.
+   - [#]: request an alternate formatting style for the hexadecimal
+     and octal integer types ([x], [X], [o], [lx], [lX], [lo], [Lx],
+     [LX], [Lo]).
 
    The optional [width] is an integer indicating the minimal
    width of the result. For instance, [%6d] prints an integer,

stdlib/scanf.ml

@@ -1032,6 +1032,7 @@ fun k fmt -> match fmt with
 
   | Scan_char_set (_, _, rest)       -> take_format_readers k rest
   | Scan_get_counter (_, rest)       -> take_format_readers k rest
+  | Scan_next_char rest              -> take_format_readers k rest
 
   | Formatting_lit (_, rest)         -> take_format_readers k rest
   | Formatting_gen (Open_tag (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest)
@@ -1096,6 +1097,7 @@ fun k ign fmt -> match ign with
   | Ignored_format_subst (_, fmtty) -> take_fmtty_format_readers k fmtty fmt
   | Ignored_scan_char_set _         -> take_format_readers k fmt
   | Ignored_scan_get_counter _      -> take_format_readers k fmt
+  | Ignored_scan_next_char          -> take_format_readers k fmt
 
 (******************************************************************************)
                           (* Generic scanning *)
@@ -1225,6 +1227,9 @@ fun ib fmt readers -> match fmt with
   | Scan_get_counter (counter, rest) ->
     let count = get_counter ib counter in
     Cons (count, make_scanf ib rest readers)
+  | Scan_next_char rest ->
+    let c = Scanning.checked_peek_char ib in
+    Cons (c, make_scanf ib rest readers)
 
   | Formatting_lit (formatting_lit, rest) ->
     String.iter (check_char ib) (string_of_formatting_lit formatting_lit);

stdlib/sort.mli

@@ -20,13 +20,13 @@
 *)
 
 val list : ('a -> 'a -> bool) -> 'a list -> 'a list
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use List.sort instead."]
 (** Sort a list in increasing order according to an ordering predicate.
    The predicate should return [true] if its first argument is
    less than or equal to its second argument. *)
 
 val array : ('a -> 'a -> bool) -> 'a array -> unit
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use Array.sort instead."]
 (** Sort an array in increasing order according to an
    ordering predicate.
    The predicate should return [true] if its first argument is
@@ -34,7 +34,7 @@ val array : ('a -> 'a -> bool) -> 'a array -> unit
    The array is sorted in place. *)
 
 val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use List.merge instead."]
 (** Merge two lists according to the given predicate.
    Assuming the two argument lists are sorted according to the
    predicate, [merge] returns a sorted list containing the elements

stdlib/string.mli

@@ -57,7 +57,7 @@ external get : string -> int -> char = "%string_safe_get"
 
 
 external set : bytes -> int -> char -> unit = "%string_safe_set"
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use Bytes.set instead."]
 (** [String.set s n c] modifies byte sequence [s] in place,
    replacing the byte at index [n] with [c].
    You can also write [s.[n] <- c] instead of [String.set s n c].
@@ -66,7 +66,8 @@ external set : bytes -> int -> char -> unit = "%string_safe_set"
 
    @deprecated This is a deprecated alias of {!Bytes.set}.[ ] *)
 
-external create : int -> bytes = "caml_create_string" [@@ocaml.deprecated]
+external create : int -> bytes = "caml_create_string"
+  [@@ocaml.deprecated "Use Bytes.create instead."]
 (** [String.create n] returns a fresh byte sequence of length [n].
    The sequence is uninitialized and contains arbitrary bytes.
 
@@ -104,7 +105,8 @@ val sub : string -> int -> int -> string
    Raise [Invalid_argument] if [start] and [len] do not
    designate a valid substring of [s]. *)
 
-val fill : bytes -> int -> int -> char -> unit [@@ocaml.deprecated]
+val fill : bytes -> int -> int -> char -> unit
+  [@@ocaml.deprecated "Use Bytes.fill instead."]
 (** [String.fill s start len c] modifies byte sequence [s] in place,
    replacing [len] bytes with [c], starting at [start].
 

stdlib/stringLabels.mli

@@ -23,22 +23,23 @@ external get : string -> int -> char = "%string_safe_get"
    Raise [Invalid_argument] if [n] not a valid index in [s]. *)
 
 external set : bytes -> int -> char -> unit = "%string_safe_set"
-  [@@ocaml.deprecated]
+  [@@ocaml.deprecated "Use BytesLabels.set instead."]
 (** [String.set s n c] modifies byte sequence [s] in place,
    replacing the byte at index [n] with [c].
    You can also write [s.[n] <- c] instead of [String.set s n c].
 
    Raise [Invalid_argument] if [n] is not a valid index in [s].
 
-   @deprecated This is a deprecated alias of {!Bytes.set}. *)
+   @deprecated This is a deprecated alias of {!BytesLabels.set}. *)
 
-external create : int -> bytes = "caml_create_string" [@@ocaml.deprecated]
+external create : int -> bytes = "caml_create_string"
+  [@@ocaml.deprecated "Use BytesLabels.create instead."]
 (** [String.create n] returns a fresh byte sequence of length [n].
    The sequence is uninitialized and contains arbitrary bytes.
 
    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
 
-   @deprecated This is a deprecated alias of {!Bytes.create}. *)
+   @deprecated This is a deprecated alias of {!BytesLabels.create}. *)
 
 val make : int -> char -> string
 (** [String.make n c] returns a fresh string of length [n],
@@ -63,14 +64,15 @@ val sub : string -> pos:int -> len:int -> string
    Raise [Invalid_argument] if [start] and [len] do not
    designate a valid substring of [s]. *)
 
-val fill : bytes -> pos:int -> len:int -> char -> unit [@@ocaml.deprecated]
+val fill : bytes -> pos:int -> len:int -> char -> unit
+  [@@ocaml.deprecated "Use BytesLabels.fill instead."]
 (** [String.fill s start len c] modifies byte sequence [s] in place,
    replacing [len] bytes by [c], starting at [start].
 
    Raise [Invalid_argument] if [start] and [len] do not
    designate a valid substring of [s].
 
-   @deprecated This is a deprecated alias of {!Bytes.fill}. *)
+   @deprecated This is a deprecated alias of {!BytesLabels.fill}. *)
 
 val blit :
   src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int

testsuite/tests/lib-dynlink-native/Makefile

@@ -49,7 +49,7 @@ run:
 
 main$(EXE): api.cmx main.cmx
 	@$(OCAMLOPT) -thread -o main$(EXE) -linkall unix.cmxa threads.cmxa \
-	             dynlink.cmxa api.cmx main.cmx $(PTHREAD_LINK)
+	             dynlink.cmxa api.cmx main.cmx
 
 main_ext$(EXE): api.cmx main.cmx factorial.$(O)
 	@$(OCAMLOPT) -o main_ext$(EXE) dynlink.cmxa api.cmx main.cmx \

testsuite/tests/lib-format/Makefile

@@ -10,11 +10,8 @@
 #                                                                       #
 #########################################################################
 
-MAIN_MODULE=tformat
-ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
-ADD_MODULES=testing
-
 BASEDIR=../..
+MODULES=testing
 
-include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/lib-format/tformat.ml

@@ -31,6 +31,7 @@ try
   test (sprintf "% d/% i" 42 43 = " 42/ 43");
   test (sprintf "%#d/%#i" 42 43 = "42/43");
   test (sprintf "%4d/%5i" 42 43 = "  42/   43");
+  test (sprintf "%*d" (-4) 42 = "42  ");
   test (sprintf "%*d/%*i" 4 42 5 43 = "  42/   43");
   test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43  ");
 
@@ -42,6 +43,7 @@ try
   test (sprintf "% d/% i" (-42) (-43) = "-42/-43");
   test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");
   test (sprintf "%4d/%5i" (-42) (-43) = " -42/  -43");
+  test (sprintf "%*d" (-4) (-42) = "-42 ");
   test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/  -43");
   test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43  ");
 
@@ -54,7 +56,7 @@ try
   test (sprintf "%#u" 42 = "42");
   test (sprintf "%4u" 42 = "  42");
   test (sprintf "%*u" 4 42 = "  42");
-  test (sprintf "%-0+ #6d" 42 = "+42   ");
+  test (sprintf "%*u" (-4) 42 = "42  ");
 
   say "\nu negative\n%!";
   begin match Sys.word_size with
@@ -74,6 +76,10 @@ try
   test (sprintf "%#x" 42 = "0x2a");
   test (sprintf "%4x" 42 = "  2a");
   test (sprintf "%*x" 5 42 = "   2a");
+  test (sprintf "%*x" (-5) 42 = "2a   ");
+  test (sprintf "%#*x" 5 42 = " 0x2a");
+  test (sprintf "%#*x" (-5) 42 = "0x2a ");
+  test (sprintf "%#-*x" 5 42 = "0x2a ");
   test (sprintf "%-0+ #*x" 5 42 = "0x2a ");
 
   say "\nx negative\n%!";
@@ -135,6 +141,7 @@ try
   test (sprintf "%5s" "foo" = "  foo");
   test (sprintf "%1s" "foo" = "foo");
   test (sprintf "%*s" 6 "foo" = "   foo");
+  test (sprintf "%*s" (-6) "foo" = "foo   ");
   test (sprintf "%*s" 2 "foo" = "foo");
   test (sprintf "%-0+ #5s" "foo" = "foo  ");
   test (sprintf "%s@@" "foo" = "foo@");
@@ -143,16 +150,19 @@ try
 
   say "\nS\n%!";
   test (sprintf "%S" "fo\"o" = "\"fo\\\"o\"");
-(*  test (sprintf "%-5S" "foo" = "\"foo\"  ");   padding not done *)
+  test (sprintf "%-7S" "foo" = "\"foo\"  ");
-(*  test (sprintf "%05S" "foo" = "  \"foo\"");   padding not done *)
+(*  test (sprintf "%07S" "foo" = "  \"foo\""); *)
+  (* %S is incompatible with '0' *)
   test (sprintf "%+S" "foo" = "\"foo\"");
   test (sprintf "% S" "foo" = "\"foo\"");
   test (sprintf "%#S" "foo" = "\"foo\"");
-(*  test (sprintf "%5S" "foo" = "  \"foo\"");    padding not done *)
+  test (sprintf "%7S" "foo" = "  \"foo\"");
   test (sprintf "%1S" "foo" = "\"foo\"");
-(*  test (sprintf "%*S" 6 "foo" = "   \"foo\"");  padding not done *)
+  test (sprintf "%*S" 8 "foo" = "   \"foo\"");
+  test (sprintf "%*S" (-8) "foo" = "\"foo\"   ");
   test (sprintf "%*S" 2 "foo" = "\"foo\"");
 (*  test (sprintf "%-0+ #5S" "foo" = "\"foo\"  ");  padding not done *)
+  (* %S is incompatible with '0','+' and ' ' *)
   test (sprintf "%S@@" "foo" = "\"foo\"@");
   test (sprintf "%S@@inria.fr" "foo" = "\"foo\"@inria.fr");
   test (sprintf "%S@@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\"");
@@ -229,7 +239,13 @@ try
   test (sprintf "%F" 42.42e42 =* "4.242e+43");
   test (sprintf "%F" 42.00 = "42.");
   test (sprintf "%F" 0.042 = "0.042");
-(* no padding, no precision
+  test (sprintf "%4F" 3. = "  3.");
+  test (sprintf "%-4F" 3. = "3.  ");
+  test (sprintf "%04F" 3. = "003.");
+(* plus-padding unsupported
+  test (sprintf "%+4F" 3. = " +3.");
+*)
+(* no precision
   test (sprintf "%.3F" 42.42 = "42.420");
   test (sprintf "%12.3F" 42.42e42 = "   4.242e+43");
   test (sprintf "%.3F" 42.00 = "42.000");
@@ -297,6 +313,8 @@ try
   say "\nB\n%!";
   test (sprintf "%B" true = "true");
   test (sprintf "%B" false = "false");
+ (* test (sprintf "%8B" false = "   false"); *)
+  (* padding not done *)
 
   say "\nld/li positive\n%!";
   test (sprintf "%ld/%li" 42l 43l = "42/43");
@@ -485,8 +503,8 @@ try
   test (sprintf "@@" = "@");
   test (sprintf "@@@@" = "@@");
   test (sprintf "@@%%" = "@%");
-
   say "\nend of tests\n%!";
+
 with e ->
   say "unexpected exception: %s\n%!" (Printexc.to_string e);
   test false;

testsuite/tests/lib-format/tformat.reference

@@ -1,91 +1,91 @@
 d/i positive
- 0 1 2 3 4 5 6 7 8
+ 0 1 2 3 4 5 6 7 8 9
 d/i negative
- 9 10 11 12 13 14 15 16 17
+ 10 11 12 13 14 15 16 17 18 19
 u positive
- 18 19 20 21 22 23 24 25 26
+ 20 21 22 23 24 25 26 27 28
 u negative
- 27
+ 29
 x positive
- 28 29 30 31 32 33 34 35 36
+ 30 31 32 33 34 35 36 37 38 39 40 41 42
 x negative
- 37
+ 43
 X positive
- 38 39 40 41 42 43 44 45 46
+ 44 45 46 47 48 49 50 51 52
 x negative
- 47
+ 53
 o positive
- 48 49 50 51 52 53 54 55 56
+ 54 55 56 57 58 59 60 61 62
 o negative
- 57
+ 63
 s
- 58 59 60 61 62 63 64 65 66 67 68 69 70 71
+ 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
 S
- 72 73 74 75 76 77 78 79 80
+ 79 80 81 82 83 84 85 86 87 88 89 90 91
 c
- 81 82 83 84
+ 92 93 94 95
 C
- 85 86 87 88 89
+ 96 97 98 99 100
 f
- 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
+ 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
 F
- 108 109 110 111
+ 119 120 121 122 123 124 125
 e
- 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
+ 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
 E
- 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
+ 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
 B
- 148 149
+ 162 163
 ld/li positive
- 150 151 152 153 154 155 156 157 158
+ 164 165 166 167 168 169 170 171 172
 ld/li negative
- 159 160 161 162 163 164 165 166 167
+ 173 174 175 176 177 178 179 180 181
 lu positive
- 168 169 170 171 172 173 174 175 176
+ 182 183 184 185 186 187 188 189 190
 lu negative
- 177
+ 191
 lx positive
- 178 179 180 181 182 183 184 185 186
+ 192 193 194 195 196 197 198 199 200
 lx negative
- 187
+ 201
 lX positive
- 188 189 190 191 192 193 194 195 196
+ 202 203 204 205 206 207 208 209 210
 lx negative
- 197
+ 211
 lo positive
- 198 199 200 201 202 203 204 205 206
+ 212 213 214 215 216 217 218 219 220
 lo negative
- 207
+ 221
 Ld/Li positive
- 208 209 210 211 212 213 214 215 216
+ 222 223 224 225 226 227 228 229 230
 Ld/Li negative
- 217 218 219 220 221 222 223 224 225
+ 231 232 233 234 235 236 237 238 239
 Lu positive
- 226 227 228 229 230 231 232 233 234
+ 240 241 242 243 244 245 246 247 248
 Lu negative
- 235
+ 249
 Lx positive
- 236 237 238 239 240 241 242 243 244
+ 250 251 252 253 254 255 256 257 258
 Lx negative
- 245
+ 259
 LX positive
- 246 247 248 249 250 251 252 253 254
+ 260 261 262 263 264 265 266 267 268
 Lx negative
- 255
-Lo positive
- 256 257 258 259 260 261 262 263 264
-Lo negative
- 265
-a
- 266
-t
- 267
-{...%}
- 268
-(...%)
  269
+Lo positive
+ 270 271 272 273 274 275 276 277 278
+Lo negative
+ 279
+a
+ 280
+t
+ 281
+{...%}
+ 282
+(...%)
+ 283
 ! % @ , and constants
- 270 271 272 273 274 275 276
+ 284 285 286 287 288 289 290
 end of tests
 
 All tests succeeded.

testsuite/tests/lib-printf/Makefile

@@ -10,11 +10,8 @@
 #                                                                       #
 #########################################################################
 
-#MODULES=
+MODULES=testing
-MAIN_MODULE=tprintf
-ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
-ADD_MODULES=testing
-
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.one
+
+include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/lib-printf/pr6534.ml

@@ -0,0 +1,19 @@
+(* these are not valid under -strict-formats, but we test them here
+   for backward-compatibility *)
+open Printf
+
+let () =
+  printf "1 [%.5s]\n" "foo";
+  printf "2 [%.*s]\n" 5 "foo";
+  printf "3 [%.-5s]\n" "foo";
+  printf "4 [%-.5s]\n" "foo";
+  printf "5 [%-.*s]\n" 5 "foo";
+  printf "6 [%.*s]\n" (-5) "foo";
+
+  printf "1 [%.7S]\n" "foo";
+  printf "2 [%.*S]\n" 7 "foo";
+  printf "3 [%.-7S]\n" "foo";
+  printf "4 [%-.7S]\n" "foo";
+  printf "5 [%-.*S]\n" 7 "foo";
+  printf "6 [%.*S]\n" (-7) "foo";
+  ()

testsuite/tests/lib-printf/pr6534.reference

@@ -0,0 +1,14 @@
+1 [  foo]
+2 [  foo]
+3 [foo  ]
+4 [foo  ]
+5 [foo  ]
+6 [foo  ]
+1 [  "foo"]
+2 [  "foo"]
+3 ["foo"  ]
+4 ["foo"  ]
+5 ["foo"  ]
+6 ["foo"  ]
+
+All tests succeeded.

testsuite/tests/lib-printf/tprintf.ml

@@ -30,6 +30,7 @@ try
   (*test (sprintf "%#d/%#i" 42 43 = "42/43");*)
     (* >> '#' is incompatible with 'd' *)
   test (sprintf "%4d/%5i" 42 43 = "  42/   43");
+  test (sprintf "%*d" (-4) 42 = "42  ");
   test (sprintf "%*d/%*i" 4 42 5 43 = "  42/   43");
   (*test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43  ");*)
     (* >> '#' is incompatible with 'd' *)
@@ -43,6 +44,7 @@ try
   (*test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");*)
     (* >> '#' is incompatible with 'd' *)
   test (sprintf "%4d/%5i" (-42) (-43) = " -42/  -43");
+  test (sprintf "%*d" (-4) (-42) = "-42 ");
   test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/  -43");
   (*test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43  ");*)
     (* >> '0' is incompatible with '-', '#' is incompatible with 'd' *)
@@ -59,8 +61,7 @@ try
     (* >> '#' is incompatible with 'u' *)
   test (sprintf "%4u" 42 = "  42");
   test (sprintf "%*u" 4 42 = "  42");
-  (*test (sprintf "%-0+ #6d" 42 = "+42   ");*)
+  test (sprintf "%*u" (-4) 42 = "42  ");
-    (* >> '-' is incompatible with '0', '#' is incompatible with 'd' *)
 
   printf "\nu negative\n%!";
   begin match Sys.word_size with
@@ -82,8 +83,11 @@ try
   test (sprintf "%#x" 42 = "0x2a");
   test (sprintf "%4x" 42 = "  2a");
   test (sprintf "%*x" 5 42 = "   2a");
-  (*test (sprintf "%-0+ #*x" 5 42 = "0x2a ");*)
+  test (sprintf "%*x" (-5) 42 = "2a   ");
-    (* >> '-' is incompatible with '0' *)
+  test (sprintf "%#*x" 5 42 = " 0x2a");
+  test (sprintf "%#*x" (-5) 42 = "0x2a ");
+  test (sprintf "%#-*x" 5 42 = "0x2a ");
+  test (sprintf "%-0+ #*x" 5 42 = "0x2a ");
 
   printf "\nx negative\n%!";
   begin match Sys.word_size with
@@ -154,6 +158,7 @@ try
   test (sprintf "%5s" "foo" = "  foo");
   test (sprintf "%1s" "foo" = "foo");
   test (sprintf "%*s" 6 "foo" = "   foo");
+  test (sprintf "%*s" (-6) "foo" = "foo   ");
   test (sprintf "%*s" 2 "foo" = "foo");
   (*test (sprintf "%-0+ #5s" "foo" = "foo  ");*)
     (* >> '-' is incompatible with '0', '#' is incompatible with 's' *)
@@ -173,7 +178,8 @@ try
     (* >> '#' is incompatible with 'S' *)
 (*  test (sprintf "%5S" "foo" = "  \"foo\"");    padding not done *)
   test (sprintf "%1S" "foo" = "\"foo\"");
-(*  test (sprintf "%*S" 6 "foo" = "   \"foo\"");  padding not done *)
+  test (sprintf "%*S" 8 "foo" = "   \"foo\"");
+  test (sprintf "%*S" (-8) "foo" = "\"foo\"   ");
   test (sprintf "%*S" 2 "foo" = "\"foo\"");
 (*  test (sprintf "%-0+ #5S" "foo" = "\"foo\"  ");  padding not done *)
   test (sprintf "%S@" "foo" = "\"foo\"@");
@@ -222,6 +228,11 @@ try
   (*test (sprintf "%-0+ #12f" 42.42 = "+42.420000  ");*)
     (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *)
   test (sprintf "%.3f" (-42.42) = "-42.420");
+  test (sprintf "%.*f" (-3) 42.42 = "42.420");
+    (* dynamically-provided negative precisions are currently silently
+       turned into their absolute value; we could error on this
+       in the future (the behavior is unspecified), but the previous
+       buggy output "%.0-3f-" is not desirable. *)
   test (sprintf "%-13.3f" (-42.42) = "-42.420      ");
   test (sprintf "%013.3f" (-42.42) = "-00000042.420");
   test (sprintf "%+.3f" 42.42 = "+42.420");
@@ -262,7 +273,13 @@ try
   test (sprintf "%F" 42.42e42 =* "4.242e+43");
   test (sprintf "%F" 42.00 = "42.");
   test (sprintf "%F" 0.042 = "0.042");
-(* no padding, no precision
+  test (sprintf "%4F" 3. = "  3.");
+  test (sprintf "%-4F" 3. = "3.  ");
+  test (sprintf "%04F" 3. = "003.");
+(* plus-padding unsupported
+  test (sprintf "%+4F" 3. = " +3.");
+*)
+(* no precision
   test (sprintf "%.3F" 42.42 = "42.420");
   test (sprintf "%12.3F" 42.42e42 = "   4.242e+43");
   test (sprintf "%.3F" 42.00 = "42.000");

testsuite/tests/lib-printf/tprintf.reference

@@ -1,91 +1,91 @@
 d/i positive
- 0 1 2 3 4 5 6
+ 0 1 2 3 4 5 6 7
 d/i negative
- 7 8 9 10 11 12 13
+ 8 9 10 11 12 13 14 15
 u positive
- 14 15 16 17 18
+ 16 17 18 19 20 21
 u negative
- 19
+ 22
 x positive
- 20 21 22 23 24 25
+ 23 24 25 26 27 28 29 30 31 32 33
 x negative
- 26
+ 34
 X positive
- 27 28 29 30 31 32
+ 35 36 37 38 39 40
 x negative
- 33
+ 41
 o positive
- 34 35 36 37 38 39
+ 42 43 44 45 46 47
 o negative
- 40
+ 48
 s
- 41 42 43 44 45 46 47 48 49
+ 49 50 51 52 53 54 55 56 57 58
 S
- 50 51 52 53 54 55
+ 59 60 61 62 63 64 65 66
 c
- 56
+ 67
 C
- 57 58
+ 68 69
 f
- 59 60 61 62 63 64 65 66 67 68 69 70 71 72
+ 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
 F
- 73 74 75 76
+ 85 86 87 88 89 90 91
 e
- 77 78 79 80 81 82 83 84 85 86 87 88 89 90
+ 92 93 94 95 96 97 98 99 100 101 102 103 104 105
 E
- 91 92 93 94 95 96 97 98 99 100 101 102 103 104
+ 106 107 108 109 110 111 112 113 114 115 116 117 118 119
 B
- 105 106
+ 120 121
 ld/li positive
- 107 108 109 110 111 112 113
+ 122 123 124 125 126 127 128
 ld/li negative
- 114 115 116 117 118 119 120
+ 129 130 131 132 133 134 135
 lu positive
- 121 122 123 124 125
+ 136 137 138 139 140
 lu negative
- 126
+ 141
 lx positive
- 127 128 129 130 131 132
+ 142 143 144 145 146 147
 lx negative
- 133
+ 148
 lX positive
- 134 135 136 137 138 139
+ 149 150 151 152 153 154
 lx negative
- 140
+ 155
 lo positive
- 141 142 143 144 145 146
+ 156 157 158 159 160 161
 lo negative
- 147
+ 162
 Ld/Li positive
- 148 149 150 151 152
+ 163 164 165 166 167
 Ld/Li negative
- 153 154 155 156 157
+ 168 169 170 171 172
 Lu positive
- 158 159 160 161 162
+ 173 174 175 176 177
 Lu negative
- 163
+ 178
 Lx positive
- 164 165 166 167 168 169
+ 179 180 181 182 183 184
 Lx negative
- 170
-LX positive
- 171 172 173 174 175 176
-Lx negative
- 177
-Lo positive
- 178 179 180 181 182 183
-Lo negative
- 184
-a
  185
+LX positive
+ 186 187 188 189 190 191
+Lx negative
+ 192
+Lo positive
+ 193 194 195 196 197 198
+Lo negative
+ 199
+a
+ 200
 t
- 186
+ 201
 {...%}
- 187
+ 202
 (...%)
- 188
+ 203
 ! % @ , and constants
- 189 190 191 192 193 194 195
+ 204 205 206 207 208 209 210
 end of tests
 
 All tests succeeded.

testsuite/tests/lib-scanf/tscanf.ml

@@ -1439,6 +1439,8 @@ let test58 () =
 test (test58 ())
 ;;
 
+(* skip test number "59" which is commented below *)
+let () = test (true);;
 (*
 let test59 () =
 ;;
@@ -1470,3 +1472,15 @@ let scan_record scan_field ib =
 let scan_field ib =
   bscanf ib "%s = %[^;]" (fun finame ficont -> finame, ficont);;
 *)
+
+(* testing formats that do not consume their input *)
+let test60 () =
+  sscanf "abc" "%0c%0c%c%n" (fun c1 c2 c3 n ->
+    c1 = 'a' && c2 = 'a' && c3 = 'a' && n = 1)
+  &&
+  sscanf "abc" "%0s%s" (fun s1 s2 -> s1 = "" && s2 = "abc")
+  &&
+  sscanf "abc" "%1s%s" (fun s1 s2 -> s1 = "a" && s2 = "bc")
+;;
+
+test (test60 ());

testsuite/tests/lib-scanf/tscanf.reference

@@ -1,2 +1,2 @@
- 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
 All tests succeeded.

testsuite/tests/tool-debugger/basic/Makefile

@@ -10,7 +10,7 @@
 #                                                                       #
 #########################################################################
 
-BASEDIR=../..
+BASEDIR=../../..
 MAIN_MODULE=debuggee
 ADD_COMPFLAGS=-g -custom
 LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix

testsuite/tests/tool-debugger/no_debug_event/.ignore

@@ -0,0 +1,4 @@
+compiler-libs
+out
+c
+c.exe

testsuite/tests/tool-debugger/no_debug_event/Makefile

@@ -0,0 +1,57 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Damien Doligez, EPI Gallium, INRIA Rocquencourt            #
+#                                                                       #
+#   Copyright 2013 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../../..
+ADD_COMPFLAGS=-g -custom
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(MAKE) compile; \
+	  $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \
+	fi
+
+.PHONY: compile
+compile: $(ML_FILES) $(CMO_FILES)
+	@rm -f c$(EXE)
+	@$(OCAMLC) $(ADD_COMPFLAGS) -c a.ml -for-pack foo
+	@$(OCAMLC) $(ADD_COMPFLAGS) a.cmo -pack -o foo.cmo
+	@$(OCAMLC) $(ADD_COMPFLAGS) -c b.ml
+	@$(OCAMLC) $(ADD_COMPFLAGS) foo.cmo b.cmo -o c$(EXE)
+	@mkdir -p compiler-libs
+	@cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/
+
+.PHONY: run
+run:
+	@printf " ... testing with ocamlc"
+	@rm -f noev.result
+	@echo 'source input_script' | \
+	 $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \
+	             c$(EXE) >noev.raw.result 2>&1 \
+	 && sed -e '/Debugger version/d' -e '/^Time:/d' \
+	        -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \
+	        noev.raw.result >noev.result \
+	 && $(DIFF) noev.reference noev.result >/dev/null \
+	 && echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.cm* c$(EXE)
+	@rm -rf compiler-libs
+
+include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/tool-debugger/no_debug_event/a.ml

@@ -0,0 +1 @@
+let x = 1

testsuite/tests/tool-debugger/no_debug_event/b.ml

@@ -0,0 +1,3 @@
+let () =
+  print_int Foo.A.x;
+  print_newline ()

testsuite/tests/tool-debugger/no_debug_event/input_script

@@ -0,0 +1,2 @@
+run
+quit

testsuite/tests/tool-debugger/no_debug_event/noev.reference

@@ -0,0 +1,4 @@
+
+(ocd) Loading program... done.
+1
+Program exit.

testsuite/tests/typing-extensions/open_types.ml.reference

@@ -76,7 +76,9 @@ Error: Signature mismatch:
           ^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
-*extension*
+_
+Matching over values of open types must include
+a wild card pattern in order to be exhaustive.
 type foo = ..
 type foo += Foo
 val f : foo -> unit = <fun>

testsuite/tests/typing-modules-bugs/pr6572_ok.ml

@@ -0,0 +1,19 @@
+module type S = sig
+  include Set.S
+  module E : sig val x : int end
+end
+
+module Make(O : Set.OrderedType) : S with type elt = O.t =
+  struct
+    include Set.Make(O)
+    module E = struct let x = 1 end
+  end
+
+module rec A : Set.OrderedType = struct
+ type t = int
+  let compare = Pervasives.compare
+end
+and B : S = struct
+ module C = Make(A)
+ include C
+end

testsuite/tests/typing-modules/aliases.ml

@@ -235,3 +235,12 @@ module R = struct
   module Q = M
 end;;
 module R' : S = R;; (* should be ok *)
+
+(* PR#6578 *)
+
+module M = struct let f x = x end
+module rec R : sig module M : sig val f : 'a -> 'a end end =
+  struct module M = M end;;
+R.M.f 3;;
+module rec R : sig module M = M end = struct module M = M end;;
+R.M.f 3;;

testsuite/tests/typing-modules/aliases.ml.reference

@@ -382,4 +382,9 @@ module K : sig module E = B module N = E.O end
     module Q = M
   end
 # module R' : S
+#           module M : sig val f : 'a -> 'a end
+module rec R : sig module M : sig val f : 'a -> 'a end end
+# - : int = 3
+# module rec R : sig module M = M end
+# - : int = 3
 # 

testsuite/tests/typing-short-paths/short-paths.ml

@@ -46,3 +46,9 @@ module M1 = struct type u = v and v = t1 end;;
 module N1 = struct type u = v and v = M1.v end;;
 type t1 = B;;
 module N2 = struct type u = v and v = M1.v end;;
+
+
+(* PR#6566 *)
+module type PR6566 = sig type t = string end;;
+module PR6566 = struct type t = int end;;
+module PR6566' : PR6566 = PR6566;;

testsuite/tests/typing-short-paths/short-paths.ml.reference

@@ -69,4 +69,15 @@ type u = M.u = C
 # module N1 : sig type u = v and v = t1 end
 # type t1 = B
 # module N2 : sig type u = v and v = N1.v end
+#       module type PR6566 = sig type t = bytes end
+# module PR6566 : sig type t = int end
+# Characters 26-32:
+  module PR6566' : PR6566 = PR6566;;
+                            ^^^^^^
+Error: Signature mismatch:
+       Modules do not match: sig type t = int end is not included in PR6566
+       Type declarations do not match:
+         type t = int
+       is not included in
+         type t = bytes
 # 

tools/.depend

@@ -1,4 +1,4 @@
-depend.cmi : ../parsing/parsetree.cmi
+depend.cmi : ../parsing/parsetree.cmi ../parsing/longident.cmi
 profiling.cmi :
 tast_iter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi
 untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \
@@ -52,11 +52,13 @@ ocaml299to3.cmx :
 ocamlcp.cmo : ../driver/main_args.cmi
 ocamlcp.cmx : ../driver/main_args.cmx
 ocamldep.cmo : ../driver/pparse.cmi ../parsing/parsetree.cmi \
-    ../parsing/parse.cmi ../utils/misc.cmi ../parsing/location.cmi depend.cmi \
+    ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \
-    ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi
+    ../parsing/location.cmi depend.cmi ../utils/config.cmi \
+    ../driver/compenv.cmi ../utils/clflags.cmi
 ocamldep.cmx : ../driver/pparse.cmx ../parsing/parsetree.cmi \
-    ../parsing/parse.cmx ../utils/misc.cmx ../parsing/location.cmx depend.cmx \
+    ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \
-    ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx
+    ../parsing/location.cmx depend.cmx ../utils/config.cmx \
+    ../driver/compenv.cmx ../utils/clflags.cmx
 ocamlmklib.cmo : ocamlmklibconfig.cmo
 ocamlmklib.cmx : ocamlmklibconfig.cmx
 ocamlmklibconfig.cmo :

toplevel/topdirs.ml

@@ -271,6 +271,8 @@ let dir_trace ppf lid =
         (* Nothing to do if it's not a closure *)
         if Obj.is_block clos
         && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag)
+        && (match Ctype.(repr (expand_head !toplevel_env desc.val_type))
+            with {desc=Tarrow _} -> true | _ -> false)
         then begin
         match is_traced clos with
         | Some opath ->

typing/includemod.ml

@@ -61,12 +61,12 @@ let value_descriptions env cxt subst id vd1 vd2 =
 
 (* Inclusion between type declarations *)
 
-let type_declarations env cxt subst id decl1 decl2 =
+let type_declarations env ?(old_env=env) cxt subst id decl1 decl2 =
   Env.mark_type_used env (Ident.name id) decl1;
   let decl2 = Subst.type_declaration subst decl2 in
   let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in
   if err <> [] then
-    raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)])
+    raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)])
 
 (* Inclusion between extension constructors *)
 
@@ -78,19 +78,20 @@ let extension_constructors env cxt subst id ext1 ext2 =
 
 (* Inclusion between class declarations *)
 
-let class_type_declarations env cxt subst id decl1 decl2 =
+let class_type_declarations ~old_env env cxt subst id decl1 decl2 =
   let decl2 = Subst.cltype_declaration subst decl2 in
   match Includeclass.class_type_declarations env decl1 decl2 with
     []     -> ()
   | reason ->
-      raise(Error[cxt, env, Class_type_declarations(id, decl1, decl2, reason)])
+      raise(Error[cxt, old_env,
+                  Class_type_declarations(id, decl1, decl2, reason)])
 
-let class_declarations env cxt subst id decl1 decl2 =
+let class_declarations ~old_env env cxt subst id decl1 decl2 =
   let decl2 = Subst.class_declaration subst decl2 in
   match Includeclass.class_declarations env decl1 decl2 with
     []     -> ()
   | reason ->
-      raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)])
+      raise(Error[cxt, old_env, Class_declarations(id, decl1, decl2, reason)])
 
 (* Expand a module type identifier when possible *)
 
@@ -314,7 +315,7 @@ and signatures env cxt subst sig1 sig2 =
         begin match unpaired with
             [] ->
               let cc =
-                signature_components new_env cxt subst (List.rev paired)
+                signature_components env new_env cxt subst (List.rev paired)
               in
               if len1 = len2 then (* see PR#5098 *)
                 simplify_structure_coercion cc id_pos_list
@@ -363,38 +364,40 @@ and signatures env cxt subst sig1 sig2 =
 
 (* Inclusion between signature components *)
 
-and signature_components env cxt subst = function
+and signature_components old_env env cxt subst paired =
+  let comps_rec rem = signature_components old_env env cxt subst rem in
+  match paired with
     [] -> []
   | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem ->
       let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
-        Val_prim p -> signature_components env cxt subst rem
+        Val_prim p -> comps_rec rem
-      | _ -> (pos, cc) :: signature_components env cxt subst rem
+      | _ -> (pos, cc) :: comps_rec rem
       end
   | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem ->
-      type_declarations env cxt subst id1 tydecl1 tydecl2;
+      type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2;
-      signature_components env cxt subst rem
+      comps_rec rem
   | (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos)
     :: rem ->
       extension_constructors env cxt subst id1 ext1 ext2;
-      (pos, Tcoerce_none) :: signature_components env cxt subst rem
+      (pos, Tcoerce_none) :: comps_rec rem
   | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem ->
       let p1 = Pident id1 in
       let cc =
         modtypes env (Module id1::cxt) subst
           (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1)
           mty2.md_type in
-      (pos, cc) :: signature_components env cxt subst rem
+      (pos, cc) :: comps_rec rem
   | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem ->
       modtype_infos env cxt subst id1 info1 info2;
-      signature_components env cxt subst rem
+      comps_rec rem
   | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem ->
-      class_declarations env cxt subst id1 decl1 decl2;
+      class_declarations ~old_env env cxt subst id1 decl1 decl2;
-      (pos, Tcoerce_none) :: signature_components env cxt subst rem
+      (pos, Tcoerce_none) :: comps_rec rem
   | (Sig_class_type(id1, info1, _),
      Sig_class_type(id2, info2, _), pos) :: rem ->
-      class_type_declarations env cxt subst id1 info1 info2;
+      class_type_declarations ~old_env env cxt subst id1 info1 info2;
-      signature_components env cxt subst rem
+      comps_rec rem
   | _ ->
       assert false
 
@@ -545,7 +548,7 @@ let rec context ppf = function
   | Modtype id :: rem ->
       fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
   | Body x :: rem ->
-      fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
+      fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
   | Arg x :: rem ->
       fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
   | [] ->
@@ -556,11 +559,14 @@ and context_mty ppf = function
   | cxt -> context ppf cxt
 and args ppf = function
     Body x :: rem ->
-      fprintf ppf "(%a)%a" ident x args rem
+      fprintf ppf "(%s)%a" (argname x) args rem
   | Arg x :: rem ->
       fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
   | cxt ->
       fprintf ppf " :@ %a" context_mty cxt
+and argname x =
+  let s = Ident.name x in
+  if s = "*" then "" else s
 
 let path_of_context = function
     Module id :: rem ->

typing/mtype.ml

@@ -361,7 +361,9 @@ let rec remove_aliases env excl mty =
     Mty_signature sg ->
       Mty_signature (remove_aliases_sig env excl sg)
   | Mty_alias _ ->
-      remove_aliases env excl (Env.scrape_alias env mty)
+      let mty' = Env.scrape_alias env mty in
+      if mty' = mty then mty else
+      remove_aliases env excl mty'
   | mty ->
       mty
 

typing/parmatch.ml

@@ -1809,7 +1809,11 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
           None -> Total
         | Some v ->
             let errmsg =
-              try
+              match v.pat_desc with
+                Tpat_construct (_, {cstr_name="*extension*"}, _) ->
+                  "_\nMatching over values of open types must include\n\
+                   a wild card pattern in order to be exhaustive."
+              | _ -> try
                 let buf = Buffer.create 16 in
                 let fmt = formatter_of_buffer buf in
                 top_pretty fmt v;
@@ -1825,9 +1829,11 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
                 end ;
                 Buffer.contents buf
               with _ ->
-                "" in
+                ""
+            in
             Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
-            Partial end
+            Partial
+        end
     | _ ->
         fatal_error "Parmatch.check_partial"
     end

typing/typecore.ml

@@ -2947,6 +2947,8 @@ and type_format loc str env =
           mk_constr "Ignored_scan_get_counter" [
             mk_counter counter
           ]
+        | Ignored_scan_next_char ->
+          mk_constr "Ignored_scan_next_char" []
       and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
       fun pad -> match pad with
         | No_padding         -> mk_constr "No_padding" []
@@ -3012,6 +3014,8 @@ and type_format loc str env =
             mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
         | Scan_get_counter (cnt, rest) ->
           mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
+        | Scan_next_char rest ->
+          mk_constr "Scan_next_char" [ mk_fmt rest ]
         | Ignored_param (ign, rest) ->
           mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
         | End_of_format ->

utils/misc.ml

@@ -87,6 +87,22 @@ let find_in_path path name =
     in try_dir path
   end
 
+let find_in_path_rel path name =
+  let rec simplify s =
+    let open Filename in
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then simplify dir
+    else concat (simplify dir) base
+  in
+  let rec try_dir = function
+    [] -> raise Not_found
+  | dir::rem ->
+      let fullname = simplify (Filename.concat dir name) in
+      if Sys.file_exists fullname then fullname else try_dir rem
+  in try_dir path
+
 let find_in_path_uncap path name =
   let uname = String.uncapitalize name in
   let rec try_dir = function

utils/misc.mli

@@ -42,6 +42,8 @@ val may_map: ('a -> 'b) -> 'a option -> 'b option
 
 val find_in_path: string list -> string -> string
         (* Search a file in a list of directories. *)
+val find_in_path_rel: string list -> string -> string
+        (* Search a relative file in a list of directories. *)
 val find_in_path_uncap: string list -> string -> string
         (* Same, but search also for uncapitalized name, i.e.
            if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml