Merge with ocaml trunk 12778 -> 13774

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

17 files changed, 253 insertions, 52 deletions

diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index 66525e5b9e..bbc8e3f0b3 100644
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (* Compiling C files and building C libraries *)
 
 let command cmdline =
@@ -60,7 +58,7 @@ let compile_file name =
             if !Clflags.native_code
             then Config.native_c_compiler
             else Config.bytecomp_c_compiler)
-       (String.concat " " (List.rev !Clflags.ccopts))
+       (String.concat " " (List.rev !Clflags.all_ccopts))
        (quote_prefixed "-I" (List.rev !Clflags.include_dirs))
        (Clflags.std_include_flag "-I")
        (Filename.quote name))
@@ -121,7 +119,7 @@ let call_linker mode output_name files extra =
         (if !Clflags.gprofile then Config.cc_profile else "")
         ""  (*(Clflags.std_include_flag "-I")*)
         (quote_prefixed "-L" !Config.load_path)
-        (String.concat " " (List.rev !Clflags.ccopts))
+        (String.concat " " (List.rev !Clflags.all_ccopts))
         files
         extra
   in
diff --git a/utils/ccomp.mli b/utils/ccomp.mli
index 66739d2bf9..63a190c339 100644
--- a/utils/ccomp.mli
+++ b/utils/ccomp.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ccomp.mli 12858 2012-08-10 14:45:51Z maranget $ *)
-
 (* Compiling C files and building C libraries *)
 
 val command: string -> int
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 790ec84116..63630ae93d 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: clflags.ml 12959 2012-09-27 13:12:51Z maranget $ *)
-
 (* Command-line parameters *)
 
 let objfiles = ref ([] : string list)   (* .cmo and .cma files *)
@@ -28,12 +26,13 @@ and debug = ref false                   (* -g *)
 and fast = ref false                    (* -unsafe *)
 and link_everything = ref false         (* -linkall *)
 and custom_runtime = ref false          (* -custom *)
+and bytecode_compatible_32 = ref false  (* -compat-32 *)
 and output_c_object = ref false         (* -output-obj *)
-and ccopts = ref ([] : string list)     (* -ccopt *)
+and all_ccopts = ref ([] : string list)     (* -ccopt *)
 and classic = ref false                 (* -nolabels *)
 and nopervasives = ref false            (* -nopervasives *)
 and preprocessor = ref(None : string option) (* -pp *)
-and ppx = ref ([] : string list)        (* -ppx *)
+and all_ppx = ref ([] : string list)        (* -ppx *)
 let annotations = ref false             (* -annot *)
 (*> JOCAML *)
 and nojoin = ref false                  (* -nojoin *)
@@ -49,6 +48,7 @@ and init_file = ref (None : string option)   (* -init *)
 and use_prims = ref ""                  (* -use-prims ... *)
 and use_runtime = ref ""                (* -use-runtime ... *)
 and principal = ref false               (* -principal *)
+and real_paths = ref true               (* -short-paths *)
 and recursive_types = ref false         (* -rectypes *)
 and strict_sequence = ref false         (* -strict-sequence *)
 and applicative_functors = ref true     (* -no-app-funct *)
@@ -60,7 +60,9 @@ and dllpaths = ref ([] : string list)   (* -dllpath *)
 and make_package = ref false            (* -pack *)
 and for_package = ref (None: string option) (* -for-pack *)
 and error_size = ref 500                (* -error-size *)
+let dump_source = ref false             (* -dsource *)
 let dump_parsetree = ref false          (* -dparsetree *)
+and dump_typedtree = ref false          (* -dtypedtree *)
 and dump_rawlambda = ref false          (* -drawlambda *)
 and dump_lambda = ref false             (* -dlambda *)
 and dump_clambda = ref false            (* -dclambda *)
@@ -74,7 +76,6 @@ let dump_selection = ref false          (* -dsel *)
 let dump_live = ref false               (* -dlive *)
 let dump_spill = ref false              (* -dspill *)
 let dump_split = ref false              (* -dsplit *)
-let dump_scheduling = ref false         (* -dscheduling *)
 let dump_interf = ref false             (* -dinterf *)
 let dump_prefer = ref false             (* -dprefer *)
 let dump_regalloc = ref false           (* -dalloc *)
@@ -86,6 +87,7 @@ let dump_combine = ref false            (* -dcombine *)
 
 let native_code = ref false             (* set to true under ocamlopt *)
 let inline_threshold = ref 10
+let force_slash = ref false             (* for ocamldep *)
 
 let dont_write_files = ref false        (* set to true under ocamldoc *)
 
@@ -104,4 +106,5 @@ let std_include_dir () =
 let shared = ref false (* -shared *)
 let dlcode = ref true (* not -nodynlink *)
 
-let runtime_variant = ref "";;     (* -runtime-variant *)
+let runtime_variant = ref "";;      (* -runtime-variant *)
+
diff --git a/utils/clflags.mli b/utils/clflags.mli
index 418b1b502f..9af66d2ec1 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: clflags.mli 12959 2012-09-27 13:12:51Z maranget $ *)
-
 val objfiles : string list ref
 val ccobjs : string list ref
 val dllibs : string list ref
@@ -25,12 +23,13 @@ val debug : bool ref
 val fast : bool ref
 val link_everything : bool ref
 val custom_runtime : bool ref
+val bytecode_compatible_32: bool ref
 val output_c_object : bool ref
-val ccopts : string list ref
+val all_ccopts : string list ref
 val classic : bool ref
 val nopervasives : bool ref
 val preprocessor : string option ref
-val ppx : string list ref
+val all_ppx : string list ref
 val annotations : bool ref
 val nojoin : bool ref
 val binary_annotations : bool ref
@@ -44,6 +43,7 @@ val init_file : string option ref
 val use_prims : string ref
 val use_runtime : string ref
 val principal : bool ref
+val real_paths : bool ref
 val recursive_types : bool ref
 val strict_sequence : bool ref
 val applicative_functors : bool ref
@@ -55,7 +55,9 @@ val dllpaths : string list ref
 val make_package : bool ref
 val for_package : string option ref
 val error_size : int ref
+val dump_source : bool ref
 val dump_parsetree : bool ref
+val dump_typedtree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref
 val dump_clambda : bool ref
@@ -83,4 +85,4 @@ val std_include_dir : unit -> string list
 val shared : bool ref
 val dlcode : bool ref
 val runtime_variant : string ref
-
+val force_slash : bool ref
diff --git a/utils/config.mlbuild b/utils/config.mlbuild
index 2ef41e9716..e624f835ce 100644
--- a/utils/config.mlbuild
+++ b/utils/config.mlbuild
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: config.mlbuild 12959 2012-09-27 13:12:51Z maranget $ *)
-
 (***********************************************************************)
 (**                                                                   **)
 (**               WARNING WARNING WARNING                             **)
@@ -132,5 +130,15 @@ let print_config oc =
   p "os_type" Sys.os_type;
   p "default_executable_name" default_executable_name;
   p_bool "systhread_supported" systhread_supported;
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
   flush oc;
 ;;
diff --git a/utils/config.mli b/utils/config.mli
index f8bfec96db..269efe4176 100644
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: config.mli 12959 2012-09-27 13:12:51Z maranget $ *)
-
 (* System configuration *)
 
 val version: string
@@ -107,6 +105,8 @@ val asm: string
 
 val asm_cfi_supported: bool
         (* Whether assembler understands CFI directives *)
+val with_frame_pointers : bool
+        (* Whether assembler should maintain frame pointers *)
 
 val ext_obj: string
         (* Extension for object files, e.g. [.o] under Unix. *)
diff --git a/utils/config.mlp b/utils/config.mlp
index d9ef859cf1..249b8dd342 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: config.mlp 12959 2012-09-27 13:12:51Z maranget $ *)
-
 (***********************************************************************)
 (**                                                                   **)
 (**               WARNING WARNING WARNING                             **)
@@ -84,6 +82,7 @@ let system = "%%SYSTEM%%"
 
 let asm = "%%ASM%%"
 let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
+let with_frame_pointers = %%WITH_FRAME_POINTERS%%
 
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
@@ -118,6 +117,7 @@ let print_config oc =
   p "system" system;
   p "asm" asm;
   p_bool "asm_cfi_supported" asm_cfi_supported;
+  p_bool "with_frame_pointers" with_frame_pointers;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;
@@ -125,6 +125,17 @@ let print_config oc =
   p "os_type" Sys.os_type;
   p "default_executable_name" default_executable_name;
   p_bool "systhread_supported" systhread_supported;
+  (* print the magic number *)
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
 (*>JOCAML *)
   p "companion OCaml"
     (match ocaml_library with None -> "None"
diff --git a/utils/consistbl.ml b/utils/consistbl.ml
index f724e4f8f7..4bc42dc5b0 100644
--- a/utils/consistbl.ml
+++ b/utils/consistbl.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (* Consistency tables: for checking consistency of module CRCs *)
 
 type t = (string, Digest.t * string) Hashtbl.t
diff --git a/utils/consistbl.mli b/utils/consistbl.mli
index a731567126..d3f2afcec9 100644
--- a/utils/consistbl.mli
+++ b/utils/consistbl.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: consistbl.mli 12858 2012-08-10 14:45:51Z maranget $ *)
-
 (* Consistency tables: for checking consistency of module CRCs *)
 
 type t
diff --git a/utils/misc.ml b/utils/misc.ml
index 02faa7ac91..866be690ce 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: misc.ml 12959 2012-09-27 13:12:51Z maranget $ *)
-
 (* Errors *)
 
 exception Fatal_error
@@ -243,4 +241,115 @@ let thd3 (_,_,x) = x
 let fst4 (x, _, _, _) = x
 let snd4 (_,x,_, _) = x
 let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+  type t = string array
+
+  let create str_size =
+    let tbl_size = str_size / Sys.max_string_length + 1 in
+    let tbl = Array.make tbl_size "" in
+    for i = 0 to tbl_size - 2 do
+      tbl.(i) <- String.create Sys.max_string_length;
+    done;
+    tbl.(tbl_size - 1) <- String.create (str_size mod Sys.max_string_length);
+    tbl
+
+  let length tbl =
+    let tbl_size = Array.length tbl in
+    Sys.max_string_length * (tbl_size - 1) + String.length tbl.(tbl_size - 1)
+
+  let get tbl ind =
+    tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length]
+
+  let set tbl ind c =
+    tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length] <- c
+
+  let blit src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let output oc tbl pos len =
+    for i = pos to pos + len - 1 do
+      output_char oc (get tbl i)
+    done
+
+  let unsafe_blit_to_string src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      String.unsafe_set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let input_bytes ic len =
+    let tbl = create len in
+    Array.iter (fun str -> really_input ic str 0 (String.length str)) tbl;
+    tbl
+end
+
+
+let edit_distance a b cutoff =
+  let la, lb = String.length a, String.length b in
+  let cutoff =
+    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+       we bring it back to the (max la lb) worstcase *)
+    min (max la lb) cutoff in
+  if abs (la - lb) > cutoff then None
+  else begin
+    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+       the worst possible cost; this is useful when computing the cost of
+       a case just at the boundary of the cutoff diagonal. *)
+    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+    m.(0).(0) <- 0;
+    for i = 1 to la do
+      m.(i).(0) <- i;
+    done;
+    for j = 1 to lb do
+      m.(0).(j) <- j;
+    done;
+    for i = 1 to la do
+      for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
+        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+        let best =
+          (* insert, delete or substitute *)
+          min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+        in
+        let best =
+          (* swap two adjacent letters; we use "cost" again in case of
+             a swap between two identical letters; this is slightly
+             redundant as this is a double-substitution case, but it
+             was done this way in most online implementations and
+             imitation has its virtues *)
+          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+          then best
+          else min best (m.(i-2).(j-2) + cost)
+        in
+        m.(i).(j) <- best
+      done;
+    done;
+    let result = m.(la).(lb) in
+    if result > cutoff
+    then None
+    else Some result
+  end
+
 
+(* split a string [s] at every char [c], and return the list of sub-strings *)
+let split s c =
+  let len = String.length s in
+  let rec iter pos to_rev =
+    if pos = len then List.rev ("" :: to_rev) else
+      match try
+              Some ( String.index_from s pos c )
+        with Not_found -> None
+      with
+          Some pos2 ->
+            if pos2 = pos then iter (pos+1) ("" :: to_rev) else
+              iter (pos2+1) ((String.sub s pos (pos2-pos)) :: to_rev)
+        | None -> List.rev ( String.sub s pos (len-pos) :: to_rev )
+  in
+  iter 0 []
+
+let cut_at s c =
+  let pos = String.index s c in
+  String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
diff --git a/utils/misc.mli b/utils/misc.mli
index 4d3bfee106..f936fa8530 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (* Miscellaneous useful types and functions *)
 
 val fatal_error: string -> 'a
@@ -124,3 +122,47 @@ val thd3: 'a * 'b * 'c -> 'c
 val fst4: 'a * 'b * 'c * 'd -> 'a
 val snd4: 'a * 'b * 'c * 'd -> 'b
 val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+module LongString :
+  sig
+    type t = string array
+    val create : int -> t
+    val length : t -> int
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+    val blit : t -> int -> t -> int -> int -> unit
+    val output : out_channel -> t -> int -> int -> unit
+    val unsafe_blit_to_string : t -> int -> string -> int -> int -> unit
+    val input_bytes : in_channel -> int -> t
+  end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+    distance [d] is smaller than [cutoff], it returns [Some d], else
+    [None].
+
+    The distance algorithm currently used is Damerau-Levenshtein: it
+    computes the number of insertion, deletion, substitution of
+    letters, or swapping of adjacent letters to go from one word to the
+    other. The particular algorithm may change in the future.
+*)
+
+val split : string -> char -> string list
+(** [String.split string char] splits the string [string] at every char
+    [char], and returns the list of sub-strings between the chars.
+    [String.concat (String.make 1 c) (String.split s c)] is the identity.
+    @since 4.01
+ *)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+   the first occurrence of [c] in [s], and the sub-string after the
+   first occurrence of [c] in [s].
+   [let (before, after) = String.cut_at s c in
+    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+   Raise [Not_found] if the character does not appear in the string
+   @since 4.01
+*)
diff --git a/utils/tbl.ml b/utils/tbl.ml
index 80f2ce782a..265bf3b8c0 100644
--- a/utils/tbl.ml
+++ b/utils/tbl.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tbl.ml 12858 2012-08-10 14:45:51Z maranget $ *)
-
 type ('a, 'b) t =
     Empty
   | Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int
diff --git a/utils/tbl.mli b/utils/tbl.mli
index 68948eeb9d..3167aa9868 100644
--- a/utils/tbl.mli
+++ b/utils/tbl.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tbl.mli 12858 2012-08-10 14:45:51Z maranget $ *)
-
 (* Association tables from any ordered type to any type.
    We use the generic ordering to compare keys. *)
 
diff --git a/utils/terminfo.ml b/utils/terminfo.ml
index d0c086587a..509e495c5d 100644
--- a/utils/terminfo.ml
+++ b/utils/terminfo.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: terminfo.ml 12858 2012-08-10 14:45:51Z maranget $ *)
-
 (* Basic interface to the terminfo database *)
 
 type status =
diff --git a/utils/terminfo.mli b/utils/terminfo.mli
index 5fa3aa14e7..3e8ab512fe 100644
--- a/utils/terminfo.mli
+++ b/utils/terminfo.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (* Basic interface to the terminfo database *)
 
 type status =
diff --git a/utils/warnings.ml b/utils/warnings.ml
index c94af46487..df4cdc94b9 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: warnings.ml 12959 2012-09-27 13:12:51Z maranget $ *)
-
 (* When you change this, you need to update the documentation:
    - man/ocamlc.m   in ocaml
    - man/ocamlopt.m in ocaml
@@ -22,7 +20,7 @@
 type t =
   | Comment_start                           (*  1 *)
   | Comment_not_end                         (*  2 *)
-  | Deprecated                              (*  3 *)
+  | Deprecated of string                    (*  3 *)
   | Fragile_match of string                 (*  4 *)
   | Partial_application                     (*  5 *)
   | Labels_omitted                          (*  6 *)
@@ -59,6 +57,11 @@ type t =
   | Unused_constructor of string * bool * bool  (* 37 *)
   | Unused_exception of string * bool       (* 38 *)
   | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool (* 40 *)
+  | Ambiguous_name of string list * string list *  bool    (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -70,7 +73,7 @@ type t =
 let number = function
   | Comment_start -> 1
   | Comment_not_end -> 2
-  | Deprecated -> 3
+  | Deprecated _ -> 3
   | Fragile_match _ -> 4
   | Partial_application -> 5
   | Labels_omitted -> 6
@@ -107,9 +110,14 @@ let number = function
   | Unused_constructor _ -> 37
   | Unused_exception _ -> 38
   | Unused_rec_flag -> 39
+  | Name_out_of_scope _ -> 40
+  | Ambiguous_name _ -> 41
+  | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
+  | Open_shadow_identifier _ -> 44
 ;;
 
-let last_warning_number = 39
+let last_warning_number = 44
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -204,7 +212,7 @@ let parse_opt flags s =
 let parse_options errflag s = parse_opt (if errflag then error else active) s;;
 
 (* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27-29-32..39";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44";;
 let defaults_warn_error = "-a";;
 
 let () = parse_options false defaults_w;;
@@ -213,7 +221,7 @@ let () = parse_options true defaults_warn_error;;
 let message = function
   | Comment_start -> "this is the start of a comment."
   | Comment_not_end -> "this is not the end of a comment."
-  | Deprecated -> "this syntax is deprecated."
+  | Deprecated s -> "deprecated feature: " ^ s
   | Fragile_match "" ->
       "this pattern-matching is fragile."
   | Fragile_match s ->
@@ -304,6 +312,32 @@ let message = function
         (However, this constructor appears in patterns.)"
   | Unused_rec_flag ->
       "unused rec flag."
+  | Name_out_of_scope (ty, [nm], false) ->
+      nm ^ " was selected from type " ^ ty ^
+      ".\nIt is not visible in the current scope, and will not \n\
+       be selected if the type becomes unknown."
+  | Name_out_of_scope (_, _, false) -> assert false
+  | Name_out_of_scope (ty, slist, true) ->
+      "this record of type "^ ty ^" contains fields that are \n\
+       not visible in the current scope: "
+      ^ String.concat " " slist ^ ".\n\
+       They will not be selected if the type becomes unknown."
+  | Ambiguous_name ([s], tl, false) ->
+      s ^ " belongs to several types: " ^ String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+  | Ambiguous_name (_, _, false) -> assert false
+  | Ambiguous_name (slist, tl, true) ->
+      "these field labels belong to several types: " ^
+      String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+  | Disambiguated_name s ->
+      "this use of " ^ s ^ " required disambiguation."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
+  | Open_shadow_identifier (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s identifier %s (which is later used)"
+        kind s
 ;;
 
 let nerrors = ref 0;;
@@ -341,7 +375,7 @@ let descriptions =
   [
     1, "Suspicious-looking start-of-comment mark.";
     2, "Suspicious-looking end-of-comment mark.";
-    3, "Deprecated syntax.";
+    3, "Deprecated feature.";
     4, "Fragile pattern matching: matching that will remain complete even\n\
    \    if additional constructors are added to one of the variant types\n\
    \    matched.";
@@ -389,6 +423,11 @@ let descriptions =
    37, "Unused constructor.";
    38, "Unused exception constructor.";
    39, "Unused rec flag.";
+   40, "Constructor or label name used out of scope.";
+   41, "Ambiguous constructor or label name.";
+   42, "Disambiguated constructor or label name.";
+   43, "Nonoptional label applied as optional.";
+   44, "Open statement shadows an already defined identifier.";
   ]
 ;;
 
diff --git a/utils/warnings.mli b/utils/warnings.mli
index fbffb33dfc..9843195faa 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -10,14 +10,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 open Format
 
 type t =
   | Comment_start                           (*  1 *)
   | Comment_not_end                         (*  2 *)
-  | Deprecated                              (*  3 *)
+  | Deprecated of string                    (*  3 *)
   | Fragile_match of string                 (*  4 *)
   | Partial_application                     (*  5 *)
   | Labels_omitted                          (*  6 *)
@@ -44,16 +42,21 @@ type t =
   | Unused_var_strict of string             (* 27 *)
   | Wildcard_arg_to_constant_constr         (* 28 *)
   | Eol_in_string                           (* 29 *)
-  | Duplicate_definitions of string * string * string * string (*30 *)
+  | Duplicate_definitions of string * string * string * string (* 30 *)
   | Multiple_definition of string * string * string (* 31 *)
   | Unused_value_declaration of string      (* 32 *)
   | Unused_open of string                   (* 33 *)
   | Unused_type_declaration of string       (* 34 *)
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
-  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_constructor of string * bool * bool (* 37 *)
   | Unused_exception of string * bool       (* 38 *)
   | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool   (* 40 *)
+  | Ambiguous_name of string list * string list * bool (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
 ;;
 
 val parse_options : bool -> string -> unit;;