merge Leo's patch for PR#6384

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

5 files changed, 45 insertions, 98 deletions

diff --git a/Changes b/Changes
index 3d199ce47..9cd3a7103 100644
--- a/Changes
+++ b/Changes
@@ -123,6 +123,7 @@ Bug fixes:
 - PR#6352: Automatic removal of optional arguments and sequencing
 - PR#6361: Hashtbl.hash not terminating on some lazy values w/ recursive types
 - PR#6383: Exception Not_found when using object type in absent module
+- PR#6384: Uncaught Not_found exception with a hidden .cmi file
 - fix -dsource printing of "external _pipe = ..."
   (Gabriel Scherer)
 - bound-checking bug in caml_string_{get,set}{16,32,64}
diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
index e4c72cda7..4c311c6be 100644
--- a/testsuite/tests/typing-objects/Tests.ml.principal.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -295,12 +295,12 @@ Warning 10: this expression should have type unit.
   unit -> object method private m : int method n : int method o : int end
 #   - : int * int = (1, 1)
 #   class c : unit -> object method m : int end
-#       - : int = 95
+#       - : int = 94
+# - : int = 95
 # - : int = 96
-# - : int = 97
-#         - : int * int * int = (98, 99, 100)
-#           - : int * int * int * int * int = (101, 102, 103, 33, 33)
-#           - : int * int * int * int * int = (104, 105, 106, 33, 33)
+#         - : int * int * int = (97, 98, 99)
+#           - : int * int * int * int * int = (100, 101, 102, 33, 33)
+#           - : int * int * int * int * int = (103, 104, 105, 33, 33)
 #         Characters 42-69:
   class a = let _ = new b in object end
             ^^^^^^^^^^^^^^^^^^^^^^^^^^^
diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index 7940d0e34..5042c35fb 100644
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -294,12 +294,12 @@ Warning 10: this expression should have type unit.
   unit -> object method private m : int method n : int method o : int end
 #   - : int * int = (1, 1)
 #   class c : unit -> object method m : int end
-#       - : int = 95
+#       - : int = 94
+# - : int = 95
 # - : int = 96
-# - : int = 97
-#         - : int * int * int = (98, 99, 100)
-#           - : int * int * int * int * int = (101, 102, 103, 33, 33)
-#           - : int * int * int * int * int = (104, 105, 106, 33, 33)
+#         - : int * int * int = (97, 98, 99)
+#           - : int * int * int * int * int = (100, 101, 102, 33, 33)
+#           - : int * int * int * int * int = (103, 104, 105, 33, 33)
 #         Characters 42-69:
   class a = let _ = new b in object end
             ^^^^^^^^^^^^^^^^^^^^^^^^^^^
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index b425144a1..e0a99b9d5 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -110,13 +110,12 @@ and compats ps qs = match ps,qs with
 | p::ps, q::qs -> compat p q && compats ps qs
 | _,_    -> assert false
 
+exception Empty (* Empty pattern *)
+
 (****************************************)
-(* Utilities for retrieving constructor *)
-(* and record label names               *)
+(* Utilities for retrieving type paths  *)
 (****************************************)
 
-exception Empty (* Empty pattern *)
-
 (* May need a clean copy, cf. PR#4745 *)
 let clean_copy ty =
   if ty.level = Btype.generic_level then ty
@@ -128,33 +127,6 @@ let get_type_path ty tenv =
   | Tconstr (path,_,_) -> path
   | _ -> fatal_error "Parmatch.get_type_path"
 
-let get_type_descr ty tenv =
-  match (Ctype.repr ty).desc with
-  | Tconstr (path,_,_) -> Env.find_type path tenv
-  | _ -> fatal_error "Parmatch.get_type_descr"
-
-let rec get_constr tag ty tenv =
-  match get_type_descr ty tenv with
-  | {type_kind=Type_variant constr_list} ->
-      Datarepr.find_constr_by_tag tag constr_list
-  | {type_manifest = Some _} ->
-      get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv
-  | _ -> fatal_error "Parmatch.get_constr"
-
-let find_label lbl lbls =
-  try
-    let l = List.nth lbls lbl.lbl_pos in
-    l.Types.ld_id
-  with Failure "nth" -> Ident.create "*Unknown label*"
-
-let rec get_record_labels ty tenv =
-  match get_type_descr ty tenv with
-  | {type_kind = Type_record(lbls, rep)} -> lbls
-  | {type_manifest = Some _} ->
-      get_record_labels (Ctype.expand_head_once tenv (clean_copy ty)) tenv
-  | _ -> fatal_error "Parmatch.get_record_labels"
-
-
 (*************************************)
 (* Values as patterns pretty printer *)
 (*************************************)
@@ -162,16 +134,8 @@ let rec get_record_labels ty tenv =
 open Format
 ;;
 
-let get_constr_name tag ty tenv  = match tag with
-| Cstr_exception (path, _) -> Path.name path
-| _ ->
-  try
-    let cd = get_constr tag ty tenv in Ident.name cd.cd_id
-  with
-  | Datarepr.Constr_not_found -> "*Unknown constructor*"
-
-let is_cons tag v  = match get_constr_name tag v.pat_type v.pat_env with
-| "::" -> true
+let is_cons = function
+| {cstr_name = "::"} -> true
 | _ -> false
 
 let pretty_const c = match c with
@@ -201,14 +165,12 @@ let rec pretty_val ppf v =
   | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
-  | Tpat_construct (_, {cstr_tag=tag},[]) ->
-      let name = get_constr_name tag v.pat_type v.pat_env in
-      fprintf ppf "%s" name
-  | Tpat_construct (_, {cstr_tag=tag},[w]) ->
-      let name = get_constr_name tag v.pat_type v.pat_env in
-      fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w
-  | Tpat_construct (_, {cstr_tag=tag},vs) ->
-      let name = get_constr_name tag v.pat_type v.pat_env in
+  | Tpat_construct (_, cstr, []) ->
+      fprintf ppf "%s" cstr.cstr_name
+  | Tpat_construct (_, cstr, [w]) ->
+      fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
+  | Tpat_construct (_, cstr, vs) ->
+      let name = cstr.cstr_name in
       begin match (name, vs) with
         ("::", [v1;v2]) ->
           fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
@@ -221,7 +183,7 @@ let rec pretty_val ppf v =
       fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
   | Tpat_record (lvs,_) ->
       fprintf ppf "@[{%a}@]"
-        (pretty_lvals (get_record_labels v.pat_type v.pat_env))
+        pretty_lvals
         (List.filter
            (function
              | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
@@ -236,14 +198,14 @@ let rec pretty_val ppf v =
       fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
 
 and pretty_car ppf v = match v.pat_desc with
-| Tpat_construct (_,{cstr_tag=tag}, [_ ; _])
-    when is_cons tag v ->
+| Tpat_construct (_,cstr, [_ ; _])
+    when is_cons cstr ->
       fprintf ppf "(%a)" pretty_val v
 | _ -> pretty_val ppf v
 
 and pretty_cdr ppf v = match v.pat_desc with
-| Tpat_construct (_,{cstr_tag=tag}, [v1 ; v2])
-    when is_cons tag v ->
+| Tpat_construct (_,cstr, [v1 ; v2])
+    when is_cons cstr ->
       fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
 | _ -> pretty_val ppf v
 
@@ -262,15 +224,13 @@ and pretty_vals sep ppf = function
   | v::vs ->
       fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
 
-and pretty_lvals lbls ppf = function
+and pretty_lvals ppf = function
   | [] -> ()
   | [_,lbl,v] ->
-      let name = find_label lbl lbls in
-      fprintf ppf "%s=%a" (Ident.name name) pretty_val v
+      fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
   | (_, lbl,v)::rest ->
-      let name = find_label lbl lbls in
       fprintf ppf "%s=%a;@ %a"
-        (Ident.name name) pretty_val v (pretty_lvals lbls) rest
+        lbl.lbl_name pretty_val v pretty_lvals rest
 
 let top_pretty ppf v =
   fprintf ppf "@[%a@]@?" pretty_val v
@@ -768,19 +728,18 @@ let rec pat_of_constrs ex_pat = function
         (pat_of_constr ex_pat cstr,
          pat_of_constrs ex_pat rem, None)}
 
-exception Not_an_adt
-
-let rec adt_path env ty =
-  match get_type_descr ty env with
-  | {type_kind=Type_variant constr_list} ->
-      begin match (Ctype.repr ty).desc with
-      | Tconstr (path,_,_) ->
-          path
-      | _ -> assert false end
-  | {type_manifest = Some _} ->
-      adt_path env (Ctype.expand_head_once env (clean_copy ty))
-  | _ -> raise Not_an_adt
-;;
+let rec get_variant_constructors env ty =
+  match (Ctype.repr ty).desc with
+  | Tconstr (path,_,_) -> begin
+      match Env.find_type path env with
+      | {type_kind=Type_variant _} ->
+          fst (Env.find_type_descrs path env)
+      | {type_manifest = Some _} ->
+          get_variant_constructors env
+            (Ctype.expand_head_once env (clean_copy ty))
+      | _ -> fatal_error "Parmatch.get_variant_constructors"
+    end
+  | _ -> fatal_error "Parmatch.get_variant_constructors"
 
 let rec map_filter f  =
   function
@@ -794,18 +753,12 @@ let rec map_filter f  =
 let complete_constrs p all_tags =
   match p.pat_desc with
   | Tpat_construct (_,c,_) ->
-      begin try
-        let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
-        let (constrs, _) =
-          Env.find_type_descrs (adt_path p.pat_env p.pat_type) p.pat_env in
+      let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
+      let constrs = get_variant_constructors p.pat_env c.cstr_res in
         map_filter
           (fun cnstr ->
             if List.mem cnstr.cstr_tag not_tags then Some cnstr else None)
           constrs
-      with
-      | Datarepr.Constr_not_found ->
-          fatal_error "Parmatch.complete_constr: constr_not_found"
-      end
   | _ -> fatal_error "Parmatch.complete_constr"
 
 
@@ -1990,7 +1943,7 @@ let check_unused tdefs casel =
                         p.pat_loc Warnings.Unused_pat)
                     ps
               | Used -> ()
-            with Empty | Not_an_adt | Not_found | NoGuard -> assert false
+            with Empty | Not_found | NoGuard -> assert false
             end ;
 
           if c_guard <> None then
diff --git a/typing/typecore.ml b/typing/typecore.ml
index e8cd8cddd..a9849886b 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -864,13 +864,6 @@ let check_recordpat_labels loc lbl_pat_list closed =
 
 (* Constructors *)
 
-let lookup_constructor_from_type env tpath lid =
-  let (constructors, _) = Env.find_type_descrs tpath env in
-    match lid with
-      Longident.Lident s ->
-        List.find (fun cstr -> cstr.cstr_name = s) constructors
-    | _ -> raise Not_found
-
 module Constructor = NameChoice (struct
   type t = constructor_description
   let type_kind = "variant"