merge 'merge-exceptions.patch' and add forgotten filesopen_types

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

82 files changed, 1501 insertions, 774 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 3eeadc9834..f1e79036da 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 449c67bc6c..5eccc8e158 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 52955e435f..4369d8e17b 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index b88a0cf3f5..3dad6c3024 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -627,7 +627,7 @@ let rec what_is_cases cases = match cases with
 (* A few operation on default environments *)
 let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases)
 
-(* For exception matching, record no imformation in matrix *)
+(* For extension matching, record no imformation in matrix *)
 let as_matrix_omega cases =
   get_mins le_pats
     (List.map
@@ -903,7 +903,7 @@ let rec split_or argo cls args def =
 
   do_split [] [] [] cls
 
-(* Ultra-naive spliting, close to semantics, used for exception/extension,
+(* Ultra-naive spliting, close to semantics, used for extension,
    as potential rebind prevents any kind of optimisation *)
 
 and split_naive cls args def k =
@@ -2155,7 +2155,7 @@ let split_extension_cases tag_lambda_list =
 let combine_constructor arg ex_pat cstr partial ctx def
     (tag_lambda_list, total1, pats) =
   if cstr.cstr_consts < 0 then begin
-    (* Special cases for exceptions and extensions *)
+    (* Special cases for extensions *)
     let fail, to_add, local_jumps =
       mk_failaction_neg partial ctx def in
     let tag_lambda_list = to_add@tag_lambda_list in
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index fbf00c0da9..4f626ff43b 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -30,40 +30,48 @@ type error =
 
 exception Error of Location.t * error
 
-(* Compile an exception definition *)
+(* Keep track of the root path (from the root of the namespace to the
+   currently compiled module expression).  Useful for naming extensions. *)
+
+let global_path glob = Some(Pident glob)
+let functor_path path param =
+  match path with
+    None -> None
+  | Some p -> Some(Papply(p, Pident param))
+let field_path path field =
+  match path with
+    None -> None
+  | Some p -> Some(Pdot(p, Ident.name field, Path.nopos))
+
+(* Compile type extensions *)
 
 let prim_set_oo_id =
   Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1;
           prim_alloc = false; prim_native_name = "";
           prim_native_float = false}
 
-let transl_exception path decl =
+let transl_extension_constructor env path ext =
   let name =
     match path with
-      None -> Ident.name decl.cd_id
+      None -> Ident.name ext.ext_id
     | Some p -> Path.name p
   in
-  Lprim(prim_set_oo_id,
-        [Lprim(Pmakeblock(Obj.object_tag, Mutable),
-              [Lconst(Const_base(Const_string (name,None)));
-               Lconst(Const_base(Const_int 0))])])
-
-(* Compile a type extension *)
-
-let transl_type_extension env tyext body =
+  match ext.ext_kind with
+    Text_decl(args, ret) ->
+      Lprim(prim_set_oo_id,
+            [Lprim(Pmakeblock(Obj.object_tag, Immutable),
+                   [Lconst(Const_base(Const_string (name,None)));
+                    Lconst(Const_base(Const_int 0))])])
+  | Text_rebind(path, lid) ->
+      transl_path ~loc:ext.ext_loc env path
+
+let transl_type_extension env rootpath tyext body =
   List.fold_right
     (fun ext body ->
-       let lam =
-         match ext.ext_kind with
-           Text_decl(args, ret) ->
-             Lprim(prim_set_oo_id,
-                   [Lprim(Pmakeblock(Obj.object_tag, Immutable),
-                          [Lconst(Const_base(Const_int 0));
-                           Lconst(Const_base(Const_int 0))])])
-         | Text_rebind(path, lid) ->
-             transl_path ~loc:ext.ext_loc env path
-       in
-         Llet(Strict, ext.ext_id, lam, body))
+      let lam =
+        transl_extension_constructor env (field_path rootpath ext.ext_id) ext
+      in
+      Llet(Strict, ext.ext_id, lam, body))
     tyext.tyext_constructors
     body
 
@@ -145,19 +153,6 @@ let record_primitive = function
       primitive_declarations := p :: !primitive_declarations
   | _ -> ()
 
-(* Keep track of the root path (from the root of the namespace to the
-   currently compiled module expression).  Useful for naming exceptions. *)
-
-let global_path glob = Some(Pident glob)
-let functor_path path param =
-  match path with
-    None -> None
-  | Some p -> Some(Papply(p, Pident param))
-let field_path path field =
-  match path with
-    None -> None
-  | Some p -> Some(Pdot(p, Ident.name field, Path.nopos))
-
 (* Utilities for compiling "module rec" definitions *)
 
 let mod_prim name =
@@ -202,8 +197,6 @@ let init_shape modl =
         init_shape_struct (Env.add_type ~check:false id tdecl env) rem
     | Sig_typext(id, ext, _) :: rem ->
         raise Not_found
-    | Sig_exception(id, edecl) :: rem ->
-        raise Not_found
     | Sig_module(id, md, _) :: rem ->
         init_shape_mod env md.md_type ::
         init_shape_struct (Env.add_module_declaration id md env) rem
@@ -296,7 +289,7 @@ let compile_recmodule compile_rhs bindings cont =
 
 (* Extract the list of "value" identifiers bound by a signature.
    "Value" identifiers are identifiers for signature components that
-   correspond to a run-time value: values, exceptions, modules, classes.
+   correspond to a run-time value: values, extensions, modules, classes.
    Note: manifest primitives do not correspond to a run-time value! *)
 
 let rec bound_value_identifiers = function
@@ -304,7 +297,6 @@ let rec bound_value_identifiers = function
   | Sig_value(id, {val_kind = Val_reg}) :: rem ->
       id :: bound_value_identifiers rem
   | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem
-  | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
   | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
   | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
   | _ :: rem -> bound_value_identifiers rem
@@ -387,14 +379,12 @@ and transl_structure fields cc rootpath = function
       transl_structure fields cc rootpath rem
   | Tstr_typext(tyext) ->
       let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
-        transl_type_extension item.str_env tyext
-          (transl_structure (List.rev_append ids fields) cc rootpath rem)
-  | Tstr_exception decl ->
-      let id = decl.cd_id in
-      Llet(Strict, id, transl_exception (field_path rootpath id) decl,
-           transl_structure (id :: fields) cc rootpath rem)
-  | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
-      Llet(Strict, id, transl_path ~loc item.str_env path,
+      transl_type_extension item.str_env rootpath tyext
+        (transl_structure (List.rev_append ids fields) cc rootpath rem)
+  | Tstr_exception ext ->
+      let id = ext.ext_id in
+      let path = field_path rootpath id in
+      Llet(Strict, id, transl_extension_constructor item.str_env path ext,
            transl_structure (id :: fields) cc rootpath rem)
   | Tstr_module mb ->
       let id = mb.mb_id in
@@ -473,8 +463,7 @@ let rec defined_idents = function
     | Tstr_typext tyext ->
       List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
       @ defined_idents rem
-    | Tstr_exception decl -> decl.cd_id :: defined_idents rem
-    | Tstr_exn_rebind(id, _, path, _, _) -> id :: defined_idents rem
+    | Tstr_exception ext -> ext.ext_id :: defined_idents rem
     | Tstr_module mb -> mb.mb_id :: defined_idents rem
     | Tstr_recmodule decls ->
       List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
@@ -498,7 +487,6 @@ let rec more_idents = function
     | Tstr_type decls -> more_idents rem
     | Tstr_typext tyext -> more_idents rem
     | Tstr_exception _ -> more_idents rem
-    | Tstr_exn_rebind(id, _, path, _, _) -> more_idents rem
     | Tstr_recmodule decls -> more_idents rem
     | Tstr_modtype _ -> more_idents rem
     | Tstr_open _ -> more_idents rem
@@ -522,8 +510,7 @@ and all_idents = function
     | Tstr_typext tyext ->
       List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
       @ all_idents rem
-    | Tstr_exception decl -> decl.cd_id :: all_idents rem
-    | Tstr_exn_rebind(id, _, path, _, _) -> id :: all_idents rem
+    | Tstr_exception ext -> ext.ext_id :: all_idents rem
     | Tstr_recmodule decls ->
       List.map (fun mb -> mb.mb_id) decls @ all_idents rem
     | Tstr_modtype _ -> all_idents rem
@@ -580,17 +567,16 @@ let transl_store_structure glob map prims str =
       transl_store rootpath subst rem
   | Tstr_typext(tyext) ->
       let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
-      let lam = transl_type_extension item.str_env tyext (store_idents ids) in
+      let lam =
+        transl_type_extension item.str_env rootpath tyext (store_idents ids)
+      in
         Lsequence(subst_lambda subst lam,
                   transl_store rootpath (add_idents false ids subst) rem)
-  | Tstr_exception decl ->
-      let id = decl.cd_id in
-      let lam = transl_exception (field_path rootpath id) decl in
-      Lsequence(Llet(Strict, id, lam, store_ident id),
-                transl_store rootpath (add_ident false id subst) rem)
-  | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
-      let lam = subst_lambda subst (transl_path ~loc item.str_env path) in
-      Lsequence(Llet(Strict, id, lam, store_ident id),
+  | Tstr_exception ext ->
+      let id = ext.ext_id in
+      let path = field_path rootpath id in
+      let lam = transl_extension_constructor item.str_env path ext in
+      Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id),
                 transl_store rootpath (add_ident false id subst) rem)
   | Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} ->
     let lam = transl_store (field_path rootpath id) subst str.str_items in
@@ -802,12 +788,11 @@ let transl_toplevel_item item =
       let idents =
         List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
       in
-        transl_type_extension item.str_env tyext
+        transl_type_extension item.str_env None tyext
           (make_sequence toploop_setvalue_id idents)
-  | Tstr_exception decl ->
-      toploop_setvalue decl.cd_id (transl_exception None decl)
-  | Tstr_exn_rebind(id, _, path, {Location.loc=loc}, _) ->
-      toploop_setvalue id (transl_path ~loc item.str_env path)
+  | Tstr_exception ext ->
+      toploop_setvalue ext.ext_id
+        (transl_extension_constructor item.str_env None ext)
   | Tstr_module {mb_id=id; mb_expr=modl} ->
       (* we need to use the unique name for the module because of issues
          with "open" (PR#1672) *)
diff --git a/man/ocamlc.m b/man/ocamlc.m
index 68922ebe6d..c5dff1ec8e 100644
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -773,7 +773,7 @@ mutually recursive types.
 \ \ Unused constructor.
 
 38
-\ \ Unused exception constructor.
+\ \ Unused extension constructor.
 
 39
 \ \ Unused rec flag.
@@ -815,7 +815,7 @@ mentioned here corresponds to the empty set.
 \ 5
 
 .B K
-\ 32, 33, 34, 35, 36, 37, 38, 39, 47
+\ 32, 33, 34, 35, 36, 37, 38, 39
 
 .B L
 \ 6
@@ -849,7 +849,7 @@ mentioned here corresponds to the empty set.
 
 .IP
 The default setting is
-.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41..42\-44\-45\-47 .
+.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41..42\-44\-45 .
 Note that warnings
 .BR 5 \ and \ 10
 are not always triggered, depending on the internals of the type checker.
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 6b0d79a9e2..72f360e30c 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -51,7 +51,6 @@ module Typedtree_search =
       | CT of string
       | X of string
       | E of string
-      | ER of string
       | P of string
       | IM of string
 
@@ -82,10 +81,8 @@ module Typedtree_search =
             [] -> assert false
           | ext :: _ -> Hashtbl.add table (X (Name.from_ident ext.ext_id)) tt
         end
-      | Typedtree.Tstr_exception decl ->
-          Hashtbl.add table (E (Name.from_ident decl.cd_id)) tt
-      | Typedtree.Tstr_exn_rebind (ident, _, _, _, _) ->
-          Hashtbl.add table (ER (Name.from_ident ident)) tt
+      | Typedtree.Tstr_exception ext ->
+          Hashtbl.add table (E (Name.from_ident ext.ext_id)) tt
       | Typedtree.Tstr_type ident_type_decl_list ->
           List.iter
             (fun td ->
@@ -143,12 +140,7 @@ module Typedtree_search =
 
     let search_exception table name =
       match Hashtbl.find table (E name) with
-      | (Typedtree.Tstr_exception decl) -> decl
-      | _ -> assert false
-
-    let search_exception_rebind table name =
-      match Hashtbl.find table (ER name) with
-      | (Typedtree.Tstr_exn_rebind (_, _, p, _, _)) -> p
+      | (Typedtree.Tstr_exception ext) -> ext
       | _ -> assert false
 
     let search_type_declaration table name =
@@ -1001,7 +993,7 @@ module Analyser =
               else (fun _ -> false)
         | Element_exception e ->
             (function
-                Types.Sig_exception (ident,_) ->
+                Types.Sig_typext (ident,_,_) ->
                   let n1 = Name.simple e.ex_name
                   and n2 = Ident.name ident in
                   n1 = n2
@@ -1364,61 +1356,59 @@ module Analyser =
               new_te.te_constructors <- exts;
               (maybe_more, new_env, [ Element_type_extension new_te ])
 
-      | Parsetree.Pstr_exception excep_decl ->
-          let name = excep_decl.Parsetree.pcd_name in
+      | Parsetree.Pstr_exception ext ->
+          let name = ext.Parsetree.pext_name in
           (* a new exception is defined *)
           let complete_name = Name.concat current_module_name name.txt in
           (* we get the exception declaration in the typed tree *)
-          let tt_excep_decl =
+          let tt_ext =
             try Typedtree_search.search_exception table name.txt
             with Not_found ->
               raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))
           in
-          let new_env = Odoc_env.add_exception env complete_name in
-          let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-          let loc_end =  loc.Location.loc_end.Lexing.pos_cnum in
-          let new_ex =
-            {
-              ex_name = complete_name ;
-              ex_info = comment_opt ;
-              ex_args = List.map (fun ctyp ->
-                Odoc_env.subst_type new_env ctyp.ctyp_type)
-                tt_excep_decl.cd_args;
-              ex_alias = None ;
-              ex_loc = { loc_impl = Some loc ; loc_inter = None } ;
-              ex_code =
-                (
-                 if !Odoc_global.keep_code then
-                   Some (get_string_of_file loc_start loc_end)
-                 else
-                   None
-                ) ;
-            }
-          in
-          (0, new_env, [ Element_exception new_ex ])
-
-      | Parsetree.Pstr_exn_rebind (name,  _, _) ->
-          (* a new exception is defined *)
-          let complete_name = Name.concat current_module_name name.txt in
-          (* we get the exception rebind in the typed tree *)
-          let tt_path =
-            try Typedtree_search.search_exception_rebind table name.txt
-            with Not_found ->
-              raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))
-          in
-          let new_env = Odoc_env.add_exception env complete_name in
-          let new_ex =
-            {
-              ex_name = complete_name ;
-              ex_info = comment_opt ;
-              ex_args = [] ;
-              ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ;
-                                ea_ex = None ; } ;
-              ex_loc = { loc_impl = Some loc ; loc_inter = None } ;
-              ex_code = None ;
-            }
+          let new_env = Odoc_env.add_extension env complete_name in
+          let new_ext =
+            match tt_ext.ext_kind with
+              Text_decl(tt_args, tt_ret_type) ->
+                let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
+                let loc_end =  loc.Location.loc_end.Lexing.pos_cnum in
+                {
+                  ex_name = complete_name ;
+                  ex_info = comment_opt ;
+                  ex_args =
+                    List.map
+                      (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type)
+                      tt_args;
+                  ex_ret =
+                    Misc.may_map
+                      (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type)
+                      tt_ret_type;
+                  ex_alias = None ;
+                  ex_loc = { loc_impl = Some loc ; loc_inter = None } ;
+                  ex_code =
+                    (
+                      if !Odoc_global.keep_code then
+                        Some (get_string_of_file loc_start loc_end)
+                      else
+                        None
+                    ) ;
+                }
+            | Text_rebind(tt_path, _) ->
+                {
+                  ex_name = complete_name ;
+                  ex_info = comment_opt ;
+                  ex_args = [] ;
+                  ex_ret = None ;
+                  ex_alias =
+                    Some { ea_name =
+                             Odoc_env.full_extension_constructor_name
+                               env (Name.from_path tt_path) ;
+                           ea_ex = None ; } ;
+                  ex_loc = { loc_impl = Some loc ; loc_inter = None } ;
+                  ex_code = None ;
+                }
           in
-          (0, new_env, [ Element_exception new_ex ])
+            (0, new_env, [ Element_exception new_ext ])
 
       | Parsetree.Pstr_module {Parsetree.pmb_name=name; pmb_expr=module_expr} ->
           (
diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli
index 6658f99e8c..c3db304ea7 100644
--- a/ocamldoc/odoc_ast.mli
+++ b/ocamldoc/odoc_ast.mli
@@ -40,16 +40,6 @@ module Typedtree_search :
          @raise Not_found if the extension was not found.*)
       val search_extension : tab -> string -> Typedtree.type_extension
 
-      (** This function returns the [Typedtree.exception_declaration] associated to the given exception name,
-         in the given table.
-         @raise Not_found if the exception was not found.*)
-      val search_exception : tab -> string -> Typedtree.constructor_declaration
-
-      (** This function returns the [Path.t] associated to the given exception rebind name,
-         in the table.
-         @raise Not_found if the exception rebind was not found.*)
-      val search_exception_rebind : tab -> string -> Path.t
-
       (** This function returns the [Typedtree.type_declaration] associated to the given type name,
          in the given table.
          @raise Not_found if the type was not found. *)
diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml
index 678b9fafe0..3e05905856 100644
--- a/ocamldoc/odoc_env.ml
+++ b/ocamldoc/odoc_env.ml
@@ -27,7 +27,6 @@ type env = {
     env_modules : env_element list ;
     env_module_types : env_element list ;
     env_extensions : env_element list ;
-    env_exceptions : env_element list ;
   }
 
 let empty = {
@@ -38,7 +37,6 @@ let empty = {
   env_modules = [] ;
   env_module_types = [] ;
   env_extensions = [] ;
-  env_exceptions = [] ;
   }
 
 (** Add a signature to an environment.  *)
@@ -55,7 +53,6 @@ let rec add_signature env root ?rel signat =
       Types.Sig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values }
     | Types.Sig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types }
     | Types.Sig_typext (ident, _, _) -> { env with env_extensions = (rel_name ident, qualify ident) :: env.env_extensions }
-    | Types.Sig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions }
     | Types.Sig_module (ident, md, _) ->
         let env2 =
           match md.Types.md_type with (* A VOIR : le cas ou c'est un identificateur, dans ce cas on n'a pas de signature *)
@@ -84,10 +81,6 @@ let add_extension env full_name =
   let simple_name = Name.simple full_name in
   { env with env_extensions = (simple_name, full_name) :: env.env_extensions }
 
-let add_exception env full_name =
-  let simple_name = Name.simple full_name in
-  { env with env_exceptions = (simple_name, full_name) :: env.env_exceptions }
-
 let add_type env full_name =
   let simple_name = Name.simple full_name in
   { env with env_types = (simple_name, full_name) :: env.env_types }
@@ -160,13 +153,6 @@ let full_extension_constructor_name env n =
     List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_extensions;
     n
 
-let full_exception_name env n =
-  try List.assoc n env.env_exceptions
-  with Not_found ->
-    print_DEBUG ("Exception "^n^" not found with env=");
-    List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_exceptions;
-    n
-
 let full_class_name env n =
   try List.assoc n env.env_classes
   with Not_found ->
diff --git a/ocamldoc/odoc_env.mli b/ocamldoc/odoc_env.mli
index 0016258bfb..4e1e8606d7 100644
--- a/ocamldoc/odoc_env.mli
+++ b/ocamldoc/odoc_env.mli
@@ -23,7 +23,6 @@ val empty : env
 
 val add_signature : env -> string -> ?rel:string -> Types.signature -> env
 val add_extension : env -> Odoc_name.t -> env
-val add_exception : env -> Odoc_name.t -> env
 val add_type : env -> Odoc_name.t -> env
 val add_value : env -> Odoc_name.t -> env
 val add_module : env -> Odoc_name.t -> env
@@ -52,9 +51,6 @@ val full_value_name : env -> Odoc_name.t -> Odoc_name.t
 (** Get the fully qualified extension name from a name.*)
 val full_extension_constructor_name : env -> Odoc_name.t -> Odoc_name.t
 
-(** Get the fully qualified exception name from a name.*)
-val full_exception_name : env -> Odoc_name.t -> Odoc_name.t
-
 (** Get the fully qualified class name from a name.*)
 val full_class_name : env -> Odoc_name.t -> Odoc_name.t
 
diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml
index a62cb7b7d5..b0e21196cc 100644
--- a/ocamldoc/odoc_exception.ml
+++ b/ocamldoc/odoc_exception.ml
@@ -23,6 +23,7 @@ and t_exception = {
     ex_name : Name.t ;
     mutable ex_info : Odoc_types.info option ; (** optional user information *)
     ex_args : Types.type_expr list ; (** the types of the parameters *)
+    ex_ret: Types.type_expr option ; (** the optional return type *)
     ex_alias : exception_alias option ;
     mutable ex_loc : Odoc_types.location ;
     mutable ex_code : string option ;
diff --git a/ocamldoc/odoc_extension.ml b/ocamldoc/odoc_extension.ml
new file mode 100644
index 0000000000..0a08419530
--- /dev/null
+++ b/ocamldoc/odoc_extension.ml
@@ -0,0 +1,46 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Representation and manipulation of type extensions. *)
+
+module Name = Odoc_name
+
+type private_flag = Asttypes.private_flag =
+    Private | Public
+
+type extension_alias = {
+    xa_name : Name.t ;
+    mutable xa_xt : t_extension_constructor option ;
+  }
+
+and t_extension_constructor = {
+    xt_name : Name.t ;
+    xt_args: Types.type_expr list ; (** the types of the parameters *)
+    xt_ret: Types.type_expr option ; (** the optional return type of the extension *)
+    xt_type_extension: t_type_extension ; (** the type extension containing this constructor *)
+    xt_alias: extension_alias option ;
+    mutable xt_loc: Odoc_types.location ;
+    mutable xt_text: Odoc_types.info option ; (** optional user description *)
+  }
+
+and t_type_extension = {
+    mutable te_info : Odoc_types.info option ; (** optional user information *)
+    te_type_name : Name.t;
+    te_type_parameters : Types.type_expr list;
+    te_private : private_flag;
+    mutable te_constructors: t_extension_constructor list;
+    mutable te_loc : Odoc_types.location ;
+    mutable te_code : string option ;
+  }
+
+let extension_constructors te = te.te_constructors
diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
index 5250c0db27..f28c4b95c5 100644
--- a/ocamldoc/odoc_html.ml
+++ b/ocamldoc/odoc_html.ml
@@ -1534,12 +1534,21 @@ class html =
       bs b (Name.simple e.ex_name);
       bs b "</span>";
       (
-       match e.ex_args with
-         [] -> ()
-       | _ ->
-           bs b (" "^(self#keyword "of")^" ");
-           self#html_of_type_expr_list
-             ~par: false b (Name.father e.ex_name) " * " e.ex_args
+        match e.ex_args, e.ex_ret with
+          [], None -> ()
+        | l,None ->
+            bs b (" "^(self#keyword "of")^" ");
+            self#html_of_type_expr_list
+                   ~par: false b (Name.father e.ex_name) " * " e.ex_args
+        | [],Some r ->
+            bs b (" " ^ (self#keyword ":") ^ " ");
+            self#html_of_type_expr b (Name.father e.ex_name) r;
+        | l,Some r ->
+            bs b (" " ^ (self#keyword ":") ^ " ");
+            self#html_of_type_expr_list
+                   ~par: false b (Name.father e.ex_name) " * " l;
+            bs b (" " ^ (self#keyword "->") ^ " ");
+            self#html_of_type_expr b (Name.father e.ex_name) r;
       );
       (
        match e.ex_alias with
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index c1f77f972d..37f86bbe29 100644
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -227,6 +227,7 @@ module Exception :
           ex_name : Name.t ;
           mutable ex_info : info option ; (** Information found in the optional associated comment. *)
           ex_args : Types.type_expr list ; (** The types of the parameters. *)
+          ex_ret : Types.type_expr option ; (** The the optional return type of the exception. *)
           ex_alias : exception_alias option ; (** [None] when the exception is not a rebind. *)
           mutable ex_loc : location ;
           mutable ex_code : string option ;
diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index 1907b446ae..74f3ae977d 100644
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -497,13 +497,23 @@ class man =
       bs b (Name.simple e.ex_name);
       bs b " \n";
       (
-       match e.ex_args with
-         [] -> ()
-       | _ ->
+        match e.ex_args, e.ex_ret with
+        | [], None -> ()
+        | l, None ->
            bs b ".B of ";
            self#man_of_type_expr_list
              ~par: false
              b (Name.father e.ex_name) " * " e.ex_args
+        | [], Some r ->
+            bs b ".B : ";
+            self#man_of_type_expr b (Name.father e.ex_name) r
+        | l, Some r ->
+            bs b ".B : ";
+            self#man_of_type_expr_list
+                   ~par: false
+                   b (Name.father e.ex_name) " * " l;
+            bs b ".B -> ";
+            self#man_of_type_expr b (Name.father e.ex_name) r
       );
       (
        match e.ex_alias with
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 7f5d5b5d91..ddc24c2b9f 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -40,7 +40,6 @@ module Signature_search =
       | C of string
       | CT of string
       | X of string
-      | E of string
       | P of string
 
     type tab = (ele, Types.signature_item) Hashtbl.t
@@ -51,8 +50,6 @@ module Signature_search =
           Hashtbl.add table (V (Name.from_ident ident)) signat
       | Types.Sig_typext (ident, _, _) ->
           Hashtbl.add table (X (Name.from_ident ident)) signat
-      | Types.Sig_exception (ident, _) ->
-          Hashtbl.add table (E (Name.from_ident ident)) signat
       | Types.Sig_type (ident, _, _) ->
           Hashtbl.add table (T (Name.from_ident ident)) signat
       | Types.Sig_class (ident, _, _) ->
@@ -79,12 +76,6 @@ module Signature_search =
       | (Types.Sig_typext (_, ext, _)) -> ext
       | _ -> assert false
 
-    let search_exception table name =
-      match Hashtbl.find table (E name) with
-      | (Types.Sig_exception (_, type_expr_list)) ->
-          type_expr_list
-      | _ -> assert false
-
     let search_type table name =
       match Hashtbl.find table (T name) with
       | (Types.Sig_type (_, type_decl, _)) -> type_decl
@@ -642,10 +633,10 @@ module Analyser =
               new_te.te_info <- merge_infos new_te.te_info info_after_opt ;
               (maybe_more + maybe_more2, new_env, [ Element_type_extension new_te ])
 
-        | Parsetree.Psig_exception exception_decl ->
-            let name = exception_decl.Parsetree.pcd_name in
-            let types_excep_decl =
-              try Signature_search.search_exception table name.txt
+        | Parsetree.Psig_exception ext ->
+            let name = ext.Parsetree.pext_name in
+            let types_ext =
+              try Signature_search.search_extension table name.txt
               with Not_found ->
                 raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt))
             in
@@ -653,7 +644,8 @@ module Analyser =
               {
                 ex_name = Name.concat current_module_name name.txt ;
                 ex_info = comment_opt ;
-                ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ;
+                ex_args = List.map (Odoc_env.subst_type env) types_ext.ext_args ;
+                ex_ret = may_map (Odoc_env.subst_type env) types_ext.ext_ret_type ;
                 ex_alias = None ;
                 ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ;
                 ex_code =
@@ -671,7 +663,7 @@ module Analyser =
                 (get_string_of_file pos_end_ele pos_limit)
             in
             e.ex_info <- merge_infos e.ex_info info_after_opt ;
-            let new_env = Odoc_env.add_exception env e.ex_name in
+            let new_env = Odoc_env.add_extension env e.ex_name in
             (maybe_more, new_env, [ Element_exception e ])
 
         | Parsetree.Psig_type name_type_decl_list ->
diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
index a0a494e8e5..782f967a9c 100644
--- a/ocamldoc/odoc_sig.mli
+++ b/ocamldoc/odoc_sig.mli
@@ -32,11 +32,6 @@ module Signature_search :
          @raise Not_found if error.*)
       val search_extension : tab -> string -> Types.extension_constructor
 
-      (** This function returns the type expression list for the exception whose name is given,
-         in the given table.
-         @raise Not_found if error.*)
-      val search_exception : tab -> string -> Types.exception_declaration
-
       (** This function returns the Types.type_declaration  for the type whose name is given,
          in the given table.
          @raise Not_found if error.*)
diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index 363e397180..db2eadca3c 100644
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -308,12 +308,21 @@ let string_of_type_extension te =
 let string_of_exception e =
   let module M = Odoc_exception in
   "exception "^(Name.simple e.M.ex_name)^
-  (match e.M.ex_args with
-    [] -> ""
-  | _ ->" : "^
-      (String.concat " -> "
-         (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") e.M.ex_args)
-      )
+  (match e.M.ex_args, e.M.ex_ret with
+     [], None -> ""
+   | l,None ->
+       " of "^
+       (String.concat " * "
+         (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))
+   | [],Some r ->
+       " : "^
+       (Odoc_print.string_of_type_expr r)
+   | l,Some r ->
+       " : "^
+       (String.concat " * "
+         (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))^
+       " -> "^
+       (Odoc_print.string_of_type_expr r)
   )^
   (match e.M.ex_alias with
     None -> ""
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index f6665e3e01..35e7b80f1d 100644
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -760,7 +760,7 @@ class texi =
         [ self#fixedblock
             ( [ Newline ; minus ; Raw "exception " ;
                 Raw (Name.simple e.ex_name) ;
-                Raw (self#string_of_type_args e.ex_args None) ] @
+                Raw (self#string_of_type_args e.ex_args e.ex_ret) ] @
               (match e.ex_alias with
               | None -> []
               | Some ea -> [ Raw " = " ; Raw
diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
index c913875704..1c7f6ba7fb 100644
--- a/ocamldoc/odoc_to_text.ml
+++ b/ocamldoc/odoc_to_text.ml
@@ -336,29 +336,36 @@ class virtual to_text =
     (** @return [text] value for an exception. *)
     method text_of_exception e =
       let s_name = Name.simple e.ex_name in
+      let father = Name.father e.ex_name in
       Format.fprintf Format.str_formatter "@[<hov 2>exception %s" s_name ;
-        (match e.ex_args with
-          [] -> ()
-        | _ ->
-            Format.fprintf Format.str_formatter "@ of "
-        );
-      let s = self#normal_type_list
-          ~par: false (Name.father e.ex_name) " * " e.ex_args
-      in
-      let s2 =
-        Format.fprintf Format.str_formatter "%s" s ;
-        (match e.ex_alias with
-          None -> ()
-        | Some ea ->
-            Format.fprintf Format.str_formatter " = %s"
-              (
-               match ea.ea_ex with
-                 None -> ea.ea_name
-               | Some e -> e.ex_name
-              )
-        );
-        Format.flush_str_formatter ()
-      in
+      (match e.ex_args, e.ex_ret with
+         [], None -> ()
+       | l, None ->
+           Format.fprintf Format.str_formatter " %s@ %s"
+             "of"
+             (self#normal_type_list ~par: false father " * " l)
+       | [], Some r ->
+           Format.fprintf Format.str_formatter " %s@ %s"
+             ":"
+             (self#normal_type father r)
+       | l, Some r ->
+           Format.fprintf Format.str_formatter " %s@ %s@ %s@ %s"
+             ":"
+             (self#normal_type_list ~par: false father " * " l)
+             "->"
+             (self#normal_type father r)
+      );
+      (match e.ex_alias with
+         None -> ()
+       | Some ea ->
+           Format.fprintf Format.str_formatter " = %s"
+            (
+              match ea.ea_ex with
+                None -> ea.ea_name
+              | Some e -> e.ex_name
+            )
+      );
+      let s2 = Format.flush_str_formatter () in
       [ CodePre s2 ] @
       [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
       (self#text_of_info e.ex_info)
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 4f182fa61f..51b0e91157 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -173,7 +173,6 @@ module Str = struct
   let type_ ?loc a = mk ?loc (Pstr_type a)
   let type_extension ?loc a = mk ?loc (Pstr_typext a)
   let exception_ ?loc a = mk ?loc (Pstr_exception a)
-  let exn_rebind ?loc ?(attrs = []) a b = mk ?loc (Pstr_exn_rebind (a, b, attrs))
   let module_ ?loc a = mk ?loc (Pstr_module a)
   let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
   let modtype ?loc a = mk ?loc (Pstr_modtype a)
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 616534e852..1dbbedf9d6 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -188,7 +188,7 @@ module Sig:
     val value: ?loc:loc -> value_description -> signature_item
     val type_: ?loc:loc -> type_declaration list -> signature_item
     val type_extension: ?loc:loc -> type_extension -> signature_item
-    val exception_: ?loc:loc -> constructor_declaration -> signature_item
+    val exception_: ?loc:loc -> extension_constructor -> signature_item
     val module_: ?loc:loc -> module_declaration -> signature_item
     val rec_module: ?loc:loc -> module_declaration list -> signature_item
     val modtype: ?loc:loc -> module_type_declaration -> signature_item
@@ -210,8 +210,7 @@ module Str:
     val primitive: ?loc:loc -> value_description -> structure_item
     val type_: ?loc:loc -> type_declaration list -> structure_item
     val type_extension: ?loc:loc -> type_extension -> structure_item
-    val exception_: ?loc:loc -> constructor_declaration -> structure_item
-    val exn_rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> structure_item
+    val exception_: ?loc:loc -> extension_constructor -> structure_item
     val module_: ?loc:loc -> module_binding -> structure_item
     val rec_module: ?loc:loc -> module_binding list -> structure_item
     val modtype: ?loc:loc -> module_type_declaration -> structure_item
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index f336753e79..0db8d0bb82 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -220,7 +220,7 @@ module MT = struct
     | Psig_value vd -> value ~loc (sub.value_description sub vd)
     | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
     | Psig_typext te -> type_extension ~loc (sub.type_extension sub te)
-    | Psig_exception ed -> exception_ ~loc (sub.constructor_declaration sub ed)
+    | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
     | Psig_module x -> module_ ~loc (sub.module_declaration sub x)
     | Psig_recmodule l ->
         rec_module ~loc (List.map (sub.module_declaration sub) l)
@@ -269,10 +269,7 @@ module M = struct
     | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
     | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
     | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
-    | Pstr_exception ed -> exception_ ~loc (sub.constructor_declaration sub ed)
-    | Pstr_exn_rebind (s, lid, attrs) ->
-        exn_rebind ~loc (map_loc sub s) (map_loc sub lid)
-          ~attrs:(sub.attributes sub attrs)
+    | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed)
     | Pstr_module x -> module_ ~loc (sub.module_binding sub x)
     | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
     | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 037d2fd265..82e5b51e6f 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -622,10 +622,8 @@ structure_item:
       { mkstr(Pstr_type (List.rev $2) ) }
   | TYPE str_type_extension
       { mkstr(Pstr_typext $2) }
-  | EXCEPTION exception_declaration
+  | EXCEPTION str_exception_declaration
       { mkstr(Pstr_exception $2) }
-  | EXCEPTION UIDENT EQUAL constr_longident post_item_attributes
-      { mkstr(Pstr_exn_rebind(mkrhs $2 2, mkloc $4 (rhs_loc 4), $5)) }
   | MODULE module_binding
       { mkstr(Pstr_module $2) }
   | MODULE REC module_bindings
@@ -721,7 +719,7 @@ signature_item:
       { mksig(Psig_type (List.rev $2)) }
   | TYPE sig_type_extension
       { mksig(Psig_typext $2) }
-  | EXCEPTION exception_declaration
+  | EXCEPTION sig_exception_declaration
       { mksig(Psig_exception $2) }
   | MODULE UIDENT module_declaration post_item_attributes
       { mksig(Psig_module (Md.mk (mkrhs $2 2)
@@ -1590,11 +1588,23 @@ constructor_declaration:
        Type.constructor (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$2
       }
 ;
-exception_declaration:
-  | constructor_declaration post_item_attributes
+str_exception_declaration:
+  | extension_constructor_declaration post_item_attributes
       {
-        let cd = $1 in
-        {cd with pcd_attributes = cd.pcd_attributes @ $2}
+        let ext = $1 in
+        {ext with pext_attributes = ext.pext_attributes @ $2}
+      }
+  | extension_constructor_rebind post_item_attributes
+      {
+        let ext = $1 in
+        {ext with pext_attributes = ext.pext_attributes @ $2}
+      }
+;
+sig_exception_declaration:
+  | extension_constructor_declaration post_item_attributes
+      {
+        let ext = $1 in
+        {ext with pext_attributes = ext.pext_attributes @ $2}
       }
 ;
 generalized_constructor_arguments:
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 9622758efe..3c39fa5cf4 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -606,7 +606,7 @@ and signature_item_desc =
         (* type t1 = ... and ... and tn = ... *)
   | Psig_typext of type_extension
         (* type t1 += ... *)
-  | Psig_exception of constructor_declaration
+  | Psig_exception of extension_constructor
         (* exception C of T *)
   | Psig_module of module_declaration
         (* module X : MT *)
@@ -709,10 +709,9 @@ and structure_item_desc =
         (* type t1 = ... and ... and tn = ... *)
   | Pstr_typext of type_extension
         (* type t1 += ... *)
-  | Pstr_exception of constructor_declaration
-        (* exception C of T *)
-  | Pstr_exn_rebind of string loc * Longident.t loc * attributes
-        (* exception C = M.X *)
+  | Pstr_exception of extension_constructor
+        (* exception C of T
+           exception C = M.X *)
   | Pstr_module of module_binding
         (* module X = ME *)
   | Pstr_recmodule of module_binding list
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index e17e86f7e0..2f20e165d7 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -695,11 +695,8 @@ class printer  ()= object(self:'self)
         end) x
 
 
-  method exception_declaration f cd =
-    pp f "@[<hov2>exception@ %s%a@]" cd.pcd_name.txt
-      (fun f ed -> match ed with
-      |[] -> ()
-      |_ -> pp f "@ of@ %a" (self#list ~sep:"*" self#core_type) ed) cd.pcd_args
+  method exception_declaration f ext =
+    pp f "@[<hov2>exception@ %a@]" self#extension_constructor ext
 
   method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} =
     let class_type_field f x =
@@ -1109,8 +1106,6 @@ class printer  ()= object(self:'self)
           self#value_description  vd
     | Pstr_include (me, _attrs) ->
         pp f "@[<hov2>include@ %a@]"  self#module_expr  me
-    | Pstr_exn_rebind (s, li, _attrs) ->        (* todo: check this *)
-        pp f "@[<hov2>exception@ %s@ =@ %a@]" s.txt self#longident_loc li
     | Pstr_recmodule decls -> (* 3.07 *)
         let aux f = function
           | {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} ->
@@ -1195,14 +1190,27 @@ class printer  ()= object(self:'self)
   end
 
   method type_extension f x =
-    let extension_constructor f x = match x.pext_kind with
+    let extension_constructor f x =
+      pp f "@\n|@;%a" self#extension_constructor x
+    in
+      pp f "@[<2>type %a%a +=@;%a@]"
+         (fun f -> function
+                | [] -> ()
+                | l ->  pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l)
+         x.ptyext_params
+         self#longident_loc x.ptyext_path
+         (self#list ~sep:"" extension_constructor)
+         x.ptyext_constructors
+
+  method extension_constructor f x =
+    match x.pext_kind with
     | Pext_decl(l, None) ->
-        pp f "@\n|@;%s%a" x.pext_name.txt
+        pp f "%s%a" x.pext_name.txt
           (fun f -> function
                  | [] -> ()
                  | l -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l) l
     | Pext_decl(l, Some r) ->
-        pp f "@\n|@;%s:@;%a" x.pext_name.txt
+        pp f "%s:@;%a" x.pext_name.txt
           (fun f -> function
                  | [] -> self#core_type1 f r
                  | l -> pp f "%a@;->@;%a"
@@ -1210,17 +1218,8 @@ class printer  ()= object(self:'self)
                            self#core_type1 r)
           l
     | Pext_rebind li ->
-        pp f "@\n|@;%s@ = @ %a" x.pext_name.txt
+        pp f "%s@ = @ %a" x.pext_name.txt
            self#longident_loc li
-    in
-      pp f "@[<2>type %a%a +=@;%a@]"
-         (fun f -> function
-                | [] -> ()
-                | l ->  pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l)
-         x.ptyext_params
-         self#longident_loc x.ptyext_path
-         (self#list ~sep:"" extension_constructor)
-         x.ptyext_constructors
 
   method case_list f l : unit =
     let aux f {pc_lhs; pc_guard; pc_rhs} =
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
index 895df4e62a..316218d310 100644
--- a/parsing/pprintast.mli
+++ b/parsing/pprintast.mli
@@ -44,10 +44,12 @@ class printer :
     method directive_argument :
       Format.formatter -> Parsetree.directive_argument -> unit
     method exception_declaration :
-      Format.formatter -> Parsetree.constructor_declaration -> unit
+      Format.formatter -> Parsetree.extension_constructor -> unit
     method expression : Format.formatter -> Parsetree.expression -> unit
     method expression1 : Format.formatter -> Parsetree.expression -> unit
     method expression2 : Format.formatter -> Parsetree.expression -> unit
+    method extension_constructor :
+      Format.formatter -> Parsetree.extension_constructor -> unit
     method label_exp :
       Format.formatter ->
       Asttypes.label * Parsetree.expression option * Parsetree.pattern ->
diff --git a/parsing/printast.ml b/parsing/printast.ml
index eac9ed7cdf..a0dd83b017 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -632,9 +632,9 @@ and signature_item i ppf x =
   | Psig_typext te ->
       line i ppf "Psig_typext\n";
       type_extension i ppf te
-  | Psig_exception cd ->
+  | Psig_exception ext ->
       line i ppf "Psig_exception\n";
-      constructor_decl i ppf cd;
+      extension_constructor i ppf ext;
   | Psig_module pmd ->
       line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name;
       attributes i ppf pmd.pmd_attributes;
@@ -740,14 +740,9 @@ and structure_item i ppf x =
   | Pstr_typext te ->
       line i ppf "Pstr_typext\n";
       type_extension i ppf te
-  | Pstr_exception cd ->
+  | Pstr_exception ext ->
       line i ppf "Pstr_exception\n";
-      constructor_decl i ppf cd;
-  | Pstr_exn_rebind (s, li, attrs) ->
-      line i ppf "Pstr_exn_rebind\n";
-      attributes i ppf attrs;
-      line (i+1) ppf "%a\n" fmt_string_loc s;
-      line (i+1) ppf "%a\n" fmt_longident_loc li
+      extension_constructor i ppf ext;
   | Pstr_module x ->
       line i ppf "Pstr_module\n";
       module_binding i ppf x
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index a6f11586e8..2115f6aa56 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -56,3 +56,28 @@ let final_tag = custom_tag
 let int_tag = 1000
 let out_of_heap_tag = 1001
 let unaligned_tag = 1002
+
+let extension_slot x =
+  let x = repr x in
+  let slot =
+    if (is_block x) && (tag x) <> object_tag && (size x) >= 1 then field x 0
+    else x
+  in
+  let name =
+    if (is_block slot) && (tag slot) = object_tag then field slot 0
+    else raise Not_found
+  in
+    if (tag name) = string_tag then slot
+    else raise Not_found
+
+let extension_name x =
+  try
+    let slot = extension_slot x in
+      (obj (field slot 0) : string)
+  with Not_found -> invalid_arg "Obj.extension_name"
+
+let extension_id x =
+  try
+    let slot = extension_slot x in
+      (obj (field slot 1) : int)
+  with Not_found -> invalid_arg "Obj.extension_id"
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 9a5bd721d5..b201cfdd05 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -53,6 +53,9 @@ val int_tag : int
 val out_of_heap_tag : int
 val unaligned_tag : int   (* should never happen @since 3.11.0 *)
 
+val extension_name : 'a -> string
+val extension_id : 'a -> int
+
 (** The following two functions are deprecated.  Use module {!Marshal}
     instead. *)
 
diff --git a/testsuite/tests/typing-extensions/Makefile b/testsuite/tests/typing-extensions/Makefile
new file mode 100644
index 0000000000..5f42b70577
--- /dev/null
+++ b/testsuite/tests/typing-extensions/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+
diff --git a/testsuite/tests/typing-extensions/cast.ml b/testsuite/tests/typing-extensions/cast.ml
new file mode 100644
index 0000000000..afcc2080dc
--- /dev/null
+++ b/testsuite/tests/typing-extensions/cast.ml
@@ -0,0 +1,96 @@
+
+(* By using two types we can have a recursive constraint *)
+type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..>
+and 'a name = Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name
+;;
+
+exception Bad_cast
+;;
+
+class type castable =
+object
+  method cast: 'a.'a name -> 'a
+end
+;;
+
+(* Lets create a castable class with a name*)
+
+class type foo_t =
+object
+  inherit castable
+  method foo: string
+end
+;;
+
+type 'a class_name += Foo: foo_t class_name
+;;
+
+class foo: foo_t =
+object(self)
+  method cast: type a. a name -> a =
+    function
+	Class Foo -> (self :> foo_t)
+      | _ -> ((raise Bad_cast) : a)
+  method foo = "foo"
+end
+;;
+
+(* Now we can create a subclass of foo *)
+
+class type bar_t =
+object
+  inherit foo
+  method bar: string
+end
+;;
+
+type 'a class_name += Bar: bar_t class_name
+;;
+
+class bar: bar_t =
+object(self)
+  inherit foo as super
+  method cast: type a. a name -> a =
+    function
+        Class Bar -> (self :> bar_t)
+      | other -> super#cast other
+  method bar = "bar"
+end
+;;
+
+(* Now lets create a mutable list of castable objects *)
+
+let clist :castable list ref = ref []
+;;
+
+let push_castable (c: #castable) =
+  clist := (c :> castable) :: !clist
+;;
+
+let pop_castable () =
+  match !clist with
+      c :: rest ->
+        clist := rest;
+        c
+    | [] -> raise Not_found
+;;
+
+(* We can add foos and bars to this list, and retrive them *)
+
+push_castable (new foo);;
+push_castable (new bar);;
+push_castable (new foo);;
+
+let c1: castable = pop_castable ();;
+let c2: castable = pop_castable ();;
+let c3: castable = pop_castable ();;
+
+(* We can also downcast these values to foos and bars *)
+
+let f1: foo = c1#cast (Class Foo);; (* Ok *)
+let f2: foo = c2#cast (Class Foo);; (* Ok *)
+let f3: foo = c3#cast (Class Foo);; (* Ok *)
+
+let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *)
+let b2: bar = c2#cast (Class Bar);; (* Ok *)
+let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *)
diff --git a/testsuite/tests/typing-extensions/cast.ml.reference b/testsuite/tests/typing-extensions/cast.ml.reference
new file mode 100644
index 0000000000..c229741638
--- /dev/null
+++ b/testsuite/tests/typing-extensions/cast.ml.reference
@@ -0,0 +1,33 @@
+
+#         type 'b class_name = .. constraint 'b = < cast : 'a. 'a name -> 'a; .. >
+and 'a name =
+    Class : 'a class_name -> (< cast : 'a0. 'a0 name -> 'a0; .. > as 'a) name
+#     exception Bad_cast
+#           class type castable = object method cast : 'a name -> 'a end
+#                 class type foo_t = object method cast : 'a name -> 'a method foo : string end
+#     type 'b class_name += Foo : foo_t class_name
+#                   class foo : foo_t
+#                 class type bar_t =
+  object
+    method bar : string
+    method cast : 'a name -> 'a
+    method foo : string
+  end
+#     type 'b class_name += Bar : bar_t class_name
+#                     class bar : bar_t
+#         val clist : castable list ref = {contents = []}
+#       val push_castable : #castable -> unit = <fun>
+#               val pop_castable : unit -> castable = <fun>
+#       - : unit = ()
+# - : unit = ()
+# - : unit = ()
+#   val c1 : castable = <obj>
+# val c2 : castable = <obj>
+# val c3 : castable = <obj>
+#       val f1 : foo = <obj>
+# val f2 : foo = <obj>
+# val f3 : foo = <obj>
+#   Exception: Bad_cast.
+# val b2 : bar = <obj>
+# Exception: Bad_cast.
+# 
diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml
new file mode 100644
index 0000000000..59a23db9d0
--- /dev/null
+++ b/testsuite/tests/typing-extensions/extensions.ml
@@ -0,0 +1,321 @@
+
+type foo = ..
+;;
+
+type foo +=
+    A
+  | B of int
+;;
+
+let is_a x =
+  match x with
+    A -> true
+  | _ -> false
+;;
+
+(* The type must be open to create extension *)
+
+type foo
+;;
+
+type foo += A of int (* Error type is not open *)
+;;
+
+(* The type parameters must match *)
+
+type 'a foo = ..
+;;
+
+type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+;;
+
+(* In a signature the type does not have to be open *)
+
+module type S =
+sig
+  type foo
+  type foo += A of float
+end
+;;
+
+(* But it must still be extensible *)
+
+module type S =
+sig
+  type foo = A of int
+  type foo += B of float (* Error foo does not have an extensible type *)
+end
+;;
+
+(* Signatures can change the grouping of extensions *)
+
+type foo = ..
+;;
+
+module M = struct
+  type foo +=
+      A of int
+    | B of string
+
+  type foo +=
+      C of int
+    | D of float
+end
+;;
+
+module type S = sig
+  type foo +=
+      B of string
+    | C of int
+
+  type foo += D of float
+
+  type foo += A of int
+end
+;;
+
+module M_S = (M : S)
+;;
+
+(* Extensions can be GADTs *)
+
+type 'a foo = ..
+;;
+
+type _ foo +=
+    A : int -> int foo
+  | B : int foo
+;;
+
+let get_num : type a. a foo -> a -> a option = fun f i1 ->
+    match f with
+        A i2 -> Some (i1 + i2)
+     |  _ -> None
+;;
+
+(* Extensions must obey constraints *)
+
+type 'a foo = .. constraint 'a = [> `Var ]
+;;
+
+type 'a foo += A of 'a
+;;
+
+let a = A 9 (* ERROR: Constraints not met *)
+;;
+
+type 'a foo += B : int foo (* ERROR: Constraints not met *)
+;;
+
+(* Signatures can make an extension private *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A of int end
+;;
+
+let a1 = M.A 10
+;;
+
+module type S = sig type foo += private A of int end
+;;
+
+module M_S = (M : S)
+;;
+
+let is_s x =
+  match x with
+    M_S.A _ -> true
+  | _ -> false
+;;
+
+let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+;;
+
+(* Extensions can be rebound *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A1 of int end
+;;
+
+type foo += A2 = M.A1
+;;
+
+type bar = ..
+;;
+
+type bar += A3 = M.A1    (* Error: rebind wrong type *)
+;;
+
+module M = struct type foo += private B1 of int end
+;;
+
+type foo += private B2 = M.B1
+;;
+
+type foo += B3 = M.B1  (* Error: rebind private extension *)
+;;
+
+type foo += C = Unknown  (* Error: unbound extension *)
+;;
+
+(* Extensions can be rebound even if type is closed *)
+
+module M : sig type foo type foo += A1 of int end
+  = struct type foo = .. type foo += A1 of int end
+
+type M.foo += A2 = M.A1
+
+(* Rebinding handles abbreviations *)
+
+type 'a foo = ..
+;;
+
+type 'a foo1 = 'a foo = ..
+;;
+
+type 'a foo2 = 'a foo = ..
+;;
+
+type 'a foo1 +=
+    A of int
+  | B of 'a
+  | C : int foo1
+;;
+
+type 'a foo2 +=
+    D = A
+  | E = B
+  | F = C
+;;
+
+(* Extensions must obey variances *)
+
+type +'a foo = ..
+;;
+
+type 'a foo += A of (int -> 'a)
+;;
+
+type 'a foo += B of ('a -> int) (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type _ foo += C : ('a -> int) -> 'a foo (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type 'a bar = ..
+;;
+
+type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+;;
+
+(* Exceptions are compatible with extensions *)
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end
+;;
+
+module M : sig
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end = struct
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end
+;;
+
+exception Foo of int * float
+;;
+
+exception Bar : 'a list -> exn
+;;
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar = Bar
+  exception Foo = Foo
+end
+;;
+
+(* Test toplevel printing *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo of int * int option
+  | Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar but not Foo (which has been shadowed) *)
+;;
+
+exception Foo of int * int option
+;;
+
+exception Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar and part of Foo (which has been shadowed) *)
+;;
+
+(* Test Obj functions *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo
+  | Bar of int
+;;
+
+let n1 = Obj.extension_name Foo
+;;
+
+let n2 = Obj.extension_name (Bar 1)
+;;
+
+let t = (Obj.extension_id (Bar 2)) = (Obj.extension_id (Bar 3)) (* true *)
+;;
+
+let f = (Obj.extension_id (Bar 2)) = (Obj.extension_id Foo) (* false *)
+;;
+
+let is_foo x = (Obj.extension_id Foo) = (Obj.extension_id x)
+
+type foo += Foo
+;;
+
+let f = is_foo Foo
+;;
+
+let _ = Obj.extension_name 7 (* Invald_arg *)
+;;
+
+let _ = Obj.extension_id (object method m = 3 end) (* Invald_arg *)
+;;
diff --git a/testsuite/tests/typing-extensions/extensions.ml.reference b/testsuite/tests/typing-extensions/extensions.ml.reference
new file mode 100644
index 0000000000..25af292de1
--- /dev/null
+++ b/testsuite/tests/typing-extensions/extensions.ml.reference
@@ -0,0 +1,131 @@
+
+#     type foo = ..
+#         type foo += A | B of int
+#           val is_a : foo -> bool = <fun>
+#         type foo
+#     Characters 13-21:
+  type foo += A of int (* Error type is not open *)
+              ^^^^^^^^
+Error: Cannot extend type definition foo
+#         type 'a foo = ..
+#     Characters 1-30:
+  type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This extension does not match the definition of type foo
+       They have different arities.
+#                 module type S = sig type foo type foo += A of float end
+#                 Characters 84-106:
+    type foo += B of float (* Error foo does not have an extensible type *)
+    ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type foo is not extensible
+#         type foo = ..
+#                     module M :
+  sig
+    type foo += A of int | B of string
+    type foo += C of int | D of float
+    
+  end
+#                     module type S =
+  sig
+    type foo += B of string | C of int
+    type foo += D of float
+    type foo += A of int
+  end
+#     module M_S : S
+#         type 'a foo = ..
+#         type _ foo += A : int -> int foo | B : int foo
+#           val get_num : 'a foo -> 'a -> 'a option = <fun>
+#         type 'a foo = .. constraint 'a = [> `Var ]
+#     type 'a foo += A of 'a
+#     Characters 11-12:
+  let a = A 9 (* ERROR: Constraints not met *)
+            ^
+Error: This expression has type int but an expression was expected of type
+         [> `Var ]
+#     Characters 20-23:
+  type 'a foo += B : int foo (* ERROR: Constraints not met *)
+                     ^^^
+Error: This type int should be an instance of type [> `Var ]
+#         type foo = ..
+#     module M : sig type foo += A of int end
+#     val a1 : foo = M.A 10
+#     module type S = sig type foo += private A of int end
+#     module M_S : S
+#           val is_s : foo -> bool = <fun>
+#     Characters 10-18:
+  let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+           ^^^^^^^^
+Error: Cannot create values of the private type foo
+#         type foo = ..
+#     module M : sig type foo += A1 of int end
+#     type foo += A2 of int
+#     type bar = ..
+#     Characters 18-22:
+  type bar += A3 = M.A1    (* Error: rebind wrong type *)
+                   ^^^^
+Error: The constructor M.A1 has type foo but was expected to be of type bar
+#     module M : sig type foo += private B1 of int end
+#     type foo += private B2 of int
+#     Characters 18-22:
+  type foo += B3 = M.B1  (* Error: rebind private extension *)
+                   ^^^^
+Error: The constructor M.B1 is private
+#     Characters 13-24:
+  type foo += C = Unknown  (* Error: unbound extension *)
+              ^^^^^^^^^^^
+Error: Unbound constructor Unknown
+#                       module M : sig type foo type foo += A1 of int end
+type M.foo += A2 of int
+type 'a foo = ..
+#     type 'a foo1 = 'a foo = ..
+#     type 'a foo2 = 'a foo = ..
+#           type 'a foo1 += A of int | B of 'a | C : int foo1
+#           type 'a foo2 += D of int | E of 'a | F : int foo2
+#         type +'a foo = ..
+#     type 'a foo += A of (int -> 'a)
+#     Characters 1-32:
+  type 'a foo += B of ('a -> int) (* ERROR: Parameter variances are not satisfied *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+       The 1st type parameter was expected to be covariant,
+       but it is injective contravariant.
+#     Characters 1-40:
+  type _ foo += C : ('a -> int) -> 'a foo (* ERROR: Parameter variances are not satisfied *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, expected parameter variances are not satisfied.
+       The 1st type parameter was expected to be covariant,
+       but it is injective contravariant.
+#     type 'a bar = ..
+#     Characters 1-33:
+  type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This extension does not match the definition of type bar
+       Their variances do not agree.
+#                       module M : sig type exn += Foo of int * float | Bar : 'a list -> exn  end
+#                   module M :
+  sig exception Bar : 'a list -> exn exception Foo of int * float end
+#     exception Foo of int * float
+#     exception Bar : 'a list -> exn
+#                   module M : sig type exn += Foo of int * float | Bar : 'a list -> exn  end
+#         type foo = ..
+#         type foo += Foo of int * int option | Bar of int option
+#     val x : foo * foo = (Foo (3, Some 4), Bar (Some 5))
+#     type foo += Foo of string
+#     val y : foo * foo = (<extension>, Bar (Some 5))
+#     exception Foo of int * int option
+#     exception Bar of int option
+#     val x : exn * exn = (Foo (3, Some 4), Bar (Some 5))
+#     type foo += Foo of string
+#     val y : exn * exn = (Foo (3, _), Bar (Some 5))
+#         type foo = ..
+#         type foo += Foo | Bar of int
+#     val n1 : string = "Foo"
+#     val n2 : string = "Bar"
+#     val t : bool = true
+#     val f : bool = false
+#         val is_foo : 'a -> bool = <fun>
+type foo += Foo
+#     val f : bool = false
+#     Exception: Invalid_argument "Obj.extension_name".
+#     Exception: Invalid_argument "Obj.extension_id".
+# 
diff --git a/testsuite/tests/typing-extensions/msg.ml b/testsuite/tests/typing-extensions/msg.ml
new file mode 100644
index 0000000000..ef1c12fb4c
--- /dev/null
+++ b/testsuite/tests/typing-extensions/msg.ml
@@ -0,0 +1,131 @@
+(* Typed names *)
+
+module Msg : sig
+
+  type 'a tag
+
+  type result = Result : 'a tag * 'a -> result
+
+  val write : 'a tag -> 'a -> unit
+
+  val read : unit -> result
+
+  type 'a tag += Int : int tag
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) : sig
+    type 'a tag += C : D.t tag
+  end
+
+end = struct
+
+  type 'a tag = ..
+
+  type ktag = T : 'a tag -> ktag
+
+  type 'a kind =
+  { tag : 'a tag;
+    label : string;
+    write : 'a -> string;
+    read : string -> 'a; }
+
+  type rkind = K : 'a kind -> rkind
+
+  type wkind = { f : 'a . 'a tag -> 'a kind }
+
+  let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13
+
+  let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13
+
+  let read_raw () : string * string = raise (Failure "Not implemented")
+
+  type result = Result : 'a tag * 'a -> result
+
+  let read () =
+    let label, content = read_raw () in
+      let K k = Hashtbl.find readTbl label in
+        let body = k.read content in
+          Result(k.tag, body)
+
+  let write_raw (label : string) (content : string) =
+    raise (Failure "Not implemented")
+
+  let write (tag : 'a tag) (body : 'a) =
+    let {f} = Hashtbl.find writeTbl (T tag) in
+    let k = f tag in
+    let content = k.write body in
+      write_raw k.label content
+
+  (* Add int kind *)
+
+  type 'a tag += Int : int tag
+
+  let ik =
+    { tag = Int;
+      label = "int";
+      write = string_of_int;
+      read = int_of_string }
+
+  let () = Hashtbl.add readTbl "int" (K ik)
+
+  let () =
+    let f (type t) (i : t tag) : t kind =
+      match i with
+        Int -> ik
+      | _ -> assert false
+    in
+      Hashtbl.add writeTbl (T Int) {f}
+
+  (* Support user defined kinds *)
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) = struct
+    type 'a tag += C : D.t tag
+    let k =
+      { tag = C;
+        label = D.label;
+        write = D.write;
+        read = D.read }
+    let () = Hashtbl.add readTbl D.label (K k)
+    let () =
+      let f (type t) (c : t tag) : t kind =
+        match c with
+          C -> k
+        | _ -> assert false
+      in
+        Hashtbl.add writeTbl (T C) {f}
+  end
+
+end;;
+
+let write_int i = Msg.write Msg.Int i;;
+
+module StrM = Msg.Define(struct
+  type t = string
+  let label = "string"
+  let read s = s
+  let write s = s
+end);;
+
+type 'a Msg.tag += String = StrM.C;;
+
+let write_string s = Msg.write String s;;
+
+let read_one () =
+  let Msg.Result(tag, body) = Msg.read () in
+  match tag with
+    Msg.Int -> print_int body
+  | String -> print_string body
+  | _ -> print_string "Unknown";;
diff --git a/testsuite/tests/typing-extensions/msg.ml.reference b/testsuite/tests/typing-extensions/msg.ml.reference
new file mode 100644
index 0000000000..e7f1a8f248
--- /dev/null
+++ b/testsuite/tests/typing-extensions/msg.ml.reference
@@ -0,0 +1,23 @@
+
+#                                                                                                                                                                                                                             module Msg :
+  sig
+    type 'a tag
+    type result = Result : 'a tag * 'a -> result
+    val write : 'a tag -> 'a -> unit
+    val read : unit -> result
+    type 'a tag += Int : int tag
+    module type Desc =
+      sig
+        type t
+        val label : string
+        val write : t -> string
+        val read : string -> t
+      end
+    module Define : functor (D : Desc) -> sig type 'a tag += C : D.t tag end
+  end
+#   val write_int : int -> unit = <fun>
+#             module StrM : sig type 'a Msg.tag += C : string Msg.tag end
+#   type 'a Msg.tag += String : string Msg.tag
+#   val write_string : string -> unit = <fun>
+#             val read_one : unit -> unit = <fun>
+# 
diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml
new file mode 100644
index 0000000000..6790fb7890
--- /dev/null
+++ b/testsuite/tests/typing-extensions/open_types.ml
@@ -0,0 +1,102 @@
+type foo = ..
+;;
+
+(* Check that abbreviations work *)
+
+type bar = foo = ..
+;;
+
+type baz = foo = ..
+;;
+
+type bar += Bar1 of int
+;;
+
+type baz += Bar2 of int
+;;
+
+module M = struct type bar += Foo of float end
+;;
+
+module type S = sig type baz += Foo of float end
+;;
+
+module M_S = (M : S)
+;;
+
+(* Abbreviations need to be made open *)
+
+type foo = ..
+;;
+
+type bar = foo
+;;
+
+type bar += Bar of int (* Error: type is not open *)
+;;
+
+type baz = bar = .. (* Error: type kinds don't match *)
+;;
+
+(* Abbreviations need to match parameters *)
+
+type 'a foo = ..
+;;
+
+type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
+;;
+
+type ('a, 'b) foo = ..
+;;
+
+type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
+;;
+
+(* Private abstract types cannot be open *)
+
+type foo = ..
+;;
+
+type bar = private foo = .. (* ERROR: Private abstract types cannot be open *)
+;;
+
+(* Check that signatures can hide open-ness *)
+
+module M = struct type foo = .. end
+;;
+
+module type S = sig type foo end
+;;
+
+module M_S = (M : S)
+;;
+
+type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
+;;
+
+(* Check that signatures cannot add open-ness *)
+
+module M = struct type foo end
+;;
+
+module type S = sig type foo = .. end
+;;
+
+module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+;;
+
+(* Check that signatures maintain variances *)
+
+module M = struct type +'a foo = .. type 'a bar = 'a foo = .. end
+;;
+
+module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
+;;
+
+module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+;;
+
+(* Exn is an open type *)
+
+type exn2 = exn = ..
+;;
diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference
new file mode 100644
index 0000000000..395c79cbd0
--- /dev/null
+++ b/testsuite/tests/typing-extensions/open_types.ml.reference
@@ -0,0 +1,74 @@
+
+#   type foo = ..
+#         type bar = foo = ..
+#     type baz = foo = ..
+#     type bar += Bar1 of int
+#     type baz += Bar2 of int
+#     module M : sig type bar += Foo of float end
+#     module type S = sig type baz += Foo of float end
+#     module M_S : S
+#         type foo = ..
+#     type bar = foo
+#     Characters 13-23:
+  type bar += Bar of int (* Error: type is not open *)
+              ^^^^^^^^^^
+Error: Cannot extend type definition bar
+#     Characters 6-20:
+  type baz = bar = .. (* Error: type kinds don't match *)
+       ^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type bar
+       Their kinds differ.
+#         type 'a foo = ..
+#     Characters 6-32:
+  type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *)
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type 'a foo
+       They have different arities.
+#     type ('a, 'b) foo = ..
+#     Characters 6-38:
+  type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This variant or record definition does not match that of type
+         ('a, 'a) foo
+       Their constraints differ.
+#         type foo = ..
+#     Characters 24-25:
+  type bar = private foo = .. (* ERROR: Private abstract types cannot be open *)
+                         ^
+Error: Syntax error
+#         module M : sig type foo = .. end
+#     module type S = sig type foo end
+#     module M_S : S
+#     Characters 17-20:
+  type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
+                  ^^^
+Error: Cannot extend type definition M_S.foo
+#         module M : sig type foo end
+#     module type S = sig type foo = .. end
+#     Characters 15-16:
+  module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+                ^
+Error: Signature mismatch:
+       Modules do not match: sig type foo = M.foo end is not included in S
+       Type declarations do not match:
+         type foo = M.foo
+       is not included in
+         type foo = ..
+       Their kinds differ.
+#         module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
+#     module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
+#     Characters 15-16:
+  module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+                ^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end
+       is not included in
+         S
+       Type declarations do not match:
+         type 'a foo = 'a M.foo = ..
+       is not included in
+         type 'a foo = ..
+       Their variances do not agree.
+#         type exn2 = exn = ..
+# 
diff --git a/tools/depend.ml b/tools/depend.ml
index 8f82e717de..bc68b886ce 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -240,8 +240,8 @@ and add_sig_item bv item =
       List.iter (add_type_declaration bv) dcls; bv
   | Psig_typext te ->
       add_type_extension bv te; bv
-  | Psig_exception pcd ->
-      add_constructor_decl bv pcd; bv
+  | Psig_exception pext ->
+      add_extension_constructor bv pext; bv
   | Psig_module pmd ->
       add_modtype bv pmd.pmd_type; StringSet.add pmd.pmd_name.txt bv
   | Psig_recmodule decls ->
@@ -300,10 +300,8 @@ and add_struct_item bv item =
   | Pstr_typext te ->
       add_type_extension bv te;
       bv
-  | Pstr_exception pcd ->
-      add_constructor_decl bv pcd; bv
-  | Pstr_exn_rebind(id, l, _attrs) ->
-      add bv l; bv
+  | Pstr_exception pext ->
+      add_extension_constructor bv pext; bv
   | Pstr_module x ->
       add_module bv x.pmb_expr; StringSet.add x.pmb_name.txt bv
   | Pstr_recmodule bindings ->
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
index 4f58295bcf..a072432578 100644
--- a/tools/tast_iter.ml
+++ b/tools/tast_iter.ml
@@ -17,10 +17,6 @@ let opt f = function None -> () | Some x -> f x
 let structure sub str =
   List.iter (sub # structure_item) str.str_items
 
-let constructor_decl sub cd =
-  List.iter (sub # core_type) cd.cd_args;
-  opt (sub # core_type) cd.cd_res
-
 let structure_item sub x =
   match x.str_desc with
   | Tstr_eval (exp, _attrs) -> sub # expression exp
@@ -28,8 +24,7 @@ let structure_item sub x =
   | Tstr_primitive v -> sub # value_description v
   | Tstr_type list -> List.iter (sub # type_declaration) list
   | Tstr_typext te -> sub # type_extension te
-  | Tstr_exception decl -> constructor_decl sub decl
-  | Tstr_exn_rebind (_id, _, _p, _, _) -> ()
+  | Tstr_exception ext -> sub # extension_constructor ext
   | Tstr_module mb -> sub # module_binding mb
   | Tstr_recmodule list -> List.iter (sub # module_binding) list
   | Tstr_modtype mtd -> opt (sub # module_type) mtd.mtd_type
@@ -44,6 +39,13 @@ let structure_item sub x =
 let value_description sub x =
   sub # core_type x.val_desc
 
+let constructor_decl sub cd =
+  List.iter (sub # core_type) cd.cd_args;
+  opt (sub # core_type) cd.cd_res
+
+let label_decl sub ld =
+  sub # core_type ld.ld_type
+
 let type_declaration sub decl =
   List.iter
     (fun (ct1, ct2, _loc) -> sub # core_type ct1; sub # core_type ct2)
@@ -53,20 +55,20 @@ let type_declaration sub decl =
   | Ttype_variant list ->
       List.iter (constructor_decl sub) list
   | Ttype_record list ->
-      List.iter (fun ld -> sub # core_type ld.ld_type) list
+      List.iter (label_decl sub) list
   | Ttype_open -> ()
   end;
   opt (sub # core_type) decl.typ_manifest
 
 let type_extension sub te =
-  let extension_constructors ext =
-    match ext.ext_kind with
-      Text_decl(ctl, cto) ->
-        List.iter (sub # core_type) ctl;
-        opt (sub # core_type) cto
-    | Text_rebind _ -> ()
-  in
-    List.iter extension_constructors te.tyext_constructors
+  List.iter (sub # extension_constructor) te.tyext_constructors
+
+let extension_constructor sub ext =
+  match ext.ext_kind with
+    Text_decl(ctl, cto) ->
+      List.iter (sub # core_type) ctl;
+      opt (sub # core_type) cto
+  | Text_rebind _ -> ()
 
 let pattern sub pat =
   let extra = function
@@ -180,8 +182,8 @@ let signature_item sub item =
       List.iter (sub # type_declaration) list
   | Tsig_typext te ->
       sub # type_extension te
-  | Tsig_exception decl ->
-      constructor_decl sub decl
+  | Tsig_exception ext ->
+      sub # extension_constructor ext
   | Tsig_module md ->
       sub # module_type md.md_type
   | Tsig_recmodule list ->
@@ -367,6 +369,7 @@ class iter = object(this)
   method class_type_field = class_type_field this
   method core_type = core_type this
   method expression = expression this
+  method extension_constructor = extension_constructor this
   method module_binding = module_binding this
   method module_expr = module_expr this
   method module_type = module_type this
diff --git a/tools/tast_iter.mli b/tools/tast_iter.mli
index b6bd5d2d66..1d81afa568 100644
--- a/tools/tast_iter.mli
+++ b/tools/tast_iter.mli
@@ -28,6 +28,7 @@ class iter: object
   method class_type_field: class_type_field -> unit
   method core_type: core_type -> unit
   method expression: expression -> unit
+  method extension_constructor: extension_constructor -> unit
   method module_binding: module_binding -> unit
   method module_expr: module_expr -> unit
   method module_type: module_type -> unit
@@ -64,6 +65,7 @@ val class_type_declaration: iter -> class_type_declaration -> unit
 val class_type_field: iter -> class_type_field -> unit
 val core_type: iter -> core_type -> unit
 val expression: iter -> expression -> unit
+val extension_constructor: iter -> extension_constructor -> unit
 val module_binding: iter -> module_binding -> unit
 val module_expr: iter -> module_expr -> unit
 val module_type: iter -> module_type -> unit
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 328b85511d..5f0a6f027e 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -55,10 +55,8 @@ and untype_structure_item item =
         Pstr_type (List.map untype_type_declaration list)
     | Tstr_typext tyext ->
         Pstr_typext (untype_type_extension tyext)
-    | Tstr_exception decl ->
-        Pstr_exception (untype_constructor_declaration decl)
-    | Tstr_exn_rebind (_id, name, _p, lid, attrs) ->
-        Pstr_exn_rebind (name, lid, attrs)
+    | Tstr_exception ext ->
+        Pstr_exception (untype_extension_constructor ext)
     | Tstr_module mb ->
         Pstr_module (untype_module_binding mb)
     | Tstr_recmodule list ->
@@ -350,8 +348,8 @@ and untype_signature_item item =
         Psig_type (List.map untype_type_declaration list)
     | Tsig_typext tyext ->
         Psig_typext (untype_type_extension tyext)
-    | Tsig_exception decl ->
-        Psig_exception (untype_constructor_declaration decl)
+    | Tsig_exception ext ->
+        Psig_exception (untype_extension_constructor ext)
     | Tsig_module md ->
         Psig_module {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type;
                      pmd_attributes = md.md_attributes; pmd_loc = md.md_loc;
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index cfc8c294d1..7a92a92559 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -187,8 +187,6 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
               Oval_stuff "<fun>"
           | Ttuple(ty_list) ->
               Oval_tuple (tree_of_val_list 0 depth obj ty_list)
-          | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
-              tree_of_exception depth obj
           | Tconstr(path, [ty_arg], _)
             when Path.same path Predef.path_list ->
               if O.is_block obj then
@@ -295,7 +293,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                         Oval_record (tree_of_fields 0 lbl_list)
                     end
                 | {type_kind = Type_open} ->
-                    Oval_stuff "<extension>"
+                    tree_of_extension path depth obj
               with
                 Not_found ->                (* raised by Env.find_type *)
                   Oval_stuff "<abstr>"
@@ -353,7 +351,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         let args = tree_of_val_list start depth obj ty_args in
         Oval_constr (lid, args)
 
-    and tree_of_exception depth bucket =
+    and tree_of_extension type_path depth bucket =
       let slot =
         if O.tag bucket <> 0 then bucket
         else O.field bucket 0
@@ -379,7 +377,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
       with Not_found | EVP.Error ->
         match check_depth depth bucket ty with
           Some x -> x
-        | None -> outval_of_untyped_exception bucket
+        | None when Path.same type_path Predef.path_exn->
+            outval_of_untyped_exception bucket
+        | None ->
+            Oval_stuff "<extension>"
 
     in tree_of_val max_depth obj ty
 
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index 591723ca60..9e9e3d7447 100644
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -175,9 +175,6 @@ let rec pr_item env = function
   | Sig_typext(id, ext, es) :: rem ->
       let tree = Printtyp.tree_of_extension_constructor id ext es in
       Some (tree, None, rem)
-  | Sig_exception(id, decl) :: rem ->
-      let tree = Printtyp.tree_of_exception_declaration id decl in
-      Some (tree, None, rem)
   | Sig_module(id, mty, rs) :: rem ->
       let tree = Printtyp.tree_of_module id mty rs in
       Some (tree, None, rem)
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index a0192b9395..ccdf54c11f 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -194,9 +194,6 @@ let rec pr_item env items =
   | Sig_typext(id, ext, es) :: rem ->
       let tree = Printtyp.tree_of_extension_constructor id ext es in
       Some (tree, None, rem)
-  | Sig_exception(id, decl) :: rem ->
-      let tree = Printtyp.tree_of_exception_declaration id decl in
-      Some (tree, None, rem)
   | Sig_module(id, md, rs) :: rem ->
       let tree = Printtyp.tree_of_module id md.md_type rs in
       Some (tree, None, rem)
diff --git a/typing/btype.ml b/typing/btype.ml
index 3e09976af8..bba7660cba 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -242,7 +242,6 @@ type type_iterators =
     it_value_description: type_iterators -> value_description -> unit;
     it_type_declaration: type_iterators -> type_declaration -> unit;
     it_extension_constructor: type_iterators -> extension_constructor -> unit;
-    it_exception_declaration: type_iterators -> exception_declaration -> unit;
     it_module_declaration: type_iterators -> module_declaration -> unit;
     it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
     it_class_declaration: type_iterators -> class_declaration -> unit;
@@ -260,7 +259,6 @@ let type_iterators =
       Sig_value (_, vd)     -> it.it_value_description it vd
     | Sig_type (_, td, _)   -> it.it_type_declaration it td
     | Sig_typext (_, td, _) -> it.it_extension_constructor it td
-    | Sig_exception (_, ed) -> it.it_exception_declaration it ed
     | Sig_module (_, md, _) -> it.it_module_declaration it md
     | Sig_modtype (_, mtd)  -> it.it_modtype_declaration it mtd
     | Sig_class (_, cd, _)  -> it.it_class_declaration it cd
@@ -276,8 +274,6 @@ let type_iterators =
     List.iter (it.it_type_expr it) td.ext_type_params;
     List.iter (it.it_type_expr it) td.ext_args;
     may (it.it_type_expr it) td.ext_ret_type
-  and it_exception_declaration it ed =
-    List.iter (it.it_type_expr it) ed.exn_args
   and it_module_declaration it md =
     it.it_module_type it md.md_type
   and it_modtype_declaration it mtd =
@@ -336,9 +332,8 @@ let type_iterators =
   in
   { it_path; it_type_expr; it_type_kind; it_class_type; it_module_type;
     it_signature; it_class_type_declaration; it_class_declaration;
-    it_modtype_declaration; it_module_declaration; it_exception_declaration;
-    it_extension_constructor; it_type_declaration; it_value_description;
-    it_signature_item; }
+    it_modtype_declaration; it_module_declaration; it_extension_constructor;
+    it_type_declaration; it_value_description; it_signature_item; }
 
 let copy_row f fixed row keep more =
   let fields = List.map
@@ -466,6 +461,11 @@ let unmark_type_decl decl =
   | Some ty -> unmark_type ty
   end
 
+let unmark_extension_constructor ext =
+  List.iter unmark_type ext.ext_type_params;
+  List.iter unmark_type ext.ext_args;
+  Misc.may unmark_type ext.ext_ret_type
+
 let unmark_class_signature sign =
   unmark_type sign.csig_self;
   Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars
diff --git a/typing/btype.mli b/typing/btype.mli
index 1d97f2e940..773e99a436 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -96,7 +96,6 @@ type type_iterators =
     it_value_description: type_iterators -> value_description -> unit;
     it_type_declaration: type_iterators -> type_declaration -> unit;
     it_extension_constructor: type_iterators -> extension_constructor -> unit;
-    it_exception_declaration: type_iterators -> exception_declaration -> unit;
     it_module_declaration: type_iterators -> module_declaration -> unit;
     it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
     it_class_declaration: type_iterators -> class_declaration -> unit;
@@ -136,6 +135,7 @@ val mark_type_params: type_expr -> unit
         (* Mark the sons of a type node *)
 val unmark_type: type_expr -> unit
 val unmark_type_decl: type_declaration -> unit
+val unmark_extension_constructor: extension_constructor -> unit
 val unmark_class_type: class_type -> unit
 val unmark_class_signature: class_signature -> unit
         (* Remove marks from a type *)
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 0b4f01f1b4..0b4a212d9b 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -577,6 +577,19 @@ let closed_type_decl decl =
     unmark_type_decl decl;
     Some ty
 
+let closed_extension_constructor ext =
+  try
+    List.iter mark_type ext.ext_type_params;
+    begin match ext.ext_ret_type with
+    | Some _ -> ()
+    | None -> List.iter closed_type ext.ext_args
+    end;
+    unmark_extension_constructor ext;
+    None
+  with Non_closed (ty, _) ->
+    unmark_extension_constructor ext;
+    Some ty
+
 type closed_class_failure =
     CC_Method of type_expr * bool * string * type_expr
   | CC_Value of type_expr * bool * string * type_expr
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 890b803662..b807fbd098 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -249,6 +249,7 @@ val closed_schema: type_expr -> bool
 val free_variables: ?env:Env.t -> type_expr -> type_expr list
         (* If env present, then check for incomplete definitions too *)
 val closed_type_decl: type_declaration -> type_expr option
+val closed_extension_constructor: extension_constructor -> type_expr option
 type closed_class_failure =
     CC_Method of type_expr * bool * string * type_expr
   | CC_Value of type_expr * bool * string * type_expr
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 869f49b161..680177e36f 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -79,7 +79,6 @@ let constructor_descrs ty_res cstrs priv =
             cstr_nonconsts = !num_nonconsts;
             cstr_normal = !num_normal;
             cstr_private = priv;
-            cstr_exception = false;
             cstr_generalized = cd_res <> None;
             cstr_loc = cd_loc;
             cstr_attributes = cd_attributes;
@@ -87,23 +86,6 @@ let constructor_descrs ty_res cstrs priv =
         (cd_id, cstr) :: descr_rem in
   describe_constructors 0 0 cstrs
 
-let exception_descr path_exc decl =
-  { cstr_name = Path.last path_exc;
-    cstr_res = Predef.type_exn;
-    cstr_existentials = [];
-    cstr_args = decl.exn_args;
-    cstr_arity = List.length decl.exn_args;
-    cstr_tag = Cstr_extension(path_exc, decl.exn_args = []);
-    cstr_consts = -1;
-    cstr_nonconsts = -1;
-    cstr_private = Public;
-    cstr_exception = true;
-    cstr_normal = -1;
-    cstr_generalized = false;
-    cstr_loc = decl.exn_loc;
-    cstr_attributes = decl.exn_attributes;
-  }
-
 let extension_descr path_ext ext =
   let ty_res =
     match ext.ext_ret_type with
@@ -129,7 +111,6 @@ let extension_descr path_ext ext =
       cstr_consts = -1;
       cstr_nonconsts = -1;
       cstr_private = ext.ext_private;
-      cstr_exception = false;
       cstr_normal = -1;
       cstr_generalized = ext.ext_ret_type <> None;
       cstr_loc = ext.ext_loc;
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index 42bfbc8668..8e298debd6 100644
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -19,8 +19,6 @@ open Types
 val constructor_descrs:
   type_expr -> constructor_declaration list ->
   private_flag -> (Ident.t * constructor_description) list
-val exception_descr:
-  Path.t -> exception_declaration -> constructor_description
 val extension_descr:
   Path.t -> extension_constructor -> constructor_description
 val label_descrs:
diff --git a/typing/env.ml b/typing/env.ml
index 84eb0555ed..9d634b7986 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -107,7 +107,6 @@ type summary =
   | Env_value of summary * Ident.t * value_description
   | Env_type of summary * Ident.t * type_declaration
   | Env_extension of summary * Ident.t * extension_constructor
-  | Env_exception of summary * Ident.t * exception_declaration
   | Env_module of summary * Ident.t * module_declaration
   | Env_modtype of summary * Ident.t * modtype_declaration
   | Env_class of summary * Ident.t * class_declaration
@@ -754,10 +753,6 @@ let mark_extension_used usage ext name =
   try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage
   with Not_found -> ()
 
-let mark_exception_used usage ed constr =
-  try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) usage
-  with Not_found -> ()
-
 let set_value_used_callback name vd callback =
   let key = (name, vd.val_loc) in
   try
@@ -1066,10 +1061,6 @@ let rec prefix_idents root pos sub = function
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
       (p::pl, final_sub)
-  | Sig_exception(id, decl) :: rem ->
-      let p = Pdot(root, Ident.name id, pos) in
-      let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
-      (p::pl, final_sub)
   | Sig_module(id, mty, _) :: rem ->
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) =
@@ -1100,8 +1091,6 @@ let subst_signature sub sg =
           Sig_type(id, Subst.type_declaration sub decl, x)
       | Sig_typext(id, ext, es) ->
           Sig_typext (id, Subst.extension_constructor sub ext, es)
-      | Sig_exception(id, decl) ->
-          Sig_exception (id, Subst.exception_declaration sub decl)
       | Sig_module(id, mty, x) ->
           Sig_module(id, Subst.module_declaration sub mty,x)
       | Sig_modtype(id, decl) ->
@@ -1194,13 +1183,6 @@ and components_of_module_maker (env, sub, path, mty) =
             c.comp_constrs <-
               add_to_tbl (Ident.name id) (descr, !pos) c.comp_constrs;
             incr pos
-        | Sig_exception(id, decl) ->
-            let decl' = Subst.exception_declaration sub decl in
-            let cstr = Datarepr.exception_descr path decl' in
-            let s = Ident.name id in
-            c.comp_constrs <-
-              add_to_tbl s (cstr, !pos) c.comp_constrs;
-            incr pos
         | Sig_module(id, md, _) ->
             let mty = md.md_type in
             let mty' = EnvLazy.create (sub, mty) in
@@ -1354,33 +1336,6 @@ and store_extension ~check slot id path ext env renv =
                 env.constrs renv.constrs;
     summary = Env_extension(env.summary, id, ext) }
 
-and store_exception ~check slot id path decl env renv =
-  let loc = decl.exn_loc in
-  if check && not loc.Location.loc_ghost &&
-    Warnings.is_active (Warnings.Unused_exception ("", false))
-  then begin
-    let ty = "exn" in
-    let c = Ident.name id in
-    let k = (ty, loc, c) in
-    if not (Hashtbl.mem used_constructors k) then begin
-      let used = constructor_usages () in
-      Hashtbl.add used_constructors k (add_constructor_usage used);
-      !add_delayed_check_forward
-        (fun () ->
-          if not env.in_signature && not used.cu_positive then
-            Location.prerr_warning loc
-              (Warnings.Unused_exception
-                 (c, used.cu_pattern)
-              )
-        )
-    end;
-  end;
-  { env with
-    constrs = EnvTbl.add "constructor" slot id
-                         (Datarepr.exception_descr path decl) env.constrs
-                         renv.constrs;
-    summary = Env_exception(env.summary, id, decl) }
-
 and store_module slot id path md env renv =
   { env with
     modules = EnvTbl.add "module" slot id (path, md) env.modules renv.modules;
@@ -1445,9 +1400,6 @@ let add_type ~check id info env =
 and add_extension ~check id ext env =
   store_extension ~check None id (Pident id) ext env env
 
-and add_exception ~check id decl env =
-  store_exception ~check None id (Pident id) decl env env
-
 and add_module_declaration ?arg id md env =
   let path =
     (*match md.md_type with
@@ -1487,7 +1439,6 @@ let enter store_fun name data env =
 let enter_value ?check = enter (store_value ?check)
 and enter_type = enter (store_type ~check:true)
 and enter_extension = enter (store_extension ~check:true)
-and enter_exception = enter (store_exception ~check:true)
 and enter_module_declaration ?arg name md env =
   let id = Ident.create name in
   (id, add_module_declaration ?arg id md env)
@@ -1507,7 +1458,6 @@ let add_item comp env =
     Sig_value(id, decl)     -> add_value id decl env
   | Sig_type(id, decl, _)   -> add_type ~check:false id decl env
   | Sig_typext(id, ext, _)  -> add_extension ~check:false id ext env
-  | Sig_exception(id, decl) -> add_exception ~check:false id decl env
   | Sig_module(id, md, _)  -> add_module_declaration id md env
   | Sig_modtype(id, decl)   -> add_modtype id decl env
   | Sig_class(id, decl, _)  -> add_class id decl env
@@ -1537,8 +1487,6 @@ let open_signature slot root sg env0 =
             store_type ~check:false slot (Ident.hide id) p decl env env0
         | Sig_typext(id, ext, _) ->
             store_extension ~check:false slot (Ident.hide id) p ext env env0
-        | Sig_exception(id, decl) ->
-            store_exception ~check:false slot (Ident.hide id) p decl env env0
         | Sig_module(id, mty, _) ->
             store_module slot (Ident.hide id) p mty env env0
         | Sig_modtype(id, decl) ->
@@ -1743,7 +1691,7 @@ and fold_cltypes f =
 let initial =
   Predef.build_initial_env
     (add_type ~check:false)
-    (add_exception ~check:false)
+    (add_extension ~check:false)
     empty
 
 (* Return the environment summary *)
diff --git a/typing/env.mli b/typing/env.mli
index 09b83f2c0c..b20730d9ba 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -19,7 +19,6 @@ type summary =
   | Env_value of summary * Ident.t * value_description
   | Env_type of summary * Ident.t * type_declaration
   | Env_extension of summary * Ident.t * extension_constructor
-  | Env_exception of summary * Ident.t * exception_declaration
   | Env_module of summary * Ident.t * module_declaration
   | Env_modtype of summary * Ident.t * modtype_declaration
   | Env_class of summary * Ident.t * class_declaration
@@ -103,7 +102,6 @@ val add_value:
     ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
 val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
 val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t
-val add_exception: check:bool -> Ident.t -> exception_declaration -> t -> t
 val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
 val add_module_declaration: ?arg:bool -> Ident.t -> module_declaration -> t -> t
 val add_modtype: Ident.t -> modtype_declaration -> t -> t
@@ -131,7 +129,6 @@ val enter_value:
     string -> value_description -> t -> Ident.t * t
 val enter_type: string -> type_declaration -> t -> Ident.t * t
 val enter_extension: string -> extension_constructor -> t -> Ident.t * t
-val enter_exception: string -> exception_declaration -> t -> Ident.t * t
 val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t
 val enter_module_declaration:
     ?arg:bool -> string -> module_declaration -> t -> Ident.t * t
@@ -208,8 +205,6 @@ val mark_constructor:
     constructor_usage -> t -> string -> constructor_description -> unit
 val mark_extension_used:
     constructor_usage -> extension_constructor -> string -> unit
-val mark_exception_used:
-    constructor_usage -> exception_declaration -> string -> unit
 
 val in_signature: t -> t
 
diff --git a/typing/envaux.ml b/typing/envaux.ml
index cef78b857d..af86fd25be 100644
--- a/typing/envaux.ml
+++ b/typing/envaux.ml
@@ -51,10 +51,6 @@ let rec env_from_summary sum subst =
           Env.add_extension ~check:false id
             (Subst.extension_constructor subst desc)
             (env_from_summary s subst)
-      | Env_exception(s, id, desc) ->
-          Env.add_exception ~check:false id
-            (Subst.exception_declaration subst desc)
-            (env_from_summary s subst)
       | Env_module(s, id, desc) ->
           Env.add_module_declaration id
             (Subst.module_declaration subst desc)
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 19b15d9e88..f04dc488f5 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -293,12 +293,6 @@ let extension_constructors env id ext1 ext2 =
     else false
   else false
 
-(* Inclusion between exception declarations *)
-
-let exception_declarations env ed1 ed2 =
-  Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2])
-    ed1.exn_args ed2.exn_args
-
 (* Inclusion between class types *)
 let encode_val (mut, ty) rem =
   begin match mut with
diff --git a/typing/includecore.mli b/typing/includecore.mli
index 320fa1342b..0c8e9558f4 100644
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -39,8 +39,6 @@ val type_declarations:
         type_declaration -> Ident.t -> type_declaration -> type_mismatch list
 val extension_constructors:
     Env.t -> Ident.t -> extension_constructor -> extension_constructor -> bool
-val exception_declarations:
-    Env.t -> exception_declaration -> exception_declaration -> bool
 (*
 val class_types:
         Env.t -> class_type -> class_type -> bool
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 0adea26d04..6d5ceba0ed 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -24,8 +24,6 @@ type symptom =
         * type_declaration * Includecore.type_mismatch list
   | Extension_constructors of
       Ident.t * extension_constructor * extension_constructor
-  | Exception_declarations of
-      Ident.t * exception_declaration * exception_declaration
   | Module_types of module_type * module_type
   | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
   | Modtype_permutation
@@ -77,15 +75,6 @@ let extension_constructors env cxt subst id ext1 ext2 =
   then ()
   else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)])
 
-(* Inclusion between exception declarations *)
-
-let exception_declarations env cxt subst id decl1 decl2 =
-  Env.mark_exception_used Env.Positive decl1 (Ident.name id);
-  let decl2 = Subst.exception_declaration subst decl2 in
-  if Includecore.exception_declarations env decl1 decl2
-  then ()
-  else raise(Error[cxt, env, Exception_declarations(id, decl1, decl2)])
-
 (* Inclusion between class declarations *)
 
 let class_type_declarations env cxt subst id decl1 decl2 =
@@ -134,7 +123,6 @@ type field_desc =
     Field_value of string
   | Field_type of string
   | Field_typext of string
-  | Field_exception of string
   | Field_module of string
   | Field_modtype of string
   | Field_class of string
@@ -144,7 +132,6 @@ let kind_of_field_desc = function
   | Field_value _ -> "value"
   | Field_type _ -> "type"
   | Field_typext _ -> "extension constructor"
-  | Field_exception _ -> "exception"
   | Field_module _ -> "module"
   | Field_modtype _ -> "module type"
   | Field_class _ -> "class"
@@ -154,7 +141,6 @@ let item_ident_name = function
     Sig_value(id, d) -> (id, d.val_loc, Field_value(Ident.name id))
   | Sig_type(id, d, _) -> (id, d.type_loc, Field_type(Ident.name id))
   | Sig_typext(id, d, _) -> (id, d.ext_loc, Field_typext(Ident.name id))
-  | Sig_exception(id, d) -> (id, d.exn_loc, Field_exception(Ident.name id))
   | Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id))
   | Sig_modtype(id, d) -> (id, d.mtd_loc, Field_modtype(Ident.name id))
   | Sig_class(id, d, _) -> (id, d.cty_loc, Field_class(Ident.name id))
@@ -167,7 +153,6 @@ let is_runtime_component = function
   | Sig_class_type(_,_,_) -> false
   | Sig_value(_,_)
   | Sig_typext(_,_,_)
-  | Sig_exception(_,_)
   | Sig_module(_,_,_)
   | Sig_class(_, _,_) -> true
 
@@ -324,7 +309,7 @@ and signatures env cxt subst sig1 sig2 =
             | Sig_modtype _ ->
                 Subst.add_modtype id2 (Mty_ident (Pident id1)) subst
             | Sig_value _ | Sig_typext _
-            | Sig_exception _ | Sig_class _ | Sig_class_type _ ->
+            | Sig_class _ | Sig_class_type _ ->
                 subst
           in
           pair_components new_subst
@@ -357,10 +342,6 @@ and signature_components env cxt subst = function
     :: rem ->
       extension_constructors env cxt subst id1 ext1 ext2;
       (pos, Tcoerce_none) :: signature_components env cxt subst rem
-  | (Sig_exception(id1, excdecl1), Sig_exception(id2, excdecl2), pos)
-    :: rem ->
-      exception_declarations env cxt subst id1 excdecl1 excdecl2;
-      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem ->
       let cc =
         modtypes env (Module id1::cxt) subst
@@ -470,13 +451,6 @@ let include_err ppf = function
       (extension_constructor id) x1
       (extension_constructor id) x2;
       show_locs ppf (x1.ext_loc, x2.ext_loc)
-  | Exception_declarations(id, d1, d2) ->
-      fprintf ppf
-       "@[<hv 2>Exception declarations do not match:@ \
-        %a@;<1 -2>is not included in@ %a@]"
-        (exception_declaration id) d1
-        (exception_declaration id) d2;
-      show_locs ppf (d1.exn_loc, d2.exn_loc)
   | Module_types(mty1, mty2)->
       fprintf ppf
        "@[<hv 2>Modules do not match:@ \
diff --git a/typing/includemod.mli b/typing/includemod.mli
index 9e0204b9d2..ea2b2f0802 100644
--- a/typing/includemod.mli
+++ b/typing/includemod.mli
@@ -29,8 +29,6 @@ type symptom =
         * type_declaration * Includecore.type_mismatch list
   | Extension_constructors of
       Ident.t * extension_constructor * extension_constructor
-  | Exception_declarations of
-      Ident.t * exception_declaration * exception_declaration
   | Module_types of module_type * module_type
   | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
   | Modtype_permutation
diff --git a/typing/mtype.ml b/typing/mtype.ml
index cac9eb8fc1..9b0544fcd4 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -62,8 +62,6 @@ and strengthen_sig env sg p =
       Sig_type(id, newdecl, rs) :: strengthen_sig env rem p
   | (Sig_typext(id, ext, es) as sigelt) :: rem ->
       sigelt :: strengthen_sig env rem p
-  | (Sig_exception(id, d) as sigelt) :: rem ->
-      sigelt :: strengthen_sig env rem p
   | Sig_module(id, md, rs) :: rem ->
       let str = strengthen_decl env md (Pdot(p, Ident.name id, nopos)) in
       Sig_module(id, str, rs)
@@ -133,13 +131,6 @@ let nondep_supertype env mid mty =
       | Sig_typext(id, ext, es) ->
           Sig_typext(id, Ctype.nondep_extension_constructor env mid ext, es)
           :: rem'
-      | Sig_exception(id, d) ->
-          let d =
-            {d with
-             exn_args = List.map (Ctype.nondep_type env mid) d.exn_args
-            }
-          in
-          Sig_exception(id, d) :: rem'
       | Sig_module(id, md, rs) ->
           Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs)
           :: rem'
@@ -217,7 +208,7 @@ and type_paths_sig env p pos sg =
       type_paths_sig (Env.add_module_declaration id md env) p (pos+1) rem
   | Sig_modtype(id, decl) :: rem ->
       type_paths_sig (Env.add_modtype id decl env) p pos rem
-  | (Sig_typext _ | Sig_exception _ | Sig_class _) :: rem ->
+  | (Sig_typext _ | Sig_class _) :: rem ->
       type_paths_sig env p (pos+1) rem
   | (Sig_class_type _) :: rem ->
       type_paths_sig env p pos rem
@@ -242,7 +233,7 @@ and no_code_needed_sig env sg =
       no_code_needed_sig (Env.add_module_declaration id md env) rem
   | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
       no_code_needed_sig env rem
-  | (Sig_typext _ | Sig_exception _ | Sig_class _) :: rem ->
+  | (Sig_typext _ | Sig_class _) :: rem ->
       false
 
 
@@ -271,7 +262,6 @@ and contains_type_item env = function
   | Sig_value _
   | Sig_type _
   | Sig_typext _
-  | Sig_exception _
   | Sig_class _
   | Sig_class_type _ ->
       ()
diff --git a/typing/oprint.ml b/typing/oprint.ml
index a0bd969f8c..1631482f2e 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -395,10 +395,11 @@ and print_out_sig_item ppf =
         (if rs = Orec_next then "and" else "class type")
         (if vir_flag then " virtual" else "") print_out_class_params params
         name !out_class_type clt
-  | Osig_typext (ext, _) ->
+  | Osig_typext (ext, Oext_exception) ->
+      fprintf ppf "@[<2>exception %a@]"
+        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+  | Osig_typext (ext, es) ->
       print_out_extension_constructor ppf ext
-  | Osig_exception (id, tyl) ->
-      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None)
   | Osig_modtype (name, Omty_abstract) ->
       fprintf ppf "@[<2>module type %s@]" name
   | Osig_modtype (name, mty) ->
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index fe7daee31d..18885e8de6 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -88,7 +88,6 @@ and out_sig_item =
       bool * string * (string * (bool * bool)) list * out_class_type *
         out_rec_status
   | Osig_typext of out_extension_constructor * out_ext_status
-  | Osig_exception of string * out_type list
   | Osig_modtype of string * out_module_type
   | Osig_module of string * out_module_type * out_rec_status
   | Osig_type of out_type_decl * out_rec_status
@@ -118,6 +117,7 @@ and out_rec_status =
 and out_ext_status =
   | Oext_first
   | Oext_next
+  | Oext_exception
 
 type out_phrase =
   | Ophr_eval of out_value * out_type
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 6d5e52fa47..9dd20852b5 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -662,7 +662,7 @@ let clean_env env =
 
 let full_match ignore_generalized closing env =  match env with
 | ({pat_desc = Tpat_construct(_,c,_);pat_type=typ},_) :: _ ->
-    if c.cstr_consts < 0 then false (* exceptions and extensions *)
+    if c.cstr_consts < 0 then false (* extensions *)
     else
       if ignore_generalized then
         (* remove generalized constructors;
@@ -827,10 +827,7 @@ let build_other_constant proj make first next p env =
 let build_other ext env =  match env with
 | ({pat_desc = Tpat_construct (lid,
       ({cstr_tag=Cstr_extension _} as c),_)},_) :: _ ->
-    let id =
-      if c.cstr_exception then Ident.create "*exception*"
-      else Ident.create "*extension*"
-    in
+    let id = Ident.create "*extension*" in
     let c = {c with cstr_tag = Cstr_extension(Path.Pident id, true)} in
       make_pat (Tpat_construct(lid, c, [])) Ctype.none Env.empty
 | ({pat_desc = Tpat_construct (_, _,_)} as p,_) :: _ ->
diff --git a/typing/predef.ml b/typing/predef.ml
index d83c9cf675..ce0cf3c027 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -119,7 +119,7 @@ and ident_nil = ident_create "[]"
 and ident_cons = ident_create "::"
 and ident_none = ident_create "None"
 and ident_some = ident_create "Some"
-let build_initial_env add_type add_exception empty_env =
+let build_initial_env add_type add_extension empty_env =
   let decl_bool =
     {decl_abstr with
      type_kind = Type_variant([cstr ident_false []; cstr ident_true []])}
@@ -128,7 +128,7 @@ let build_initial_env add_type add_exception empty_env =
      type_kind = Type_variant([cstr ident_void []])}
   and decl_exn =
     {decl_abstr with
-     type_kind = Type_variant []}
+     type_kind = Type_open}
   and decl_array =
     let tvar = newgenvar() in
     {decl_abstr with
@@ -164,24 +164,30 @@ let build_initial_env add_type add_exception empty_env =
      type_variance = [Variance.covariant]}
   in
 
-  let add_exception id l =
-    add_exception id
-      { exn_args = l; exn_loc = Location.none; exn_attributes = [] }
+  let add_extension id l =
+    add_extension id
+      { ext_type_path = path_exn;
+        ext_type_params = [];
+        ext_args = l;
+        ext_ret_type = None;
+        ext_private = Asttypes.Public;
+        ext_loc = Location.none;
+        ext_attributes = [] }
   in
-  add_exception ident_match_failure
+  add_extension ident_match_failure
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
-  add_exception ident_out_of_memory [] (
-  add_exception ident_stack_overflow [] (
-  add_exception ident_invalid_argument [type_string] (
-  add_exception ident_failure [type_string] (
-  add_exception ident_not_found [] (
-  add_exception ident_sys_blocked_io [] (
-  add_exception ident_sys_error [type_string] (
-  add_exception ident_end_of_file [] (
-  add_exception ident_division_by_zero [] (
-  add_exception ident_assert_failure
+  add_extension ident_out_of_memory [] (
+  add_extension ident_stack_overflow [] (
+  add_extension ident_invalid_argument [type_string] (
+  add_extension ident_failure [type_string] (
+  add_extension ident_not_found [] (
+  add_extension ident_sys_blocked_io [] (
+  add_extension ident_sys_error [type_string] (
+  add_extension ident_end_of_file [] (
+  add_extension ident_division_by_zero [] (
+  add_extension ident_assert_failure
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
-  add_exception ident_undefined_recursive_module
+  add_extension ident_undefined_recursive_module
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
   add_type ident_int64 decl_abstr (
   add_type ident_int32 decl_abstr (
diff --git a/typing/predef.mli b/typing/predef.mli
index a2f4724718..c13893bcea 100644
--- a/typing/predef.mli
+++ b/typing/predef.mli
@@ -51,11 +51,11 @@ val path_undefined_recursive_module : Path.t
 
 (* To build the initial environment. Since there is a nasty mutual
    recursion between predef and env, we break it by parameterizing
-   over Env.t, Env.add_type and Env.add_exception. *)
+   over Env.t, Env.add_type and Env.add_extension. *)
 
 val build_initial_env:
   (Ident.t -> type_declaration -> 'a -> 'a) ->
-  (Ident.t -> exception_declaration -> 'a -> 'a) ->
+  (Ident.t -> extension_constructor -> 'a -> 'a) ->
   'a -> 'a
 
 (* To initialize linker tables *)
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index def57c358f..a2e1502d76 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -914,22 +914,13 @@ let tree_of_extension_constructor id ext es =
     match es with
         Text_first -> Oext_first
       | Text_next -> Oext_next
+      | Text_exception -> Oext_exception
   in
     Osig_typext (ext, es)
 
 let extension_constructor id ppf ext =
   !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)
 
-(* Print an exception declaration *)
-
-let tree_of_exception_declaration id decl =
-  reset_and_mark_loops_list decl.exn_args;
-  let tyl = tree_of_typlist false decl.exn_args in
-  Osig_exception (Ident.name id, tyl)
-
-let exception_declaration id ppf decl =
-  !Oprint.out_sig_item ppf (tree_of_exception_declaration id decl)
-
 (* Print a value declaration *)
 
 let tree_of_value_description id decl =
@@ -1194,8 +1185,6 @@ and tree_of_signature_rec env' = function
             [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)]
         | Sig_typext(id, ext, es) ->
             [tree_of_extension_constructor id ext es]
-        | Sig_exception(id, decl) ->
-            [tree_of_exception_declaration id decl]
         | Sig_module(id, md, rs) ->
             [Osig_module (Ident.name id, tree_of_modtype md.md_type,
                           tree_of_rec rs)]
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index 3432eb16b0..b58b854cca 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -49,10 +49,6 @@ val tree_of_extension_constructor:
     Ident.t -> extension_constructor -> ext_status -> out_sig_item
 val extension_constructor:
     Ident.t -> formatter -> extension_constructor -> unit
-val tree_of_exception_declaration:
-    Ident.t -> exception_declaration -> out_sig_item
-val exception_declaration:
-    Ident.t -> formatter -> exception_declaration -> unit
 val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item
 val modtype: formatter -> module_type -> unit
 val signature: formatter -> signature -> unit
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 34048e56c7..117f572a1e 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -614,9 +614,9 @@ and signature_item i ppf x =
   | Tsig_typext e ->
       line i ppf "Psig_typext\n";
       type_extension i ppf e;
-  | Tsig_exception cd ->
+  | Tsig_exception ext ->
       line i ppf "Psig_exception\n";
-      constructor_decl i ppf cd
+      extension_constructor i ppf ext
   | Tsig_module md ->
       line i ppf "Psig_module \"%a\"\n" fmt_ident md.md_id;
       attributes i ppf md.md_attributes;
@@ -721,12 +721,9 @@ and structure_item i ppf x =
   | Tstr_typext te ->
       line i ppf "Pstr_typext\n";
       type_extension i ppf te
-  | Tstr_exception cd ->
+  | Tstr_exception ext ->
       line i ppf "Pstr_exception\n";
-      constructor_decl i ppf cd;
-  | Tstr_exn_rebind (s, _, li, _, attrs) ->
-      line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li;
-      attributes i ppf attrs
+      extension_constructor i ppf ext;
   | Tstr_module x ->
       line i ppf "Pstr_module\n";
       module_binding i ppf x
diff --git a/typing/subst.ml b/typing/subst.ml
index d816efa98b..2e84be01ff 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -312,12 +312,6 @@ let extension_constructor s ext =
     cleanup_types ();
     ext
 
-let exception_declaration s descr =
-  { exn_args = List.map (type_expr s) descr.exn_args;
-    exn_loc = loc s descr.exn_loc;
-    exn_attributes = attrs s descr.exn_attributes;
-   }
-
 let rec rename_bound_idents s idents = function
     [] -> (List.rev idents, s)
   | Sig_type(id, d, _) :: sg ->
@@ -330,7 +324,7 @@ let rec rename_bound_idents s idents = function
       let id' = Ident.rename id in
       rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s)
                           (id' :: idents) sg
-  | (Sig_value(id, _) | Sig_typext(id, _, _) | Sig_exception(id, _) |
+  | (Sig_value(id, _) | Sig_typext(id, _, _) |
      Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents s (id' :: idents) sg
@@ -370,8 +364,6 @@ and signature_component s comp newid =
       Sig_type(newid, type_declaration s d, rs)
   | Sig_typext(id, ext, es) ->
       Sig_typext(newid, extension_constructor s ext, es)
-  | Sig_exception(id, d) ->
-      Sig_exception(newid, exception_declaration s d)
   | Sig_module(id, d, rs) ->
       Sig_module(newid, module_declaration s d, rs)
   | Sig_modtype(id, d) ->
diff --git a/typing/subst.mli b/typing/subst.mli
index c75dbc6a6e..a197f82f48 100644
--- a/typing/subst.mli
+++ b/typing/subst.mli
@@ -45,8 +45,6 @@ val value_description: t -> value_description -> value_description
 val type_declaration: t -> type_declaration -> type_declaration
 val extension_constructor:
         t -> extension_constructor -> extension_constructor
-val exception_declaration:
-        t -> exception_declaration -> exception_declaration
 val class_declaration: t -> class_declaration -> class_declaration
 val cltype_declaration: t -> class_type_declaration -> class_type_declaration
 val modtype: t -> module_type -> module_type
diff --git a/typing/typecore.ml b/typing/typecore.ml
index febce8e3c5..bfe30537c1 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -189,8 +189,7 @@ let iter_expression f e =
     | Pstr_open _
     | Pstr_class_type _
     | Pstr_attribute _
-    | Pstr_extension _
-    | Pstr_exn_rebind _ -> ()
+    | Pstr_extension _ -> ()
     | Pstr_include (me, _)
     | Pstr_module {pmb_expr = me} -> module_expr me
     | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l
@@ -281,8 +280,7 @@ let extract_concrete_record env ty =
 
 let extract_concrete_variant env ty =
   match extract_concrete_typedecl env ty with
-    (* exclude exceptions *)
-    (p0, p, {type_kind=Type_variant (_::_ as cstrs)}) -> (p0, p, cstrs)
+    (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)
   | _ -> raise Not_found
 
 let extract_label_names sexp env ty =
@@ -1428,8 +1426,8 @@ and is_nonexpansive_mod mexp =
   | Tmod_structure str ->
       List.for_all
         (fun item -> match item.str_desc with
-          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _
-          | Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true
+          | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
+          | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _  -> true
           | Tstr_value (_, pat_exp_list) ->
               List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
           | Tstr_module {mb_expr=m;_}
@@ -1437,7 +1435,9 @@ and is_nonexpansive_mod mexp =
           | Tstr_recmodule id_mod_list ->
               List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
                 id_mod_list
-          | Tstr_exception _ -> false (* true would be unsound *)
+          | Tstr_exception {ext_kind = Text_decl _} ->
+              false (* true would be unsound *)
+          | Tstr_exception {ext_kind = Text_rebind _} -> true
           | Tstr_typext te ->
               List.for_all
                 (function {ext_kind = Text_decl _} -> false
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 06820f81b7..68392ab5f6 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -38,13 +38,11 @@ type error =
   | Extension_mismatch of Path.t * Includecore.type_mismatch list
   | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
   | Rebind_private of Longident.t
-  | Not_an_exception of Longident.t
   | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool)
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
-  | Unbound_type_var_exc of type_expr * type_expr
+  | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
-  | Exception_constructor_with_result
 
 open Typedtree
 
@@ -146,6 +144,30 @@ let make_params env params =
   in
     List.map make_param params
 
+let make_constructor env type_path type_params sargs sret_type =
+  match sret_type with
+  | None ->
+      let targs = List.map (transl_simple_type env true) sargs in
+      let args = List.map (fun cty -> cty.ctyp_type) targs in
+        targs, None, args, None
+  | Some sret_type ->
+      (* if it's a generalized constructor we must first narrow and
+         then widen so as to not introduce any new constraints *)
+      let z = narrow () in
+      reset_type_variables ();
+      let targs = List.map (transl_simple_type env false) sargs in
+      let args = List.map (fun cty -> cty.ctyp_type) targs in
+      let tret_type = transl_simple_type env false sret_type in
+      let ret_type = tret_type.ctyp_type in
+      begin
+        match (Ctype.repr ret_type).desc with
+          Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | _ -> raise (Error (sret_type.ptyp_loc, Constraint_failed
+                              (ret_type, Ctype.newconstr type_path type_params)))
+      end;
+      widen z;
+      targs, Some tret_type, args, Some ret_type
+
 let transl_declaration env sdecl id =
   (* Bind type parameters *)
   reset_type_variables();
@@ -161,54 +183,43 @@ let transl_declaration env sdecl id =
   let (tkind, kind) =
     match sdecl.ptype_kind with
         Ptype_abstract -> Ttype_abstract, Type_abstract
-      | Ptype_variant cstrs ->
+      | Ptype_variant scstrs ->
         let all_constrs = ref StringSet.empty in
         List.iter
           (fun {pcd_name = {txt = name}} ->
             if StringSet.mem name !all_constrs then
               raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
             all_constrs := StringSet.add name !all_constrs)
-          cstrs;
+          scstrs;
         if List.length
-          (List.filter (fun cd -> cd.pcd_args <> []) cstrs)
+          (List.filter (fun cd -> cd.pcd_args <> []) scstrs)
           > (Config.max_tag + 1) then
           raise(Error(sdecl.ptype_loc, Too_many_constructors));
-        let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} =
-          let name = Ident.create lid.txt in
-          match ret_type with
-            | None ->
-              (name, lid, List.map (transl_simple_type env true) args,
-               None, None, loc, attrs)
-            | Some sty ->
-              (* if it's a generalized constructor we must first narrow and
-                 then widen so as to not introduce any new constraints *)
-              let z = narrow () in
-              reset_type_variables ();
-              let args = List.map (transl_simple_type env false) args in
-              let cty = transl_simple_type env false sty in
-              let ret_type =
-                let ty = cty.ctyp_type in
-                let p = Path.Pident id in
-                match (Ctype.repr ty).desc with
-                  Tconstr (p', _, _) when Path.same p p' -> ty
-                | _ ->
-                    raise (Error (sty.ptyp_loc, Constraint_failed
-                                    (ty, Ctype.newconstr p params)))
-              in
-              widen z;
-              (name, lid, args, Some cty, Some ret_type, loc, attrs)
+        let make_cstr scstr =
+          let name = Ident.create scstr.pcd_name.txt in
+          let targs, tret_type, args, ret_type =
+            make_constructor env (Path.Pident id) params
+                             scstr.pcd_args scstr.pcd_res
+          in
+          let tcstr =
+            { cd_id = name;
+              cd_name = scstr.pcd_name;
+              cd_args = targs;
+              cd_res = tret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+          let cstr =
+            { Types.cd_id = name;
+              cd_args = args;
+              cd_res = ret_type;
+              cd_loc = scstr.pcd_loc;
+              cd_attributes = scstr.pcd_attributes }
+          in
+            tcstr, cstr
         in
-        let cstrs = List.map make_cstr cstrs in
-        Ttype_variant (List.map (fun (name, lid, ctys, res, _, loc, attrs) ->
-          {cd_id = name; cd_name = lid; cd_args = ctys; cd_res = res;
-           cd_loc = loc; cd_attributes = attrs}
-        ) cstrs),
-        Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, attrs) ->
-            {Types.cd_id = name; cd_args = List.map (fun cty -> cty.ctyp_type) ctys;
-             cd_res = option;
-             cd_loc = loc; cd_attributes = attrs}
-          ) cstrs)
-
+        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
+          Ttype_variant tcstrs, Type_variant cstrs
       | Ptype_record lbls ->
         let all_labels = ref StringSet.empty in
         List.iter
@@ -1017,47 +1028,16 @@ let transl_type_decl env sdecl_list =
 
 (* Translating type extensions *)
 
-let transl_extension_constructor env check_open type_decl
-                                 type_path type_params priv sext =
+let transl_extension_constructor env check_open type_path type_params
+                                 typext_params priv sext =
   let id = Ident.create sext.pext_name.txt in
   let args, ret_type, kind =
     match sext.pext_kind with
-      Pext_decl(args, None) ->
-        begin
-          match type_decl.type_kind with
-            Type_open -> ()
-          | Type_abstract ->
-              if check_open then
-                raise (Error(sext.pext_loc, Not_open_type type_path))
-          | _ -> assert false
-        end;
-        let targs = List.map (transl_simple_type env true) args in
-        let args = List.map (fun cty -> cty.ctyp_type) targs in
-          args, None, Text_decl(targs, None)
-    | Pext_decl(args, Some ret_type) ->
-        begin
-          match type_decl.type_kind with
-            Type_open -> ()
-          | Type_abstract ->
-              if check_open then
-                raise (Error(sext.pext_loc, Not_open_type type_path))
-          | _ -> assert false
-        end;
-        let z = narrow () in
-        reset_type_variables ();
-        let targs = List.map (transl_simple_type env false) args in
-        let args = List.map (fun cty -> cty.ctyp_type) targs in
-        let tret_type = transl_simple_type env false ret_type in
-        let ret_type =
-          let ty = tret_type.ctyp_type in
-          match (Ctype.repr ty).desc with
-              Tconstr (p, _, _) when Path.same type_path p -> ty
-            | _ ->
-              raise(Error(sext.pext_loc,
-                Constraint_failed (ty, Ctype.newconstr type_path type_params)))
+      Pext_decl(sargs, sret_type) ->
+        let targs, tret_type, args, ret_type =
+          make_constructor env type_path typext_params sargs sret_type
         in
-          widen z;
-          args, Some ret_type, Text_decl(targs, Some tret_type)
+          args, ret_type, Text_decl(targs, tret_type)
     | Pext_rebind lid ->
       let cdescr = Typetexp.find_constructor env sext.pext_loc lid.txt in
       let usage =
@@ -1070,10 +1050,10 @@ let transl_extension_constructor env check_open type_decl
           if cdescr.cstr_generalized then
             let res =
               Ctype.newconstr type_path
-                (Ctype.instance_list env type_decl.type_params)
+                (Ctype.instance_list env type_params)
             in
               res, Some res
-          else (Ctype.newconstr type_path type_params), None
+          else (Ctype.newconstr type_path typext_params), None
         in
           begin
             try
@@ -1091,7 +1071,7 @@ let transl_extension_constructor env check_open type_decl
                 (function {desc = Tvar (Some "_")} as ty ->
                           if List.memq ty vars then ty.desc <- Tvar None
                           | _ -> ())
-                type_params
+                typext_params
           end;
           (* Disallow rebinding private constructors to non-private *)
           begin
@@ -1109,7 +1089,7 @@ let transl_extension_constructor env check_open type_decl
   in
   let ext =
     { ext_type_path = type_path;
-      ext_type_params = type_params;
+      ext_type_params = typext_params;
       ext_args = args;
       ext_ret_type = ret_type;
       ext_private = priv;
@@ -1131,7 +1111,18 @@ let transl_type_extension check_open env loc styext =
   in
   begin
     match type_decl.type_kind with
-      Type_open | Type_abstract -> ()
+      Type_open -> ()
+    | Type_abstract ->
+        if check_open then begin
+          try
+            let {pext_loc} =
+              List.find (function {pext_kind = Pext_decl _} -> true
+                                | {pext_kind = Pext_rebind _} -> false)
+                        styext.ptyext_constructors
+            in
+              raise (Error(pext_loc, Not_open_type type_path))
+          with Not_found -> ()
+        end
     | _ -> raise (Error(loc, Not_extensible_type type_path))
   end;
   let type_variance =
@@ -1158,8 +1149,8 @@ let transl_type_extension check_open env loc styext =
     (Ctype.instance_list env type_decl.type_params)
     type_params;
   let constructors =
-    List.map (transl_extension_constructor env check_open type_decl
-                type_path type_params styext.ptyext_private)
+    List.map (transl_extension_constructor env check_open type_path
+               type_decl.type_params type_params styext.ptyext_private)
       styext.ptyext_constructors
   in
   Ctype.end_def();
@@ -1170,6 +1161,13 @@ let transl_type_extension check_open env loc styext =
        List.iter Ctype.generalize ext.ext_type.ext_args;
        may Ctype.generalize ext.ext_type.ext_ret_type)
     constructors;
+  (* Check that all type variable are closed *)
+  List.iter
+    (fun ext ->
+       match Ctype.closed_extension_constructor ext.ext_type with
+         Some ty -> raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+       | None -> ())
+    constructors;
   (* Check variances are correct *)
   List.iter
     (fun ext->
@@ -1193,56 +1191,25 @@ let transl_type_extension check_open env loc styext =
   in
     (tyext, newenv)
 
-(* Translate an exception declaration *)
-let transl_closed_type env sty =
-  let cty = transl_simple_type env true sty in
-  let ty = cty.ctyp_type in
-  let ty =
-  match Ctype.free_variables ty with
-  | []      -> ty
-  | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty)))
-  in
-  { cty with ctyp_type = ty }
-
-let transl_exception env excdecl =
-  let loc = excdecl.pcd_loc in
-  if excdecl.pcd_res <> None then raise (Error (loc, Exception_constructor_with_result));
+let transl_exception env sext =
   reset_type_variables();
   Ctype.begin_def();
-  let ttypes = List.map (transl_closed_type env) excdecl.pcd_args in
-  Ctype.end_def();
-  let types = List.map (fun cty -> cty.ctyp_type) ttypes in
-  List.iter Ctype.generalize types;
-  let exn_decl =
-    {
-      exn_args = types;
-      exn_attributes = excdecl.pcd_attributes;
-      Types.exn_loc = loc;
-    }
-  in
-  let (id, newenv) = Env.enter_exception excdecl.pcd_name.txt exn_decl env in
-  let cd =
-    { cd_id = id;
-      cd_name = excdecl.pcd_name;
-      cd_args = ttypes;
-      cd_loc = loc;
-      cd_res = None;
-      cd_attributes = excdecl.pcd_attributes;
-     }
+  let ext =
+    transl_extension_constructor env false
+      Predef.path_exn [] [] Asttypes.Public sext
   in
-  cd, exn_decl, newenv
-
-(* Translate an exception rebinding *)
-let transl_exn_rebind env loc lid =
-  let cdescr = Typetexp.find_constructor env loc lid in
-  Env.mark_constructor Env.Positive env (Longident.last lid) cdescr;
-  if not cdescr.cstr_exception then raise(Error(loc, Not_an_exception lid));
-  match cdescr.cstr_tag with
-    Cstr_extension(path, _) ->
-      (path, {exn_args = cdescr.cstr_args;
-              exn_attributes = [];
-              Types.exn_loc = loc})
-  | _ -> assert false
+  Ctype.end_def();
+  (* Generalize types *)
+  List.iter Ctype.generalize ext.ext_type.ext_args;
+  may Ctype.generalize ext.ext_type.ext_ret_type;
+  (* Check that all type variable are closed *)
+  begin match Ctype.closed_extension_constructor ext.ext_type with
+    Some ty ->
+      raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
+  | None -> ()
+  end;
+  let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in
+    ext, newenv
 
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
@@ -1500,9 +1467,9 @@ let report_error ppf = function
           explain_unbound_single ppf ty ty'
       | _ -> ()
       end
-  | Unbound_type_var_exc (tv, ty) ->
-      fprintf ppf "A type variable is unbound in this exception declaration";
-      explain_unbound_single ppf (Ctype.repr tv) ty
+  | Unbound_type_var_ext (ty, ext) ->
+      fprintf ppf "A type variable is unbound in this extension constructor";
+      explain_unbound ppf ty ext.ext_args (fun c -> c) "type" (fun _ -> "")
   | Not_open_type path ->
       fprintf ppf "@[%s@ %a@]"
         "Cannot extend type definition"
@@ -1531,9 +1498,6 @@ let report_error ppf = function
         "The constructor"
         Printtyp.longident lid
         "is private"
-  | Not_an_exception lid ->
-      fprintf ppf "The constructor@ %a@ is not an exception"
-        Printtyp.longident lid
   | Bad_variance (n, v1, v2) ->
       let variance (p,n,i) =
         let inj = if i then "injective " else "" in
@@ -1579,8 +1543,6 @@ let report_error ppf = function
       fprintf ppf "@[%s@ %s@ %s@]"
         "In this GADT definition," "the variance of some parameter"
         "cannot be checked"
-  | Exception_constructor_with_result ->
-      fprintf ppf "Exception constructors cannot specify a result type"
 
 let () =
   Location.register_error_of_exn
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index c1db94a659..0d235076d0 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -21,10 +21,7 @@ val transl_type_decl:
 
 val transl_exception:
     Env.t ->
-    Parsetree.constructor_declaration -> Typedtree.constructor_declaration * exception_declaration * Env.t
-
-val transl_exn_rebind:
-    Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
+    Parsetree.extension_constructor -> Typedtree.extension_constructor * Env.t
 
 val transl_type_extension:
     bool -> Env.t -> Location.t -> Parsetree.type_extension ->
@@ -78,13 +75,11 @@ type error =
   | Extension_mismatch of Path.t * Includecore.type_mismatch list
   | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
   | Rebind_private of Longident.t
-  | Not_an_exception of Longident.t
   | Bad_variance of int * (bool*bool*bool) * (bool*bool*bool)
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
-  | Unbound_type_var_exc of type_expr * type_expr
+  | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
-  | Exception_constructor_with_result
 
 exception Error of Location.t * error
 
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index a9d580f0fe..dfb8ee8f78 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -211,9 +211,7 @@ and structure_item_desc =
   | Tstr_primitive of value_description
   | Tstr_type of type_declaration list
   | Tstr_typext of type_extension
-  | Tstr_exception of constructor_declaration
-  | Tstr_exn_rebind of
-      Ident.t * string loc * Path.t * Longident.t loc * attribute list
+  | Tstr_exception of extension_constructor
   | Tstr_module of module_binding
   | Tstr_recmodule of module_binding list
   | Tstr_modtype of module_type_declaration
@@ -278,7 +276,7 @@ and signature_item_desc =
     Tsig_value of value_description
   | Tsig_type of type_declaration list
   | Tsig_typext of type_extension
-  | Tsig_exception of constructor_declaration
+  | Tsig_exception of extension_constructor
   | Tsig_module of module_declaration
   | Tsig_recmodule of module_declaration list
   | Tsig_modtype of module_type_declaration
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 183abb8129..0941f538c6 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -210,8 +210,7 @@ and structure_item_desc =
   | Tstr_primitive of value_description
   | Tstr_type of type_declaration list
   | Tstr_typext of type_extension
-  | Tstr_exception of constructor_declaration
-  | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attributes
+  | Tstr_exception of extension_constructor
   | Tstr_module of module_binding
   | Tstr_recmodule of module_binding list
   | Tstr_modtype of module_type_declaration
@@ -276,7 +275,7 @@ and signature_item_desc =
     Tsig_value of value_description
   | Tsig_type of type_declaration list
   | Tsig_typext of type_extension
-  | Tsig_exception of constructor_declaration
+  | Tsig_exception of extension_constructor
   | Tsig_module of module_declaration
   | Tsig_recmodule of module_declaration list
   | Tsig_modtype of module_type_declaration
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 716b7526f7..eacae82411 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -135,8 +135,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tstr_primitive vd -> iter_value_description vd
         | Tstr_type list -> List.iter iter_type_declaration list
         | Tstr_typext tyext -> iter_type_extension tyext
-        | Tstr_exception cd -> iter_constructor_declaration cd
-        | Tstr_exn_rebind _ -> ()
+        | Tstr_exception ext -> iter_extension_constructor ext
         | Tstr_module x -> iter_module_binding x
         | Tstr_recmodule list -> List.iter iter_module_binding list
         | Tstr_modtype mtd -> iter_module_type_declaration mtd
@@ -355,8 +354,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_value_description vd
         | Tsig_type list ->
             List.iter iter_type_declaration list
-        | Tsig_exception cd ->
-            iter_constructor_declaration cd
+        | Tsig_exception ext ->
+            iter_extension_constructor ext
         | Tsig_typext tyext ->
             iter_type_extension tyext
         | Tsig_module md ->
@@ -592,7 +591,6 @@ module DefaultIteratorArgument = struct
       let enter_type_declaration _ = ()
       let enter_type_extension _ = ()
       let enter_extension_constructor _ = ()
-      let enter_exception_declaration _ = ()
       let enter_pattern _ = ()
       let enter_expression _ = ()
       let enter_package_type _ = ()
@@ -621,7 +619,6 @@ module DefaultIteratorArgument = struct
       let leave_type_declaration _ = ()
       let leave_type_extension _ = ()
       let leave_extension_constructor _ = ()
-      let leave_exception_declaration _ = ()
       let leave_pattern _ = ()
       let leave_expression _ = ()
       let leave_package_type _ = ()
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 0e3909eade..9cc7de64a3 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -120,10 +120,8 @@ module MakeMap(Map : MapArgument) = struct
           Tstr_type (List.map map_type_declaration list)
         | Tstr_typext tyext ->
           Tstr_typext (map_type_extension tyext)
-        | Tstr_exception cd ->
-          Tstr_exception (map_constructor_declaration cd)
-        | Tstr_exn_rebind (id, name, path, lid, attrs) ->
-          Tstr_exn_rebind (id, name, path, lid, attrs)
+        | Tstr_exception ext ->
+          Tstr_exception (map_extension_constructor ext)
         | Tstr_module x ->
           Tstr_module (map_module_binding x)
         | Tstr_recmodule list ->
@@ -411,8 +409,8 @@ module MakeMap(Map : MapArgument) = struct
         | Tsig_type list -> Tsig_type (List.map map_type_declaration list)
         | Tsig_typext tyext ->
           Tsig_typext (map_type_extension tyext)
-        | Tsig_exception cd ->
-          Tsig_exception (map_constructor_declaration cd)
+        | Tsig_exception ext ->
+          Tsig_exception (map_extension_constructor ext)
         | Tsig_module md ->
           Tsig_module {md with md_type = map_module_type md.md_type}
         | Tsig_recmodule list ->
@@ -646,7 +644,6 @@ module DefaultMapArgument = struct
   let enter_type_declaration t = t
   let enter_type_extension t = t
   let enter_extension_constructor t = t
-  let enter_exception_declaration t = t
   let enter_pattern t = t
   let enter_expression t = t
   let enter_package_type t = t
@@ -674,8 +671,6 @@ module DefaultMapArgument = struct
   let leave_type_declaration t = t
   let leave_type_extension t = t
   let leave_extension_constructor t = t
-
-  let leave_exception_declaration t = t
   let leave_pattern t = t
   let leave_expression t = t
   let leave_package_type t = t
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 5d1d9eaef7..b32a1230a0 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -426,33 +426,25 @@ let check_sig_item type_names module_names modtype_names loc = function
       check "module type" loc modtype_names (Ident.name id)
   | _ -> ()
 
-let rec remove_duplicates val_ids ext_ids exn_ids = function
+let rec remove_duplicates val_ids ext_ids = function
     [] -> []
   | Sig_value (id, _) :: rem
     when List.exists (Ident.equal id) val_ids ->
-      remove_duplicates val_ids ext_ids exn_ids rem
+      remove_duplicates val_ids ext_ids rem
   | Sig_typext (id, _, _) :: rem
     when List.exists (Ident.equal id) ext_ids ->
-      remove_duplicates val_ids ext_ids exn_ids rem
-  | Sig_exception(id, _) :: rem
-    when List.exists (Ident.equal id) exn_ids ->
-      remove_duplicates val_ids ext_ids exn_ids rem
-  | f :: rem -> f :: remove_duplicates val_ids ext_ids exn_ids rem
+      remove_duplicates val_ids ext_ids rem
+  | f :: rem -> f :: remove_duplicates val_ids ext_ids rem
 
 let rec get_values = function
     [] -> []
   | Sig_value (id, _) :: rem -> id :: get_values rem
   | f :: rem -> get_values rem
 
-let rec get_type_extensions = function
+let rec get_extension_constructors = function
     [] -> []
-  | Sig_typext (id, _, _) :: rem -> id :: get_type_extensions rem
-  | f :: rem -> get_type_extensions rem
-
-let rec get_exceptions = function
-    [] -> []
-  | Sig_exception (id, _) :: rem -> id :: get_exceptions rem
-  | f :: rem -> get_exceptions rem
+  | Sig_typext (id, _, _) :: rem -> id :: get_extension_constructors rem
+  | f :: rem -> get_extension_constructors rem
 
 (* Check and translate a module type expression *)
 
@@ -564,20 +556,25 @@ and transl_signature env sg =
             let constructors =
               List.filter
                 (fun ext -> not
-                  (List.exists (Ident.equal ext.ext_id) (get_type_extensions rem)))
+                  (List.exists (Ident.equal ext.ext_id)
+                               (get_extension_constructors rem)))
                 tyext.tyext_constructors
             in
               mksig (Tsig_typext tyext) env loc :: trem,
               map_ext (fun es ext ->
                 Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem,
               final_env
-        | Psig_exception sarg ->
-            let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
+        | Psig_exception sext ->
+            let (ext, newenv) = Typedecl.transl_exception env sext in
             let (trem, rem, final_env) = transl_sig newenv srem in
-            let id = arg.cd_id in
-            mksig (Tsig_exception arg) env loc :: trem,
-            (if List.exists (Ident.equal id) (get_exceptions rem) then rem
-             else Sig_exception(id, decl) :: rem),
+            let shadowed =
+              List.exists
+                (Ident.equal ext.ext_id)
+                (get_extension_constructors rem)
+            in
+            mksig (Tsig_exception ext) env loc :: trem,
+            (if shadowed then rem else
+               Sig_typext(ext.ext_id, ext.ext_type, Text_exception) :: rem),
             final_env
         | Psig_module pmd ->
             check "module" item.psig_loc module_names pmd.pmd_name.txt;
@@ -639,8 +636,8 @@ and transl_signature env sg =
             let newenv = Env.add_signature sg env in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_include (tmty, sg, attrs)) env loc :: trem,
-            remove_duplicates (get_values rem) (get_type_extensions rem)
-              (get_exceptions rem) sg @ rem,
+            remove_duplicates (get_values rem)
+              (get_extension_constructors rem) sg @ rem,
             final_env
         | Psig_class cl ->
             List.iter
@@ -1186,14 +1183,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
            (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es))
            tyext.tyext_constructors [],
          newenv)
-    | Pstr_exception sarg ->
-        let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
-        Tstr_exception arg, [Sig_exception(arg.cd_id, decl)], newenv
-    | Pstr_exn_rebind(name, longid, attrs) ->
-        let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in
-        let (id, newenv) = Env.enter_exception name.txt arg env in
-        Tstr_exn_rebind(id, name, path, longid, attrs),
-        [Sig_exception(id, arg)],
+    | Pstr_exception sext ->
+        let (ext, newenv) = Typedecl.transl_exception env sext in
+        Tstr_exception ext,
+        [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)],
         newenv
     | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
                    pmb_loc;
@@ -1344,7 +1337,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
                       Sig_module (id, {md with md_type =
                                        Mty_alias (Pdot(p,Ident.name id,n))},
                                   rs)
-                  | Sig_value (_, {val_kind=Val_reg}) | Sig_exception _
+                  | Sig_value (_, {val_kind=Val_reg})
                   | Sig_typext _ | Sig_class _ as it ->
                       incr pos; it
                   | Sig_value _ | Sig_type _ | Sig_modtype _
@@ -1408,7 +1401,7 @@ and normalize_signature_item env = function
   | Sig_module(id, md, _) -> normalize_modtype env md.md_type
   | _ -> ()
 
-(* Simplify multiple specifications of a value or an exception in a signature.
+(* Simplify multiple specifications of a value or an extension in a signature.
    (Other signature components, e.g. types, modules, etc, are checked for
    name uniqueness.)  If multiple specifications with the same name,
    keep only the last (rightmost) one. *)
@@ -1421,31 +1414,25 @@ let rec simplify_modtype mty =
   | Mty_signature sg -> Mty_signature(simplify_signature sg)
 
 and simplify_signature sg =
-  let rec simplif val_names ext_names exn_names res = function
+  let rec simplif val_names ext_names res = function
     [] -> res
   | (Sig_value(id, descr) as component) :: sg ->
       let name = Ident.name id in
-      simplif (StringSet.add name val_names) ext_names exn_names
+      simplif (StringSet.add name val_names) ext_names
               (if StringSet.mem name val_names then res else component :: res)
               sg
   | (Sig_typext(id, ext, es) as component) :: sg ->
       let name = Ident.name id in
-      simplif val_names (StringSet.add name ext_names) exn_names
+      simplif val_names (StringSet.add name ext_names)
               (if StringSet.mem name ext_names then res else component :: res)
               sg
-  | (Sig_exception(id, decl) as component) :: sg ->
-      let name = Ident.name id in
-      simplif val_names ext_names (StringSet.add name exn_names)
-              (if StringSet.mem name exn_names then res else component :: res)
-              sg
   | Sig_module(id, md, rs) :: sg ->
       let md = {md with md_type = simplify_modtype md.md_type} in
-      simplif val_names ext_names exn_names
-              (Sig_module(id, md, rs) :: res) sg
+      simplif val_names ext_names (Sig_module(id, md, rs) :: res) sg
   | component :: sg ->
-      simplif val_names ext_names exn_names (component :: res) sg
+      simplif val_names ext_names (component :: res) sg
   in
-    simplif StringSet.empty StringSet.empty StringSet.empty [] (List.rev sg)
+    simplif StringSet.empty StringSet.empty [] (List.rev sg)
 
 (* Extract the module type of a module expression *)
 
diff --git a/typing/types.ml b/typing/types.ml
index 1d07bc48f8..91ece7e0d9 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -117,7 +117,6 @@ type constructor_description =
     cstr_normal: int;                   (* Number of non generalized constrs *)
     cstr_generalized: bool;             (* Constrained return type? *)
     cstr_private: private_flag;         (* Read-only constructor? *)
-    cstr_exception: bool;               (* Exception constructor? *)
     cstr_loc: Location.t;
     cstr_attributes: Parsetree.attributes;
    }
@@ -229,12 +228,6 @@ and type_transparence =
   | Type_new         (* "new" type *)
   | Type_private     (* private type *)
 
-type exception_declaration =
-    { exn_args: type_expr list;
-      exn_loc: Location.t;
-      exn_attributes: Parsetree.attributes;
-     }
-
 (* Type expressions for the class language *)
 
 module Concr = Set.Make(OrderedString)
@@ -284,7 +277,6 @@ and signature_item =
     Sig_value of Ident.t * value_description
   | Sig_type of Ident.t * type_declaration * rec_status
   | Sig_typext of Ident.t * extension_constructor * ext_status
-  | Sig_exception of Ident.t * exception_declaration
   | Sig_module of Ident.t * module_declaration * rec_status
   | Sig_modtype of Ident.t * modtype_declaration
   | Sig_class of Ident.t * class_declaration * rec_status
@@ -312,3 +304,4 @@ and rec_status =
 and ext_status =
     Text_first                     (* first constructor of an extension *)
   | Text_next                      (* not first constructor of an extension *)
+  | Text_exception                 (* an exception *)
diff --git a/typing/types.mli b/typing/types.mli
index 8f2c2e08a6..aa4fef7aa4 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -114,7 +114,6 @@ type constructor_description =
     cstr_normal: int;                   (* Number of non generalized constrs *)
     cstr_generalized: bool;             (* Constrained return type? *)
     cstr_private: private_flag;         (* Read-only constructor? *)
-    cstr_exception: bool;               (* Exception constructor? *)
     cstr_loc: Location.t;
     cstr_attributes: Parsetree.attributes;
    }
@@ -219,12 +218,6 @@ and type_transparence =
   | Type_new         (* "new" type *)
   | Type_private     (* private type *)
 
-type exception_declaration =
-    { exn_args: type_expr list;
-      exn_loc: Location.t;
-      exn_attributes: Parsetree.attributes;
-    }
-
 (* Type expressions for the class language *)
 
 module Concr : Set.S with type elt = string
@@ -274,7 +267,6 @@ and signature_item =
     Sig_value of Ident.t * value_description
   | Sig_type of Ident.t * type_declaration * rec_status
   | Sig_typext of Ident.t * extension_constructor * ext_status
-  | Sig_exception of Ident.t * exception_declaration
   | Sig_module of Ident.t * module_declaration * rec_status
   | Sig_modtype of Ident.t * modtype_declaration
   | Sig_class of Ident.t * class_declaration * rec_status
@@ -302,3 +294,4 @@ and rec_status =
 and ext_status =
     Text_first                     (* first constructor in an extension *)
   | Text_next                      (* not first constructor in an extension *)
+  | Text_exception
diff --git a/utils/warnings.ml b/utils/warnings.ml
index db8a5b36fd..d0a6d88184 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -55,7 +55,7 @@ type t =
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
   | Unused_constructor of string * bool * bool  (* 37 *)
-  | Unused_exception of string * bool       (* 38 *)
+  | Unused_extension of string * bool * 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 *)
@@ -65,7 +65,6 @@ type t =
   | Open_shadow_label_constructor of string * string (* 45 *)
   | Bad_env_variable of string * string     (* 46 *)
   | Attribute_payload of string * string    (* 47 *)
-  | Unused_extension of string * bool * bool  (* 48 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -112,7 +111,7 @@ let number = function
   | Unused_for_index _ -> 35
   | Unused_ancestor _ -> 36
   | Unused_constructor _ -> 37
-  | Unused_exception _ -> 38
+  | Unused_extension _ -> 38
   | Unused_rec_flag -> 39
   | Name_out_of_scope _ -> 40
   | Ambiguous_name _ -> 41
@@ -122,10 +121,9 @@ let number = function
   | Open_shadow_label_constructor _ -> 45
   | Bad_env_variable _ -> 46
   | Attribute_payload _ -> 47
-  | Unused_extension _ -> 48
 ;;
 
-let last_warning_number = 48
+let last_warning_number = 47
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -141,7 +139,7 @@ let letter = function
   | 'h' -> []
   | 'i' -> []
   | 'j' -> []
-  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39; 48]
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39]
   | 'l' -> [6]
   | 'm' -> [7]
   | 'n' -> []
@@ -228,7 +226,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-41..42-44-45-48";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45";;
 let defaults_warn_error = "-a";;
 
 let () = parse_options false defaults_w;;
@@ -320,12 +318,15 @@ let message = function
       "constructor " ^ s ^
       " is never used to build values.\n\
         Its type is exported as a private type."
-  | Unused_exception (s, false) ->
-      "unused exception constructor " ^ s ^ "."
-  | Unused_exception (s, true) ->
-      "exception constructor " ^ s ^
-      " is never raised or used to build values.\n\
+  | Unused_extension (s, false, false) -> "unused extension constructor " ^ s ^ "."
+  | Unused_extension (s, true, _) ->
+      "extension constructor " ^ s ^
+      " is never used to build values.\n\
         (However, this constructor appears in patterns.)"
+  | Unused_extension (s, false, true) ->
+      "extension constructor " ^ s ^
+      " is never used to build values.\n\
+        It is exported or rebound as a private extension."
   | Unused_rec_flag ->
       "unused rec flag."
   | Name_out_of_scope (ty, [nm], false) ->
@@ -362,15 +363,6 @@ let message = function
       Printf.sprintf "illegal environment variable %s : %s" var s
   | Attribute_payload (a, s) ->
       Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
-  | Unused_extension (s, false, false) -> "unused extension constructor " ^ s ^ "."
-  | Unused_extension (s, true, _) ->
-      "extension constructor " ^ s ^
-      " is never used to build values.\n\
-        (However, this constructor appears in patterns.)"
-  | Unused_extension (s, false, true) ->
-      "extension constructor " ^ s ^
-      " is never used to build values.\n\
-        It is exported or rebound as a private extension."
 ;;
 
 let nerrors = ref 0;;
@@ -454,7 +446,7 @@ let descriptions =
    35, "Unused for-loop index.";
    36, "Unused ancestor variable.";
    37, "Unused constructor.";
-   38, "Unused exception constructor.";
+   38, "Unused extension constructor.";
    39, "Unused rec flag.";
    40, "Constructor or label name used out of scope.";
    41, "Ambiguous constructor or label name.";
@@ -464,7 +456,6 @@ let descriptions =
    45, "Open statement shadows an already defined label or constructor.";
    46, "Illegal environment variable";
    47, "Illegal attribute payload";
-   48, "Unused extension constructor.";
   ]
 ;;
 
diff --git a/utils/warnings.mli b/utils/warnings.mli
index b495b6095a..4f354252ef 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -50,7 +50,7 @@ type t =
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
   | Unused_constructor of string * bool * bool (* 37 *)
-  | Unused_exception of string * bool       (* 38 *)
+  | Unused_extension of string * bool * 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 *)
@@ -60,7 +60,6 @@ type t =
   | Open_shadow_label_constructor of string * string (* 45 *)
   | Bad_env_variable of string * string     (* 46 *)
   | Attribute_payload of string * string    (* 47 *)
-  | Unused_extension of string * bool * bool  (* 48 *)
 ;;
 
 val parse_options : bool -> string -> unit;;