Merge pull request #2127 from lpw25/lookup-errors

Refactor lookup functions

Author: trefis

boot/ocamlc

@@ -75,24 +75,27 @@ let value_path event env path =
       fatal_error ("Cannot find address for: " ^ (Path.name path))
 
 let rec expression event env = function
-    E_ident lid ->
-      begin try
-        let (p, valdesc) = Env.lookup_value lid env in
-        (begin match valdesc.val_kind with
-           Val_ivar (_, cl_num) ->
-             let (p0, _) =
-               Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
-             in
-             let v = value_path event env p0 in
-             let i = value_path event env p in
-             Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
-         | _ ->
-             value_path event env p
-         end,
-         Ctype.correct_levels valdesc.val_type)
-      with Not_found ->
-        raise(Error(Unbound_long_identifier lid))
-      end
+  | E_ident lid -> begin
+      match Env.find_value_by_name lid env with
+      | (p, valdesc) ->
+          let v =
+            match valdesc.val_kind with
+            | Val_ivar (_, cl_num) ->
+                let (p0, _) =
+                  Env.find_value_by_name
+                    (Longident.Lident ("self-" ^ cl_num)) env
+                in
+                let v = value_path event env p0 in
+                let i = value_path event env p in
+                Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
+            | _ ->
+                value_path event env p
+          in
+          let typ = Ctype.correct_levels valdesc.val_type in
+          v, typ
+      | exception Not_found ->
+          raise(Error(Unbound_long_identifier lid))
+    end
   | E_result ->
       begin match event with
         Some {ev_ev = {ev_kind = Event_after ty; ev_typsubst = subst}}

boot/ocamllex

@@ -99,10 +99,14 @@ let init () =
 
 let match_printer_type desc typename =
   let printer_type =
-    try
-      Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty
-    with Not_found ->
-      raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in
+    match
+      Env.find_type_by_name
+        (Ldot(Lident "Topdirs", typename)) Env.empty
+    with
+    | path, _ -> path
+    | exception Not_found ->
+        raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename))))
+  in
   Ctype.begin_def();
   let ty_arg = Ctype.newvar() in
   Ctype.unify Env.empty
@@ -113,17 +117,18 @@ let match_printer_type desc typename =
   ty_arg
 
 let find_printer_type lid =
-  try
-    let (path, desc) = Env.lookup_value lid Env.empty in
-    let (ty_arg, is_old_style) =
-      try
-        (match_printer_type desc "printer_type_new", false)
-      with Ctype.Unify _ ->
-        (match_printer_type desc "printer_type_old", true) in
-    (ty_arg, path, is_old_style)
-  with
-  | Not_found -> raise(Error(Unbound_identifier lid))
-  | Ctype.Unify _ -> raise(Error(Wrong_type lid))
+  match Env.find_value_by_name lid Env.empty with
+  | (path, desc) -> begin
+      match match_printer_type desc "printer_type_new" with
+      | ty_arg -> (ty_arg, path, false)
+      | exception Ctype.Unify _ -> begin
+          match match_printer_type desc "printer_type_old" with
+          | ty_arg -> (ty_arg, path, true)
+          | exception Ctype.Unify _ -> raise(Error(Wrong_type lid))
+        end
+    end
+  | exception Not_found ->
+      raise(Error(Unbound_identifier lid))
 
 let install_printer ppf lid =
   let (ty_arg, path, is_old_style) = find_printer_type lid in

debugger/eval.ml

@@ -656,7 +656,7 @@ let transl_prim mod_name name =
   let pers = Ident.create_persistent mod_name in
   let env = Env.add_persistent_structure pers Env.empty in
   let lid = Longident.Ldot (Longident.Lident mod_name, name) in
-  match Env.lookup_value lid env with
+  match Env.find_value_by_name lid env with
   | path, _ -> transl_value_path Location.none env path
   | exception Not_found ->
       fatal_error ("Primitive " ^ name ^ " not found.")

debugger/loadprinter.ml

@@ -1766,7 +1766,7 @@ let get_mod_field modname field =
      | exception Not_found ->
          fatal_error ("Module " ^ modname ^ " unavailable.")
      | env -> (
-         match Env.lookup_value (Longident.Lident field) env with
+         match Env.find_value_by_name (Longident.Lident field) env with
          | exception Not_found ->
              fatal_error ("Primitive " ^ modname ^ "." ^ field ^ " not found.")
          | path, _ -> transl_value_path Location.none env path

lambda/lambda.ml

@@ -16,10 +16,10 @@ let last_is_anys = function
 [%%expect{|
 (let
   (last_is_anys/10 =
-     (function param/11 : int
+     (function param/12 : int
        (catch
-         (if (field 0 param/11) (if (field 1 param/11) (exit 1) 1)
-           (if (field 1 param/11) (exit 1) 2))
+         (if (field 0 param/12) (if (field 1 param/12) (exit 1) 1)
+           (if (field 1 param/12) (exit 1) 2))
         with (1) 3)))
   (apply (field 1 (global Toploop!)) "last_is_anys" last_is_anys/10))
 val last_is_anys : bool * bool -> int = <fun>
@@ -32,13 +32,13 @@ let last_is_vars = function
 ;;
 [%%expect{|
 (let
-  (last_is_vars/16 =
-     (function param/19 : int
+  (last_is_vars/17 =
+     (function param/21 : int
        (catch
-         (if (field 0 param/19) (if (field 1 param/19) (exit 3) 1)
-           (if (field 1 param/19) (exit 3) 2))
+         (if (field 0 param/21) (if (field 1 param/21) (exit 3) 1)
+           (if (field 1 param/21) (exit 3) 2))
         with (3) 3)))
-  (apply (field 1 (global Toploop!)) "last_is_vars" last_is_vars/16))
+  (apply (field 1 (global Toploop!)) "last_is_vars" last_is_vars/17))
 val last_is_vars : bool * bool -> int = <fun>
 |}]
 
@@ -52,12 +52,12 @@ type t += A | B of unit | C of bool * int;;
 0a
 type t = ..
 (let
-  (A/23 = (makeblock 248 "A" (caml_fresh_oo_id 0))
-   B/24 = (makeblock 248 "B" (caml_fresh_oo_id 0))
-   C/25 = (makeblock 248 "C" (caml_fresh_oo_id 0)))
-  (seq (apply (field 1 (global Toploop!)) "A/23" A/23)
-    (apply (field 1 (global Toploop!)) "B/24" B/24)
-    (apply (field 1 (global Toploop!)) "C/25" C/25)))
+  (A/25 = (makeblock 248 "A" (caml_fresh_oo_id 0))
+   B/26 = (makeblock 248 "B" (caml_fresh_oo_id 0))
+   C/27 = (makeblock 248 "C" (caml_fresh_oo_id 0)))
+  (seq (apply (field 1 (global Toploop!)) "A/25" A/25)
+    (apply (field 1 (global Toploop!)) "B/26" B/26)
+    (apply (field 1 (global Toploop!)) "C/27" C/27)))
 type t += A | B of unit | C of bool * int
 |}]
 
@@ -71,20 +71,20 @@ let f = function
 ;;
 [%%expect{|
 (let
-  (C/25 = (apply (field 0 (global Toploop!)) "C/25")
-   B/24 = (apply (field 0 (global Toploop!)) "B/24")
-   A/23 = (apply (field 0 (global Toploop!)) "A/23")
-   f/26 =
-     (function param/27 : int
-       (let (*match*/28 =a (field 0 param/27))
+  (C/27 = (apply (field 0 (global Toploop!)) "C/27")
+   B/26 = (apply (field 0 (global Toploop!)) "B/26")
+   A/25 = (apply (field 0 (global Toploop!)) "A/25")
+   f/28 =
+     (function param/30 : int
+       (let (*match*/31 =a (field 0 param/30))
          (catch
-           (if (== *match*/28 A/23) (if (field 1 param/27) 1 (exit 8))
+           (if (== *match*/31 A/25) (if (field 1 param/30) 1 (exit 8))
              (exit 8))
           with (8)
-           (if (field 1 param/27)
-             (if (== (field 0 *match*/28) B/24) 2
-               (if (== (field 0 *match*/28) C/25) 3 4))
-             (if (field 2 param/27) 12 11))))))
-  (apply (field 1 (global Toploop!)) "f" f/26))
+           (if (field 1 param/30)
+             (if (== (field 0 *match*/31) B/26) 2
+               (if (== (field 0 *match*/31) C/27) 3 4))
+             (if (field 2 param/30) 12 11))))))
+  (apply (field 1 (global Toploop!)) "f" f/28))
 val f : t * bool * bool -> int = <fun>
 |}]

lambda/matching.ml

@@ -100,9 +100,9 @@ include struct open struct type t = T end let x = T end
 Line 1, characters 15-41:
 1 | include struct open struct type t = T end let x = T end
                    ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The type t/143 introduced by this open appears in the signature
+Error: The type t/150 introduced by this open appears in the signature
        Line 1, characters 46-47:
-         The value x has no valid type if t/143 is hidden
+         The value x has no valid type if t/150 is hidden
 |}];;
 
 module A = struct
@@ -120,9 +120,9 @@ Lines 3-6, characters 4-7:
 4 |       type t = T
 5 |       let x = T
 6 |     end
-Error: The type t/149 introduced by this open appears in the signature
+Error: The type t/156 introduced by this open appears in the signature
        Line 7, characters 8-9:
-         The value y has no valid type if t/149 is hidden
+         The value y has no valid type if t/156 is hidden
 |}];;
 
 module A = struct
@@ -139,9 +139,9 @@ Lines 3-5, characters 4-7:
 3 | ....open struct
 4 |       type t = T
 5 |     end
-Error: The type t/155 introduced by this open appears in the signature
+Error: The type t/162 introduced by this open appears in the signature
        Line 6, characters 8-9:
-         The value y has no valid type if t/155 is hidden
+         The value y has no valid type if t/162 is hidden
 |}]
 
 (* It was decided to not allow this anymore. *)

testsuite/tests/basic/patmatch_split_no_or.ml

@@ -48,21 +48,21 @@ type t =
 #warnings "@3";;
 let x =
 Foo ();;
-(* "Foo ()": the whole construct, with arguments, is deprecated *)
+
 [%%expect{|
 type t = Foo of unit | Bar
-Line 6, characters 0-6:
+Line 6, characters 0-3:
 6 | Foo ();;
-    ^^^^^^
+    ^^^
 Error (alert deprecated): Foo
 |}];;
 function
 Foo _ -> () | Bar -> ();;
-(* "Foo _", the whole construct is deprecated *)
+
 [%%expect{|
-Line 2, characters 0-5:
+Line 2, characters 0-3:
 2 | Foo _ -> () | Bar -> ();;
-    ^^^^^
+    ^^^
 Error (alert deprecated): Foo
 |}];;
 

testsuite/tests/generalized-open/gpr1506.ml

@@ -91,17 +91,6 @@ Error: This expression has type 'a * 'b
 |}]
 
 
-(** Masked instance variable *)
-let c = object val x= 0 val y = x end
-[%%expect{|
-Line 1, characters 32-33:
-1 | let c = object val x= 0 val y = x end
-                                    ^
-Error: The instance variable x
-       cannot be accessed from the definition of another instance variable
-|}]
-
-
 (** No value clause *)
 
 let f x = match x with exception Not_found -> ();;