Browse files

merge Leo's patch for PR#6384

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14702 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
1 parent 6cb386e commit 48f52f450c37ca4593d787b5bc9107b73d6461a3 Jacques Garrigue committed Apr 29, 2014
View
1 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}
View
10 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
^^^^^^^^^^^^^^^^^^^^^^^^^^^
View
10 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
^^^^^^^^^^^^^^^^^^^^^^^^^^^
View
115 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,50 +127,15 @@ 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 *)
(*************************************)
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
View
7 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"

0 comments on commit 48f52f4

Please sign in to comment.