merge trunk up to rev 14663

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

45 files changed, 413 insertions, 134 deletions

diff --git a/Changes b/Changes
index ebbae21c8e..3a9bc539b6 100644
--- a/Changes
+++ b/Changes
@@ -52,6 +52,7 @@ Compilers:
 
 Toplevel interactive system:
 - Support for directive with multiple arguments
+- PR#5377: New "#show" directive
 
 Runtime system:
 - Fixed a major performance problem on large heaps (~1GB) by making heap
@@ -76,6 +77,8 @@ OCamldoc:
            record fields
 - PR#6310: fix ocamldoc's subscript/superscript CSS font size
            (patch by Anil Madhavapeddy)
+- PR#6273: fix Sys.file_exists on large files (Win32)
+           (patch by Christoph Bauer)
 
 Bug fixes:
 - PR#4719: Sys.executable_name wrong if executable name contains dots (Windows)
diff --git a/Makefile b/Makefile
index 90edd5efb5..a61ed7c299 100644
--- a/Makefile
+++ b/Makefile
@@ -724,6 +724,12 @@ ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries
 ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
 	cd ocamldoc && $(MAKE) opt.opt
 
+# Documentation
+
+html_doc: ocamldoc
+	make -C ocamldoc html_doc
+	@echo "documentation is in ./ocamldoc/stdlib_html/"
+
 partialclean::
 	cd ocamldoc && $(MAKE) clean
 
diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
index 9c971857bd..5e6afbcabf 100644
--- a/asmcomp/amd64/selection.ml
+++ b/asmcomp/amd64/selection.ml
@@ -156,7 +156,7 @@ method! select_store addr exp =
   match exp with
     Cconst_int n when self#is_immediate n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
-  | Cconst_natint n when self#is_immediate_natint n ->
+  | (Cconst_natint n | Cconst_blockheader n) when self#is_immediate_natint n ->
       (Ispecific(Istore_int(n, addr)), Ctuple [])
   | Cconst_pointer n when self#is_immediate n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml
index f5f730003c..d86f1b2823 100644
--- a/asmcomp/i386/selection.ml
+++ b/asmcomp/i386/selection.ml
@@ -182,7 +182,7 @@ method! select_store addr exp =
   match exp with
     Cconst_int n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
-  | Cconst_natint n ->
+  | (Cconst_natint n | Cconst_blockheader n) ->
       (Ispecific(Istore_int(n, addr)), Ctuple [])
   | Cconst_pointer n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index c1d5dc5196..a8f073e53a 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -47,7 +47,8 @@ let oper_result_type = function
 
 let size_expr env exp =
   let rec size localenv = function
-      Cconst_int _ | Cconst_natint _ -> Arch.size_int
+      Cconst_int _ | Cconst_natint _
+    | Cconst_blockheader _ -> Arch.size_int
     | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ ->
         Arch.size_addr
     | Cconst_float _ -> Arch.size_float
@@ -178,6 +179,7 @@ class virtual selector_generic = object (self)
 method is_simple_expr = function
     Cconst_int _ -> true
   | Cconst_natint _ -> true
+  | Cconst_blockheader _ -> true
   | Cconst_float _ -> true
   | Cconst_symbol _ -> true
   | Cconst_pointer _ -> true
diff --git a/boot/ocamlc b/boot/ocamlc
index de19eafc7f..d429f8c448 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index c75d44fd54..b082a5ae7a 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 1540e30133..265c91ccde 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/byterun/config.h b/byterun/config.h
index 02bdd53be8..f77598850c 100644
--- a/byterun/config.h
+++ b/byterun/config.h
@@ -44,20 +44,22 @@ typedef unsigned short uint32;
 #error "No 32-bit integer type available"
 #endif
 
-#if defined(ARCH_INT64_TYPE)
-typedef ARCH_INT64_TYPE int64;
-typedef ARCH_UINT64_TYPE uint64;
+#ifndef ARCH_INT64_TYPE
+#if SIZEOF_LONGLONG == 8
+#define ARCH_INT64_TYPE long long
+#define ARCH_UINT64_TYPE unsigned long long
+#define ARCH_INT64_PRINTF_FORMAT "ll"
 #elif SIZEOF_LONG == 8
-typedef long int64;
-typedef unsigned long uint64;
+#define ARCH_INT64_TYPE long
+#define ARCH_UINT64_TYPE unsigned long
 #define ARCH_INT64_PRINTF_FORMAT "l"
-#elif SIZEOF_LONGLONG == 8
-typedef long long int64;
-typedef unsigned long long uint64;
-#define ARCH_INT64_PRINTF_FORMAT "ll"
 #else
 #error "No 64-bit integer type available"
 #endif
+#endif
+
+typedef ARCH_INT64_TYPE int64;
+typedef ARCH_UINT64_TYPE uint64;
 
 #if SIZEOF_PTR == SIZEOF_LONG
 /* Standard models: ILP32 or I32LP64 */
diff --git a/byterun/debugger.c b/byterun/debugger.c
index d64583f2d4..6024ed92fe 100644
--- a/byterun/debugger.c
+++ b/byterun/debugger.c
@@ -250,7 +250,6 @@ static void safe_output_value(struct channel *chan, value val)
 
 void caml_debugger(enum event_kind event)
 {
-  int frame_number;
   value * frame;
   intnat i, pos;
   value val;
@@ -258,7 +257,6 @@ void caml_debugger(enum event_kind event)
   if (dbg_socket == -1) return;  /* Not connected to a debugger. */
 
   /* Reset current frame */
-  frame_number = 0;
   frame = caml_extern_sp + 1;
 
   /* Report the event to the debugger */
diff --git a/byterun/printexc.c b/byterun/printexc.c
index 8f6badd922..4f7b56b6ae 100644
--- a/byterun/printexc.c
+++ b/byterun/printexc.c
@@ -95,7 +95,14 @@ CAMLexport char * caml_format_exception(value exn)
 }
 
 
-void caml_fatal_uncaught_exception(value exn)
+#ifdef NATIVE_CODE
+#  define DEBUGGER_IN_USE 0
+#else
+#  define DEBUGGER_IN_USE caml_debugger_in_use
+#endif
+
+/* Default C implementation in case the OCaml one is not registered. */
+static void default_fatal_uncaught_exception(value exn)
 {
   char * msg;
   value * at_exit;
@@ -116,13 +123,20 @@ void caml_fatal_uncaught_exception(value exn)
   fprintf(stderr, "Fatal error: exception %s\n", msg);
   free(msg);
   /* Display the backtrace if available */
-  if (caml_backtrace_active
-#ifndef NATIVE_CODE
-      && !caml_debugger_in_use
-#endif
-      ) {
+  if (caml_backtrace_active && !DEBUGGER_IN_USE)
     caml_print_exception_backtrace();
-  }
+}
+
+void caml_fatal_uncaught_exception(value exn)
+{
+  value *handle_uncaught_exception;
+
+  handle_uncaught_exception = caml_named_value("Printexc.handle_uncaught_exception");
+  if (handle_uncaught_exception != NULL)
+    /* [Printexc.handle_uncaught_exception] does not raise exception. */
+    caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));
+  else
+    default_fatal_uncaught_exception(exn);
   /* Terminate the process */
   exit(2);
 }
diff --git a/byterun/sys.c b/byterun/sys.c
index ee2a770249..03ca1e3e34 100644
--- a/byterun/sys.c
+++ b/byterun/sys.c
@@ -152,13 +152,21 @@ CAMLprim value caml_sys_close(value fd)
 
 CAMLprim value caml_sys_file_exists(value name)
 {
+#ifdef _WIN32
+  struct _stati64 st;
+#else
   struct stat st;
+#endif
   char * p;
   int ret;
 
   p = caml_strdup(String_val(name));
   caml_enter_blocking_section();
+#ifdef _WIN32
+  ret = _stati64(p, &st);
+#else
   ret = stat(p, &st);
+#endif
   caml_leave_blocking_section();
   caml_stat_free(p);
 
@@ -168,13 +176,21 @@ CAMLprim value caml_sys_file_exists(value name)
 CAMLprim value caml_sys_is_directory(value name)
 {
   CAMLparam1(name);
+#ifdef _WIN32
+  struct _stati64 st;
+#else
   struct stat st;
+#endif
   char * p;
   int ret;
 
   p = caml_strdup(String_val(name));
   caml_enter_blocking_section();
+#ifdef _WIN32
+  ret = _stati64(p, &st);
+#else
   ret = stat(p, &st);
+#endif
   caml_leave_blocking_section();
   caml_stat_free(p);
 
diff --git a/byterun/win32.c b/byterun/win32.c
index 8647437f0a..b74b409803 100644
--- a/byterun/win32.c
+++ b/byterun/win32.c
@@ -296,7 +296,7 @@ int caml_read_directory(char * dirname, struct ext_table * contents)
     template = caml_strconcat(2, dirname, "\\*.*");
   h = _findfirst(template, &fileinfo);
   if (h == -1) {
-    caml_strbuf_free(&template);
+    caml_stat_free(template);
     return errno == ENOENT ? 0 : -1;
   }
   do {
diff --git a/driver/compenv.ml b/driver/compenv.ml
index ef47981363..e2a90d29a6 100644
--- a/driver/compenv.ml
+++ b/driver/compenv.ml
@@ -126,6 +126,10 @@ let setter ppf f name options s =
       (Warnings.Bad_env_variable ("OCAMLPARAM",
                                   Printf.sprintf "bad value for %s" name))
 
+(* 'can-discard=' specifies which arguments can be discarded without warning
+   because they are not understood by some versions of OCaml. *)
+let can_discard = ref []
+
 let read_OCAMLPARAM ppf position =
   try
     let s = Sys.getenv "OCAMLPARAM" in
@@ -137,7 +141,6 @@ let read_OCAMLPARAM ppf position =
            (Warnings.Bad_env_variable ("OCAMLPARAM", s));
          [],[]
     in
-
     let set name options s =  setter ppf (fun b -> b) name options s in
     let clear name options s = setter ppf (fun b -> not b) name options s in
     List.iter (fun (name, v) ->
@@ -252,10 +255,16 @@ let read_OCAMLPARAM ppf position =
             first_objfiles := v :: !first_objfiles
         end
 
+      | "can-discard" ->
+        can_discard := v ::!can_discard
+
       | _ ->
-        Printf.eprintf
+        if not (List.mem name !can_discard) then begin
+          can_discard := name :: !can_discard;
+          Printf.eprintf
             "Warning: discarding value of variable %S in OCAMLPARAM\n%!"
             name
+        end
     ) (match position with
         Before_args -> before
       | Before_compile | Before_link -> after)
diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
index da6bd5c1b5..6529ae1e44 100644
--- a/ocamldoc/Makefile
+++ b/ocamldoc/Makefile
@@ -181,6 +181,7 @@ $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
 	$(OCAMLOPT) -a -o $@ $(LINKFLAGS)	$(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES)
 
 manpages: stdlib_man/Pervasives.3o
+html_doc: stdlib_html/Pervasives.html
 
 dot: $(EXECMOFILES)
 	$(OCAMLDOC_RUN) -dot -dot-reduce -o ocamldoc.dot $(INCLUDES) \
@@ -306,6 +307,13 @@ stdlib_man/Pervasives.3o: $(STDLIB_MLIS)
 	-t "OCaml library" -man-mini \
 	$(STDLIB_MLIS)
 
+stdlib_html/Pervasives.html: $(STDLIB_MLIS)
+	$(MKDIR) stdlib_html
+	$(OCAMLDOC_RUN) -d stdlib_html -html $(INCLUDES) \
+	-t "OCaml library" \
+	$(STDLIB_MLIS)
+
+
 autotest_stdlib: dummy
 	$(MKDIR) $@
 	$(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 9459640936..046c5a0fe7 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -300,28 +300,31 @@ module Mb = struct
 end
 
 module Opn = struct
-  let mk ?(attrs = []) ?(override = Fresh) lid =
+  let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid =
     {
      popen_lid = lid;
      popen_override = override;
+     popen_loc = loc;
      popen_attributes = attrs;
     }
 end
 
 module Incl = struct
-  let mk ?(attrs = []) mexpr =
+  let mk ?(loc = !default_loc) ?(attrs = []) mexpr =
     {
      pincl_mod = mexpr;
+     pincl_loc = loc;
      pincl_attributes = attrs;
     }
 end
 
 module Vb = struct
-  let mk ?(attrs = []) pat expr =
+  let mk ?(loc = !default_loc) ?(attrs = []) pat expr =
     {
      pvb_pat = pat;
      pvb_expr = expr;
      pvb_attributes = attrs;
+     pvb_loc = loc;
     }
 end
 
@@ -393,11 +396,12 @@ module Cstr = struct
 end
 
 module Exrb = struct
-  let mk ?(attrs = []) name lid =
+  let mk ?(loc  = !default_loc) ?(attrs = []) name lid =
     {
      pexrb_name = name;
      pexrb_lid = lid;
      pexrb_attributes = attrs;
+     pexrb_loc = loc;
     }
 end
 
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 7fc10d74dc..c8f031457f 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -241,20 +241,20 @@ module Mb:
 (* Opens *)
 module Opn:
   sig
-    val mk: ?attrs:attrs -> ?override:override_flag -> lid -> open_description
+    val mk: ?loc: loc -> ?attrs:attrs -> ?override:override_flag -> lid -> open_description
   end
 
 (* Includes *)
 module Incl:
   sig
-    val mk: ?attrs:attrs -> 'a -> 'a include_infos
+    val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos
   end
 
 (** Value bindings *)
 
 module Vb:
   sig
-    val mk: ?attrs:attrs -> pattern -> expression -> value_binding
+    val mk: ?loc: loc -> ?attrs:attrs -> pattern -> expression -> value_binding
   end
 
 
@@ -338,7 +338,7 @@ module Cstr:
 (** Exception rebinding *)
 module Exrb:
   sig
-    val mk: ?attrs:attrs -> str -> lid -> exception_rebind
+    val mk: ?loc:loc -> ?attrs:attrs -> str -> lid -> exception_rebind
 end
 
 
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 488e300b61..4ccd13ae03 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -13,7 +13,7 @@
 (* A generic Parsetree mapping class *)
 
 (*
-[@@@warning "+9"]
+[@@@ocaml.warning "+9"]
   (* Ensure that record patterns don't miss any field. *)
 *)
 
@@ -495,31 +495,35 @@ let default_mapper =
 
 
     open_description =
-      (fun this {popen_lid; popen_override; popen_attributes} ->
+      (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
          Opn.mk (map_loc this popen_lid)
            ~override:popen_override
+           ~loc:(this.location this popen_loc)
            ~attrs:(this.attributes this popen_attributes)
       );
 
 
     include_description =
-      (fun this {pincl_mod; pincl_attributes} ->
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
          Incl.mk (this.module_type this pincl_mod)
+           ~loc:(this.location this pincl_loc)
            ~attrs:(this.attributes this pincl_attributes)
       );
 
     include_declaration =
-      (fun this {pincl_mod; pincl_attributes} ->
+      (fun this {pincl_mod; pincl_attributes; pincl_loc} ->
          Incl.mk (this.module_expr this pincl_mod)
+           ~loc:(this.location this pincl_loc)
            ~attrs:(this.attributes this pincl_attributes)
       );
 
 
     value_binding =
-      (fun this {pvb_pat; pvb_expr; pvb_attributes} ->
+      (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
          Vb.mk
            (this.pat this pvb_pat)
            (this.expr this pvb_expr)
+           ~loc:(this.location this pvb_loc)
            ~attrs:(this.attributes this pvb_attributes)
       );
 
@@ -545,10 +549,11 @@ let default_mapper =
       );
 
     exception_rebind =
-      (fun this {pexrb_name; pexrb_lid; pexrb_attributes} ->
+      (fun this {pexrb_name; pexrb_lid; pexrb_attributes; pexrb_loc} ->
          Exrb.mk
            (map_loc this pexrb_name)
            (map_loc this pexrb_lid)
+           ~loc:(this.location this pexrb_loc)
            ~attrs:(this.attributes this pexrb_attributes)
       );
 
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index b54f111041..79e3b8e958 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -40,3 +40,16 @@ val in_string : unit -> bool;;
 val print_warnings : bool ref
 val comments : unit -> (string * Location.t) list
 val token_with_comments : Lexing.lexbuf -> Parser.token
+
+(*
+  [set_preprocessor init preprocessor] registers [init] as the function
+to call to initialize the preprocessor when the lexer is initialized,
+and [preprocessor] a function that is called when a new token is needed
+by the parser, as [preprocessor lexer lexbuf] where [lexer] is the
+lexing function.
+*)
+
+val set_preprocessor :
+  (unit -> unit) ->
+  ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) ->
+  unit
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 3f5a0b5d33..e07ba80fbf 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -216,6 +216,8 @@ let update_loc lexbuf file line absolute chars =
   }
 ;;
 
+let preprocessor = ref None
+
 (* Warn about Latin-1 characters used in idents *)
 
 let warn_latin1 lexbuf =
@@ -284,9 +286,19 @@ let float_literal =
   (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
 
 rule token = parse
+  | "\\" newline {
+      match !preprocessor with
+      | None ->
+        raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
+                     Location.curr lexbuf))
+      | Some _ ->
+        update_loc lexbuf None 1 false 0;
+        token lexbuf }
   | newline
       { update_loc lexbuf None 1 false 0;
-        token lexbuf
+        match !preprocessor with
+        | None -> token lexbuf
+        | Some _ -> EOL
       }
   | blank +
       { token lexbuf }
@@ -635,7 +647,11 @@ and skip_sharp_bang = parse
   | "" { () }
 
 {
-  let token_with_comments = token
+
+  let token_with_comments lexbuf =
+    match !preprocessor with
+    | None -> token lexbuf
+    | Some (_init, preprocess) -> preprocess token lexbuf
 
   let last_comments = ref []
   let rec token lexbuf =
@@ -645,9 +661,16 @@ and skip_sharp_bang = parse
           token lexbuf
       | tok -> tok
   let comments () = List.rev !last_comments
+
   let init () =
     is_in_string := false;
     last_comments := [];
-    comment_start_loc := []
+    comment_start_loc := [];
+    match !preprocessor with
+    | None -> ()
+    | Some (init, _preprocess) -> init ()
+
+  let set_preprocessor init preprocess =
+    preprocessor := Some (init, preprocess)
 
 }
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 5836ad521e..06aabdc80a 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -408,6 +408,8 @@ let mkexp_attrs d attrs =
 %token WITH
 %token <string * Location.t> COMMENT
 
+%token EOL
+
 /* Precedences and associativities.
 
 Tokens and rules have precedences.  A reduce/reduce conflict is resolved
@@ -642,8 +644,9 @@ structure_item:
   | EXCEPTION exception_declaration
       { mkstr(Pstr_exception $2) }
   | EXCEPTION UIDENT EQUAL constr_longident post_item_attributes
-      { mkstr (Pstr_exn_rebind (Exrb.mk (mkrhs $2 2)
-                                        (mkloc $4 (rhs_loc 4)) ~attrs:$5)) }
+      { mkstr (Pstr_exn_rebind
+                 (Exrb.mk (mkrhs $2 2)
+                    (mkloc $4 (rhs_loc 4)) ~attrs:$5 ~loc:(symbol_rloc()))) }
   | MODULE module_binding
       { mkstr(Pstr_module $2) }
   | MODULE REC module_bindings
@@ -654,14 +657,13 @@ structure_item:
   | MODULE TYPE ident EQUAL module_type post_item_attributes
       { mkstr(Pstr_modtype (Mtd.mk (mkrhs $3 3)
                               ~typ:$5 ~attrs:$6 ~loc:(symbol_rloc()))) }
-  | OPEN override_flag mod_longident post_item_attributes
-      { mkstr(Pstr_open (Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4)) }
+  | open_statement { mkstr(Pstr_open $1) }
   | CLASS class_declarations
       { mkstr(Pstr_class (List.rev $2)) }
   | CLASS TYPE class_type_declarations
       { mkstr(Pstr_class_type (List.rev $3)) }
   | INCLUDE module_expr post_item_attributes
-      { mkstr(Pstr_include (Incl.mk $2 ~attrs:$3)) }
+      { mkstr(Pstr_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) }
   | item_extension post_item_attributes
       { mkstr(Pstr_extension ($1, $2)) }
   | floating_attribute
@@ -748,10 +750,10 @@ signature_item:
       { mksig(Psig_modtype (Mtd.mk (mkrhs $3 3) ~typ:$5
                               ~loc:(symbol_rloc())
                               ~attrs:$6)) }
-  | OPEN override_flag mod_longident post_item_attributes
-      { mksig(Psig_open (Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4)) }
+  | open_statement
+      { mksig(Psig_open $1) }
   | INCLUDE module_type post_item_attributes %prec below_WITH
-      { mksig(Psig_include (Incl.mk $2 ~attrs:$3)) }
+      { mksig(Psig_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) }
   | CLASS class_descriptions
       { mksig(Psig_class (List.rev $2)) }
   | CLASS TYPE class_type_declarations
@@ -761,7 +763,10 @@ signature_item:
   | floating_attribute
       { mksig(Psig_attribute $1) }
 ;
-
+open_statement:
+  | OPEN override_flag mod_longident post_item_attributes
+      { Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 ~loc:(symbol_rloc()) }
+;
 module_declaration:
     COLON module_type
       { $2 }
@@ -1311,7 +1316,9 @@ lident_list:
   | LIDENT lident_list                { $1 :: $2 }
 ;
 let_binding:
-    let_binding_ post_item_attributes { let (p, e) = $1 in Vb.mk ~attrs:$2 p e }
+    let_binding_ post_item_attributes {
+      let (p, e) = $1 in Vb.mk ~loc:(symbol_rloc()) ~attrs:$2 p e
+    }
 ;
 let_binding_:
     val_ident fun_binding
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index fadef05690..5747f51eb3 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -297,7 +297,7 @@ and expression_desc =
            Pexp_constraint(Pexp_pack, Ptyp_package S) *)
   | Pexp_open of override_flag * Longident.t loc * expression
         (* let open M in E
-           let! open M in E 
+           let! open M in E
         *)
   | Pexp_extension of extension
         (* [%id] *)
@@ -390,6 +390,7 @@ and exception_rebind =
     {
      pexrb_name: string loc;
      pexrb_lid: Longident.t loc;
+     pexrb_loc: Location.t;
      pexrb_attributes: attributes;
     }
 (* exception C = M.X *)
@@ -638,6 +639,7 @@ and open_description =
     {
      popen_lid: Longident.t loc;
      popen_override: override_flag;
+     popen_loc: Location.t;
      popen_attributes: attributes;
     }
 (* open! X - popen_override = Override (silences the 'used identifier
@@ -648,6 +650,7 @@ and open_description =
 and 'a include_infos =
     {
      pincl_mod: 'a;
+     pincl_loc: Location.t;
      pincl_attributes: attributes;
     }
 
@@ -742,6 +745,7 @@ and value_binding =
     pvb_pat: pattern;
     pvb_expr: expression;
     pvb_attributes: attributes;
+    pvb_loc: Location.t;
   }
 
 and module_binding =
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index a09fcf95ca..28965bce3d 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -793,7 +793,9 @@ class printer  ()= object(self:'self)
           | Pexp_poly (e,None) ->
               self#binding f {pvb_pat={ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
                               pvb_expr=e;
-                              pvb_attributes=[]}
+                              pvb_attributes=[];
+                              pvb_loc=Location.none;
+                             }
           | _ ->
               self#expression f e ) e
     | Pcf_constraint (ct1, ct2) ->
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 8b64236a7e..0f6480b826 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -112,11 +112,11 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
       | Unknown "-help" -> ()
       | Unknown "--help" -> ()
       | Unknown s ->
-          bprintf b "%s: unknown option `%s'.\n" progname s
+          bprintf b "%s: unknown option '%s'.\n" progname s
       | Missing s ->
-          bprintf b "%s: option `%s' needs an argument.\n" progname s
+          bprintf b "%s: option '%s' needs an argument.\n" progname s
       | Wrong (opt, arg, expected) ->
-          bprintf b "%s: wrong argument `%s'; option `%s' expects %s.\n"
+          bprintf b "%s: wrong argument '%s'; option '%s' expects %s.\n"
                   progname arg opt expected
       | Message s ->
           bprintf b "%s: %s.\n" progname s
@@ -129,7 +129,7 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
   incr current;
   while !current < l do
     let s = argv.(!current) in
-    if String.length s >= 1 && String.get s 0 = '-' then begin
+    if String.length s >= 1 && s.[0] = '-' then begin
       let action =
         try assoc3 s !speclist
         with Not_found -> stop (Unknown s)
diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml
index 0c0bab5df6..e405f17274 100644
--- a/stdlib/bytes.ml
+++ b/stdlib/bytes.ml
@@ -44,7 +44,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 "String.sub"
+  then invalid_arg "Bytes.sub"
   else begin
     let r = create len in
     unsafe_blit s ofs r 0 len;
@@ -55,13 +55,13 @@ let sub_string b ofs len = unsafe_to_string (sub b ofs len)
 
 let fill s ofs len c =
   if ofs < 0 || len < 0 || ofs > length s - len
-  then invalid_arg "String.fill"
+  then invalid_arg "Bytes.fill"
   else unsafe_fill s ofs len c
 
 let blit s1 ofs1 s2 ofs2 len =
   if len < 0 || ofs1 < 0 || ofs1 > length s1 - len
              || ofs2 < 0 || ofs2 > length s2 - len
-  then invalid_arg "String.blit"
+  then invalid_arg "Bytes.blit"
   else unsafe_blit s1 ofs1 s2 ofs2 len
 
 let iter f a =
@@ -182,7 +182,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 "String.index_from" else
+  if i < 0 || i > l then invalid_arg "Bytes.index_from" else
   index_rec s l i c;;
 
 let rec rindex_rec s i c =
@@ -192,18 +192,18 @@ 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 "String.rindex_from" else
+  if i < -1 || i >= length s then invalid_arg "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 "String.contains_from" else
+  if i < 0 || i > l then invalid_arg "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 "String.rcontains_from" else
+  if i < 0 || i >= length s then invalid_arg "Bytes.rcontains_from" else
   try ignore (rindex_rec s i c); true with Not_found -> false;;
 
 type t = bytes
diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
index aa61061cc5..4f52b18654 100644
--- a/stdlib/genlex.ml
+++ b/stdlib/genlex.ml
@@ -29,11 +29,11 @@ let bufpos = ref 0
 let reset_buffer () = buffer := initial_buffer; bufpos := 0
 
 let store c =
-  if !bufpos >= Bytes.length !buffer then
-    begin
-      let newbuffer = Bytes.create (2 * !bufpos) in
-      Bytes.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer
-    end;
+  if !bufpos >= Bytes.length !buffer then begin
+    let newbuffer = Bytes.create (2 * !bufpos) in
+    Bytes.blit !buffer 0 newbuffer 0 !bufpos;
+    buffer := newbuffer
+  end;
   Bytes.set !buffer !bufpos c;
   incr bufpos
 
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index 5424df40d1..0c3e4999f3 100644
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -187,6 +187,34 @@ val stats : ('a, 'b) t -> statistics
 
 (** {6 Functorial interface} *)
 
+(** The functorial interface allows the use of specific comparison
+    and hash functions, either for performance/security concerns,
+    or because keys are not hashable/comparable with the polymorphic builtins.
+
+    For instance, one might want to specialize a table for integer keys:
+    {[
+      module IntHash =
+        struct
+          type t = int
+          let equal i j = i=j
+          let hash i = i land max_int
+        end
+
+      module IntHashtbl = Hashtbl.Make(IntHash)
+
+      let h = IntHashtbl.create 17 in
+      IntHashtbl.add h 12 "hello";;
+    ]}
+
+    This creates a new module [IntHashtbl], with a new type ['a
+    IntHashtbl.t] of tables from [int] to ['a]. In this example, [h]
+    contains [string] values so its type is [string IntHashtbl.t].
+
+    Note that the new type ['a IntHashtbl.t] is not compatible with
+    the type [('a,'b) Hashtbl.t] of the generic interface. For
+    example, [Hashtbl.length h] would not type-check, you must use
+    [IntHashtbl.length].
+*)
 
 module type HashedType =
   sig
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 9f20c7b464..285308b79d 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -184,3 +184,64 @@ let exn_slot_id x =
 let exn_slot_name x =
   let slot = exn_slot x in
   (Obj.obj (Obj.field slot 0) : string)
+
+
+let uncaught_exception_handler = ref None
+
+let set_uncaught_exception_handler fn = uncaught_exception_handler := Some fn
+
+let empty_backtrace : raw_backtrace = Obj.obj (Obj.new_block Obj.abstract_tag 0)
+
+let try_get_raw_backtrace () =
+  try
+    get_raw_backtrace ()
+  with _ (* Out_of_memory? *) ->
+    empty_backtrace
+
+let handle_uncaught_exception' exn debugger_in_use =
+  try
+    (* Get the backtrace now, in case one of the [at_exit] function
+       destroys it. *)
+    let raw_backtrace =
+      if debugger_in_use (* Same test as in [byterun/printexc.c] *) then
+        empty_backtrace
+      else
+        try_get_raw_backtrace ()
+    in
+    (try Pervasives.do_at_exit () with _ -> ());
+    match !uncaught_exception_handler with
+    | None ->
+        eprintf "Fatal error: exception %s\n" (to_string exn);
+        print_raw_backtrace stderr raw_backtrace;
+        flush stderr
+    | Some handler ->
+        try
+          handler exn raw_backtrace
+        with exn' ->
+          let raw_backtrace' = try_get_raw_backtrace () in
+          eprintf "Fatal error: exception %s\n" (to_string exn);
+          print_raw_backtrace stderr raw_backtrace;
+          eprintf "Fatal error in uncaught exception handler: exception %s\n"
+            (to_string exn');
+          print_raw_backtrace stderr raw_backtrace';
+          flush stderr
+  with
+    | Out_of_memory ->
+        prerr_endline
+          "Fatal error: out of memory in uncaught exception handler"
+
+(* This function is called by [caml_fatal_uncaught_exception] in
+   [byterun/printexc.c] which expects no exception is raised. *)
+let handle_uncaught_exception exn debugger_in_use =
+  try
+    handle_uncaught_exception' exn debugger_in_use
+  with _ ->
+    (* There is not much we can do at this point *)
+    ()
+
+external register_named_value : string -> 'a -> unit
+  = "caml_register_named_value"
+
+let () =
+  register_named_value "Printexc.handle_uncaught_exception"
+    handle_uncaught_exception
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index f662e501bd..2916bf1435 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -100,6 +100,21 @@ val get_raw_backtrace: unit -> raw_backtrace
 val print_raw_backtrace: out_channel -> raw_backtrace -> unit
 val raw_backtrace_to_string: raw_backtrace -> string
 
+(** {6 Uncaught exceptions} *)
+
+val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
+(** [Printexc.set_uncaught_exception_handler fn] registers [fn] as the handler
+    for uncaught exceptions. The default handler prints the exception and
+    backtrace on standard error output.
+
+    Note that when [fn] is called all the functions registered with
+    {!Pervasives.at_exit} have already been called. Because of this you must
+    make sure any output channel [fn] writes on is flushed.
+
+    If [fn] raises an exception, it is ignored.
+
+    @since 4.02.0
+*)
 
 (** {6 Current call stack} *)
 
diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll
index 3d93076f20..7da6541892 100644
--- a/testsuite/tests/asmcomp/lexcmm.mll
+++ b/testsuite/tests/asmcomp/lexcmm.mll
@@ -99,7 +99,7 @@ let store_string_char c =
   incr string_index
 
 let get_stored_string () =
-  let s = Bytes.substring (!string_buff) 0 (!string_index) in
+  let s = Bytes.sub_string (!string_buff) 0 (!string_index) in
   string_buff := initial_string_buffer;
   s
 
diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml
index 4a4a1a2d69..a65812e4bb 100644
--- a/testsuite/tests/typing-modules/aliases.ml
+++ b/testsuite/tests/typing-modules/aliases.ml
@@ -198,3 +198,9 @@ module type S = sig module M : sig type t val x : t end end;;
 module H = struct type t = A let x = A end;;
 module H' = H;;
 module type S' = S with module M = H';; (* shouldn't introduce an alias *)
+
+(* PR#6376 *)
+module type Alias = sig module N : sig end module M = N end;;
+module F (X : sig end) = struct type t end;;
+module type A = Alias with module N := F(List);;
+module rec Bad : A = Bad;;
diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference
index a024731abe..d31516b987 100644
--- a/testsuite/tests/typing-modules/aliases.ml.reference
+++ b/testsuite/tests/typing-modules/aliases.ml.reference
@@ -351,4 +351,24 @@ Error: In this `with' constraint, the new definition of I
 # module H : sig type t = A val x : t end
 # module H' = H
 # module type S' = sig module M : sig type t = H.t = A val x : t end end
+#     module type Alias = sig module N : sig  end module M = N end
+# module F : functor (X : sig  end) -> sig type t end
+# Characters -1--1:
+  module type A = Alias with module N := F(List);;
+  
+Error: Module type declarations do not match:
+         module type A = sig module M = F(List) end
+       does not match
+         module type A = sig module M = F(List) end
+       At position module type A = <here>
+       Modules do not match:
+         sig module M = F(List) end
+       is not included in
+         sig module M = F(List) end
+       At position module type A = sig module M : <here> end
+       Module F(List) cannot be aliased
+# Characters 17-18:
+  module rec Bad : A = Bad;;
+                   ^
+Error: Unbound module type A
 # 
diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
index 76ade67556..e4c72cda7f 100644
--- a/testsuite/tests/typing-objects/Tests.ml.principal.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -244,9 +244,9 @@ Error: Signature mismatch:
          val f : (#c as 'a) -> 'a
        is not included in
          val f : #c -> #c
-#   Characters 32-55:
+#   Characters 38-39:
   module M = struct type t = int class t () = object end end;;
-                                 ^^^^^^^^^^^^^^^^^^^^^^^
+                                       ^
 Error: Multiple definition of the type name t.
        Names must be unique in a given structure or signature.
 #   - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun>
diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index 97ed42ca7d..7940d0e34d 100644
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -244,9 +244,9 @@ Error: Signature mismatch:
          val f : (#c as 'a) -> 'a
        is not included in
          val f : #c -> #c
-#   Characters 32-55:
+#   Characters 38-39:
   module M = struct type t = int class t () = object end end;;
-                                 ^^^^^^^^^^^^^^^^^^^^^^^
+                                       ^
 Error: Multiple definition of the type name t.
        Names must be unique in a given structure or signature.
 #   - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun>
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 966368abfc..eaf3aadf5c 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -67,7 +67,9 @@ and untype_structure_item item =
                       pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;}
     | Tstr_open od ->
         Pstr_open {popen_lid = od.open_txt; popen_override = od.open_override;
-                   popen_attributes = od.open_attributes}
+                   popen_attributes = od.open_attributes;
+                   popen_loc = od.open_loc;
+                  }
     | Tstr_class list ->
         Pstr_class (List.map (fun (ci, _, _) ->
               { pci_virt = ci.ci_virt;
@@ -91,7 +93,9 @@ and untype_structure_item item =
           ) list)
     | Tstr_include incl ->
         Pstr_include {pincl_mod = untype_module_expr incl.incl_mod;
-                      pincl_attributes = incl.incl_attributes}
+                      pincl_attributes = incl.incl_attributes;
+                      pincl_loc = incl.incl_loc;
+                     }
     | Tstr_attribute x ->
         Pstr_attribute x
   in
@@ -155,6 +159,7 @@ and untype_exception_rebind er =
    pexrb_name = er.exrb_name;
    pexrb_lid = er.exrb_txt;
    pexrb_attributes = er.exrb_attributes;
+   pexrb_loc = er.exrb_loc;
   }
 
 and untype_pattern pat =
@@ -229,11 +234,12 @@ and untype_case {c_lhs; c_guard; c_rhs} =
    pc_rhs = untype_expression c_rhs;
   }
 
-and untype_binding {vb_pat; vb_expr; vb_attributes} =
+and untype_binding {vb_pat; vb_expr; vb_attributes; vb_loc} =
   {
     pvb_pat = untype_pattern vb_pat;
     pvb_expr = untype_expression vb_expr;
     pvb_attributes = vb_attributes;
+    pvb_loc = vb_loc;
   }
 
 and untype_expression exp =
@@ -358,10 +364,14 @@ and untype_signature_item item =
     | Tsig_open od ->
         Psig_open {popen_lid = od.open_txt;
                    popen_override = od.open_override;
-                   popen_attributes = od.open_attributes}
+                   popen_attributes = od.open_attributes;
+                   popen_loc = od.open_loc;
+                  }
     | Tsig_include incl ->
         Psig_include {pincl_mod = untype_module_type incl.incl_mod;
-                      pincl_attributes = incl.incl_attributes}
+                      pincl_attributes = incl.incl_attributes;
+                      pincl_loc = incl.incl_loc;
+                     }
     | Tsig_class list ->
         Psig_class (List.map untype_class_description list)
     | Tsig_class_type list ->
diff --git a/typing/includemod.ml b/typing/includemod.ml
index ee035a3f08..af0feb2ecf 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -36,6 +36,7 @@ type symptom =
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
   | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
 
 type pos =
     Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
@@ -190,6 +191,8 @@ let rec modtypes env cxt subst mty1 mty2 =
 and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
   | (Mty_alias p1, Mty_alias p2) ->
+      if Env.is_functor_arg p2 env then
+        raise (Error[cxt, env, Invalid_module_alias p2]);
       if Path.same p1 p2 then Tcoerce_none else
       let p1 = Env.normalize_path None env p1
       and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
@@ -486,6 +489,8 @@ let include_err ppf = function
       fprintf ppf "Unbound module type %a" Printtyp.path path
   | Unbound_module_path path ->
       fprintf ppf "Unbound module %a" Printtyp.path path
+  | Invalid_module_alias path ->
+      fprintf ppf "Module %a cannot be aliased" Printtyp.path path
 
 let rec context ppf = function
     Module id :: rem ->
diff --git a/typing/includemod.mli b/typing/includemod.mli
index 7786ee4ab9..2e00bb0246 100644
--- a/typing/includemod.mli
+++ b/typing/includemod.mli
@@ -41,6 +41,7 @@ type symptom =
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
   | Unbound_module_path of Path.t
+  | Invalid_module_alias of Path.t
 
 type pos =
     Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 92d510f74f..e8cd8cddd0 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -3035,7 +3035,9 @@ and type_argument env sarg ty_expected' ty_expected =
       let let_pat, let_var = var_pair "arg" texp.exp_type in
       re { texp with exp_type = ty_fun; exp_desc =
            Texp_let (Nonrecursive,
-                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]}],
+                     [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
+                       vb_loc=Location.none;
+                      }],
                      func let_var) }
       end
   | _ ->
@@ -3627,7 +3629,9 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
   let l =
     List.map2
       (fun (p, e) pvb ->
-        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes})
+        {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
+         vb_loc=pvb.pvb_loc;
+        })
       l spat_sexp_list
   in
   (l, new_env, unpacks)
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index d09130f929..d2d3b385dc 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -1049,25 +1049,25 @@ let transl_exception env excdecl =
   cd, exn_decl, newenv
 
 (* Translate an exception rebinding *)
-let transl_exn_rebind env loc ser =
+let transl_exn_rebind env ser =
   let name = ser.pexrb_name in
   let lid = ser.pexrb_lid in
   let cdescr =
     try
       Env.lookup_constructor lid.txt env
     with Not_found ->
-      raise(Error(loc, Unbound_exception lid.txt)) in
+      raise(Error(lid.loc, Unbound_exception lid.txt)) in
   Env.mark_constructor Env.Positive env (Longident.last lid.txt) cdescr;
   let path =
     match cdescr.cstr_tag with
       Cstr_exception (path, _) -> path
-    | _ -> raise(Error(loc, Not_an_exception lid.txt))
+    | _ -> raise(Error(lid.loc, Not_an_exception lid.txt))
   in
   let exn_decl =
     {
      exn_args = cdescr.cstr_args;
      exn_attributes = [];
-     Types.exn_loc = loc
+     Types.exn_loc = ser.pexrb_loc;
     }
   in
   let (id, newenv) = Env.enter_exception name.txt exn_decl env in
@@ -1078,6 +1078,7 @@ let transl_exn_rebind env loc ser =
       exrb_txt = lid;
       exrb_type = exn_decl;
       exrb_attributes = ser.pexrb_attributes;
+      exrb_loc = ser.pexrb_loc;
      }
   in
     er, newenv
@@ -1341,9 +1342,9 @@ let report_error ppf = function
       fprintf ppf "A type variable is unbound in this exception declaration";
       explain_unbound_single ppf (Ctype.repr tv) ty
   | Unbound_exception lid ->
-      fprintf ppf "Unbound exception constructor@ %a" Printtyp.longident lid
+      fprintf ppf "Unbound exception constructor %a" Printtyp.longident lid
   | Not_an_exception lid ->
-      fprintf ppf "The constructor@ %a@ is not an exception"
+      fprintf ppf "The constructor %a is not an exception"
         Printtyp.longident lid
   | Bad_variance (n, v1, v2) ->
       let variance (p,n,i) =
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 6f6bc52c2b..b26621012a 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -24,7 +24,7 @@ val transl_exception:
     Parsetree.constructor_declaration -> Typedtree.constructor_declaration * exception_declaration * Env.t
 
 val transl_exn_rebind:
-    Env.t -> Location.t -> Parsetree.exception_rebind -> Typedtree.exception_rebind * Env.t
+    Env.t -> Parsetree.exception_rebind -> Typedtree.exception_rebind * Env.t
 
 val transl_value_decl:
     Env.t -> Location.t ->
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index bc71b7a1fa..76d6534a2b 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -235,6 +235,7 @@ and value_binding =
     vb_pat: pattern;
     vb_expr: expression;
     vb_attributes: attributes;
+    vb_loc: Location.t;
   }
 
 and module_coercion =
@@ -308,6 +309,7 @@ and open_description =
      open_path: Path.t;
      open_txt: Longident.t loc;
      open_override: override_flag;
+     open_loc: Location.t;
      open_attributes: attribute list;
     }
 
@@ -315,6 +317,7 @@ and 'a include_infos =
     {
      incl_mod: 'a;
      incl_type: Types.signature;
+     incl_loc: Location.t;
      incl_attributes: attribute list;
     }
 
@@ -416,6 +419,7 @@ and exception_rebind =
      exrb_path: Path.t;
      exrb_txt: Longident.t loc;
      exrb_type: Types.exception_declaration;
+     exrb_loc: Location.t;
      exrb_attributes: attribute list;
     }
 
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 1815dfc6e5..3bc104fcce 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -234,6 +234,7 @@ and value_binding =
     vb_pat: pattern;
     vb_expr: expression;
     vb_attributes: attributes;
+    vb_loc: Location.t;
   }
 
 and module_coercion =
@@ -307,6 +308,7 @@ and open_description =
      open_path: Path.t;
      open_txt: Longident.t loc;
      open_override: override_flag;
+     open_loc: Location.t;
      open_attributes: attribute list;
     }
 
@@ -314,6 +316,7 @@ and 'a include_infos =
     {
      incl_mod: 'a;
      incl_type: Types.signature;
+     incl_loc: Location.t;
      incl_attributes: attribute list;
     }
 
@@ -416,6 +419,7 @@ and exception_rebind =
      exrb_path: Path.t;
      exrb_txt: Longident.t loc;
      exrb_type: Types.exception_declaration;
+     exrb_loc: Location.t;
      exrb_attributes: attribute list;
     }
 
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 4f83f5a63d..ddd3f5bd40 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -86,6 +86,7 @@ module MakeMap(Map : MapArgument) = struct
       vb_pat = map_pattern vb.vb_pat;
       vb_expr = map_expression vb.vb_expr;
       vb_attributes = vb.vb_attributes;
+      vb_loc = vb.vb_loc;
     }
 
   and map_bindings rec_flag list =
diff --git a/typing/typemod.ml b/typing/typemod.ml
index a647e73e82..feee30b28d 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -67,12 +67,27 @@ let extract_sig_open env loc mty =
 
 (* Compute the environment after opening a module *)
 
-let type_open ?toplevel ovf env loc lid =
-  let path = Typetexp.find_module env loc lid.txt in
+let type_open_ ?toplevel ovf env loc lid =
+  let path = Typetexp.find_module env lid.loc lid.txt in
   let md = Env.find_module path env in
-  let sg = extract_sig_open env loc md.md_type in
+  let sg = extract_sig_open env lid.loc md.md_type in
   path, Env.open_signature ~loc ?toplevel ovf path sg env
 
+let type_open ?toplevel env sod =
+  let (path, newenv) =
+    type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid
+  in
+  let od =
+    {
+      open_override = sod.popen_override;
+      open_path = path;
+      open_txt = sod.popen_lid;
+      open_attributes = sod.popen_attributes;
+      open_loc = sod.popen_loc;
+    }
+  in
+  (path, newenv, od)
+
 (* Record a module type *)
 let rm node =
   Stypes.record (Stypes.Ti_mod node);
@@ -362,9 +377,7 @@ and approx_sig env ssg =
           let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
           Sig_modtype(id, info) :: approx_sig newenv srem
       | Psig_open sod ->
-          let (path, mty) =
-            type_open sod.popen_override env item.psig_loc sod.popen_lid
-          in
+          let (path, mty, _od) = type_open env sod in
           approx_sig mty srem
       | Psig_include sincl ->
           let smty = sincl.pincl_mod in
@@ -418,6 +431,9 @@ let check cl loc set_ref name =
   then raise(Error(loc, Env.empty, Repeated_name(cl, name)))
   else set_ref := StringSet.add name !set_ref
 
+let check_name cl set_ref name =
+  check cl name.loc set_ref name.txt
+
 let check_sig_item type_names module_names modtype_names loc = function
     Sig_type(id, _, _) ->
       check "type" loc type_names (Ident.name id)
@@ -542,7 +558,7 @@ and transl_signature env sg =
         | Psig_type sdecls ->
             List.iter
               (fun decl ->
-                check "type" item.psig_loc type_names decl.ptype_name.txt)
+                check_name "type" type_names decl.ptype_name)
               sdecls;
             let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
             let (trem, rem, final_env) = transl_sig newenv srem in
@@ -559,7 +575,7 @@ and transl_signature env sg =
              else Sig_exception(id, decl) :: rem),
             final_env
         | Psig_module pmd ->
-            check "module" item.psig_loc module_names pmd.pmd_name.txt;
+            check_name "module" module_names pmd.pmd_name;
             let tmty = transl_modtype env pmd.pmd_type in
             let md = {
               md_type=tmty.mty_type;
@@ -578,8 +594,7 @@ and transl_signature env sg =
             final_env
         | Psig_recmodule sdecls ->
             List.iter
-              (fun pmd ->
-                 check "module" item.psig_loc module_names pmd.pmd_name.txt)
+              (fun pmd -> check_name "module" module_names pmd.pmd_name)
               sdecls;
             let (decls, newenv) =
               transl_recmodule_modtypes item.psig_loc env sdecls in
@@ -602,17 +617,7 @@ and transl_signature env sg =
             sg :: rem,
             final_env
         | Psig_open sod ->
-            let (path, newenv) =
-              type_open sod.popen_override env item.psig_loc sod.popen_lid
-            in
-            let od =
-              {
-               open_override = sod.popen_override;
-               open_path = path;
-               open_txt = sod.popen_lid;
-               open_attributes = sod.popen_attributes;
-              }
-            in
+            let (path, newenv, od) = type_open env sod in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_open od) env loc :: trem,
             rem, final_env
@@ -630,7 +635,9 @@ and transl_signature env sg =
             let incl =
               { incl_mod = tmty;
                 incl_type = sg;
-                incl_attributes = sincl.pincl_attributes }
+                incl_attributes = sincl.pincl_attributes;
+                incl_loc = sincl.pincl_loc;
+              }
             in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_include incl) env loc :: trem,
@@ -638,8 +645,7 @@ and transl_signature env sg =
             final_env
         | Psig_class cl ->
             List.iter
-              (fun {pci_name = name} ->
-                 check "type" item.psig_loc type_names name.txt )
+              (fun {pci_name = name} -> check_name "type" type_names name)
               cl;
             let (classes, newenv) = Typeclass.class_descriptions env cl in
             let (trem, rem, final_env) = transl_sig newenv srem in
@@ -661,8 +667,7 @@ and transl_signature env sg =
             final_env
         | Psig_class_type cl ->
             List.iter
-              (fun {pci_name = name} ->
-                 check "type" item.psig_loc type_names name.txt)
+              (fun {pci_name = name} -> check_name "type" type_names name)
               cl;
             let (classes, newenv) = Typeclass.class_type_declarations env cl in
             let (trem,rem, final_env) = transl_sig newenv srem in
@@ -694,7 +699,7 @@ and transl_signature env sg =
 
 and transl_modtype_decl modtype_names env loc
     {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
-  check "module type" loc modtype_names pmtd_name.txt;
+  check_name "module type" modtype_names pmtd_name;
   let tmty = Misc.may_map (transl_modtype env) pmtd_type in
   let decl =
     {
@@ -1164,7 +1169,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv
     | Pstr_type sdecls ->
         List.iter
-          (fun decl -> check "type" loc type_names decl.ptype_name.txt)
+          (fun decl -> check_name "type" type_names decl.ptype_name)
           sdecls;
         let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
         Tstr_type decls,
@@ -1175,14 +1180,14 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
         Tstr_exception arg, [Sig_exception(arg.cd_id, decl)], newenv
     | Pstr_exn_rebind ser ->
-        let (er, newenv) = Typedecl.transl_exn_rebind env loc ser in
+        let (er, newenv) = Typedecl.transl_exn_rebind env ser in
         Tstr_exn_rebind er,
         [Sig_exception(er.exrb_id, er.exrb_type)],
         newenv
     | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
                    pmb_loc;
                   } ->
-        check "module" loc module_names name.txt;
+        check_name "module" module_names name;
         let modl =
           type_module ~alias:true true funct_body
             (anchor_submodule name.txt anchor) env smodl in
@@ -1219,7 +1224,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
             sbind
         in
         List.iter
-          (fun (name, _, _, _, _) -> check "module" loc module_names name.txt)
+          (fun (name, _, _, _, _) -> check_name "module" module_names name)
           sbind;
         let (decls, newenv) =
           transl_recmodule_modtypes loc env
@@ -1261,21 +1266,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         in
         Tstr_modtype mtd, [sg], newenv
     | Pstr_open sod ->
-        let (path, newenv) =
-          type_open sod.popen_override ~toplevel env loc sod.popen_lid
-        in
-        let od =
-          {
-           open_override = sod.popen_override;
-           open_path = path;
-           open_txt = sod.popen_lid;
-           open_attributes = sod.popen_attributes;
-          }
-        in
+        let (path, newenv, od) = type_open ~toplevel env sod in
         Tstr_open od, [], newenv
     | Pstr_class cl ->
         List.iter
-          (fun {pci_name = name} -> check "type" loc type_names name.txt)
+          (fun {pci_name = name} -> check_name "type" type_names name)
           cl;
         let (classes, new_env) = Typeclass.class_declarations env cl in
         Tstr_class
@@ -1302,7 +1297,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         new_env
     | Pstr_class_type cl ->
         List.iter
-          (fun {pci_name = name} -> check "type" loc type_names name.txt)
+          (fun {pci_name = name} -> check_name "type" type_names name)
           cl;
         let (classes, new_env) = Typeclass.class_type_declarations env cl in
         Tstr_class_type
@@ -1354,7 +1349,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         let incl =
           { incl_mod = modl;
             incl_type = sg;
-            incl_attributes = sincl.pincl_attributes }
+            incl_attributes = sincl.pincl_attributes;
+            incl_loc = sincl.pincl_loc;
+          }
         in
         Tstr_include incl, sg, new_env
     | Pstr_extension ((s, _), _) ->
@@ -1518,7 +1515,7 @@ let () =
   Typecore.type_module := type_module;
   Typetexp.transl_modtype_longident := transl_modtype_longident;
   Typetexp.transl_modtype := transl_modtype;
-  Typecore.type_open := type_open ?toplevel:None;
+  Typecore.type_open := type_open_ ?toplevel:None;
   Typecore.type_package := type_package;
   type_module_type_of_fwd := type_module_type_of
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index eaf13141d2..b219c814a8 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -333,6 +333,12 @@ let rec transl_type env policy styp =
     ctyp (Ttyp_tuple ctys) ty
   | Ptyp_constr(lid, stl) ->
       let (path, decl) = find_type env styp.ptyp_loc lid.txt in
+      let stl =
+        match stl with
+        | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
+            List.map (fun _ -> t) decl.type_params
+        | _ -> stl
+      in
       if List.length stl <> decl.type_arity then
         raise(Error(styp.ptyp_loc, env,
                     Type_arity_mismatch(lid.txt, decl.type_arity,