From c19e8b23506e38fc47c110138d50b57fe93f7d7e Mon Sep 17 00:00:00 2001 From: Leo White Date: Fri, 12 Oct 2018 10:20:21 +0100 Subject: [PATCH] Refactor environment lookup functions --- debugger/eval.ml | 39 +- debugger/loadprinter.ml | 35 +- lambda/lambda.ml | 2 +- lambda/matching.ml | 2 +- testsuite/tests/basic/patmatch_split_no_or.ml | 52 +- testsuite/tests/generalized-open/gpr1506.ml | 12 +- testsuite/tests/messages/precise_locations.ml | 12 +- testsuite/tests/typing-objects/Tests.ml | 10 +- .../tests/typing-warnings/open_warnings.ml | 24 +- .../tests/typing-warnings/unused_types.ml | 34 +- toplevel/genprintval.ml | 21 +- toplevel/opttopdirs.ml | 42 +- toplevel/topdirs.ml | 158 +- typing/ctype.ml | 46 +- typing/ctype.mli | 1 - typing/env.ml | 2212 +++++++++++------ typing/env.mli | 224 +- typing/envaux.ml | 6 + typing/includecore.ml | 21 +- typing/includemod.ml | 19 +- typing/predef.mli | 8 + typing/printtyp.ml | 45 +- typing/typeclass.ml | 37 +- typing/typecore.ml | 338 ++- typing/typecore.mli | 7 +- typing/typedecl.ml | 31 +- typing/typemod.ml | 64 +- typing/types.ml | 5 - typing/types.mli | 5 - typing/typetexp.ml | 277 +-- typing/typetexp.mli | 52 +- typing/untypeast.ml | 7 +- utils/misc.ml | 12 +- utils/misc.mli | 10 +- 34 files changed, 2133 insertions(+), 1737 deletions(-) diff --git a/debugger/eval.ml b/debugger/eval.ml index d3dbf2a30..92acfc3ff 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -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}} diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index f664a2783..3cb66a09b 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -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 diff --git a/lambda/lambda.ml b/lambda/lambda.ml index da78d66b1..a68385484 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.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.") diff --git a/lambda/matching.ml b/lambda/matching.ml index 538a9431c..68f180077 100644 --- a/lambda/matching.ml +++ b/lambda/matching.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 diff --git a/testsuite/tests/basic/patmatch_split_no_or.ml b/testsuite/tests/basic/patmatch_split_no_or.ml index 8e0290685..4f494656e 100644 --- a/testsuite/tests/basic/patmatch_split_no_or.ml +++ b/testsuite/tests/basic/patmatch_split_no_or.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 = @@ -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 = |}] @@ -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 = |}] diff --git a/testsuite/tests/generalized-open/gpr1506.ml b/testsuite/tests/generalized-open/gpr1506.ml index a6747abd0..8d2800ea4 100644 --- a/testsuite/tests/generalized-open/gpr1506.ml +++ b/testsuite/tests/generalized-open/gpr1506.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. *) diff --git a/testsuite/tests/messages/precise_locations.ml b/testsuite/tests/messages/precise_locations.ml index 3b5612a3b..a6bc225df 100644 --- a/testsuite/tests/messages/precise_locations.ml +++ b/testsuite/tests/messages/precise_locations.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 |}];; diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index 2b233d218..d63160cb7 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -931,8 +931,8 @@ class a = object (self) val x = self#m method m = 3 end;; Line 1, characters 32-36: 1 | class a = object (self) val x = self#m method m = 3 end;; ^^^^ -Error: The instance variable self - cannot be accessed from the definition of another instance variable +Error: The self variable self + cannot be accessed from the definition of an instance variable |}];; class a = object method m = 3 end @@ -942,8 +942,6 @@ class a : object method m : int end Line 2, characters 44-49: 2 | class b = object inherit a as super val x = super#m end;; ^^^^^ -Error: The instance variable super - cannot be accessed from the definition of another instance variable +Error: The ancestor variable super + cannot be accessed from the definition of an instance variable |}];; - - diff --git a/testsuite/tests/typing-warnings/open_warnings.ml b/testsuite/tests/typing-warnings/open_warnings.ml index d0778c4d0..7c5d7a83f 100644 --- a/testsuite/tests/typing-warnings/open_warnings.ml +++ b/testsuite/tests/typing-warnings/open_warnings.ml @@ -43,9 +43,9 @@ Line 2, characters 2-13: 2 | type t0 = A (* unused type and constructor *) ^^^^^^^^^^^ Warning 34: unused type t0. -Line 2, characters 2-13: +Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) - ^^^^^^^^^^^ + ^ Warning 37: unused constructor A. module T3 : sig end |}] @@ -61,9 +61,9 @@ Line 3, characters 20-30: 3 | module M = struct type t = A end (* unused type and constructor *) ^^^^^^^^^^ Warning 34: unused type t. -Line 3, characters 20-30: +Line 3, characters 29-30: 3 | module M = struct type t = A end (* unused type and constructor *) - ^^^^^^^^^^ + ^ Warning 37: unused constructor A. Line 4, characters 2-8: 4 | open M (* unused open; no shadowing (A below refers to the one in t0) *) @@ -87,9 +87,9 @@ Line 2, characters 2-13: 2 | type t0 = A (* unused type and constructor *) ^^^^^^^^^^^ Warning 34: unused type t0. -Line 2, characters 2-13: +Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) - ^^^^^^^^^^^ + ^ Warning 37: unused constructor A. module T5 : sig end |}] @@ -131,9 +131,9 @@ Line 2, characters 2-13: 2 | type t0 = A (* unused type and constructor *) ^^^^^^^^^^^ Warning 34: unused type t0. -Line 2, characters 2-13: +Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) - ^^^^^^^^^^^ + ^ Warning 37: unused constructor A. module T3_bis : sig end |}] @@ -149,9 +149,9 @@ Line 3, characters 20-30: 3 | module M = struct type t = A end (* unused type and constructor *) ^^^^^^^^^^ Warning 34: unused type t. -Line 3, characters 20-30: +Line 3, characters 29-30: 3 | module M = struct type t = A end (* unused type and constructor *) - ^^^^^^^^^^ + ^ Warning 37: unused constructor A. Line 4, characters 2-9: 4 | open! M (* unused open; no shadowing (A below refers to the one in t0) *) @@ -171,9 +171,9 @@ Line 2, characters 2-13: 2 | type t0 = A (* unused type and constructor *) ^^^^^^^^^^^ Warning 34: unused type t0. -Line 2, characters 2-13: +Line 2, characters 12-13: 2 | type t0 = A (* unused type and constructor *) - ^^^^^^^^^^^ + ^ Warning 37: unused constructor A. module T5_bis : sig end |}] diff --git a/testsuite/tests/typing-warnings/unused_types.ml b/testsuite/tests/typing-warnings/unused_types.ml index bbe46c217..e5d94ab1c 100644 --- a/testsuite/tests/typing-warnings/unused_types.ml +++ b/testsuite/tests/typing-warnings/unused_types.ml @@ -40,9 +40,9 @@ Line 3, characters 2-27: 3 | type unused = A of unused ^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 34: unused type unused. -Line 3, characters 2-27: +Line 3, characters 16-27: 3 | type unused = A of unused - ^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^ Warning 37: unused constructor A. module Unused_rec : sig end |}] @@ -66,9 +66,9 @@ end = struct end ;; [%%expect {| -Line 4, characters 2-12: +Line 4, characters 11-12: 4 | type t = T - ^^^^^^^^^^ + ^ Warning 37: unused constructor T. module Unused_constructor : sig type t end |}] @@ -83,9 +83,9 @@ end = struct end ;; [%%expect {| -Line 5, characters 2-12: +Line 5, characters 11-12: 5 | type t = T - ^^^^^^^^^^ + ^ Warning 37: constructor T is never used to build values. (However, this constructor appears in patterns.) module Unused_constructor_outside_patterns : @@ -99,9 +99,9 @@ end = struct end ;; [%%expect {| -Line 4, characters 2-12: +Line 4, characters 11-12: 4 | type t = T - ^^^^^^^^^^ + ^ Warning 37: constructor T is never used to build values. Its type is exported as a private type. module Unused_constructor_exported_private : sig type t = private T end @@ -117,11 +117,6 @@ end = struct end ;; [%%expect {| -Line 5, characters 2-20: -5 | type t = private T - ^^^^^^^^^^^^^^^^^^ -Warning 37: constructor T is never used to build values. -(However, this constructor appears in patterns.) module Used_private_constructor : sig type t val nothing : t -> unit end |}] @@ -132,9 +127,9 @@ end = struct end ;; [%%expect {| -Line 4, characters 2-20: +Line 4, characters 19-20: 4 | type t = private T - ^^^^^^^^^^^^^^^^^^ + ^ Warning 37: unused constructor T. module Unused_private_constructor : sig type t end |}] @@ -285,11 +280,6 @@ end = struct end ;; [%%expect {| -Line 6, characters 20-31: -6 | type t += private Private_ext - ^^^^^^^^^^^ -Warning 38: extension constructor Private_ext is never used to build values. -(However, this constructor appears in patterns.) module Used_private_extension : sig type t val nothing : t -> unit end |}] @@ -337,9 +327,9 @@ end = struct type t = A [@@warning "-34"] end;; [%%expect {| -Line 3, characters 2-30: +Line 3, characters 11-12: 3 | type t = A [@@warning "-34"] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^ Warning 37: unused constructor A. module Unused_type_disable_warning : sig end |}] diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index bda4fd9c9..b86503757 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -197,16 +197,16 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct it comes from. Attempt to omit the prefix if the type comes from a module that has been opened. *) - let tree_of_qualified lookup_fun env ty_path name = + let tree_of_qualified find env ty_path name = match ty_path with | Pident _ -> Oide_ident name | Pdot(p, _s) -> - if try - match (lookup_fun (Lident (Out_name.print name)) env).desc with - | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' - | _ -> false - with Not_found -> false + if + match (find (Lident (Out_name.print name)) env).desc with + | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' + | _ -> false + | exception Not_found -> false then Oide_ident name else Oide_dot (Printtyp.tree_of_path p, Out_name.print name) | Papply _ -> @@ -214,10 +214,13 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let tree_of_constr = tree_of_qualified - (fun lid env -> (Env.lookup_constructor lid env).cstr_res) + (fun lid env -> + (Env.find_constructor_by_name lid env).cstr_res) and tree_of_label = - tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res) + tree_of_qualified + (fun lid env -> + (Env.find_label_by_name lid env).lbl_res) (* An abstract type *) @@ -548,7 +551,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct try (* Attempt to recover the constructor description for the exn from its name *) - let cstr = Env.lookup_constructor lid env in + let cstr = Env.find_constructor_by_name lid env in let path = match cstr.cstr_tag with Cstr_extension(p, _) -> p diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml index 5dfe97d0d..967c236cf 100644 --- a/toplevel/opttopdirs.ml +++ b/toplevel/opttopdirs.ml @@ -125,11 +125,15 @@ type 'a printer_type_old = 'a -> unit let match_printer_type ppf desc typename = let printer_type = - try - Env.lookup_type (Ldot(Lident "Opttopdirs", typename)) !toplevel_env - with Not_found -> - fprintf ppf "Cannot find type Topdirs.%s.@." typename; - raise Exit in + match + Env.find_type_by_name + (Ldot(Lident "Opttopdirs", typename)) !toplevel_env + with + | (path, _) -> path + | exception Not_found -> + fprintf ppf "Cannot find type Topdirs.%s.@." typename; + raise Exit + in Ctype.begin_def(); let ty_arg = Ctype.newvar() in Ctype.unify !toplevel_env @@ -140,22 +144,22 @@ let match_printer_type ppf desc typename = ty_arg let find_printer_type ppf lid = - try - let (path, desc) = Env.lookup_value lid !toplevel_env in - let (ty_arg, is_old_style) = - try - (match_printer_type ppf desc "printer_type_new", false) - with Ctype.Unify _ -> - (match_printer_type ppf desc "printer_type_old", true) in - (ty_arg, path, is_old_style) - with - | Not_found -> + match Env.find_value_by_name lid !toplevel_env with + | (path, desc) -> begin + match match_printer_type ppf desc "printer_type_new" with + | ty_arg -> (ty_arg, path, false) + | exception Ctype.Unify _ -> begin + match match_printer_type ppf desc "printer_type_old" with + | ty_arg -> (ty_arg, path, true) + | exception Ctype.Unify _ -> + fprintf ppf "%a has a wrong type for a printing function.@." + Printtyp.longident lid; + raise Exit + end + end + | exception Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid; raise Exit - | Ctype.Unify _ -> - fprintf ppf "%a has a wrong type for a printing function.@." - Printtyp.longident lid; - raise Exit let dir_install_printer ppf lid = try diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 8469d84b6..f4526692b 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -280,11 +280,15 @@ type 'a printer_type_old = 'a -> unit let printer_type ppf typename = let printer_type = - try - Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env - with Not_found -> - fprintf ppf "Cannot find type Topdirs.%s.@." typename; - raise Exit in + match + Env.find_type_by_name + (Ldot(Lident "Topdirs", typename)) !toplevel_env + with + | path, _ -> path + | exception Not_found -> + fprintf ppf "Cannot find type Topdirs.%s.@." typename; + raise Exit + in printer_type let match_simple_printer_type desc printer_type = @@ -333,18 +337,18 @@ let match_printer_type ppf desc = false) let find_printer_type ppf lid = - try - let (path, desc) = Env.lookup_value lid !toplevel_env in - let (ty_arg, is_old_style) = match_printer_type ppf desc in - (ty_arg, path, is_old_style) - with - | Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid; - raise Exit - | Ctype.Unify _ -> + match Env.find_value_by_name lid !toplevel_env with + | (path, desc) -> begin + match match_printer_type ppf desc with + | (ty_arg, is_old_style) -> (ty_arg, path, is_old_style) + | exception Ctype.Unify _ -> fprintf ppf "%a has a wrong type for a printing function.@." Printtyp.longident lid; raise Exit + end + | exception Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + raise Exit let dir_install_printer ppf lid = try @@ -407,59 +411,60 @@ let tracing_function_ptr = (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) let dir_trace ppf lid = - try - let (path, desc) = Env.lookup_value lid !toplevel_env in - (* Check if this is a primitive *) - match desc.val_kind with - | Val_prim _ -> - fprintf ppf "%a is an external function and cannot be traced.@." - Printtyp.longident lid - | _ -> - let clos = eval_value_path !toplevel_env path in - (* Nothing to do if it's not a closure *) - if Obj.is_block clos - && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) - && (match Ctype.(repr (expand_head !toplevel_env desc.val_type)) - with {desc=Tarrow _} -> true | _ -> false) - then begin - match is_traced clos with - | Some opath -> - fprintf ppf "%a is already traced (under the name %a).@." - Printtyp.path path - Printtyp.path opath - | None -> - (* Instrument the old closure *) - traced_functions := - { path = path; - closure = clos; - actual_code = get_code_pointer clos; - instrumented_fun = - instrument_closure !toplevel_env lid ppf desc.val_type } - :: !traced_functions; - (* Redirect the code field of the closure to point - to the instrumentation function *) - set_code_pointer clos tracing_function_ptr; - fprintf ppf "%a is now traced.@." Printtyp.longident lid - end else fprintf ppf "%a is not a function.@." Printtyp.longident lid - with - | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid + match Env.find_value_by_name lid !toplevel_env with + | (path, desc) -> begin + (* Check if this is a primitive *) + match desc.val_kind with + | Val_prim _ -> + fprintf ppf "%a is an external function and cannot be traced.@." + Printtyp.longident lid + | _ -> + let clos = eval_value_path !toplevel_env path in + (* Nothing to do if it's not a closure *) + if Obj.is_block clos + && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) + && (match Ctype.(repr (expand_head !toplevel_env desc.val_type)) + with {desc=Tarrow _} -> true | _ -> false) + then begin + match is_traced clos with + | Some opath -> + fprintf ppf "%a is already traced (under the name %a).@." + Printtyp.path path + Printtyp.path opath + | None -> + (* Instrument the old closure *) + traced_functions := + { path = path; + closure = clos; + actual_code = get_code_pointer clos; + instrumented_fun = + instrument_closure !toplevel_env lid ppf desc.val_type } + :: !traced_functions; + (* Redirect the code field of the closure to point + to the instrumentation function *) + set_code_pointer clos tracing_function_ptr; + fprintf ppf "%a is now traced.@." Printtyp.longident lid + end else fprintf ppf "%a is not a function.@." Printtyp.longident lid + end + | exception Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid let dir_untrace ppf lid = - try - let (path, _desc) = Env.lookup_value lid !toplevel_env in - let rec remove = function - | [] -> - fprintf ppf "%a was not traced.@." Printtyp.longident lid; - [] - | f :: rem -> - if Path.same f.path path then begin - set_code_pointer f.closure f.actual_code; - fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; - rem - end else f :: remove rem in - traced_functions := remove !traced_functions - with - | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid + match Env.find_value_by_name lid !toplevel_env with + | (path, _desc) -> + let rec remove = function + | [] -> + fprintf ppf "%a was not traced.@." Printtyp.longident lid; + [] + | f :: rem -> + if Path.same f.path path then begin + set_code_pointer f.closure f.actual_code; + fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; + rem + end else f :: remove rem in + traced_functions := remove !traced_functions + | exception Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid let dir_untrace_all ppf () = List.iter @@ -531,7 +536,7 @@ let reg_show_prim name to_sig doc = let () = reg_show_prim "show_val" (fun env loc id lid -> - let _path, desc = Typetexp.find_value env loc lid in + let _path, desc = Env.lookup_value ~loc lid env in [ Sig_value (id, desc, Exported) ] ) "Print the signature of the corresponding value." @@ -539,7 +544,7 @@ let () = let () = reg_show_prim "show_type" (fun env loc id lid -> - let _path, desc = Typetexp.find_type env loc lid in + let _path, desc = Env.lookup_type ~loc lid env in [ Sig_type (id, desc, Trec_not, Exported) ] ) "Print the signature of the corresponding type constructor." @@ -547,7 +552,7 @@ let () = let () = reg_show_prim "show_exception" (fun env loc id lid -> - let desc = Typetexp.find_constructor env loc lid in + let desc = Env.lookup_constructor ~loc Env.Positive lid env in if not (Ctype.equal env true [desc.cstr_res] [Predef.type_exn]) then raise Not_found; let ret_type = @@ -570,26 +575,27 @@ let () = let () = reg_show_prim "show_module" (fun env loc id lid -> - let rec accum_aliases path acc = - let md = Env.find_module path env in + let rec accum_aliases md acc = let acc = Sig_module (id, Mp_present, {md with md_type = trim_signature md.md_type}, Trec_not, Exported) :: acc in match md.md_type with - | Mty_alias path -> accum_aliases path acc + | Mty_alias path -> + let md = Env.find_module path env in + accum_aliases md acc | Mty_ident _ | Mty_signature _ | Mty_functor _ -> List.rev acc in - let path, _ = Typetexp.find_module env loc lid in - accum_aliases path [] + let _, md = Env.lookup_module ~loc lid env in + accum_aliases md [] ) "Print the signature of the corresponding module." let () = reg_show_prim "show_module_type" (fun env loc id lid -> - let _path, desc = Typetexp.find_modtype env loc lid in + let _path, desc = Env.lookup_modtype ~loc lid env in [ Sig_modtype (id, desc, Exported) ] ) "Print the signature of the corresponding module type." @@ -597,7 +603,7 @@ let () = let () = reg_show_prim "show_class" (fun env loc id lid -> - let _path, desc = Typetexp.find_class env loc lid in + let _path, desc = Env.lookup_class ~loc lid env in [ Sig_class (id, desc, Trec_not, Exported) ] ) "Print the signature of the corresponding class." @@ -605,7 +611,7 @@ let () = let () = reg_show_prim "show_class_type" (fun env loc id lid -> - let _path, desc = Typetexp.find_class_type env loc lid in + let _path, desc = Env.lookup_cltype ~loc lid env in [ Sig_class_type (id, desc, Trec_not, Exported) ] ) "Print the signature of the corresponding class type." diff --git a/typing/ctype.ml b/typing/ctype.ml index 101c4caa7..e4d385db3 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2420,8 +2420,7 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = environment. However no operation which cares about levels/scopes is going to happen while this module exists. The only operations that happen are: - - Env.lookup_type - - Env.find_type + - Env.find_type_by_name - nondep_instance None of which check the scope. @@ -2435,23 +2434,22 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = | n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 -> nt2 :: complete (if n = n2 then nl else nl1) ntl' | n :: nl, _ -> - try - let path = - Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env' - in - match Env.find_type path env' with - {type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = Some t2} -> - (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 - | {type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = None} when allow_absent -> - complete nl ntl2 - | _ -> raise Exit - with - | Not_found when allow_absent -> complete nl ntl2 - | Exit -> raise Not_found + let lid = concat_longident (Longident.Lident "Pkg") n in + match Env.find_type_by_name lid env' with + | (_, {type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = Some t2}) -> + (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 + | (_, {type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = None}) + when allow_absent -> + complete nl ntl2 + | _ -> raise Exit + | exception Not_found when allow_absent-> + complete nl ntl2 in - complete nl1 (List.combine nl2 tl2) + match complete nl1 (List.combine nl2 tl2) with + | res -> res + | exception Exit -> raise Not_found (* raise Not_found rather than Unify if the module types are incompatible *) let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = @@ -3942,18 +3940,8 @@ let rec filter_visited = function let memq_warn t visited = if List.memq t visited then (warn := true; true) else false -let rec lid_of_path ?(hash="") = function - Path.Pident id -> - Longident.Lident (hash ^ Ident.name id) - | Path.Pdot (p1, s) -> - Longident.Ldot (lid_of_path p1, hash ^ s) - | Path.Papply (p1, p2) -> - Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2) - let find_cltype_for_path env p = - let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in - let cl_abbr = Env.find_type cl_path env in - + let cl_abbr = Env.find_hash_type p env in match cl_abbr.type_manifest with Some ty -> begin match (repr ty).desc with diff --git a/typing/ctype.mli b/typing/ctype.mli index 496ab019a..2403668d9 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -149,7 +149,6 @@ val set_object_name: val remove_object_name: type_expr -> unit val hide_private_methods: type_expr -> unit val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr -val lid_of_path: ?hash:string -> Path.t -> Longident.t val sort_row_fields: (label * row_field) list -> (label * row_field) list val merge_row_fields: diff --git a/typing/env.ml b/typing/env.ml index d8071085a..c9ac5c679 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -45,10 +45,16 @@ type constructor_usages = mutable cu_pattern: bool; mutable cu_privatize: bool; } -let add_constructor_usage cu = function - | Positive -> cu.cu_positive <- true - | Pattern -> cu.cu_pattern <- true - | Privatize -> cu.cu_privatize <- true +let add_constructor_usage priv cu usage = + match priv with + | Asttypes.Private -> cu.cu_positive <- true + | Asttypes.Public -> begin + match usage with + | Positive -> cu.cu_positive <- true + | Pattern -> cu.cu_pattern <- true + | Privatize -> cu.cu_privatize <- true + end + let constructor_usages () = {cu_positive = false; cu_pattern = false; cu_privatize = false} @@ -56,17 +62,18 @@ let used_constructors : (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t = Hashtbl.create 16 -type error = - | Missing_module of Location.t * Path.t * Path.t - | Illegal_value_name of Location.t * string - -exception Error of error - -let error err = raise (Error err) - (** Map indexed by the name of module components. *) module NameMap = String.Map +type value_unbound_reason = + | Val_unbound_instance_variable + | Val_unbound_self + | Val_unbound_ancestor + | Val_unbound_ghost_recursive of Location.t + +type module_unbound_reason = + | Mod_unbound_illegal_recursion + type summary = Env_empty | Env_value of summary * Ident.t * value_description @@ -81,6 +88,8 @@ type summary = | Env_constraints of summary * type_declaration Path.Map.t | Env_copy_types of summary | Env_persistent of summary * Ident.t + | Env_value_unbound of summary * string * value_unbound_reason + | Env_module_unbound of summary * string * module_unbound_reason type address = | Aident of Ident.t @@ -141,22 +150,23 @@ module TycompTbl = let nothing = fun () -> () - let mk_callback rest name desc = function + let mk_callback rest name desc using = + match using with | None -> nothing | Some f -> (fun () -> match rest with | [] -> f name None - | (hidden, _) :: _ -> f name (Some (desc, hidden)) - ) + | (hidden, _) :: _ -> f name (Some (desc, hidden))) - let rec find_all name tbl = + let rec find_all ~mark name tbl = List.map (fun (_id, desc) -> desc, nothing) (Ident.find_all name tbl.current) @ match tbl.opened with | None -> [] | Some {using; next; components} -> - let rest = find_all name next in + let rest = find_all ~mark name next in + let using = if mark then using else None in match NameMap.find name components with | exception Not_found -> rest | opened -> @@ -203,22 +213,22 @@ module IdTbl = bindings between each of them. *) - type 'a t = { + type ('a, 'b) t = { current: 'a Ident.tbl; (** Local bindings since the last open *) - layer: 'a layer; + layer: ('a, 'b) layer; (** Symbolic representation of the last (innermost) open, if any. *) } - and 'a layer = + and ('a, 'b) layer = | Open of { root: Path.t; (** The path of the opened module, to be prefixed in front of its local names to produce a valid path in the current environment. *) - components: 'a NameMap.t; + components: 'b NameMap.t; (** Components from the opened module. *) using: (string -> ('a * 'a) option -> unit) option; @@ -226,13 +236,13 @@ module IdTbl = "open". This is used to detect unused "opens". The arguments are used to detect shadowing. *) - next: 'a t; + next: ('a, 'b) t; (** The table before opening the module. *) } | Map of { f: ('a -> 'a); - next: 'a t; + next: ('a, 'b) t; } | Nothing @@ -271,7 +281,7 @@ module IdTbl = | Nothing -> raise exn end - let rec find_name ~mark name tbl = + let rec find_name wrap ~mark name tbl = try let (id, desc) = Ident.find_name name tbl.current in Pident id, desc @@ -279,28 +289,28 @@ module IdTbl = begin match tbl.layer with | Open {using; root; next; components} -> begin try - let descr = NameMap.find name components in + let descr = wrap (NameMap.find name components) in let res = Pdot (root, name), descr in if mark then begin match using with | None -> () | Some f -> begin - match find_name ~mark:false name next with + match find_name wrap ~mark:false name next with | exception Not_found -> f name None | _, descr' -> f name (Some (descr', descr)) end end; res with Not_found -> - find_name ~mark name next + find_name wrap ~mark name next end | Map {f; next} -> - let (p, desc) = find_name ~mark name next in + let (p, desc) = find_name wrap ~mark name next in p, f desc | Nothing -> raise exn end - let rec find_all name tbl = + let rec find_all wrap name tbl = List.map (fun (id, desc) -> Pident id, desc) (Ident.find_all name tbl.current) @ @@ -308,16 +318,16 @@ module IdTbl = | Nothing -> [] | Open {root; using = _; next; components} -> begin try - let desc = NameMap.find name components in - (Pdot (root, name), desc) :: find_all name next + let desc = wrap (NameMap.find name components) in + (Pdot (root, name), desc) :: find_all wrap name next with Not_found -> - find_all name next + find_all wrap name next end | Map {f; next} -> List.map (fun (p, desc) -> (p, f desc)) - (find_all name next) + (find_all wrap name next) - let rec fold_name f tbl acc = + let rec fold_name wrap f tbl acc = let acc = Ident.fold_name (fun id d -> f (Ident.name id) (Pident id, d)) @@ -327,14 +337,16 @@ module IdTbl = | Open {root; using = _; next; components} -> acc |> NameMap.fold - (fun name desc -> f name (Pdot (root, name), desc)) + (fun name desc -> f name (Pdot (root, name), wrap desc)) components - |> fold_name f next + |> fold_name wrap f next | Nothing -> acc | Map {f=g; next} -> acc - |> fold_name (fun name (path, desc) -> f name (path, g desc)) next + |> fold_name wrap + (fun name (path, desc) -> f name (path, g desc)) + next let rec local_keys tbl acc = let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in @@ -343,7 +355,7 @@ module IdTbl = | Nothing -> acc - let rec iter f tbl = + let rec iter wrap f tbl = Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; match tbl.layer with | Open {root; using = _; next; components} -> @@ -351,11 +363,11 @@ module IdTbl = (fun s x -> let root_scope = Path.scope root in f (Ident.create_scoped ~scope:root_scope s) - (Pdot (root, s), x)) + (Pdot (root, s), wrap x)) components; - iter f next + iter wrap f next | Map {f=g; next} -> - iter (fun id (path, desc) -> f id (path, g desc)) next + iter wrap (fun id (path, desc) -> f id (path, g desc)) next | Nothing -> () let diff_keys tbl1 tbl2 = @@ -374,20 +386,15 @@ type type_descriptions = let in_signature_flag = 0x01 -type 'a value_or_persistent = - | Value of 'a - | Persistent - type t = { - values: (value_description * address_lazy) IdTbl.t; - constrs: (constructor_description * address_lazy option) TycompTbl.t; - labels: label_description TycompTbl.t; - types: (type_declaration * type_descriptions) IdTbl.t; - modules: (module_declaration_lazy * address_lazy) value_or_persistent IdTbl.t; - modtypes: modtype_declaration IdTbl.t; - components: (module_components * address_lazy) value_or_persistent IdTbl.t; - classes: (class_declaration * address_lazy) IdTbl.t; - cltypes: class_type_declaration IdTbl.t; + values: (value_entry, value_data) IdTbl.t; + constrs: constructor_data TycompTbl.t; + labels: label_data TycompTbl.t; + types: (type_data, type_data) IdTbl.t; + modules: (module_entry, module_data) IdTbl.t; + modtypes: (modtype_data, modtype_data) IdTbl.t; + classes: (class_data, class_data) IdTbl.t; + cltypes: (cltype_data, cltype_data) IdTbl.t; functor_args: unit Ident.tbl; summary: summary; local_constraints: type_declaration Path.Map.t; @@ -401,7 +408,10 @@ and module_components = { alerts: alerts; loc: Location.t; - comps: (components_maker, module_components_repr option) EnvLazy.t; + comps: + (components_maker, + (module_components_repr, module_components_failure) result) + EnvLazy.t; } and components_maker = { @@ -417,17 +427,19 @@ and module_components_repr = Structure_comps of structure_components | Functor_comps of functor_components +and module_components_failure = + | No_components_abstract + | No_components_alias of Path.t + and structure_components = { - mutable comp_values: (value_description * address_lazy) NameMap.t; - mutable comp_constrs: - ((constructor_description * address_lazy option) list) NameMap.t; - mutable comp_labels: label_description list NameMap.t; - mutable comp_types: (type_declaration * type_descriptions) NameMap.t; - mutable comp_modules: (module_declaration_lazy * address_lazy) NameMap.t; - mutable comp_modtypes: modtype_declaration NameMap.t; - mutable comp_components: (module_components * address_lazy) NameMap.t; - mutable comp_classes: (class_declaration * address_lazy) NameMap.t; - mutable comp_cltypes: class_type_declaration NameMap.t; + mutable comp_values: value_data NameMap.t; + mutable comp_constrs: constructor_data list NameMap.t; + mutable comp_labels: label_data list NameMap.t; + mutable comp_types: type_data NameMap.t; + mutable comp_modules: module_data NameMap.t; + mutable comp_modtypes: modtype_data NameMap.t; + mutable comp_classes: class_data NameMap.t; + mutable comp_cltypes: cltype_data NameMap.t; } and functor_components = { @@ -444,6 +456,42 @@ and address_unforced = and address_lazy = (address_unforced, address) EnvLazy.t +and value_data = + { vda_description : value_description; + vda_address : address_lazy } + +and value_entry = + | Val_bound of value_data + | Val_unbound of value_unbound_reason + +and constructor_data = + { cda_description : constructor_description; + cda_address : address_lazy option; } + +and label_data = label_description + +and type_data = + { tda_declaration : type_declaration; + tda_descriptions : type_descriptions; } + +and module_data = + { mda_declaration : module_declaration_lazy; + mda_components : module_components; + mda_address : address_lazy; } + +and module_entry = + | Mod_local of module_data + | Mod_persistent + | Mod_unbound of module_unbound_reason + +and modtype_data = modtype_declaration + +and class_data = + { clda_declaration : class_declaration; + clda_address : address_lazy } + +and cltype_data = class_type_declaration + let empty_structure = Structure_comps { comp_values = NameMap.empty; @@ -451,9 +499,47 @@ let empty_structure = comp_labels = NameMap.empty; comp_types = NameMap.empty; comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; - comp_components = NameMap.empty; comp_classes = NameMap.empty; + comp_classes = NameMap.empty; comp_cltypes = NameMap.empty } +type unbound_value_hint = + | No_hint + | Missing_rec of Location.t + +type lookup_error = + | Unbound_value of Longident.t * unbound_value_hint + | Unbound_type of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t + | Unbound_instance_variable of string + | Not_an_instance_variable of string + | Masked_instance_variable of Longident.t + | Masked_self_variable of Longident.t + | Masked_ancestor_variable of Longident.t + | Structure_used_as_functor of Longident.t + | Abstract_used_as_functor of Longident.t + | Functor_used_as_structure of Longident.t + | Abstract_used_as_structure of Longident.t + | Generative_used_as_applicative of Longident.t + | Illegal_reference_to_recursive_module + | Cannot_scrape_alias of Longident.t * Path.t + +type error = + | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string + | Lookup_error of Location.t * t * lookup_error + +exception Error of error + +let error err = raise (Error err) + +let lookup_error loc env err = + error (Lookup_error(loc, env, err)) + let copy_local ~from env = { env with local_constraints = from.local_constraints; @@ -471,8 +557,10 @@ let check_well_formed_module = ref (fun _ -> assert false) type declarations to silence the shadowing warnings. *) let check_shadowing env = function - | `Constructor (Some ((c1, _), (c2, _))) - when not (!same_constr env c1.cstr_res c2.cstr_res) -> + | `Constructor (Some (cda1, cda2)) + when not (!same_constr env + cda1.cda_description.cstr_res + cda2.cda_description.cstr_res) -> Some "constructor" | `Label (Some (l1, l2)) when not (!same_constr env l1.lbl_res l2.lbl_res) -> @@ -495,8 +583,7 @@ let empty = { values = IdTbl.empty; constrs = TycompTbl.empty; labels = TycompTbl.empty; types = IdTbl.empty; modules = IdTbl.empty; modtypes = IdTbl.empty; - components = IdTbl.empty; classes = IdTbl.empty; - cltypes = IdTbl.empty; + classes = IdTbl.empty; cltypes = IdTbl.empty; summary = Env_empty; local_constraints = Path.Map.empty; flags = 0; functor_args = Ident.empty; @@ -511,12 +598,21 @@ let in_signature b env = let is_in_signature env = env.flags land in_signature_flag <> 0 +let has_local_constraints env = + not (Path.Map.is_empty env.local_constraints) + let is_ident = function Pident _ -> true | Pdot _ | Papply _ -> false -let is_local_ext = function - | {cstr_tag = Cstr_extension(p, _)}, _ -> is_ident p +let is_ext cda = + match cda.cda_description with + | {cstr_tag = Cstr_extension _} -> true + | _ -> false + +let is_local_ext cda = + match cda.cda_description with + | {cstr_tag = Cstr_extension(p, _)} -> is_ident p | _ -> false let diff env1 env2 = @@ -525,23 +621,27 @@ let diff env1 env2 = IdTbl.diff_keys env1.modules env2.modules @ IdTbl.diff_keys env1.classes env2.classes +(* Functions for use in "wrap" parameters in IdTbl *) +let wrap_identity x = x +let wrap_value vda = Val_bound vda +let wrap_module mda = Mod_local mda + (* Forward declarations *) -let components_of_module' = - ref ((fun ~alerts:_ ~loc:_ _env _fsub _psub _path _addr _mty -> assert false): - alerts:alerts -> loc:Location.t -> t -> - Subst.t option -> Subst.t -> Path.t -> address_lazy -> module_type -> - module_components) let components_of_module_maker' = ref ((fun _ -> assert false) : - components_maker -> module_components_repr option) + components_maker -> + (module_components_repr, module_components_failure) result) + let components_of_functor_appl' = - ref ((fun _f _env _p1 _p2 -> assert false) : - functor_components -> t -> Path.t -> Path.t -> module_components) -let check_modtype_inclusion = - (* to be filled with Includemod.check_modtype_inclusion *) - ref ((fun ~loc:_ _env _mty1 _path1 _mty2 -> assert false) : - loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) + ref ((fun ~loc:_ _f _env _p1 _p2 -> assert false) : + loc:Location.t -> functor_components -> t -> + Path.t -> Path.t -> module_components) +let check_functor_application = + (* to be filled by Includemod *) + ref ((fun ~errors:_ ~loc:_ _env _mty1 _path1 _mty2 _path2 -> assert false) : + errors:bool -> loc:Location.t -> t -> module_type -> + Path.t -> module_type -> Path.t -> unit) let strengthen = (* to be filled with Mtype.strengthen *) ref ((fun ~aliasable:_ _env _mty _path -> assert false) : @@ -584,54 +684,75 @@ let find_same_module id tbl = | x -> x | exception Not_found when Ident.persistent id && not (Current_unit_name.is_name_of id) -> - Persistent + Mod_persistent -(* signature of persistent compilation units *) -type persistent_module = { - pm_signature: signature Lazy.t; - pm_components: module_components; -} +let find_name_module ~mark name tbl = + match IdTbl.find_name wrap_module ~mark name tbl with + | x -> x + | exception Not_found when not (Current_unit_name.is name) -> + let path = Pident(Ident.create_persistent name) in + path, Mod_persistent let add_persistent_structure id env = if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure"; if not (Current_unit_name.is_name_of id) then { env with - modules = IdTbl.add id Persistent env.modules; - components = IdTbl.add id Persistent env.components; + modules = IdTbl.add id Mod_persistent env.modules; summary = Env_persistent (env.summary, id); } else env +let components_of_module ~alerts ~loc env fs ps path addr mty = + { + alerts; + loc; + comps = EnvLazy.create { + cm_env = env; + cm_freshening_subst = fs; + cm_prefixing_subst = ps; + cm_path = path; + cm_addr = addr; + cm_mty = mty + } + } + let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } = let name = cmi.cmi_name in let sign = cmi.cmi_sign in let flags = cmi.cmi_flags in let id = Ident.create_persistent name in let path = Pident id in - let addr = EnvLazy.create_forced (Aident id) in let alerts = List.fold_left (fun acc -> function Alerts s -> s | _ -> acc) Misc.Stdlib.String.Map.empty flags in let loc = Location.none in - let pm_signature = lazy (Subst.signature Make_local Subst.identity sign) in - let pm_components = + let md = md (Mty_signature sign) in + let mda_address = EnvLazy.create_forced (Aident id) in + let mda_declaration = + EnvLazy.create (Subst.identity, Subst.Make_local, md) + in + let mda_components = let freshening_subst = - if freshen then (Some Subst.identity) else None in - !components_of_module' ~alerts ~loc - empty freshening_subst Subst.identity path addr (Mty_signature sign) in + if freshen then (Some Subst.identity) else None + in + components_of_module ~alerts ~loc + empty freshening_subst Subst.identity + path mda_address (Mty_signature sign) + in { - pm_signature; - pm_components; + mda_declaration; + mda_components; + mda_address; } let read_sign_of_cmi = sign_of_cmi ~freshen:true let save_sign_of_cmi = sign_of_cmi ~freshen:false -let persistent_env : persistent_module Persistent_env.t = +let persistent_env : module_data Persistent_env.t = Persistent_env.empty () let without_cmis f x = @@ -677,7 +798,7 @@ let reset_cache_toplevel () = (* get_components *) -let get_components_opt c = +let get_components_res c = match Persistent_env.can_load_cmis persistent_env with | Persistent_env.Can_load_cmis -> EnvLazy.force !components_of_module_maker' c.comps @@ -685,78 +806,150 @@ let get_components_opt c = EnvLazy.force_logged log !components_of_module_maker' c.comps let get_components c = - match get_components_opt c with - | None -> empty_structure - | Some c -> c + match get_components_res c with + | Error _ -> empty_structure + | Ok c -> c + +(* Module type of functor application *) + +let modtype_of_functor_appl fcomp p1 p2 = + match fcomp.fcomp_res with + | Mty_alias _ as mty -> mty + | mty -> + try + Hashtbl.find fcomp.fcomp_subst_cache p2 + with Not_found -> + let scope = Path.scope (Papply(p1, p2)) in + let mty = + Subst.modtype (Rescope scope) + (Subst.add_module fcomp.fcomp_param p2 Subst.identity) + mty + in + Hashtbl.add fcomp.fcomp_subst_cache p2 mty; + mty (* Lookup by identifier *) -let rec find_module_descr path env = +let find_ident_module id env = + match find_same_module id env.modules with + | Mod_local data -> data + | Mod_unbound _ -> raise Not_found + | Mod_persistent -> find_pers_mod (Ident.name id) + +let rec find_module_components path env = match path with - Pident id -> - begin match find_same_module id env.components with - | Value x -> fst x - | Persistent -> (find_pers_mod (Ident.name id)).pm_components - end + | Pident id -> (find_ident_module id env).mda_components | Pdot(p, s) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - fst (NameMap.find s c.comp_components) - | Functor_comps _ -> - raise Not_found - end + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modules).mda_components | Papply(p1, p2) -> - begin match get_components (find_module_descr p1 env) with - Functor_comps f -> - !components_of_functor_appl' f env p1 p2 - | Structure_comps _ -> - raise Not_found - end + let fc = find_functor_components p1 env in + let loc = Location.(in_file !input_name) in + !components_of_functor_appl' ~loc fc env p1 p2 -let find proj1 proj2 path env = +and find_structure_components path env = + match get_components (find_module_components path env) with + | Structure_comps c -> c + | Functor_comps _ -> raise Not_found + +and find_functor_components path env = + match get_components (find_module_components path env) with + | Functor_comps f -> f + | Structure_comps _ -> raise Not_found + +let find_module ~alias path env = match path with - Pident id -> IdTbl.find_same id (proj1 env) + | Pident id -> + let data = find_ident_module id env in + EnvLazy.force subst_modtype_maker data.mda_declaration | Pdot(p, s) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> NameMap.find s (proj2 c) - | Functor_comps _ -> - raise Not_found - end - | Papply _ -> - raise Not_found + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + EnvLazy.force subst_modtype_maker data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) -let find_value_full = - find (fun env -> env.values) (fun sc -> sc.comp_values) -and find_type_full = - find (fun env -> env.types) (fun sc -> sc.comp_types) -and find_modtype = - find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) -and find_class_full = - find (fun env -> env.classes) (fun sc -> sc.comp_classes) -and find_cltype = - find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) +let find_value_full path env = + match path with + | Pident id -> begin + match IdTbl.find_same id env.values with + | Val_bound data -> data + | Val_unbound _ -> raise Not_found + end + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_values + | Papply _ -> raise Not_found -let find_value p env = - fst (find_value_full p env) -let find_class p env = - fst (find_class_full p env) +let find_type_full path env = + match path with + | Pident id -> IdTbl.find_same id env.types + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_types + | Papply _ -> raise Not_found + +let find_modtype path env = + match path with + | Pident id -> IdTbl.find_same id env.modtypes + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_modtypes + | Papply _ -> raise Not_found + +let find_class_full path env = + match path with + | Pident id -> IdTbl.find_same id env.classes + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_classes + | Papply _ -> raise Not_found + +let find_cltype path env = + match path with + | Pident id -> IdTbl.find_same id env.cltypes + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_cltypes + | Papply _ -> raise Not_found + +let find_value path env = + (find_value_full path env).vda_description + +let find_class path env = + (find_class_full path env).clda_declaration + +let find_ident_constructor id env = + (TycompTbl.find_same id env.constrs).cda_description + +let find_ident_label id env = + TycompTbl.find_same id env.labels let type_of_cstr path = function - | {cstr_inlined = Some d; _} -> - (d, ([], List.map snd (Datarepr.labels_of_type path d))) + | {cstr_inlined = Some decl; _} -> + let labels = + List.map snd (Datarepr.labels_of_type path decl) + in + { tda_declaration = decl; tda_descriptions = ([], labels) } | _ -> assert false let find_type_full path env = match Path.constructor_typath path with - | Regular p -> - (try (Path.Map.find p env.local_constraints, ([], [])) - with Not_found -> find_type_full p env) + | Regular p -> begin + match Path.Map.find p env.local_constraints with + | decl -> + { tda_declaration = decl; tda_descriptions = [], [] } + | exception Not_found -> find_type_full p env + end | Cstr (ty_path, s) -> - let (_, (cstrs, _)) = + let tda = try find_type_full ty_path env with Not_found -> assert false in + let (cstrs, _) = tda.tda_descriptions in let cstr = try List.find (fun cstr -> cstr.cstr_name = s) cstrs with Not_found -> assert false @@ -764,93 +957,35 @@ let find_type_full path env = type_of_cstr path cstr | LocalExt id -> let cstr = - try fst (TycompTbl.find_same id env.constrs) + try (TycompTbl.find_same id env.constrs).cda_description with Not_found -> assert false in type_of_cstr path cstr | Ext (mod_path, s) -> let comps = - try find_module_descr mod_path env + try find_structure_components mod_path env with Not_found -> assert false in - let comps = - match get_components comps with - | Structure_comps c -> c - | Functor_comps _ -> assert false - in - let exts = - List.filter - (function ({cstr_tag=Cstr_extension _}, _) -> true | _ -> false) - (try NameMap.find s comps.comp_constrs - with Not_found -> assert false) + let cstrs = + try NameMap.find s comps.comp_constrs + with Not_found -> assert false in + let exts = List.filter is_ext cstrs in match exts with - | [(cstr, _)] -> type_of_cstr path cstr + | [cda] -> type_of_cstr path cda.cda_description | _ -> assert false let find_type p env = - fst (find_type_full p env) + (find_type_full p env).tda_declaration let find_type_descrs p env = - snd (find_type_full p env) - -let find_module ~alias path env = - match path with - Pident id -> - begin - match find_same_module id env.modules with - | Value (data, _) -> EnvLazy.force subst_modtype_maker data - | Persistent -> - let pm = find_pers_mod (Ident.name id) in - md (Mty_signature(Lazy.force pm.pm_signature)) - end - | Pdot(p, s) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - let data, _ = NameMap.find s c.comp_modules in - EnvLazy.force subst_modtype_maker data - | Functor_comps _ -> - raise Not_found - end - | Papply(p1, p2) -> - let desc1 = find_module_descr p1 env in - begin match get_components desc1 with - Functor_comps f -> - let mty = - match f.fcomp_res with - | Mty_alias _ as mty -> mty - | mty -> - if alias then mty else - try - Hashtbl.find f.fcomp_subst_cache p2 - with Not_found -> - let mty = - Subst.modtype (Rescope (Path.scope path)) - (Subst.add_module f.fcomp_param p2 Subst.identity) - f.fcomp_res in - Hashtbl.add f.fcomp_subst_cache p2 mty; - mty - in - md mty - | Structure_comps _ -> - raise Not_found - end + (find_type_full p env).tda_descriptions let rec find_module_address path env = match path with - | Pident id -> - begin - match find_same_module id env.modules with - | Value (_, addr) -> get_address addr - | Persistent -> Aident id - end - | Pdot(p, s) -> begin - match get_components (find_module_descr p env) with - | Structure_comps c -> - let _, addr = NameMap.find s c.comp_modules in - get_address addr - | Functor_comps _ -> - raise Not_found - end + | Pident id -> get_address (find_ident_module id env).mda_address + | Pdot(p, s) -> + let c = find_structure_components p env in + get_address (NameMap.find s c.comp_modules).mda_address | Papply _ -> raise Not_found and force_address = function @@ -860,31 +995,46 @@ and force_address = function and get_address a = EnvLazy.force force_address a -let find_value_address p env = - get_address (snd (find_value_full p env)) +let find_value_address path env = + get_address (find_value_full path env).vda_address -let find_class_address p env = - get_address (snd (find_class_full p env)) +let find_class_address path env = + get_address (find_class_full path env).clda_address let rec get_constrs_address = function | [] -> raise Not_found - | (_, None) :: rest -> get_constrs_address rest - | (_, Some a) :: _ -> get_address a + | cda :: rest -> + match cda.cda_address with + | None -> get_constrs_address rest + | Some a -> get_address a let find_constructor_address path env = match path with | Pident id -> begin - match TycompTbl.find_same id env.constrs with - | _, None -> raise Not_found - | _, Some addr -> get_address addr - end - | Pdot(p, s) -> begin - match get_components (find_module_descr p env) with - | Structure_comps c -> - get_constrs_address (NameMap.find s c.comp_constrs) - | Functor_comps _ -> - raise Not_found + let cda = TycompTbl.find_same id env.constrs in + match cda.cda_address with + | None -> raise Not_found + | Some addr -> get_address addr end + | Pdot(p, s) -> + let c = find_structure_components p env in + get_constrs_address (NameMap.find s c.comp_constrs) + | Papply _ -> + raise Not_found + +let find_hash_type path env = + match path with + | Pident id -> + let name = "#" ^ Ident.name id in + let _, tda = + IdTbl.find_name wrap_identity ~mark:false name env.types + in + tda.tda_declaration + | Pdot(p, s) -> + let c = find_structure_components p env in + let name = "#" ^ s in + let tda = NameMap.find name c.comp_types in + tda.tda_declaration | Papply _ -> raise Not_found @@ -1015,216 +1165,7 @@ let rec is_functor_arg path env = | Pdot (p, _s) -> is_functor_arg p env | Papply _ -> true -(* Lookup by name *) - -exception Recmodule - -let report_alerts ?loc p alerts = - match loc with - | Some loc -> - Misc.Stdlib.String.Map.iter - (fun kind message -> - let message = if message = "" then "" else "\n" ^ message in - Location.alert ~kind loc - (Printf.sprintf "module %s%s" (Path.name p) message) - ) - alerts - | _ -> () - -let mark_module_used name loc = - try Hashtbl.find module_declarations (name, loc) () - with Not_found -> () - -let rec lookup_module_descr_aux ?loc ~mark lid env = - match lid with - Lident s -> - let find_components s = (find_pers_mod s).pm_components in - begin match IdTbl.find_name ~mark s env.components with - | exception Not_found when not (Current_unit_name.is s) -> - let p = Path.Pident (Ident.create_persistent s) in - (p, find_components s) - | (p, data) -> - (p, - match data with - | Value (comp, _) -> comp - | Persistent -> find_components s) - end - | Ldot(l, s) -> - let (p, descr) = lookup_module_descr ?loc ~mark l env in - begin match get_components descr with - Structure_comps c -> - let (descr, _addr) = NameMap.find s c.comp_components in - (Pdot(p, s), descr) - | Functor_comps _ -> - raise Not_found - end - | Lapply(l1, l2) -> - let (p1, desc1) = lookup_module_descr ?loc ~mark l1 env in - let p2 = lookup_module ~load:true ~mark ?loc l2 env in - let {md_type=mty2} = find_module p2 env in - begin match get_components desc1 with - Functor_comps f -> - let loc = match loc with Some l -> l | None -> Location.none in - (match f.fcomp_arg with - | None -> raise Not_found (* PR#7611 *) - | Some arg -> !check_modtype_inclusion ~loc env mty2 p2 arg); - (Papply(p1, p2), !components_of_functor_appl' f env p1 p2) - | Structure_comps _ -> - raise Not_found - end - -and lookup_module_descr ?loc ~mark lid env = - let (p, comps) as res = lookup_module_descr_aux ?loc ~mark lid env in - if mark then mark_module_used (Path.last p) comps.loc; -(* - Format.printf "USE module %s at %a@." (Path.last p) - Location.print comps.loc; -*) - report_alerts ?loc p comps.alerts; - res - -and lookup_module ~load ?loc ~mark lid env : Path.t = - match lid with - Lident s -> - begin match IdTbl.find_name ~mark s env.modules with - | exception Not_found - when not (Current_unit_name.is s) - && !Clflags.transparent_modules - && not load -> - check_pers_mod s - ~loc:(Option.value loc ~default:Location.none); - Path.Pident (Ident.create_persistent s) - | p, data -> - begin match data with - | Value (data, _) -> - let {md_loc; md_attributes; md_type} = - EnvLazy.force subst_modtype_maker data - in - if mark then mark_module_used s md_loc; - begin match md_type with - | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" -> - (* see #5965 *) - raise Recmodule - | _ -> () - end; - report_alerts ?loc p - (Builtin_attributes.alerts_of_attrs md_attributes) - | Persistent -> - if !Clflags.transparent_modules && not load then - check_pers_mod s - ~loc:(Option.value loc ~default:Location.none) - else begin - let pm = find_pers_mod s in - report_alerts ?loc p pm.pm_components.alerts - end - end; - p - end - | Ldot(l, s) -> - let (p, descr) = lookup_module_descr ?loc ~mark l env in - begin match get_components descr with - Structure_comps c -> - let (comps, _) = NameMap.find s c.comp_components in - if mark then mark_module_used s comps.loc; - let p = Pdot(p, s) in - report_alerts ?loc p comps.alerts; - p - | Functor_comps _ -> - raise Not_found - end - | Lapply(l1, l2) -> - let (p1, desc1) = lookup_module_descr ?loc ~mark l1 env in - let p2 = lookup_module ~load:true ?loc ~mark l2 env in - let {md_type=mty2} = find_module p2 env in - let p = Papply(p1, p2) in - begin match get_components desc1 with - Functor_comps f -> - let loc = match loc with Some l -> l | None -> Location.none in - (match f.fcomp_arg with - | None -> raise Not_found (* PR#7611 *) - | Some arg -> (!check_modtype_inclusion ~loc env mty2 p2) arg); - p - | Structure_comps _ -> - raise Not_found - end - -let lookup proj1 proj2 ?loc ~mark lid env = - match lid with - | Lident s -> IdTbl.find_name ~mark s (proj1 env) - | Ldot(l, s) -> - let path, desc = lookup_module_descr ?loc ~mark l env in - begin match get_components desc with - Structure_comps c -> - let data = NameMap.find s (proj2 c) in - (Pdot(path, s), data) - | Functor_comps _ -> - raise Not_found - end - | Lapply _ -> - raise Not_found - -let lookup_all_simple proj1 proj2 shadow ?loc ~mark lid env = - match lid with - Lident s -> - let xl = TycompTbl.find_all s (proj1 env) in - let rec do_shadow = - function - | [] -> [] - | ((x, f) :: xs) -> - (x, f) :: - (do_shadow (List.filter (fun (y, _) -> not (shadow x y)) xs)) - in - do_shadow xl - | Ldot(l, s) -> - let (_p, desc) = lookup_module_descr ?loc ~mark l env in - begin match get_components desc with - Structure_comps c -> - let comps = - try NameMap.find s (proj2 c) with Not_found -> [] - in - List.map - (fun data -> (data, (fun () -> ()))) - comps - | Functor_comps _ -> - raise Not_found - end - | Lapply _ -> - raise Not_found - -let has_local_constraints env = not (Path.Map.is_empty env.local_constraints) - -let cstr_shadow (cstr1, _) (cstr2, _) = - match cstr1.cstr_tag, cstr2.cstr_tag with - | Cstr_extension _, Cstr_extension _ -> true - | _ -> false - -let lbl_shadow _lbl1 _lbl2 = false - -let ignore_address (path, (desc, _addr)) = (path, desc) - -let lookup_value ?loc ~mark lid env = - ignore_address - (lookup (fun env -> env.values) (fun sc -> sc.comp_values) - ?loc ~mark lid env) -let lookup_all_constructors ?loc ~mark lid env = - lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) - cstr_shadow ?loc ~mark lid env -let lookup_all_labels ?loc ~mark lid env = - lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) - lbl_shadow ?loc ~mark lid env -let lookup_type ?loc ~mark lid env= - lookup (fun env -> env.types) (fun sc -> sc.comp_types) - ?loc ~mark lid env -let lookup_modtype ?loc ~mark lid env = - lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) - ?loc ~mark lid env -let lookup_class ?loc ~mark lid env = - ignore_address - (lookup (fun env -> env.classes) (fun sc -> sc.comp_classes) - ?loc ~mark lid env) -let lookup_cltype ?loc ~mark lid env = - lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) - ?loc ~mark lid env +(* Copying types associated with values *) let make_copy_of_types env0 = let memo = Hashtbl.create 16 in @@ -1236,8 +1177,12 @@ let make_copy_of_types env0 = Hashtbl.add memo t.id t2; t2 in - let f (desc, addr) = - {desc with val_type = copy desc.val_type}, addr + let f = function + | Val_unbound _ as entry -> entry + | Val_bound vda -> + let desc = vda.vda_description in + let desc = { desc with val_type = copy desc.val_type } in + Val_bound { vda with vda_description = desc } in let values = IdTbl.map f env0.values @@ -1247,151 +1192,6 @@ let make_copy_of_types env0 = {env with values; summary = Env_copy_types env.summary} ) -let mark_value_used name vd = - try Hashtbl.find value_declarations (name, vd.val_loc) () - with Not_found -> () - -let mark_type_used name vd = - try Hashtbl.find type_declarations (name, vd.type_loc) () - with Not_found -> () - -let mark_constructor_used usage name vd constr = - try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage - with Not_found -> () - -let mark_extension_used usage ext name = - let ty_name = Path.last ext.ext_type_path in - try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage - with Not_found -> () - -let set_value_used_callback name vd callback = - let key = (name, vd.val_loc) in - try - let old = Hashtbl.find value_declarations key in - Hashtbl.replace value_declarations key (fun () -> old (); callback ()) - (* this is to support cases like: - let x = let x = 1 in x in x - where the two declarations have the same location - (e.g. resulting from Camlp4 expansion of grammar entries) *) - with Not_found -> - Hashtbl.add value_declarations key callback - -let set_type_used_callback name td callback = - let loc = td.type_loc in - if loc.Location.loc_ghost then () - else let key = (name, loc) in - let old = - try Hashtbl.find type_declarations key - with Not_found -> ignore - in - Hashtbl.replace type_declarations key (fun () -> callback old) - -let lookup_value ?loc ?(mark = true) lid env = - let (_, desc) as r = lookup_value ?loc ~mark lid env in - if mark then mark_value_used (Longident.last lid) desc; - r - -let lookup_type ?loc ?(mark = true) lid env = - let (path, (decl, _)) = lookup_type ?loc ~mark lid env in - if mark then mark_type_used (Longident.last lid) decl; - path - -let mark_type_path env path = - try - let decl = find_type path env in - mark_type_used (Path.last path) decl - with Not_found -> () - -let ty_path t = - match repr t with - | {desc=Tconstr(path, _, _)} -> path - | _ -> assert false - -let lookup_constructor ?loc ?(mark = true) lid env = - match lookup_all_constructors ?loc ~mark lid env with - [] -> raise Not_found - | ((desc, _), use) :: _ -> - if mark then begin - mark_type_path env (ty_path desc.cstr_res); - use () - end; - desc - -let is_lident = function - Lident _ -> true - | _ -> false - -let lookup_all_constructors ?loc ?(mark = true) lid env = - try - let cstrs = lookup_all_constructors ?loc ~mark lid env in - let wrap_use desc use () = - if mark then begin - mark_type_path env (ty_path desc.cstr_res); - use () - end - in - List.map (fun ((cstr, _), use) -> (cstr, wrap_use cstr use)) cstrs - with - Not_found when is_lident lid -> [] - -let mark_constructor usage env name desc = - match desc.cstr_tag with - | Cstr_extension _ -> - begin - let ty_path = ty_path desc.cstr_res in - let ty_name = Path.last ty_path in - try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage - with Not_found -> () - end - | _ -> - let ty_path = ty_path desc.cstr_res in - let ty_decl = try find_type ty_path env with Not_found -> assert false in - let ty_name = Path.last ty_path in - mark_constructor_used usage ty_name ty_decl name - -let lookup_label ?loc ?(mark = true) lid env = - match lookup_all_labels ?loc ~mark lid env with - [] -> raise Not_found - | (desc, use) :: _ -> - if mark then begin - mark_type_path env (ty_path desc.lbl_res); - use () - end; - desc - -let lookup_all_labels ?loc ?(mark = true) lid env = - try - let lbls = lookup_all_labels ?loc ~mark lid env in - let wrap_use desc use () = - if mark then begin - mark_type_path env (ty_path desc.lbl_res); - use () - end - in - List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls - with - Not_found when is_lident lid -> [] - -let lookup_module ~load ?loc ?(mark = true) lid env = - lookup_module ~load ?loc ~mark lid env - -let lookup_modtype ?loc ?(mark = true) lid env = - lookup_modtype ?loc ~mark lid env - -let lookup_class ?loc ?(mark = true) lid env = - let (_, desc) as r = lookup_class ?loc ~mark lid env in - (* special support for Typeclass.unbound_class *) - if Path.name desc.cty_path = "" then ignore (lookup_type ?loc ~mark lid env) - else if mark then mark_type_path env desc.cty_path; - r - -let lookup_cltype ?loc ?(mark = true) lid env = - let (_, desc) as r = lookup_cltype ?loc ~mark lid env in - if Path.name desc.clty_path = "" then ignore (lookup_type ?loc lid env) - else mark_type_path env desc.clty_path; - mark_type_path env desc.clty_path; - r - (* Helper to handle optional substitutions. *) let may_subst subst_f sub x = @@ -1405,7 +1205,7 @@ let may_subst subst_f sub x = type iter_cont = unit -> unit let iter_env_cont = ref [] -let rec scrape_alias_for_visit env sub mty = +let rec scrape_alias_for_visit env (sub : Subst.t option) mty = match mty with | Mty_alias path -> begin match may_subst Subst.module_path sub path with @@ -1419,8 +1219,8 @@ let rec scrape_alias_for_visit env sub mty = end | _ -> true -let iter_env proj1 proj2 f env () = - IdTbl.iter (fun id x -> f (Pident id) x) (proj1 env); +let iter_env wrap proj1 proj2 f env () = + IdTbl.iter wrap (fun id x -> f (Pident id) x) (proj1 env); let rec iter_components path path' mcomps = let cont () = let visit = @@ -1436,22 +1236,26 @@ let iter_env proj1 proj2 f env () = (fun s d -> f (Pdot (path, s)) (Pdot (path', s), d)) (proj2 comps); NameMap.iter - (fun s (c, _) -> - iter_components (Pdot (path, s)) (Pdot (path', s)) c) - comps.comp_components + (fun s mda -> + iter_components + (Pdot (path, s)) (Pdot (path', s)) mda.mda_components) + comps.comp_modules | Functor_comps _ -> () in iter_env_cont := (path, cont) :: !iter_env_cont in - IdTbl.iter - (fun id (path, comps) -> - match comps with - | Value (comps, _) -> iter_components (Pident id) path comps - | Persistent -> + IdTbl.iter wrap_module + (fun id (path, entry) -> + match entry with + | Mod_unbound _ -> () + | Mod_local data -> + iter_components (Pident id) path data.mda_components + | Mod_persistent -> let modname = Ident.name id in match Persistent_env.find_in_cache persistent_env modname with | None -> () - | Some pm -> iter_components (Pident id) path pm.pm_components) - env.components + | Some data -> + iter_components (Pident id) path data.mda_components) + env.modules let run_iter_cont l = iter_env_cont := []; @@ -1460,55 +1264,59 @@ let run_iter_cont l = iter_env_cont := []; cont -let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f +let iter_types f = + iter_env wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types) + (fun p1 (p2, tda) -> f p1 (p2, tda.tda_declaration)) let same_types env1 env2 = - env1.types == env2.types && env1.components == env2.components + env1.types == env2.types && env1.modules == env2.modules let used_persistent () = Persistent_env.fold persistent_env (fun s _m r -> Concr.add s r) Concr.empty -let find_all_comps proj s (p,(mcomps, _)) = - match get_components mcomps with +let find_all_comps wrap proj s (p, mda) = + match get_components mda.mda_components with Functor_comps _ -> [] | Structure_comps comps -> try let c = NameMap.find s (proj comps) in - [Pdot(p,s), c] + [Pdot(p,s), wrap c] with Not_found -> [] let rec find_shadowed_comps path env = match path with - Pident id -> + | Pident id -> List.filter_map (fun (p, data) -> match data with - | Value x -> Some (p, x) - | Persistent -> None) - (IdTbl.find_all (Ident.name id) env.components) + | Mod_local x -> Some (p, x) + | Mod_unbound _ | Mod_persistent -> None) + (IdTbl.find_all wrap_module (Ident.name id) env.modules) | Pdot (p, s) -> let l = find_shadowed_comps p env in let l' = - List.map (find_all_comps (fun comps -> comps.comp_components) s) l + List.map + (find_all_comps wrap_identity + (fun comps -> comps.comp_modules) s) l in List.flatten l' | Papply _ -> [] -let find_shadowed proj1 proj2 path env = +let find_shadowed wrap proj1 proj2 path env = match path with Pident id -> - IdTbl.find_all (Ident.name id) (proj1 env) + IdTbl.find_all wrap (Ident.name id) (proj1 env) | Pdot (p, s) -> let l = find_shadowed_comps p env in - let l' = List.map (find_all_comps proj2 s) l in + let l' = List.map (find_all_comps wrap proj2 s) l in List.flatten l' | Papply _ -> [] let find_shadowed_types path env = List.map fst - (find_shadowed + (find_shadowed wrap_identity (fun env -> env.types) (fun comps -> comps.comp_types) path env) (* Expand manifest module type names at the top of the given module type *) @@ -1639,22 +1447,9 @@ let module_declaration_address env id presence md = | Mp_present -> EnvLazy.create_forced (Aident id) -let rec components_of_module ~alerts ~loc env fs ps path addr mty = - { - alerts; - loc; - comps = EnvLazy.create { - cm_env = env; - cm_freshening_subst = fs; - cm_prefixing_subst = ps; - cm_path = path; - cm_addr = addr; - cm_mty = mty - } - } - -and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; - cm_path; cm_addr; cm_mty} = +let rec components_of_module_maker + {cm_env; cm_freshening_subst; cm_prefixing_subst; + cm_path; cm_addr; cm_mty} : _ result = match scrape_alias cm_env cm_freshening_subst cm_mty with Mty_signature sg -> let c = @@ -1662,8 +1457,8 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; comp_constrs = NameMap.empty; comp_labels = NameMap.empty; comp_types = NameMap.empty; comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; - comp_components = NameMap.empty; comp_classes = NameMap.empty; - comp_cltypes = NameMap.empty } in + comp_classes = NameMap.empty; comp_cltypes = NameMap.empty } + in let items_and_paths, freshening_sub, prefixing_sub = prefix_idents cm_path cm_freshening_subst cm_prefixing_subst sg in @@ -1686,8 +1481,8 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; | Val_prim _ -> EnvLazy.create_failed Not_found | _ -> next_address () in - c.comp_values <- - NameMap.add (Ident.name id) (decl', addr) c.comp_values; + let vda = { vda_description = decl'; vda_address = addr } in + c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; | Sig_type(id, decl, _, _) -> let fresh_decl = may_subst Subst.type_declaration freshening_sub decl @@ -1699,14 +1494,16 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; List.map snd (Datarepr.constructors_of_type path final_decl) in let labels = List.map snd (Datarepr.labels_of_type path final_decl) in - c.comp_types <- - NameMap.add (Ident.name id) - (final_decl, (constructors, labels)) - c.comp_types; + let tda = + { tda_declaration = final_decl; + tda_descriptions = (constructors, labels); } + in + c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; List.iter (fun descr -> - c.comp_constrs <- - add_to_tbl descr.cstr_name (descr, None) c.comp_constrs) + let cda = { cda_description = descr; cda_address = None } in + c.comp_constrs <- + add_to_tbl descr.cstr_name cda c.comp_constrs) constructors; List.iter (fun descr -> @@ -1718,8 +1515,8 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; let ext' = Subst.extension_constructor sub ext in let descr = Datarepr.extension_descr path ext' in let addr = next_address () in - c.comp_constrs <- - add_to_tbl (Ident.name id) (descr, Some addr) c.comp_constrs + let cda = { cda_description = descr; cda_address = Some addr } in + c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs | Sig_module(id, pres, md, _, _) -> let md' = (* The prefixed items get the same scope as [cm_path], which is @@ -1737,8 +1534,6 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; end | Mp_present -> next_address () in - c.comp_modules <- - NameMap.add (Ident.name id) (md', addr) c.comp_modules; let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in @@ -1746,8 +1541,13 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; components_of_module ~alerts ~loc:md.md_loc !env freshening_sub prefixing_sub path addr md.md_type in - c.comp_components <- - NameMap.add (Ident.name id) (comps, addr) c.comp_components; + let mda = + { mda_declaration = md'; + mda_components = comps; + mda_address = addr } + in + c.comp_modules <- + NameMap.add (Ident.name id) mda c.comp_modules; env := store_module ~freshening_sub ~check:false id addr pres md !env | Sig_modtype(id, decl, _) -> @@ -1768,21 +1568,21 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; env := store_modtype id fresh_decl !env | Sig_class(id, decl, _, _) -> let decl' = Subst.class_declaration sub decl in - c.comp_classes <- - NameMap.add (Ident.name id) (decl', next_address ()) - c.comp_classes + let addr = next_address () in + let clda = { clda_declaration = decl'; clda_address = addr } in + c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes | Sig_class_type(id, decl, _, _) -> let decl' = Subst.cltype_declaration sub decl in c.comp_cltypes <- NameMap.add (Ident.name id) decl' c.comp_cltypes) items_and_paths; - Some (Structure_comps c) + Ok (Structure_comps c) | Mty_functor(param, ty_arg, ty_res) -> let sub = may_subst Subst.compose cm_freshening_subst cm_prefixing_subst in let scoping = Subst.Rescope (Path.scope cm_path) in - Some (Functor_comps { + Ok (Functor_comps { fcomp_param = param; (* fcomp_arg and fcomp_res must be prefixed eagerly, because they are interpreted in the outer environment *) @@ -1790,8 +1590,8 @@ and components_of_module_maker {cm_env; cm_freshening_subst; cm_prefixing_subst; fcomp_res = Subst.modtype scoping sub ty_res; fcomp_cache = Hashtbl.create 17; fcomp_subst_cache = Hashtbl.create 17 }) - | Mty_ident _ - | Mty_alias _ -> None + | Mty_ident _ -> Error No_components_abstract + | Mty_alias p -> Error (No_components_alias p) (* Insertion of bindings by identifier + path *) @@ -1812,19 +1612,18 @@ and check_value_name name loc = (* Note: we could also check here general validity of the identifier, to protect against bad identifiers forged by -pp or -ppx preprocessors. *) - if String.length name > 0 && (name.[0] = '#') then for i = 1 to String.length name - 1 do if name.[i] = '#' then error (Illegal_value_name(loc, name)) done - and store_value ?check id addr decl env = check_value_name (Ident.name id) decl.val_loc; Option.iter (fun f -> check_usage decl.val_loc id f value_declarations) check; + let vda = { vda_description = decl; vda_address = addr } in { env with - values = IdTbl.add id (decl, addr) env.values; + values = IdTbl.add id (Val_bound vda) env.values; summary = Env_value(env.summary, id, decl) } and store_type ~check id info env = @@ -1836,39 +1635,42 @@ and store_type ~check id info env = let constructors = Datarepr.constructors_of_type path info in let labels = Datarepr.labels_of_type path info in let descrs = (List.map snd constructors, List.map snd labels) in - + let tda = { tda_declaration = info; tda_descriptions = descrs } in if check && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_constructor ("", false, false)) then begin - let ty = Ident.name id in + let ty_name = Ident.name id in + let priv = info.type_private in List.iter - begin fun (_, {cstr_name = c; _}) -> - let k = (ty, loc, c) in + begin fun (_, cstr) -> + let name = cstr.cstr_name in + let loc = cstr.cstr_loc in + let k = (ty_name, loc, name) in if not (Hashtbl.mem used_constructors k) then let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); - if not (ty = "" || ty.[0] = '_') + Hashtbl.add used_constructors k (add_constructor_usage priv used); + if not (ty_name = "" || ty_name.[0] = '_') then !add_delayed_check_forward (fun () -> if not (is_in_signature env) && not used.cu_positive then Location.prerr_warning loc (Warnings.Unused_constructor - (c, used.cu_pattern, used.cu_privatize))) + (name, used.cu_pattern, used.cu_privatize))) end constructors end; { env with constrs = List.fold_right - (fun (id, descr) constrs -> TycompTbl.add id (descr, None) constrs) - constructors - env.constrs; + (fun (id, descr) constrs -> + let cda = { cda_description = descr; cda_address = None } in + TycompTbl.add id cda constrs) + constructors env.constrs; labels = List.fold_right (fun (id, descr) labels -> TycompTbl.add id descr labels) - labels - env.labels; - types = IdTbl.add id (info, descrs) env.types; + labels env.labels; + types = IdTbl.add id tda env.types; summary = Env_type(env.summary, id, info) } and store_type_infos id info env = @@ -1877,35 +1679,38 @@ and store_type_infos id info env = manifest-ness of the type. Used in components_of_module to keep track of type abbreviations (e.g. type t = float) in the computation of label representations. *) + let tda = { tda_declaration = info; tda_descriptions = [], [] } in { env with - types = IdTbl.add id (info,([],[])) env.types; + types = IdTbl.add id tda env.types; summary = Env_type(env.summary, id, info) } and store_extension ~check id addr ext env = let loc = ext.ext_loc in + let cstr = Datarepr.extension_descr (Pident id) ext in + let cda = { cda_description = cstr; cda_address = Some addr } in if check && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_extension ("", false, false, false)) then begin + let priv = ext.ext_private in let is_exception = Path.same ext.ext_type_path Predef.path_exn in - let ty = Path.last ext.ext_type_path in - let n = Ident.name id in - let k = (ty, loc, n) in + let ty_name = Path.last ext.ext_type_path in + let name = cstr.cstr_name in + let k = (ty_name, loc, name) in if not (Hashtbl.mem used_constructors k) then begin let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); + Hashtbl.add used_constructors k (add_constructor_usage priv used); !add_delayed_check_forward (fun () -> if not (is_in_signature env) && not used.cu_positive then Location.prerr_warning loc (Warnings.Unused_extension - (n, is_exception, used.cu_pattern, used.cu_privatize) + (name, is_exception, used.cu_pattern, used.cu_privatize) ) ) end; end; - let desc = Datarepr.extension_descr (Pident id) ext in { env with - constrs = TycompTbl.add id (desc, Some addr) env.constrs; + constrs = TycompTbl.add id cda env.constrs; summary = Env_extension(env.summary, id, ext) } and store_module ~check ~freshening_sub id addr presence md env = @@ -1919,15 +1724,17 @@ and store_module ~check ~freshening_sub id addr presence md env = | None -> EnvLazy.create_forced md | Some s -> EnvLazy.create (s, Subst.Rescope (Ident.scope id), md) in + let comps = + components_of_module ~alerts ~loc:md.md_loc + env freshening_sub Subst.identity (Pident id) addr md.md_type + in + let mda = + { mda_declaration = module_decl_lazy; + mda_components = comps; + mda_address = addr } + in { env with - modules = IdTbl.add id (Value (module_decl_lazy, addr)) env.modules; - components = - IdTbl.add id - (Value - (components_of_module ~alerts ~loc:md.md_loc - env freshening_sub Subst.identity (Pident id) addr md.md_type, - addr)) - env.components; + modules = IdTbl.add id (Mod_local mda) env.modules; summary = Env_module(env.summary, id, presence, md) } and store_modtype id info env = @@ -1936,8 +1743,9 @@ and store_modtype id info env = summary = Env_modtype(env.summary, id, info) } and store_class id addr desc env = + let clda = { clda_declaration = desc; clda_address = addr } in { env with - classes = IdTbl.add id (desc, addr) env.classes; + classes = IdTbl.add id clda env.classes; summary = Env_class(env.summary, id, desc) } and store_cltype id desc env = @@ -1949,7 +1757,7 @@ let scrape_alias env mty = scrape_alias env None mty (* Compute the components of a functor application in a path. *) -let components_of_functor_appl f env p1 p2 = +let components_of_functor_appl ~loc f env p1 p2 = try Hashtbl.find f.fcomp_cache p2 with Not_found -> @@ -1959,7 +1767,7 @@ let components_of_functor_appl f env p1 p2 = because of the call to [check_well_formed_module]. *) let mty = Subst.modtype (Rescope (Path.scope p)) sub f.fcomp_res in let addr = EnvLazy.create_failed Not_found in - !check_well_formed_module env Location.(in_file !input_name) + !check_well_formed_module env loc ("the signature of " ^ Path.name p) mty; let comps = components_of_module ~alerts:Misc.Stdlib.String.Map.empty @@ -1973,7 +1781,6 @@ let components_of_functor_appl f env p1 p2 = (* Define forward functions *) let _ = - components_of_module' := components_of_module; components_of_functor_appl' := components_of_functor_appl; components_of_module_maker' := components_of_module_maker @@ -2083,22 +1890,33 @@ let enter_signature ~scope sg env = let sg = Subst.signature (Rescope scope) Subst.identity sg in sg, add_signature sg env +(* Add "unbound" bindings *) + +let enter_unbound_value name reason env = + let id = Ident.create_local name in + { env with + values = IdTbl.add id (Val_unbound reason) env.values; + summary = Env_value_unbound(env.summary, name, reason) } + +let enter_unbound_module name reason env = + let id = Ident.create_local name in + { env with + modules = IdTbl.add id (Mod_unbound reason) env.modules; + summary = Env_module_unbound(env.summary, name, reason) } + (* Open a signature path *) let add_components slot root env0 comps = let add_l w comps env0 = TycompTbl.add_open slot w comps env0 in - let add w comps env0 = IdTbl.add_open slot w root comps env0 in - let constrs = add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs in let labels = add_l (fun x -> `Label x) comps.comp_labels env0.labels in - let values = add (fun x -> `Value x) comps.comp_values env0.values in @@ -2114,20 +1932,9 @@ let add_components slot root env0 comps = let cltypes = add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes in - let components = - let components = - NameMap.map (fun x -> Value x) comps.comp_components - in - add (fun x -> `Component x) components env0.components - in - let modules = - let modules = - NameMap.map (fun x -> Value x) comps.comp_modules - in - add (fun x -> `Module x) modules env0.modules + add (fun x -> `Module x) comps.comp_modules env0.modules in - { env0 with summary = Env_open(env0.summary, root); constrs; @@ -2137,12 +1944,11 @@ let add_components slot root env0 comps = modtypes; classes; cltypes; - components; modules; } let open_signature slot root env0 = - match get_components (find_module_descr root env0) with + match get_components (find_module_components root env0) with | Functor_comps _ -> None | Structure_comps comps -> Some (add_components slot root env0 comps) @@ -2206,8 +2012,11 @@ let open_signature (* Read a signature from a file *) let read_signature modname filename = - let pm = read_pers_mod modname filename in - Lazy.force pm.pm_signature + let mda = read_pers_mod modname filename in + let md = EnvLazy.force subst_modtype_maker mda.mda_declaration in + match md.md_type with + | Mty_signature sg -> sg + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false let is_identchar_latin1 = function | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' @@ -2256,70 +2065,784 @@ let save_signature_with_imports ~alerts sg modname filename imports = save_signature_with_transform with_imports ~alerts sg modname filename +(* Make the initial environment *) +let (initial_safe_string, initial_unsafe_string) = + Predef.build_initial_env + (add_type ~check:false) + (add_extension ~check:false) + empty + +(* Tracking usage *) + +let mark_module_used name loc = + match Hashtbl.find module_declarations (name, loc) with + | mark -> mark () + | exception Not_found -> () + +let mark_modtype_used _name _mtd = () + +let mark_value_used name vd = + match Hashtbl.find value_declarations (name, vd.val_loc) with + | mark -> mark () + | exception Not_found -> () + +let mark_type_used name td = + match Hashtbl.find type_declarations (name, td.type_loc) with + | mark -> mark () + | exception Not_found -> () + +let mark_type_path_used env path = + match find_type path env with + | decl -> mark_type_used (Path.last path) decl + | exception Not_found -> () + +let mark_constructor_used usage ty_name cd = + let name = Ident.name cd.cd_id in + let loc = cd.cd_loc in + let k = (ty_name, loc, name) in + match Hashtbl.find used_constructors k with + | mark -> mark usage + | exception Not_found -> () + +let mark_extension_used usage name ext = + let ty_name = Path.last ext.ext_type_path in + let loc = ext.ext_loc in + let k = (ty_name, loc, name) in + match Hashtbl.find used_constructors k with + | mark -> mark usage + | exception Not_found -> () + +let mark_constructor_description_used usage env cstr = + let ty_path = + match repr cstr.cstr_res with + | {desc=Tconstr(path, _, _)} -> path + | _ -> assert false + in + mark_type_path_used env ty_path; + let ty_name = Path.last ty_path in + let k = (ty_name, cstr.cstr_loc, cstr.cstr_name) in + match Hashtbl.find used_constructors k with + | mark -> mark usage + | exception Not_found -> () + +let mark_label_description_used () env lbl = + let ty_path = + match repr lbl.lbl_res with + | {desc=Tconstr(path, _, _)} -> path + | _ -> assert false + in + mark_type_path_used env ty_path + +let mark_class_used name cty = + match Hashtbl.find type_declarations (name, cty.cty_loc) with + | mark -> mark () + | exception Not_found -> () + +let mark_cltype_used name clty = + match Hashtbl.find type_declarations (name, clty.clty_loc) with + | mark -> mark () + | exception Not_found -> () + +let set_value_used_callback name vd callback = + let key = (name, vd.val_loc) in + try + let old = Hashtbl.find value_declarations key in + Hashtbl.replace value_declarations key (fun () -> old (); callback ()) + (* this is to support cases like: + let x = let x = 1 in x in x + where the two declarations have the same location + (e.g. resulting from Camlp4 expansion of grammar entries) *) + with Not_found -> + Hashtbl.add value_declarations key callback + +let set_type_used_callback name td callback = + let loc = td.type_loc in + if loc.Location.loc_ghost then () + else let key = (name, loc) in + let old = + try Hashtbl.find type_declarations key + with Not_found -> ignore + in + Hashtbl.replace type_declarations key (fun () -> callback old) + +(* Lookup by name *) + +let may_lookup_error report_errors loc env err = + if report_errors then lookup_error loc env err + else raise Not_found + +let report_module_unbound ~errors ~loc env reason = + match reason with + | Mod_unbound_illegal_recursion -> + (* see #5965 *) + may_lookup_error errors loc env Illegal_reference_to_recursive_module + +let report_value_unbound ~errors ~loc env reason lid = + match reason with + | Val_unbound_instance_variable -> + may_lookup_error errors loc env (Masked_instance_variable lid) + | Val_unbound_self -> + may_lookup_error errors loc env (Masked_self_variable lid) + | Val_unbound_ancestor -> + may_lookup_error errors loc env (Masked_ancestor_variable lid) + | Val_unbound_ghost_recursive rloc -> + let show_hint = + (* Only display the "missing rec" hint for non-ghost code *) + not loc.Location.loc_ghost + && not rloc.Location.loc_ghost + in + let hint = + if show_hint then Missing_rec rloc else No_hint + in + may_lookup_error errors loc env (Unbound_value(lid, hint)) + +let use_module ~use ~loc name path mda = + if use then begin + let comps = mda.mda_components in + mark_module_used name comps.loc; + Misc.Stdlib.String.Map.iter + (fun kind message -> + let message = if message = "" then "" else "\n" ^ message in + Location.alert ~kind loc + (Printf.sprintf "module %s%s" (Path.name path) message) + ) + comps.alerts + end + +let use_value ~use ~loc name path vda = + if use then begin + let desc = vda.vda_description in + mark_value_used name desc; + Builtin_attributes.check_alerts loc desc.val_attributes + (Path.name path) + end + +let use_type ~use ~loc name path tda = + if use then begin + let decl = tda.tda_declaration in + mark_type_used name decl; + Builtin_attributes.check_alerts loc decl.type_attributes + (Path.name path) + end + +let use_modtype ~use ~loc name path desc = + if use then begin + mark_modtype_used name desc; + Builtin_attributes.check_alerts loc desc.mtd_attributes + (Path.name path) + end + +let use_class ~use ~loc name path clda = + if use then begin + let desc = clda.clda_declaration in + mark_class_used name desc; + Builtin_attributes.check_alerts loc desc.cty_attributes + (Path.name path) + end + +let use_cltype ~use ~loc name path desc = + if use then begin + mark_cltype_used name desc; + Builtin_attributes.check_alerts loc desc.clty_attributes + (Path.name path) + end + +let use_label ~use ~loc env lbl = + if use then begin + mark_label_description_used () env lbl; + Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name + end + +let use_constructor_desc ~use ~loc usage env cstr = + if use then begin + mark_constructor_description_used usage env cstr; + Builtin_attributes.check_alerts loc cstr.cstr_attributes cstr.cstr_name + end + +let use_constructor ~use ~loc usage env cda = + use_constructor_desc ~use ~loc usage env cda.cda_description + +type _ load = + | Load : module_data load + | Don't_load : unit load + +let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = + let path, data = + match find_name_module ~mark:use s env.modules with + | res -> res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Lident s)) + in + match data with + | Mod_local mda -> begin + use_module ~use ~loc s path mda; + match load with + | Load -> path, (mda : a) + | Don't_load -> path, (() : a) + end + | Mod_unbound reason -> + report_module_unbound ~errors ~loc env reason + | Mod_persistent -> begin + match load with + | Don't_load -> + check_pers_mod ~loc s; + path, (() : a) + | Load -> begin + match find_pers_mod s with + | mda -> + use_module ~use ~loc s path mda; + path, (mda : a) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Lident s)) + end + end + +let lookup_ident_value ~errors ~use ~loc name env = + match IdTbl.find_name wrap_value ~mark:use name env.values with + | (path, Val_bound vda) -> + use_value ~use ~loc name path vda; + path, vda.vda_description + | (_, Val_unbound reason) -> + report_value_unbound ~errors ~loc env reason (Lident name) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_value (Lident name, No_hint)) + +let lookup_ident_type ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.types with + | (path, data) as res -> + use_type ~use ~loc s path data; + res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_type (Lident s)) + +let lookup_ident_modtype ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with + | (path, data) as res -> + use_modtype ~use ~loc s path data; + res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_modtype (Lident s)) + +let lookup_ident_class ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.classes with + | (path, clda) -> + use_class ~use ~loc s path clda; + path, clda.clda_declaration + | exception Not_found -> + may_lookup_error errors loc env (Unbound_class (Lident s)) + +let lookup_ident_cltype ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with + | (path, data) as res -> + use_cltype ~use ~loc s path data; + res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_cltype (Lident s)) + +let lookup_all_ident_labels ~errors ~use ~loc s env = + match TycompTbl.find_all ~mark:use s env.labels with + | [] -> may_lookup_error errors loc env (Unbound_label (Lident s)) + | lbls -> begin + List.map + (fun (lbl, use_fn) -> + let use_fn () = + use_label ~use ~loc env lbl; + use_fn () + in + (lbl, use_fn)) + lbls + end + +(* Drop all extension constructors *) +let drop_exts cstrs = + List.filter (fun (cda, _) -> not (is_ext cda)) cstrs + +(* Only keep the latest extension constructor *) +let rec filter_shadowed_constructors cstrs = + match cstrs with + | (cda, _) as hd :: tl -> + if is_ext cda then hd :: drop_exts tl + else hd :: filter_shadowed_constructors tl + | [] -> [] + +let lookup_all_ident_constructors ~errors ~use ~loc usage s env = + match TycompTbl.find_all ~mark:use s env.constrs with + | [] -> may_lookup_error errors loc env (Unbound_constructor (Lident s)) + | cstrs -> + let cstrs = filter_shadowed_constructors cstrs in + List.map + (fun (cda, use_fn) -> + let use_fn () = + use_constructor ~use ~loc usage env cda; + use_fn () + in + (cda.cda_description, use_fn)) + cstrs + +let rec lookup_module_components ~errors ~use ~loc lid env = + match lid with + | Lident s -> + let path, data = lookup_ident_module Load ~errors ~use ~loc s env in + path, data.mda_components + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + path, data.mda_components + | Lapply(l1, l2) -> + let p1, f, arg = lookup_functor_components ~errors ~use ~loc l1 env in + let p2, md = lookup_module ~errors ~use ~loc l2 env in + !check_functor_application ~errors ~loc env md.md_type p2 arg p1; + let comps = !components_of_functor_appl' ~loc f env p1 p2 in + (Papply(p1, p2), comps) + +and lookup_structure_components ~errors ~use ~loc lid env = + let path, comps = lookup_module_components ~errors ~use ~loc lid env in + match get_components_res comps with + | Ok (Structure_comps comps) -> path, comps + | Ok (Functor_comps _) -> + may_lookup_error errors loc env (Functor_used_as_structure lid) + | Error No_components_abstract -> + may_lookup_error errors loc env (Abstract_used_as_structure lid) + | Error (No_components_alias p) -> + may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) + +and lookup_functor_components ~errors ~use ~loc lid env = + let path, comps = lookup_module_components ~errors ~use ~loc lid env in + match get_components_res comps with + | Ok (Functor_comps fcomps) -> begin + match fcomps.fcomp_arg with + | None -> (* PR#7611 *) + may_lookup_error errors loc env (Generative_used_as_applicative lid) + | Some arg -> path, fcomps, arg + end + | Ok (Structure_comps _) -> + may_lookup_error errors loc env (Structure_used_as_functor lid) + | Error No_components_abstract -> + may_lookup_error errors loc env (Abstract_used_as_functor lid) + | Error (No_components_alias p) -> + may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) + +and lookup_module ~errors ~use ~loc lid env = + match lid with + | Lident s -> + let path, data = lookup_ident_module Load ~errors ~use ~loc s env in + let md = EnvLazy.force subst_modtype_maker data.mda_declaration in + path, md + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + let md = EnvLazy.force subst_modtype_maker data.mda_declaration in + path, md + | Lapply(l1, l2) -> + let p1, fc, arg = lookup_functor_components ~errors ~use ~loc l1 env in + let p2, md2 = lookup_module ~errors ~use ~loc l2 env in + !check_functor_application ~errors ~loc env md2.md_type p2 arg p1; + let md = md (modtype_of_functor_appl fc p1 p2) in + Papply(p1, p2), md + +and lookup_dot_module ~errors ~use ~loc l s env = + let p, comps = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_modules with + | mda -> + let path = Pdot(p, s) in + use_module ~use ~loc s path mda; + (path, mda) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Ldot(l, s))) + +let lookup_dot_value ~errors ~use ~loc l s env = + let (path, comps) = + lookup_structure_components ~errors ~use ~loc l env + in + match NameMap.find s comps.comp_values with + | vda -> + let path = Pdot(path, s) in + use_value ~use ~loc s path vda; + (path, vda.vda_description) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint)) + +let lookup_dot_type ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_types with + | tda -> + let path = Pdot(p, s) in + use_type ~use ~loc s path tda; + (path, tda) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_type (Ldot(l, s))) + +let lookup_dot_modtype ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_modtypes with + | desc -> + let path = Pdot(p, s) in + use_modtype ~use ~loc s path desc; + (path, desc) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s))) + +let lookup_dot_class ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_classes with + | clda -> + let path = Pdot(p, s) in + use_class ~use ~loc s path clda; + (path, clda.clda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_class (Ldot(l, s))) + +let lookup_dot_cltype ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_cltypes with + | desc -> + let path = Pdot(p, s) in + use_cltype ~use ~loc s path desc; + (path, desc) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s))) + +let lookup_all_dot_labels ~errors ~use ~loc l s env = + let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_labels with + | [] | exception Not_found -> + may_lookup_error errors loc env (Unbound_label (Ldot(l, s))) + | lbls -> + List.map + (fun lbl -> + let use_fun () = use_label ~use ~loc env lbl in + (lbl, use_fun)) + lbls + +let lookup_all_dot_constructors ~errors ~use ~loc usage l s env = + match l with + | Longident.Lident "*predef*" -> + (* Hack to support compilation of default arguments *) + lookup_all_ident_constructors + ~errors ~use ~loc usage s initial_safe_string + | _ -> + let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_constrs with + | [] | exception Not_found -> + may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s))) + | cstrs -> + List.map + (fun cda -> + let use_fun () = use_constructor ~use ~loc usage env cda in + (cda.cda_description, use_fun)) + cstrs + +(* General forms of the lookup functions *) + +let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t = + match lid with + | Lident s -> + if !Clflags.transparent_modules && not load then + fst (lookup_ident_module Don't_load ~errors ~use ~loc s env) + else + fst (lookup_ident_module Load ~errors ~use ~loc s env) + | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env) + | Lapply(l1, l2) -> + let (p1, _, arg) = lookup_functor_components ~errors ~use ~loc l1 env in + let p2, md2 = lookup_module ~errors ~use ~loc l2 env in + !check_functor_application ~errors ~loc env md2.md_type p2 arg p1; + Papply(p1, p2) + +let lookup_value ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_value ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_value ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_type_full ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_type ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_type ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_type ~errors ~use ~loc lid env = + let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in + path, tda.tda_declaration + +let lookup_modtype ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_class ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_class ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_class ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_cltype ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_cltype ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_all_labels ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_all_ident_labels ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_label ~errors ~use ~loc lid env = + match lookup_all_labels ~errors ~use ~loc lid env with + | [] -> assert false + | (desc, use) :: _ -> use (); desc + +let lookup_all_labels_from_type ~use ~loc ty_path env = + match find_type_descrs ty_path env with + | exception Not_found -> [] + | (_, lbls) -> + List.map + (fun lbl -> + let use_fun () = use_label ~use ~loc env lbl in + (lbl, use_fun)) + lbls + +let lookup_all_constructors ~errors ~use ~loc usage lid env = + match lid with + | Lident s -> lookup_all_ident_constructors ~errors ~use ~loc usage s env + | Ldot(l, s) -> lookup_all_dot_constructors ~errors ~use ~loc usage l s env + | Lapply _ -> assert false + +let lookup_constructor ~errors ~use ~loc usage lid env = + match lookup_all_constructors ~errors ~use ~loc usage lid env with + | [] -> assert false + | (desc, use) :: _ -> use (); desc + +let lookup_all_constructors_from_type ~use ~loc usage ty_path env = + match find_type_descrs ty_path env with + | exception Not_found -> [] + | (cstrs, _) -> + List.map + (fun cstr -> + let use_fun () = + use_constructor_desc ~use ~loc usage env cstr + in + (cstr, use_fun)) + cstrs + +(* Lookup functions that do not mark the item as used or + warn if it has alerts, and raise [Not_found] rather + than report errors *) + +let find_module_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_module ~errors:false ~use:false ~loc lid env + +let find_value_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_value ~errors:false ~use:false ~loc lid env + +let find_type_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_type ~errors:false ~use:false ~loc lid env + +let find_modtype_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_modtype ~errors:false ~use:false ~loc lid env + +let find_class_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_class ~errors:false ~use:false ~loc lid env + +let find_cltype_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_cltype ~errors:false ~use:false ~loc lid env + +let find_constructor_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_constructor ~errors:false ~use:false ~loc Positive lid env + +let find_label_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_label ~errors:false ~use:false ~loc lid env + +(* Ordinary lookup functions *) + +let lookup_module_path ?(use=true) ~loc ~load lid env = + lookup_module_path ~errors:true ~use ~loc ~load lid env + +let lookup_module ?(use=true) ~loc lid env = + lookup_module ~errors:true ~use ~loc lid env + +let lookup_value ?(use=true) ~loc lid env = + check_value_name (Longident.last lid) loc; + lookup_value ~errors:true ~use ~loc lid env + +let lookup_type ?(use=true) ~loc lid env = + lookup_type ~errors:true ~use ~loc lid env + +let lookup_modtype ?(use=true) ~loc lid env = + lookup_modtype ~errors:true ~use ~loc lid env + +let lookup_class ?(use=true) ~loc lid env = + lookup_class ~errors:true ~use ~loc lid env + +let lookup_cltype ?(use=true) ~loc lid env = + lookup_cltype ~errors:true ~use ~loc lid env + +let lookup_all_constructors ?(use=true) ~loc usage lid env = + match lookup_all_constructors ~errors:true ~use ~loc usage lid env with + | exception Error(Lookup_error(loc', env', err)) -> + (Error(loc', env', err) : _ result) + | cstrs -> Ok cstrs + +let lookup_constructor ?(use=true) ~loc lid env = + lookup_constructor ~errors:true ~use ~loc lid env + +let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env = + lookup_all_constructors_from_type ~use ~loc usage ty_path env + +let lookup_all_labels ?(use=true) ~loc lid env = + match lookup_all_labels ~errors:true ~use ~loc lid env with + | exception Error(Lookup_error(loc', env', err)) -> + (Error(loc', env', err) : _ result) + | lbls -> Ok lbls + +let lookup_label ?(use=true) ~loc lid env = + lookup_label ~errors:true ~use ~loc lid env + +let lookup_all_labels_from_type ?(use=true) ~loc ty_path env = + lookup_all_labels_from_type ~use ~loc ty_path env + +let lookup_instance_variable ?(use=true) ~loc name env = + match IdTbl.find_name wrap_value ~mark:use name env.values with + | (path, Val_bound vda) -> begin + let desc = vda.vda_description in + match desc.val_kind with + | Val_ivar(mut, cl_num) -> + use_value ~use ~loc name path vda; + path, mut, cl_num, desc.val_type + | _ -> + lookup_error loc env (Not_an_instance_variable name) + end + | (_, Val_unbound Val_unbound_instance_variable) -> + lookup_error loc env (Masked_instance_variable (Lident name)) + | (_, Val_unbound Val_unbound_self) -> + lookup_error loc env (Not_an_instance_variable name) + | (_, Val_unbound Val_unbound_ancestor) -> + lookup_error loc env (Not_an_instance_variable name) + | (_, Val_unbound Val_unbound_ghost_recursive _) -> + lookup_error loc env (Unbound_instance_variable name) + | exception Not_found -> + lookup_error loc env (Unbound_instance_variable name) + +(* Checking if a name is bound *) + +let bound_module name env = + match IdTbl.find_name wrap_module ~mark:false name env.modules with + | _ -> true + | exception Not_found -> + if Current_unit_name.is name then false + else begin + match find_pers_mod name with + | _ -> true + | exception Not_found -> false + end + +let bound wrap proj name env = + match IdTbl.find_name wrap ~mark:false name (proj env) with + | _ -> true + | exception Not_found -> false + +let bound_value name env = + bound wrap_value (fun env -> env.values) name env + +let bound_type name env = + bound wrap_identity (fun env -> env.types) name env + +let bound_modtype name env = + bound wrap_identity (fun env -> env.modtypes) name env + +let bound_class name env = + bound wrap_identity (fun env -> env.classes) name env + +let bound_cltype name env = + bound wrap_identity (fun env -> env.cltypes) name env + (* Folding on environments *) -let find_all proj1 proj2 f lid env acc = +let find_all wrap proj1 proj2 f lid env acc = match lid with - | None -> - IdTbl.fold_name + | None -> + IdTbl.fold_name wrap (fun name (p, data) acc -> f name p data acc) (proj1 env) acc - | Some l -> - let p, desc = lookup_module_descr ~mark:true l env in + | Some l -> + let p, desc = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in begin match get_components desc with - Structure_comps c -> - NameMap.fold - (fun s data acc -> f s (Pdot (p, s)) data acc) - (proj2 c) acc - | Functor_comps _ -> - acc + | Structure_comps c -> + NameMap.fold + (fun s data acc -> f s (Pdot (p, s)) (wrap data) acc) + (proj2 c) acc + | Functor_comps _ -> + acc end let find_all_simple_list proj1 proj2 f lid env acc = match lid with - | None -> + | None -> TycompTbl.fold_name (fun data acc -> f data acc) (proj1 env) acc - | Some l -> - let (_p, desc) = lookup_module_descr ~mark:true l env in + | Some l -> + let (_p, desc) = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in begin match get_components desc with - Structure_comps c -> - NameMap.fold - (fun _s comps acc -> - match comps with - | [] -> acc - | data :: _ -> f data acc) - (proj2 c) acc - | Functor_comps _ -> - acc + | Structure_comps c -> + NameMap.fold + (fun _s comps acc -> + match comps with + | [] -> acc + | data :: _ -> f data acc) + (proj2 c) acc + | Functor_comps _ -> + acc end let fold_modules f lid env acc = match lid with | None -> - IdTbl.fold_name - (fun name (p, data) acc -> - match data with - | Value (data, _) -> - let data = EnvLazy.force subst_modtype_maker data in - f name p data acc - | Persistent -> + IdTbl.fold_name wrap_module + (fun name (p, entry) acc -> + match entry with + | Mod_unbound _ -> acc + | Mod_local mda -> + let md = + EnvLazy.force subst_modtype_maker mda.mda_declaration + in + f name p md acc + | Mod_persistent -> match Persistent_env.find_in_cache persistent_env name with | None -> acc - | Some pm -> - let data = md (Mty_signature (Lazy.force pm.pm_signature)) in - f name p data acc) + | Some mda -> + let md = + EnvLazy.force subst_modtype_maker mda.mda_declaration + in + f name p md acc) env.modules acc | Some l -> - let p, desc = lookup_module_descr ~mark:true l env in + let p, desc = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in begin match get_components desc with | Structure_comps c -> NameMap.fold - (fun s (data, _) acc -> - f s (Pdot (p, s)) - (EnvLazy.force subst_modtype_maker data) acc) + (fun s mda acc -> + let md = + EnvLazy.force subst_modtype_maker mda.mda_declaration + in + f s (Pdot (p, s)) md acc) c.comp_modules acc | Functor_comps _ -> @@ -2327,30 +2850,38 @@ let fold_modules f lid env acc = end let fold_values f = - find_all (fun env -> env.values) (fun sc -> sc.comp_values) - (fun k p (vd, _) acc -> f k p vd acc) + find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values) + (fun k p ve acc -> + match ve with + | Val_unbound _ -> acc + | Val_bound vda -> f k p vda.vda_description acc) and fold_constructors f = find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) - (fun (cd, _) acc -> f cd acc) + (fun cda acc -> f cda.cda_description acc) and fold_labels f = find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f and fold_types f = - find_all (fun env -> env.types) (fun sc -> sc.comp_types) f + find_all wrap_identity + (fun env -> env.types) (fun sc -> sc.comp_types) + (fun k p tda acc -> f k p tda.tda_declaration acc) and fold_modtypes f = - find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f + find_all wrap_identity + (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f and fold_classes f = - find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) - (fun k p (vd, _) acc -> f k p vd acc) + find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes) + (fun k p clda acc -> f k p clda.clda_declaration acc) and fold_cltypes f = - find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f + find_all wrap_identity + (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f let filter_non_loaded_persistent f env = let to_remove = - IdTbl.fold_name - (fun name (_, data) acc -> - match data with - | Value _ -> acc - | Persistent -> + IdTbl.fold_name wrap_module + (fun name (_, entry) acc -> + match entry with + | Mod_local _ -> acc + | Mod_unbound _ -> acc + | Mod_persistent -> match Persistent_env.find_in_cache persistent_env name with | Some _ -> acc | None -> @@ -2400,20 +2931,16 @@ let filter_non_loaded_persistent f env = filter_summary s (String.Set.remove (Ident.name id) ids) else Env_persistent (filter_summary s ids, id) + | Env_value_unbound (s, n, r) -> + Env_value_unbound (filter_summary s ids, n, r) + | Env_module_unbound (s, n, r) -> + Env_module_unbound (filter_summary s ids, n, r) in { env with modules = remove_ids env.modules to_remove; - components = remove_ids env.components to_remove; summary = filter_summary env.summary to_remove; } -(* Make the initial environment *) -let (initial_safe_string, initial_unsafe_string) = - Predef.build_initial_env - (add_type ~check:false) - (add_extension ~check:false) - empty - (* Return the environment summary *) let summary env = @@ -2451,6 +2978,130 @@ let env_of_only_summary env_from_summary env = open Format +(* Forward declarations *) + +let print_longident = + ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit) + +let print_path = + ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit) + +let spellcheck ppf extract env lid = + let choices ~path name = Misc.spellcheck (extract path env) name in + match lid with + | Longident.Lapply _ -> () + | Longident.Lident s -> + Misc.did_you_mean ppf (fun () -> choices ~path:None s) + | Longident.Ldot (r, s) -> + Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) + +let spellcheck_name ppf extract env name = + Misc.did_you_mean ppf + (fun () -> Misc.spellcheck (extract env) name) + +let extract_values path env = + fold_values (fun name _ _ acc -> name :: acc) path env [] +let extract_types path env = + fold_types (fun name _ _ acc -> name :: acc) path env [] +let extract_modules path env = + fold_modules (fun name _ _ acc -> name :: acc) path env [] +let extract_constructors path env = + fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env [] +let extract_labels path env = + fold_labels (fun desc acc -> desc.lbl_name :: acc) path env [] +let extract_classes path env = + fold_classes (fun name _ _ acc -> name :: acc) path env [] +let extract_modtypes path env = + fold_modtypes (fun name _ _ acc -> name :: acc) path env [] +let extract_cltypes path env = + fold_cltypes (fun name _ _ acc -> name :: acc) path env [] +let extract_instance_variables env = + fold_values + (fun name _ descr acc -> + match descr.val_kind with + | Val_ivar _ -> name :: acc + | _ -> acc) None env [] + +let report_lookup_error _loc env ppf = function + | Unbound_value(lid, hint) -> begin + fprintf ppf "Unbound value %a" !print_longident lid; + spellcheck ppf extract_values env lid; + match hint with + | No_hint -> () + | Missing_rec def_loc -> + let (_, line, _) = + Location.get_pos_info def_loc.Location.loc_start + in + fprintf ppf + "@.@[%s@ %s %i@]" + "Hint: If this is a recursive definition," + "you should add the 'rec' keyword on line" + line + end + | Unbound_type lid -> + fprintf ppf "Unbound type constructor %a" !print_longident lid; + spellcheck ppf extract_types env lid; + | Unbound_module lid -> + fprintf ppf "Unbound module %a" !print_longident lid; + spellcheck ppf extract_modules env lid; + | Unbound_constructor lid -> + fprintf ppf "Unbound constructor %a" !print_longident lid; + spellcheck ppf extract_constructors env lid; + | Unbound_label lid -> + fprintf ppf "Unbound record field %a" !print_longident lid; + spellcheck ppf extract_labels env lid; + | Unbound_class lid -> + fprintf ppf "Unbound class %a" !print_longident lid; + spellcheck ppf extract_classes env lid; + | Unbound_modtype lid -> + fprintf ppf "Unbound module type %a" !print_longident lid; + spellcheck ppf extract_modtypes env lid; + | Unbound_cltype lid -> + fprintf ppf "Unbound class type %a" !print_longident lid; + spellcheck ppf extract_cltypes env lid; + | Unbound_instance_variable s -> + fprintf ppf "Unbound instance variable %s" s; + spellcheck_name ppf extract_instance_variables env s; + | Not_an_instance_variable s -> + fprintf ppf "The value %s is not an instance variable" s; + spellcheck_name ppf extract_instance_variables env s; + | Masked_instance_variable lid -> + fprintf ppf + "The instance variable %a@ \ + cannot be accessed from the definition of another instance variable" + !print_longident lid + | Masked_self_variable lid -> + fprintf ppf + "The self variable %a@ \ + cannot be accessed from the definition of an instance variable" + !print_longident lid + | Masked_ancestor_variable lid -> + fprintf ppf + "The ancestor variable %a@ \ + cannot be accessed from the definition of an instance variable" + !print_longident lid + | Illegal_reference_to_recursive_module -> + fprintf ppf "Illegal recursive module reference" + | Structure_used_as_functor lid -> + fprintf ppf "@[The module %a is a structure, it cannot be applied@]" + !print_longident lid + | Abstract_used_as_functor lid -> + fprintf ppf "@[The module %a is abstract, it cannot be applied@]" + !print_longident lid + | Functor_used_as_structure lid -> + fprintf ppf "@[The module %a is a functor, \ + it cannot have any components@]" !print_longident lid + | Abstract_used_as_structure lid -> + fprintf ppf "@[The module %a is abstract, \ + it cannot have any components@]" !print_longident lid + | Generative_used_as_applicative lid -> + fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ + applied@ in@ type@ expressions@]" !print_longident lid + | Cannot_scrape_alias(lid, p) -> + fprintf ppf + "The module %a is an alias for module %a, which is missing" + !print_longident lid !print_path p + let report_error ppf = function | Missing_module(_, path1, path2) -> fprintf ppf "@[@["; @@ -2465,18 +3116,23 @@ let report_error ppf = function | Illegal_value_name(_loc, name) -> fprintf ppf "'%s' is not a valid value identifier." name + | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err let () = Location.register_error_of_exn (function | Error err -> - let loc = match err with - (Missing_module (loc, _, _) | Illegal_value_name (loc, _)) -> loc + let loc = + match err with + | Missing_module (loc, _, _) + | Illegal_value_name (loc, _) + | Lookup_error(loc, _, _) -> loc in let error_of_printer = if loc = Location.none then Location.error_of_printer_file - else Location.error_of_printer ~loc ?sub:None in + else Location.error_of_printer ~loc ?sub:None + in Some (error_of_printer report_error err) | _ -> None diff --git a/typing/env.mli b/typing/env.mli index d521942b3..5aa0c7080 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -18,6 +18,15 @@ open Types open Misc +type value_unbound_reason = + | Val_unbound_instance_variable + | Val_unbound_self + | Val_unbound_ancestor + | Val_unbound_ghost_recursive of Location.t + +type module_unbound_reason = + | Mod_unbound_illegal_recursion + type summary = Env_empty | Env_value of summary * Ident.t * value_description @@ -34,6 +43,8 @@ type summary = | Env_constraints of summary * type_declaration Path.Map.t | Env_copy_types of summary | Env_persistent of summary * Ident.t + | Env_value_unbound of summary * string * value_unbound_reason + | Env_module_unbound of summary * string * module_unbound_reason type address = | Aident of Ident.t @@ -53,7 +64,7 @@ type type_descriptions = (* For short-paths *) type iter_cont val iter_types: - (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> + (Path.t -> Path.t * type_declaration -> unit) -> t -> iter_cont val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list val same_types: t -> t -> bool @@ -73,6 +84,9 @@ val find_modtype: Path.t -> t -> modtype_declaration val find_class: Path.t -> t -> class_declaration val find_cltype: Path.t -> t -> class_type_declaration +val find_ident_constructor: Ident.t -> t -> constructor_description +val find_ident_label: Ident.t -> t -> label_description + val find_type_expansion: Path.t -> t -> type_expr list * type_expr * int val find_type_expansion_opt: @@ -81,6 +95,9 @@ val find_type_expansion_opt: of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> module_type +val find_hash_type: Path.t -> t -> type_declaration +(* Find the "#t" type given the path for "t" *) + val find_value_address: Path.t -> t -> address val find_module_address: Path.t -> t -> address val find_class_address: Path.t -> t -> address @@ -109,47 +126,137 @@ val add_required_global: Ident.t -> unit val has_local_constraints: t -> bool +(* Mark definitions as used *) +val mark_value_used: string -> value_description -> unit +val mark_module_used: string -> Location.t -> unit +val mark_type_used: string -> type_declaration -> unit + +type constructor_usage = Positive | Pattern | Privatize +val mark_constructor_used: + constructor_usage -> string -> constructor_declaration -> unit +val mark_extension_used: + constructor_usage -> string -> extension_constructor -> unit + (* Lookup by long identifiers *) -(* ?loc is used to report 'deprecated module' warnings and other alerts *) +(* Lookup errors *) + +type unbound_value_hint = + | No_hint + | Missing_rec of Location.t + +type lookup_error = + | Unbound_value of Longident.t * unbound_value_hint + | Unbound_type of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t + | Unbound_instance_variable of string + | Not_an_instance_variable of string + | Masked_instance_variable of Longident.t + | Masked_self_variable of Longident.t + | Masked_ancestor_variable of Longident.t + | Structure_used_as_functor of Longident.t + | Abstract_used_as_functor of Longident.t + | Functor_used_as_structure of Longident.t + | Abstract_used_as_structure of Longident.t + | Generative_used_as_applicative of Longident.t + | Illegal_reference_to_recursive_module + | Cannot_scrape_alias of Longident.t * Path.t + +val lookup_error: Location.t -> t -> lookup_error -> 'a + +(* The [lookup_foo] functions will emit proper error messages (by + raising [Error]) if the identifier cannot be found, whereas the + [find_foo_by_name] functions will raise [Not_found] instead. + + The [~use] parameters of the [lookup_foo] functions control + whether this lookup should be counted as a use for usage + warnings and alerts. + + [Longident.t]s in the program source should be looked up using + [lookup_foo ~use:true] exactly one time -- otherwise warnings may be + emitted the wrong number of times. *) val lookup_value: - ?loc:Location.t -> ?mark:bool -> - Longident.t -> t -> Path.t * value_description -val lookup_constructor: - ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> constructor_description -val lookup_all_constructors: - ?loc:Location.t -> ?mark:bool -> - Longident.t -> t -> (constructor_description * (unit -> unit)) list -val lookup_label: - ?loc:Location.t -> ?mark:bool -> - Longident.t -> t -> label_description -val lookup_all_labels: - ?loc:Location.t -> ?mark:bool -> - Longident.t -> t -> (label_description * (unit -> unit)) list + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * value_description val lookup_type: - ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t - (* Since 4.04, this function no longer returns [type_description]. - To obtain it, you should either call [Env.find_type], or replace - it by [Typetexp.find_type] *) + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * type_declaration val lookup_module: - load:bool -> ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * module_declaration val lookup_modtype: - ?loc:Location.t -> ?mark:bool -> - Longident.t -> t -> Path.t * modtype_declaration + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * modtype_declaration val lookup_class: - ?loc:Location.t -> ?mark:bool -> - Longident.t -> t -> Path.t * class_declaration + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * class_declaration val lookup_cltype: - ?loc:Location.t -> ?mark:bool -> + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * class_type_declaration + +val lookup_module_path: + ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t + +val lookup_constructor: + ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> + constructor_description +val lookup_all_constructors: + ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> + ((constructor_description * (unit -> unit)) list, + Location.t * t * lookup_error) result +val lookup_all_constructors_from_type: + ?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t -> + (constructor_description * (unit -> unit)) list + +val lookup_label: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + label_description +val lookup_all_labels: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + ((label_description * (unit -> unit)) list, + Location.t * t * lookup_error) result +val lookup_all_labels_from_type: + ?use:bool -> loc:Location.t -> Path.t -> t -> + (label_description * (unit -> unit)) list + +val lookup_instance_variable: + ?use:bool -> loc:Location.t -> string -> t -> + Path.t * Asttypes.mutable_flag * string * type_expr + +val find_value_by_name: + Longident.t -> t -> Path.t * value_description +val find_type_by_name: + Longident.t -> t -> Path.t * type_declaration +val find_module_by_name: + Longident.t -> t -> Path.t * module_declaration +val find_modtype_by_name: + Longident.t -> t -> Path.t * modtype_declaration +val find_class_by_name: + Longident.t -> t -> Path.t * class_declaration +val find_cltype_by_name: Longident.t -> t -> Path.t * class_type_declaration -val make_copy_of_types: t -> (t -> t) +val find_constructor_by_name: + Longident.t -> t -> constructor_description +val find_label_by_name: + Longident.t -> t -> label_description -exception Recmodule - (* Raise by lookup_module when the identifier refers - to one of the modules of a recursive definition - during the computation of its approximation (see #5965). *) +(* Check if a name is bound *) + +val bound_value: string -> t -> bool +val bound_module: string -> t -> bool +val bound_type: string -> t -> bool +val bound_modtype: string -> t -> bool +val bound_class: string -> t -> bool +val bound_cltype: string -> t -> bool + +val make_copy_of_types: t -> (t -> t) (* Insertion by identifier *) @@ -224,6 +331,10 @@ val enter_cltype: in the process. *) val enter_signature: scope:int -> signature -> t -> signature * t +val enter_unbound_value : string -> value_unbound_reason -> t -> t + +val enter_unbound_module : string -> module_unbound_reason -> t -> t + (* Initialize the cache of in-core module interfaces. *) val reset_cache: unit -> unit @@ -276,6 +387,7 @@ val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t type error = | Missing_module of Location.t * Path.t * Path.t | Illegal_value_name of Location.t * string + | Lookup_error of Location.t * t * lookup_error exception Error of error @@ -283,18 +395,7 @@ open Format val report_error: formatter -> error -> unit - -val mark_value_used: string -> value_description -> unit -val mark_module_used: string -> Location.t -> unit -val mark_type_used: string -> type_declaration -> unit - -type constructor_usage = Positive | Pattern | Privatize -val mark_constructor_used: - constructor_usage -> string -> type_declaration -> string -> unit -val mark_constructor: - constructor_usage -> t -> string -> constructor_description -> unit -val mark_extension_used: - constructor_usage -> extension_constructor -> string -> unit +val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit val in_signature: bool -> t -> t @@ -306,8 +407,9 @@ val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit (* Forward declaration to break mutual recursion with Includemod. *) -val check_modtype_inclusion: - (loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref +val check_functor_application: + (errors:bool -> loc:Location.t -> t -> module_type -> + Path.t -> module_type -> Path.t -> unit) ref (* Forward declaration to break mutual recursion with Typemod. *) val check_well_formed_module: (t -> Location.t -> string -> module_type -> unit) ref @@ -318,36 +420,10 @@ val strengthen: (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref (* Forward declaration to break mutual recursion with Ctype. *) val same_constr: (t -> type_expr -> type_expr -> bool) ref - -(** Folding over all identifiers (for analysis purpose) *) - -val fold_values: - (string -> Path.t -> value_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_types: - (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_constructors: - (constructor_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_labels: - (label_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a - -(** Persistent structures are only traversed if they are already loaded. *) -val fold_modules: - (string -> Path.t -> module_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a - -val fold_modtypes: - (string -> Path.t -> modtype_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_classes: - (string -> Path.t -> class_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_cltypes: - (string -> Path.t -> class_type_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a +(* Forward declaration to break mutual recursion with Printtyp. *) +val print_longident: (Format.formatter -> Longident.t -> unit) ref +(* Forward declaration to break mutual recursion with Printtyp. *) +val print_path: (Format.formatter -> Path.t -> unit) ref (** Utilities *) val scrape_alias: t -> module_type -> module_type diff --git a/typing/envaux.ml b/typing/envaux.ml index ddb792aa9..2d3a02bc1 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -86,6 +86,12 @@ let rec env_from_summary sum subst = | Env_persistent (s, id) -> let env = env_from_summary s subst in Env.add_persistent_structure id env + | Env_value_unbound (s, str, reason) -> + let env = env_from_summary s subst in + Env.enter_unbound_value str reason env + | Env_module_unbound (s, str, reason) -> + let env = env_from_summary s subst in + Env.enter_unbound_module str reason env in Hashtbl.add env_cache (sum, subst) env; env diff --git a/typing/includecore.ml b/typing/includecore.ml index ed2fb068a..49a9ac34b 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -380,19 +380,18 @@ let type_declarations ?(equality = false) ~loc env ~mark name (_, Type_abstract) -> None | (Type_variant cstrs1, Type_variant cstrs2) -> if mark then begin - let mark cstrs usage name decl = + let mark usage name cstrs = List.iter - (fun c -> - Env.mark_constructor_used usage name decl - (Ident.name c.Types.cd_id)) + (fun cstr -> + Env.mark_constructor_used usage name cstr) cstrs in let usage = - if decl1.type_private = Private || decl2.type_private = Public - then Env.Positive else Env.Privatize + if decl2.type_private = Public then Env.Positive + else Env.Privatize in - mark cstrs1 usage name decl1; - if equality then mark cstrs2 Env.Positive (Path.name path) decl2 + mark usage name cstrs1; + if equality then mark Env.Positive (Path.name path) cstrs2 end; Option.map (fun var_err -> Variant_mismatch var_err) @@ -443,10 +442,10 @@ let type_declarations ?(equality = false) ~loc env ~mark name let extension_constructors ~loc env ~mark id ext1 ext2 = if mark then begin let usage = - if ext1.ext_private = Private || ext2.ext_private = Public - then Env.Positive else Env.Privatize + if ext2.ext_private = Public then Env.Positive + else Env.Privatize in - Env.mark_extension_used usage ext1 (Ident.name id) + Env.mark_extension_used usage (Ident.name id) ext1 end; let ty1 = Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) diff --git a/typing/includemod.ml b/typing/includemod.ml index 0de55dc26..c15a53808 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -45,6 +45,7 @@ type pos = type error = pos list * Env.t * symptom exception Error of error list +exception Apply_error of Location.t * Path.t * Path.t * error list type mark = | Mark_both @@ -543,9 +544,15 @@ let check_modtype_inclusion ~loc env mty1 path1 mty2 = (Mtype.strengthen ~aliasable env mty1 path1) mty2) let () = - Env.check_modtype_inclusion := (fun ~loc a b c d -> - try (check_modtype_inclusion ~loc a b c d : unit) - with Error _ -> raise Not_found) + Env.check_functor_application := + (fun ~errors ~loc env mty1 path1 mty2 path2 -> + try + check_modtype_inclusion ~loc env mty1 path1 mty2 + with Error errs -> + if errors then + raise (Apply_error(loc, path1, path2, errs)) + else + raise Not_found) (* Check that an implementation of a compilation unit meets its interface. *) @@ -841,11 +848,17 @@ let report_error ppf errs = fprintf ppf "@[%a%a%t@]" print_errs errs include_err err Printtyp.Conflicts.print_explanations +let report_apply_error p1 p2 ppf errs = + fprintf ppf "@[The type of %a does not match %a's parameter@ %a@]" + Printtyp.path p1 Printtyp.path p2 report_error errs + (* We could do a better job to split the individual error items as sub-messages of the main interface mismatch on the whole unit. *) let () = Location.register_error_of_exn (function | Error err -> Some (Location.error_of_printer_file report_error err) + | Apply_error(loc, p1, p2, err) -> + Some (Location.error_of_printer ~loc (report_apply_error p1 p2) err) | _ -> None ) diff --git a/typing/predef.mli b/typing/predef.mli index 878dc6eb9..962a276a9 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -57,6 +57,14 @@ val path_match_failure: Path.t val path_assert_failure : Path.t val path_undefined_recursive_module : Path.t +val ident_false : Ident.t +val ident_true : Ident.t +val ident_void : Ident.t +val ident_nil : Ident.t +val ident_cons : Ident.t +val ident_none : Ident.t +val ident_some : Ident.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_extension. *) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index adc87df01..974a71a96 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -34,6 +34,8 @@ let rec longident ppf = function | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 +let () = Env.print_longident := longident + (* Print an identifier avoiding name collisions *) module Out_name = struct @@ -79,16 +81,14 @@ module Namespace = struct let lookup = let to_lookup f lid = - fst @@ f ?loc:None ?mark:(Some false) (Lident lid) !printing_env in + fst @@ f (Lident lid) !printing_env + in function - | Type -> fun id -> - Env.lookup_type ?loc:None ~mark:false (Lident id) !printing_env - | Module -> fun id -> - Env.lookup_module ~load:true ~mark:false ?loc:None - (Lident id) !printing_env - | Module_type -> to_lookup Env.lookup_modtype - | Class -> to_lookup Env.lookup_class - | Class_type -> to_lookup Env.lookup_cltype + | Type -> to_lookup Env.find_type_by_name + | Module -> to_lookup Env.find_module_by_name + | Module_type -> to_lookup Env.find_modtype_by_name + | Class -> to_lookup Env.find_class_by_name + | Class_type -> to_lookup Env.find_cltype_by_name | Other -> fun _ -> raise Not_found let location namespace id = @@ -330,8 +330,9 @@ let ident_stdlib = Ident.create_persistent "Stdlib" let non_shadowed_pervasive = function | Pdot(Pident id, s) as path -> Ident.same id ident_stdlib && - (try Path.same path (Env.lookup_type (Lident s) !printing_env) - with Not_found -> true) + (match Env.find_type_by_name (Lident s) !printing_env with + | (path', _) -> Path.same path path' + | exception Not_found -> true) | _ -> false let find_double_underscore s = @@ -374,12 +375,12 @@ let rec rewrite_double_underscore_paths env p = String.capitalize_ascii (String.sub name (i + 2) (String.length name - i - 2))) in - match Env.lookup_module ~load:true better_lid env with + match Env.find_module_by_name better_lid env with | exception Not_found -> p - | p' -> - if module_path_is_an_alias_of env p' ~alias_of:p then - p' - else + | p', _ -> + if module_path_is_an_alias_of env p' ~alias_of:p then + p' + else p let rewrite_double_underscore_paths env p = @@ -412,6 +413,8 @@ let strings_of_paths namespace p = let trees = List.map (tree_of_path namespace) p in List.map (Format.asprintf "%a" !Oprint.out_ident) trees +let () = Env.print_path := path + (* Print a recursive annotation *) let tree_of_rec = function @@ -676,6 +679,14 @@ let wrap_printing_env ~error env f = if error then Env.without_cmis (wrap_printing_env env) f else wrap_printing_env env f +let rec lid_of_path = function + Path.Pident id -> + Longident.Lident (Ident.name id) + | Path.Pdot (p1, s) -> + Longident.Ldot (lid_of_path p1, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lid_of_path p1, lid_of_path p2) + let is_unambiguous path env = let l = Env.find_shadowed_types path env in List.exists (Path.same path) l || (* concrete paths are ok *) @@ -689,7 +700,7 @@ let is_unambiguous path env = (* also allow repeatedly defining and opening (for toplevel) *) let id = lid_of_path p in List.for_all (fun p -> lid_of_path p = id) rem && - Path.same p (Env.lookup_type id env) + Path.same p (fst (Env.find_type_by_name id env)) let rec get_best_path r = match !r with diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 10717a7ce..3e39991ce 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -257,22 +257,15 @@ let rc node = (* Enter a value in the method environment only *) -let enter_met_env ?check loc lab kind ty val_env met_env par_env = - let (id, val_env) = - Env.enter_value lab - {val_type = ty; - val_kind = Val_unbound Val_unbound_instance_variable; - val_attributes = []; - Types.val_loc = loc} val_env +let enter_met_env ?check loc lab kind unbound_kind ty val_env met_env par_env = + let val_env = Env.enter_unbound_value lab unbound_kind val_env in + let par_env = Env.enter_unbound_value lab unbound_kind par_env in + let (id, met_env) = + Env.enter_value ?check lab + {val_type = ty; val_kind = kind; + val_attributes = []; Types.val_loc = loc} met_env in - (id, val_env, - Env.add_value ?check id {val_type = ty; val_kind = kind; - val_attributes = []; - Types.val_loc = loc} met_env, - Env.add_value id {val_type = ty; - val_kind = Val_unbound Val_unbound_instance_variable; - val_attributes = []; - Types.val_loc = loc} par_env) + (id, val_env, met_env, par_env) (* Enter an instance variable in the environment *) let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = @@ -294,7 +287,7 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = match id with Some id -> (id, val_env, met_env, par_env) | None -> enter_met_env Location.none lab (Val_ivar (mut, cl_num)) - ty val_env met_env par_env + Val_unbound_instance_variable ty val_env met_env par_env in vars := Vars.add lab (id, mut, virt, ty) !vars; result @@ -536,7 +529,7 @@ and class_type_aux env scty = in match scty.pcty_desc with Pcty_constr (lid, styl) -> - let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in + let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in if Path.same decl.clty_path unbound_class then raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); let (params, clty) = @@ -641,8 +634,8 @@ and class_field_aux self_loc cl_num self_type meths vars | Some {txt=name} -> let (_id, val_env, met_env, par_env) = enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s) - sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type - val_env met_env par_env + sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) + Val_unbound_ancestor self_type val_env met_env par_env in (val_env, met_env, par_env,Some name) in @@ -944,7 +937,7 @@ and class_expr cl_num val_env met_env scl = and class_expr_aux cl_num val_env met_env scl = match scl.pcl_desc with Pcl_constr (lid, styl) -> - let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in + let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in if Path.same decl.cty_path unbound_class then raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); let tyl = List.map @@ -1136,14 +1129,14 @@ and class_expr_aux cl_num val_env met_env scl = let ty' = extract_option_type val_env ty and ty0' = extract_option_type val_env ty0 in let arg = type_argument val_env sarg0 ty' ty0' in - Some (option_some arg) + Some (option_some val_env arg) with Not_found -> sargs, more_sargs, if Btype.is_optional l && (List.mem_assoc Nolabel sargs || List.mem_assoc Nolabel more_sargs) then - Some (option_none ty0 Location.none) + Some (option_none val_env ty0 Location.none) else None in let omitted = if arg = None then (l,ty0) :: omitted else omitted in diff --git a/typing/typecore.ml b/typing/typecore.ml index aa92832e6..7dbcd7bad 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -77,7 +77,7 @@ type error = | Private_label of Longident.t * type_expr | Private_constructor of constructor_description * type_expr | Unbound_instance_variable of string * string list - | Instance_variable_not_mutable of bool * string + | Instance_variable_not_mutable of string | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t | Outside_class | Value_multiply_overridden of string @@ -86,7 +86,6 @@ type error = | Too_many_arguments of bool * type_expr * type_forcing_context option | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option | Scoping_let_module of string * type_expr - | Masked_instance_variable of Longident.t | Not_a_variant_type of Longident.t | Incoherent_label_order | Less_general of string * Ctype.Unification_trace.t @@ -229,15 +228,14 @@ let type_option ty = let mkexp exp_desc exp_type exp_loc exp_env = { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } -let option_none ty loc = - let lid = Longident.Lident "None" - and env = Env.initial_safe_string in - let cnone = Env.lookup_constructor lid env in +let option_none env ty loc = + let lid = Longident.Lident "None" in + let cnone = Env.find_ident_constructor Predef.ident_none env in mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env -let option_some texp = +let option_some env texp = let lid = Longident.Lident "Some" in - let csome = Env.lookup_constructor lid Env.initial_safe_string in + let csome = Env.find_ident_constructor Predef.ident_some env in mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) (type_option texp.exp_type) texp.exp_loc texp.exp_env @@ -379,17 +377,13 @@ let reset_pattern scope allow = let maybe_add_pattern_variables_ghost loc_let env pv = List.fold_right - (fun {pv_id; pv_type; _} env -> - let lid = Longident.Lident (Ident.name pv_id) in - match Env.lookup_value ~mark:false lid env with - | _ -> env - | exception Not_found -> - Env.add_value pv_id - { val_type = pv_type; - val_kind = Val_unbound Val_unbound_ghost_recursive; - val_loc = loc_let; - val_attributes = []; - } env + (fun {pv_id; _} env -> + let name = Ident.name pv_id in + if Env.bound_value name env then env + else begin + Env.enter_unbound_value name + (Val_unbound_ghost_recursive loc_let) env + end ) pv env let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty @@ -511,8 +505,7 @@ let rec build_as_type env p = | Tpat_array _ | Tpat_lazy _ | Tpat_exception _ -> p.pat_type let build_or_pat env loc lid = - let path, decl = Typetexp.find_type env lid.loc lid.txt - in + let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in let tyl = List.map (fun _ -> newvar()) decl.type_params in let row0 = let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in @@ -600,11 +593,12 @@ let label_of_kind kind = module NameChoice(Name : sig type t + type usage val type_kind: string val get_name: t -> string val get_type: t -> type_expr - val get_descrs: Env.type_descriptions -> t list - val unbound_name_error: Env.t -> Longident.t loc -> 'a + val lookup_all_from_type: + Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list val in_env: t -> bool end) = struct open Name @@ -614,18 +608,21 @@ end) = struct | Tconstr(p, _, _) -> p | _ -> assert false - let lookup_from_type env tpath lid = - let descrs = get_descrs (Env.find_type_descrs tpath env) in - Env.mark_type_used (Path.last tpath) (Env.find_type tpath env); + let lookup_from_type env tpath usage lid = + let descrs = lookup_all_from_type lid.loc usage tpath env in match lid.txt with - Longident.Lident s -> begin - try - List.find (fun nd -> get_name nd = s) descrs - with Not_found -> - let names = List.map get_name descrs in - raise (Error (lid.loc, env, - Wrong_name ("", mk_expected (newvar ()), - type_kind, tpath, s, names))) + | Longident.Lident s -> begin + match + List.find (fun (nd, _) -> get_name nd = s) descrs + with + | descr, use -> + use (); + descr + | exception Not_found -> + let names = List.map (fun (nd, _) -> get_name nd) descrs in + raise (Error (lid.loc, env, + Wrong_name ("", mk_expected (newvar ()), + type_kind, tpath, s, names))) end | _ -> raise Not_found @@ -647,19 +644,25 @@ end) = struct reset(); strings_of_paths Type tpaths) let disambiguate_by_type env tpath lbls = - let check_type (lbl, _) = - let lbl_tpath = get_type_path lbl in - compare_type_path env tpath lbl_tpath - in - List.find check_type lbls + match lbls with + | (Error _ : _ result) -> raise Not_found + | Ok lbls -> + let check_type (lbl, _) = + let lbl_tpath = get_type_path lbl in + compare_type_path env tpath lbl_tpath + in + List.find check_type lbls - let disambiguate ?(warn=Location.prerr_warning) ?scope lid env opath lbls = + let disambiguate ?(warn=Location.prerr_warning) ?scope + usage lid env opath lbls = let scope = match scope with None -> lbls | Some l -> l in let lbl = match opath with None -> begin match lbls with - [] -> unbound_name_error env lid - | (lbl, use) :: rest -> + | (Error(loc', env', err) : _ result) -> + Env.lookup_error loc' env' err + | Ok [] -> assert false + | Ok((lbl, use) :: rest) -> use (); Printtyp.Conflicts.reset (); let paths = ambiguous_types env lbl rest in @@ -684,8 +687,8 @@ end) = struct if not pr then begin (* Check if non-principal type is affecting result *) match lbls with - [] -> warn_pr () - | (lbl', _use') :: rest -> + | (Error _ : _ result) | Ok [] -> warn_pr () + | Ok ((lbl', _use') :: rest) -> let lbl_tpath = get_type_path lbl' in if not (compare_type_path env tpath lbl_tpath) then warn_pr () else @@ -701,7 +704,7 @@ end) = struct end; lbl with Not_found -> try - let lbl = lookup_from_type env tpath lid in + let lbl = lookup_from_type env tpath usage lid in if in_env lbl then begin let s = @@ -713,22 +716,25 @@ end) = struct if not pr then warn_pr (); lbl with Not_found -> - if lbls = [] then unbound_name_error env lid else - let tp = (tpath0, expand_path env tpath) in - let tpl = - List.map - (fun (lbl, _) -> - let tp0 = get_type_path lbl in - let tp = expand_path env tp0 in - (tp0, tp)) - lbls - in - raise (Error (lid.loc, env, - Name_type_mismatch (type_kind, lid.txt, tp, tpl))) + match lbls with + | (Error(loc', env', err) : _ result) -> + Env.lookup_error loc' env' err + | Ok lbls -> + let tp = (tpath0, expand_path env tpath) in + let tpl = + List.map + (fun (lbl, _) -> + let tp0 = get_type_path lbl in + let tp = expand_path env tp0 in + (tp0, tp)) + lbls + in + raise (Error (lid.loc, env, + Name_type_mismatch (type_kind, lid.txt, tp, tpl))) in if in_env lbl then begin match scope with - (lab1,_)::_ when lab1 == lbl -> () + | Ok ((lab1,_)::_) when lab1 == lbl -> () | _ -> Location.prerr_warning lid.loc (Warnings.Disambiguated_name(get_name lbl)) @@ -742,11 +748,12 @@ let wrap_disambiguate kind ty f x = module Label = NameChoice (struct type t = label_description + type usage = unit let type_kind = "record" let get_name lbl = lbl.lbl_name let get_type lbl = lbl.lbl_res - let get_descrs = snd - let unbound_name_error = Typetexp.unbound_label_error + let lookup_all_from_type loc () path env = + Env.lookup_all_labels_from_type ~loc path env let in_env lbl = match lbl.lbl_repres with | Record_regular | Record_float | Record_unboxed false -> true @@ -791,16 +798,21 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = there is still at least one candidate (for error message) * if the reduced list is valid, call Label.disambiguate *) - let scope = Typetexp.find_all_labels env lid.loc lid.txt in - if opath = None && scope = [] then - Typetexp.unbound_label_error env lid; - let (ok, labels) = - match opath with - Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *) - | _ -> disambiguate_label_by_ids (opath=None) closed ids scope - in - if ok then Label.disambiguate lid env opath labels ~warn ~scope - else fst (List.hd labels) (* will fail later *) + let scope = Env.lookup_all_labels ~loc:lid.loc lid.txt env in + match opath, scope with + | None, Error(loc, env, err) -> + Env.lookup_error loc env err + | Some _, Error _ -> + Label.disambiguate () lid env opath scope ~warn ~scope + | _, Ok lbls -> + let (ok, lbls) = + match opath with + | Some (_, _, true) -> + (true, lbls) (* disambiguate only checks scope *) + | _ -> disambiguate_label_by_ids (opath=None) closed ids lbls + in + if ok then Label.disambiguate () lid env opath (Ok lbls) ~warn ~scope + else fst (List.hd lbls) (* will fail later *) in let lbl_a_list = List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in @@ -902,11 +914,12 @@ let check_recordpat_labels loc lbl_pat_list closed = module Constructor = NameChoice (struct type t = constructor_description + type usage = Env.constructor_usage let type_kind = "variant" let get_name cstr = cstr.cstr_name let get_type cstr = cstr.cstr_res - let get_descrs = fst - let unbound_name_error = Typetexp.unbound_constructor_error + let lookup_all_from_type loc usage path env = + Env.lookup_all_constructors_from_type ~loc usage path env let in_env _ = true end) @@ -1164,19 +1177,17 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode let candidates = match lid.txt, constrs with Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> - [Hashtbl.find constrs s, (fun () -> ())] - | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt + Ok [Hashtbl.find constrs s, (fun () -> ())] + | _ -> + Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in let constr = wrap_disambiguate "This variant pattern is expected to have" (mk_expected expected_ty) - (Constructor.disambiguate lid !env opath) candidates + (Constructor.disambiguate Env.Pattern lid !env opath) candidates in if constr.cstr_generalized && constrs <> None && mode = Inside_or then raise Need_backtrack; - Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; - Builtin_attributes.check_alerts loc constr.cstr_attributes - constr.cstr_name; begin match no_existentials, constr.cstr_existentials with | None, _ | _, [] -> () | Some r, (_ :: _ as exs) -> @@ -1598,12 +1609,8 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = List.fold_right (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} (val_env, met_env, par_env) -> - (Env.add_value pv_id {val_type = pv_type; - val_kind = - Val_unbound Val_unbound_instance_variable; - val_attributes = pv_attributes; - Types.val_loc = pv_loc; - } val_env, + let name = Ident.name pv_id in + (Env.enter_unbound_value name Val_unbound_self val_env, Env.add_value pv_id {val_type = pv_type; val_kind = Val_self (meths, vars, cl_num, privty); @@ -1613,12 +1620,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = ~check:(fun s -> if pv_as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s) met_env, - Env.add_value pv_id {val_type = pv_type; - val_kind = - Val_unbound Val_unbound_instance_variable; - val_attributes = pv_attributes; - Types.val_loc = pv_loc; - } par_env)) + Env.enter_unbound_value name Val_unbound_self par_env)) pv (val_env, met_env, par_env) in (pat, meths, vars, val_env, met_env, par_env) @@ -1821,13 +1823,11 @@ let rec approx_type env sty = | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> - begin try - let path = Env.lookup_type lid.txt env in - let decl = Env.find_type path env in - if List.length ctl <> decl.type_arity then raise Not_found; + let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in + if List.length ctl <> decl.type_arity then newvar () + else begin let tyl = List.map (approx_type env) ctl in newconstr path tyl - with Not_found -> newvar () end | Ptyp_poly (_, sty) -> approx_type env sty @@ -2189,7 +2189,8 @@ and type_expect_ match desc.val_kind with | Val_ivar (_, cl_num) -> let (self_path, _) = - Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env in Texp_instvar(self_path, path, match lid.txt with @@ -2197,22 +2198,9 @@ and type_expect_ | _ -> assert false) | Val_self (_, _, cl_num, _) -> let (path, _) = - Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env in Texp_ident(path, lid, desc) - | Val_unbound Val_unbound_instance_variable -> - raise(Error(loc, env, Masked_instance_variable lid.txt)) - | Val_unbound Val_unbound_ghost_recursive -> - let desc_loc = desc.Types.val_loc in - (* Only display the "missing rec" hint for non-ghost code *) - if not loc.Location.loc_ghost - && not desc_loc.Location.loc_ghost - then - raise Typetexp.(Error ( - loc, env, Unbound_value_missing_rec (lid.txt, desc_loc) - )) - else - raise Typetexp.(Error (loc, env, Unbound_value lid.txt)) | _ -> Texp_ident(path, lid, desc) in @@ -2602,8 +2590,6 @@ and type_expect_ unify_exp env record ty_record; if label.lbl_mut = Immutable then raise(Error(loc, env, Label_not_mutable lid.txt)); - Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes - (Longident.last lid.txt); rue { exp_desc = Texp_setfield(record, label_loc, label, newval); exp_loc = loc; exp_extra = []; @@ -2815,10 +2801,12 @@ and type_expect_ end in begin match - Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env, - Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env + Env.find_value_by_name + (Longident.Lident ("selfpat-" ^ cl_num)) env, + Env.find_value_by_name + (Longident.Lident ("self-" ^cl_num)) env with - (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)), + | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)), (path, _) -> obj_meths := Some meths; let (_, typ) = @@ -2909,7 +2897,7 @@ and type_expect_ Undefined_method (obj.exp_type, met, valid_methods))) end | Pexp_new cl -> - let (cl_path, cl_decl) = Typetexp.find_class env cl.loc cl.txt in + let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in begin match cl_decl.cty_new with None -> raise(Error(loc, env, Virtual_class cl.txt)) @@ -2921,37 +2909,27 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } end - | Pexp_setinstvar (lab, snewval) -> - begin try - let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in - match desc.val_kind with - Val_ivar (Mutable, cl_num) -> - let newval = - type_expect env snewval (mk_expected (instance desc.val_type)) - in - let (path_self, _) = - Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env - in - rue { - exp_desc = Texp_setinstvar(path_self, path, lab, newval); - exp_loc = loc; exp_extra = []; - exp_type = instance Predef.type_unit; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Val_ivar _ -> - raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt))) - | _ -> - raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt))) - with - Not_found -> - let collect_vars name _path val_desc li = - match val_desc.val_kind with - | Val_ivar (Mutable, _) -> name::li - | _ -> li in - let valid_vars = Env.fold_values collect_vars None env [] in - raise(Error(loc, env, - Unbound_instance_variable (lab.txt, valid_vars))) - end + | Pexp_setinstvar (lab, snewval) -> begin + let (path, mut, cl_num, ty) = + Env.lookup_instance_variable ~loc lab.txt env + in + match mut with + | Mutable -> + let newval = + type_expect env snewval (mk_expected (instance ty)) + in + let (path_self, _) = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + rue { + exp_desc = Texp_setinstvar(path_self, path, lab, newval); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + raise(Error(loc, env, Instance_variable_not_mutable lab.txt)) + end | Pexp_override lst -> let _ = List.fold_right @@ -2964,8 +2942,8 @@ and type_expect_ [] in begin match try - Env.lookup_value (Longident.Lident "selfpat-*") env, - Env.lookup_value (Longident.Lident "self-*") env + Env.find_value_by_name (Longident.Lident "selfpat-*") env, + Env.find_value_by_name (Longident.Lident "self-*") env with Not_found -> raise(Error(loc, env, Outside_class)) with @@ -3275,7 +3253,10 @@ and type_expect_ Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _) } ] -> let path = - match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with + let cd = + Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env + in + match cd.cstr_tag with | Cstr_extension (path, _) -> path | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) in @@ -3299,7 +3280,7 @@ and type_expect_ exp_env = env } and type_ident env ?(recarg=Rejected) lid = - let (path, desc) = Typetexp.find_value env lid.loc lid.txt in + let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in if !Clflags.annotations then begin let dloc = desc.Types.val_loc in let annot = @@ -3331,24 +3312,13 @@ and type_binding_op_ident env s = let path, desc = type_ident env lid in let path = match desc.val_kind with - | Val_ivar _ | Val_unbound Val_unbound_instance_variable -> + | Val_ivar _ -> fatal_error "Illegal name for instance variable" | Val_self (_, _, cl_num, _) -> let path, _ = - Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env in path - | Val_unbound Val_unbound_ghost_recursive -> - let desc_loc = desc.Types.val_loc in - (* Only display the "missing rec" hint for non-ghost code *) - if not loc.Location.loc_ghost - && not desc_loc.Location.loc_ghost - then - raise Typetexp.(Error ( - loc, env, Unbound_value_missing_rec (lid.txt, desc_loc) - )) - else - raise Typetexp.(Error (loc, env, Unbound_value lid.txt)) | _ -> path in path, desc @@ -3421,10 +3391,10 @@ and type_label_access env srecord lid = Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal) with Not_found -> None in - let labels = Typetexp.find_all_labels env lid.loc lid.txt in + let labels = Env.lookup_all_labels ~loc:lid.loc lid.txt env in let label = wrap_disambiguate "This expression has" (mk_expected ty_exp) - (Label.disambiguate lid env opath) labels in + (Label.disambiguate () lid env opath) labels in (record, label, opath) (* Typing format strings for printing or reading. @@ -3752,7 +3722,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = let rec make_args args ty_fun = match (expand_head env ty_fun).desc with | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> - let ty = option_none (instance ty_arg) sarg.pexp_loc in + let ty = option_none env (instance ty_arg) sarg.pexp_loc in make_args ((l, Some ty) :: args) ty_fun | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> List.rev args, ty_fun, no_labels ty_res' @@ -3960,9 +3930,10 @@ and type_application env funct sargs = else begin may_warn sarg0.pexp_loc (Warnings.Not_principal "using an optional argument here"); - Some (fun () -> option_some (type_argument ~explanation env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0))) + Some (fun () -> + option_some env (type_argument ~explanation env sarg0 + (extract_option_type env ty) + (extract_option_type env ty0))) end with Not_found -> sargs, more_sargs, @@ -3973,7 +3944,7 @@ and type_application env funct sargs = may_warn funct.exp_loc (Warnings.Without_principality "eliminated optional argument"); ignored := (l,ty,lv) :: !ignored; - Some (fun () -> option_none (instance ty) Location.none) + Some (fun () -> option_none env (instance ty) Location.none) end else begin may_warn funct.exp_loc (Warnings.Without_principality "commuted an argument"); @@ -4029,14 +4000,14 @@ and type_construct env loc lid sarg ty_expected_explained attrs = Some(p0, p, principal) with Not_found -> None in - let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in + let constrs = + Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env + in let constr = wrap_disambiguate "This variant expression is expected to have" ty_expected_explained - (Constructor.disambiguate lid env opath) constrs in - Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; - Builtin_attributes.check_alerts loc constr.cstr_attributes - constr.cstr_name; + (Constructor.disambiguate Env.Positive lid env opath) constrs + in let sargs = match sarg with None -> [] @@ -4653,8 +4624,9 @@ let type_expression env sexp = generalize exp.exp_type; match sexp.pexp_desc with Pexp_ident lid -> + let loc = sexp.pexp_loc in (* Special case for keeping type variables when looking-up a variable *) - let (_path, desc) = Env.lookup_value lid.txt env in + let (_path, desc) = Env.lookup_value ~use:false ~loc lid.txt env in {exp with exp_type = desc.val_type} | _ -> exp @@ -4958,11 +4930,8 @@ let report_error ~loc env = function fprintf ppf "Unbound instance variable %s" var; spellcheck ppf var valid_vars; ) () - | Instance_variable_not_mutable (b, v) -> - if b then - Location.errorf ~loc "The instance variable %s is not mutable" v - else - Location.errorf ~loc "The value %s is not an instance variable" v + | Instance_variable_not_mutable v -> + Location.errorf ~loc "The instance variable %s is not mutable" v | Not_subtype(tr1, tr2) -> Location.error_of_printer ~loc (fun ppf () -> report_subtyping_error ppf env tr1 "is not a subtype of" tr2 @@ -5022,11 +4991,6 @@ let report_error ~loc env = function "This `let module' expression has type@ %a@ \ In this type, the locally bound module name %s escapes its scope" type_expr ty id - | Masked_instance_variable lid -> - Location.errorf ~loc - "The instance variable %a@ \ - cannot be accessed from the definition of another instance variable" - longident lid | Private_type ty -> Location.errorf ~loc "Cannot create values of the private type %a" type_expr ty diff --git a/typing/typecore.mli b/typing/typecore.mli index 4529c4704..27fd59853 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -102,8 +102,8 @@ val type_argument: Env.t -> Parsetree.expression -> type_expr -> type_expr -> Typedtree.expression -val option_some: Typedtree.expression -> Typedtree.expression -val option_none: type_expr -> Location.t -> Typedtree.expression +val option_some: Env.t -> Typedtree.expression -> Typedtree.expression +val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression val extract_option_type: Env.t -> type_expr -> type_expr val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit val generalizable: int -> type_expr -> bool @@ -144,7 +144,7 @@ type error = | Private_label of Longident.t * type_expr | Private_constructor of constructor_description * type_expr | Unbound_instance_variable of string * string list - | Instance_variable_not_mutable of bool * string + | Instance_variable_not_mutable of string | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t | Outside_class | Value_multiply_overridden of string @@ -153,7 +153,6 @@ type error = | Too_many_arguments of bool * type_expr * type_forcing_context option | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option | Scoping_let_module of string * type_expr - | Masked_instance_variable of Longident.t | Not_a_variant_type of Longident.t | Incoherent_label_order | Less_general of string * Ctype.Unification_trace.t diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 58ee4e313..4ad1fb6e8 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -508,9 +508,11 @@ let transl_declaration env sdecl id = Ctype.end_def (); (* Add abstract row *) if is_fixed_type sdecl then begin - let p = - try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env - with Not_found -> assert false in + let p, _ = + try Env.find_type_by_name + (Longident.Lident(Ident.name id ^ "#row")) env + with Not_found -> assert false + in set_fixed_row env sdecl.ptype_loc p decl end; (* Check for cyclic abbreviations *) @@ -888,10 +890,15 @@ let transl_type_decl env rec_flag sdecl_list = let sdecl_list = List.map (fun sdecl -> - let ptype_name = - mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in + let ptype_name = + let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in + mkloc (sdecl.ptype_name.txt ^"#row") loc + in + let ptype_kind = Ptype_abstract in + let ptype_manifest = None in + let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in {sdecl with - ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) + ptype_name; ptype_kind; ptype_manifest; ptype_loc }) fixed_types @ sdecl_list in @@ -1023,12 +1030,8 @@ let transl_extension_constructor env type_path type_params in args, ret_type, Text_decl(targs, tret_type) | Pext_rebind lid -> - let cdescr = Typetexp.find_constructor env lid.loc lid.txt in - let usage = - if cdescr.cstr_private = Private || priv = Public - then Env.Positive else Env.Privatize - in - Env.mark_constructor usage env (Longident.last lid.txt) cdescr; + let usage = if priv = Public then Env.Positive else Env.Privatize in + let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in let (args, cstr_res) = Ctype.instance_constructor cdescr in let res, ret_type = if cdescr.cstr_generalized then @@ -1136,9 +1139,9 @@ let transl_extension_constructor env type_path type_params let transl_type_extension extend env loc styext = reset_type_variables(); Ctype.begin_def(); - let (type_path, type_decl) = + let type_path, type_decl = let lid = styext.ptyext_path in - Typetexp.find_type env lid.loc lid.txt + Env.lookup_type ~loc:lid.loc lid.txt env in begin match type_decl.type_kind with diff --git a/typing/typemod.ml b/typing/typemod.ml index dca91d2eb..97fe26a45 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -105,11 +105,6 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error -let update_location loc = function - Error (_, env, err) -> Error (loc, env, err) - | err -> err -let () = Typetexp.typemod_update_location := update_location - open Typedtree let rec path_concat head p = @@ -137,7 +132,7 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) let type_open_ ?used_slot ?toplevel ovf env loc lid = - let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in + let path = Env.lookup_module_path ~load:true ~loc:lid.loc lid.txt env in match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with | Some env -> path, env | None -> @@ -529,7 +524,7 @@ let merge_constraint initial_env remove_aliases loc sg constr = update_rec_next rs rem | (Sig_module(id, pres, md, rs, priv) :: rem, [s], Pwith_module (_, lid')) when Ident.name id = s -> - let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let path, md' = Env.lookup_module ~loc lid'.txt initial_env in let mty = md'.md_type in let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in let md'' = { md' with md_type = mty } in @@ -539,7 +534,7 @@ let merge_constraint initial_env remove_aliases loc sg constr = Sig_module(id, pres, newmd, rs, priv) :: rem | (Sig_module(id, _, md, rs, _) :: rem, [s], Pwith_modsubst (_, lid')) when Ident.name id = s -> - let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let path, md' = Env.lookup_module ~loc lid'.txt initial_env in let aliasable = not (Env.is_functor_arg path env) in let newmd = Mtype.strengthen_decl ~aliasable env md' path in ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); @@ -598,8 +593,8 @@ let merge_constraint initial_env remove_aliases loc sg constr = in match type_decl_is_alias sdecl with | Some lid -> - let replacement = - try Env.lookup_type lid.txt initial_env + let replacement, _ = + try Env.find_type_by_name lid.txt initial_env with Not_found -> assert false in fun s path -> Subst.add_type_path path replacement s @@ -678,11 +673,16 @@ let map_ext fn exts rem = let rec approx_modtype env smty = match smty.pmty_desc with Pmty_ident lid -> - let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in + let (path, _info) = + Env.lookup_modtype ~use:false ~loc:smty.pmty_loc lid.txt env + in Mty_ident path | Pmty_alias lid -> - let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in - Mty_alias path + let path = + Env.lookup_module_path ~use:false ~load:false + ~loc:smty.pmty_loc lid.txt env + in + Mty_alias(path) | Pmty_signature ssg -> Mty_signature(approx_sig env ssg) | Pmty_functor(param, sarg, sres) -> @@ -705,9 +705,9 @@ let rec approx_modtype env smty = | Pwith_module (_, lid') -> (* Lookup the module to make sure that it is not recursive. (GPR#1626) *) - ignore (Typetexp.find_module env lid'.loc lid'.txt) + ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env) | Pwith_modsubst (_, lid') -> - ignore (Typetexp.find_module env lid'.loc lid'.txt)) + ignore (Env.lookup_module ~use:false ~loc:lid'.loc lid'.txt env)) constraints; body | Pmty_typeof smod -> @@ -749,7 +749,8 @@ and approx_sig env ssg = let scope = Ctype.create_scope () in let id = Ident.create_scoped ~scope pms.pms_name.txt in let _, md = - Typetexp.find_module env pms.pms_manifest.loc pms.pms_manifest.txt + Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc + pms.pms_manifest.txt env in let pres = match md.Types.md_type with @@ -1065,11 +1066,11 @@ let has_remove_aliases_attribute attr = (* Check and translate a module type expression *) let transl_modtype_longident loc env lid = - let (path, _info) = Typetexp.find_modtype env loc lid in + let (path, _info) = Env.lookup_modtype ~loc lid env in path let transl_module_alias loc env lid = - Typetexp.lookup_module env loc lid + Env.lookup_module_path ~load:false ~loc lid env let mkmty desc typ env loc attrs = let mty = { @@ -1265,7 +1266,8 @@ and transl_signature env sg = let scope = Ctype.create_scope () in let id = Ident.create_scoped ~scope pms.pms_name.txt in let path, md = - Typetexp.find_module env pms.pms_manifest.loc pms.pms_manifest.txt + Env.lookup_module ~loc:pms.pms_manifest.loc + pms.pms_manifest.txt env in let aliasable = not (Env.is_functor_arg path env) in let md = @@ -1479,18 +1481,11 @@ and transl_recmodule_modtypes env sdecls = List.map (fun x -> Ident.create_scoped ~scope x.pmd_name.txt) sdecls in let approx_env = - (* - cf #5965 - We use a dummy module type in order to detect a reference to one - of the module being defined during the call to approx_modtype. - It will be detected in Env.lookup_module. - *) List.fold_left (fun env id -> - let dummy = - Mty_ident (Path.Pident (Ident.create_scoped ~scope "#recmod#")) - in - Env.add_module ~arg:true id Mp_present dummy env + (* cf #5965 *) + Env.enter_unbound_module (Ident.name id) + Mod_unbound_illegal_recursion env ) env ids in @@ -1718,16 +1713,14 @@ let rec package_constraints env loc mty constrs = Mty_signature sg' let modtype_of_package env loc p nl tl = - try match (Env.find_modtype p env).mtd_type with + match (Env.find_modtype p env).mtd_type with | Some mty when nl <> [] -> package_constraints env loc mty (List.combine (List.map Longident.flatten nl) tl) | _ -> if nl = [] then Mty_ident p else raise(Error(loc, env, Signature_expected)) - with Not_found -> - let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in - raise(Typetexp.Error(loc, env, error)) + | exception Not_found -> assert false let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = let mkmty p nl tl = @@ -1767,7 +1760,8 @@ and type_module_aux ~alias sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> let path = - Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in + Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env + in let md = { mod_desc = Tmod_ident (path, lid); mod_type = Mty_alias path; mod_env = env; @@ -2331,7 +2325,7 @@ let type_module_type_of env smod = let tmty = match smod.pmod_desc with | Pmod_ident lid -> (* turn off strengthening in this case *) - let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in + let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in rm { mod_desc = Tmod_ident (path, lid); mod_type = md.md_type; mod_env = env; diff --git a/typing/types.ml b/typing/types.ml index aa49e2e95..24012dd8c 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -104,11 +104,6 @@ and value_kind = (* Self *) | Val_anc of (string * Ident.t) list * string (* Ancestor *) - | Val_unbound of value_unbound_reason (* Unbound variable *) - -and value_unbound_reason = - | Val_unbound_instance_variable - | Val_unbound_ghost_recursive (* Variance *) diff --git a/typing/types.mli b/typing/types.mli index 87b082b66..80010b62c 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -264,11 +264,6 @@ and value_kind = (* Self *) | Val_anc of (string * Ident.t) list * string (* Ancestor *) - | Val_unbound of value_unbound_reason (* Unbound variable *) - -and value_unbound_reason = - | Val_unbound_instance_variable - | Val_unbound_ghost_recursive (* Variance *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index cf9a3a51c..9784b73d7 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -28,8 +28,7 @@ exception Already_bound type error = Unbound_type_variable of string - | Unbound_type_constructor of Longident.t - | Unbound_type_constructor_2 of Path.t + | Undefined_type_constructor of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string | Recursive_type @@ -45,26 +44,8 @@ type error = | Cannot_quantify of string * type_expr | Multiple_constraints_on_type of Longident.t | Method_mismatch of string * type_expr * type_expr - | Unbound_value of Longident.t - | Unbound_constructor of Longident.t - | Unbound_label of Longident.t - | Unbound_module of Longident.t - | Unbound_class of Longident.t - | Unbound_modtype of Longident.t - | Unbound_cltype of Longident.t - | Ill_typed_functor_application - of Longident.t * Longident.t * Includemod.error list option - | Illegal_reference_to_recursive_module - | Wrong_use_of_module of Longident.t * [ `Structure_used_as_functor - | `Abstract_used_as_functor - | `Functor_used_as_structure - | `Abstract_used_as_structure - | `Generative_used_as_applicative - ] - | Cannot_scrape_alias of Longident.t * Path.t | Opened_object of Path.t option | Not_an_object of type_expr - | Unbound_value_missing_rec of Longident.t * Location.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -74,149 +55,6 @@ module TyVarMap = Misc.Stdlib.String.Map type variable_context = int * type_expr TyVarMap.t -(* To update locations from Typemod.check_well_founded_module. *) - -let typemod_update_location = ref (fun _ -> assert false) - -(* Narrowing unbound identifier errors. *) - -let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = - fun env loc lid make_error -> - let check_module mlid = - try ignore (Env.lookup_module ~load:true mlid env) with - | Not_found -> - narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid) - | Env.Recmodule -> - raise (Error (loc, env, Illegal_reference_to_recursive_module)) - in - let error e = raise (Error (loc, env, e)) in - begin match lid with - | Longident.Lident _ -> () - | Longident.Ldot (mlid, _) -> - check_module mlid; - let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in - begin match Env.scrape_alias env md.md_type with - | Mty_functor _ -> - error (Wrong_use_of_module (mlid, `Functor_used_as_structure)) - | Mty_ident _ -> - error (Wrong_use_of_module (mlid, `Abstract_used_as_structure)) - | Mty_alias p -> error (Cannot_scrape_alias(mlid, p)) - | Mty_signature _ -> () - end - | Longident.Lapply (flid, mlid) -> - check_module flid; - let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in - let mty_param = - match Env.scrape_alias env fmd.md_type with - | Mty_signature _ -> - error (Wrong_use_of_module (flid, `Structure_used_as_functor)) - | Mty_ident _ -> - error (Wrong_use_of_module (flid, `Abstract_used_as_functor)) - | Mty_alias p -> error (Cannot_scrape_alias(flid, p)) - | Mty_functor (_, None, _) -> - error (Wrong_use_of_module (flid, `Generative_used_as_applicative)) - | Mty_functor (_, Some mty_param, _) -> mty_param - in - check_module mlid; - let mpath = Env.lookup_module ~load:true mlid env in - let mmd = Env.find_module mpath env in - begin match Env.scrape_alias env mmd.md_type with - | Mty_alias p -> error (Cannot_scrape_alias(mlid, p)) - | mty_arg -> - let details = - try Includemod.check_modtype_inclusion - ~loc env mty_arg mpath mty_param; - None (* should be impossible *) - with Includemod.Error e -> Some e - in - error (Ill_typed_functor_application (flid, mlid, details)) - end - end; - error (make_error lid) - -let find_component (lookup : ?loc:_ -> ?mark:_ -> _) make_error env loc lid = - try - match lid with - | Longident.Ldot (Longident.Lident "*predef*", s) -> - lookup ~loc (Longident.Lident s) Env.initial_safe_string - | _ -> - lookup ~loc lid env - with Not_found -> - narrow_unbound_lid_error env loc lid make_error - | Env.Recmodule -> - raise (Error (loc, env, Illegal_reference_to_recursive_module)) - | err -> - raise (!typemod_update_location loc err) - -let find_type env loc lid = - let path = - find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid) - env loc lid - in - let decl = Env.find_type path env in - Builtin_attributes.check_alerts loc decl.type_attributes (Path.name path); - (path, decl) - -let find_constructor = - find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) -let find_all_constructors = - find_component Env.lookup_all_constructors - (fun lid -> Unbound_constructor lid) -let find_label = - find_component Env.lookup_label (fun lid -> Unbound_label lid) -let find_all_labels = - find_component Env.lookup_all_labels (fun lid -> Unbound_label lid) - -let find_class env loc lid = - let (path, decl) as r = - find_component Env.lookup_class (fun lid -> Unbound_class lid) env loc lid - in - Builtin_attributes.check_alerts loc decl.cty_attributes (Path.name path); - r - -let find_value env loc lid = - Env.check_value_name (Longident.last lid) loc; - let (path, decl) as r = - find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid - in - Builtin_attributes.check_alerts loc decl.val_attributes (Path.name path); - r - -let lookup_module ?(load=false) env loc lid = - find_component - (fun ?loc ?mark lid env -> (Env.lookup_module ~load ?loc ?mark lid env)) - (fun lid -> Unbound_module lid) env loc lid - -let find_module env loc lid = - let path = lookup_module ~load:true env loc lid in - let decl = Env.find_module path env in - (* No need to check for alerts here, this is done in Env. *) - (path, decl) - -let find_modtype env loc lid = - let (path, decl) as r = - find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid) - env loc lid - in - Builtin_attributes.check_alerts loc decl.mtd_attributes (Path.name path); - r - -let find_class_type env loc lid = - let (path, decl) as r = - find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) - env loc lid - in - Builtin_attributes.check_alerts loc decl.clty_attributes (Path.name path); - r - -let unbound_constructor_error env lid = - narrow_unbound_lid_error env lid.loc lid.txt - (fun lid -> Unbound_constructor lid) - -let unbound_label_error env lid = - narrow_unbound_lid_error env lid.loc lid.txt - (fun lid -> Unbound_label lid) - (* Support for first-class modules. *) let transl_modtype_longident = ref (fun _ -> assert false) @@ -375,7 +213,7 @@ and transl_type_aux env policy styp = let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in ctyp (Ttyp_tuple ctys) ty | Ptyp_constr(lid, stl) -> - let (path, decl) = find_type env lid.loc lid.txt in + let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in let stl = match stl with | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 -> @@ -415,8 +253,7 @@ and transl_type_aux env policy styp = | Ptyp_class(lid, stl) -> let (path, decl, _is_variant) = try - let path = Env.lookup_type lid.txt env in - let decl = Env.find_type path env in + let path, decl = Env.find_type_by_name lid.txt env in let rec check decl = match decl.type_manifest with None -> raise Not_found @@ -437,11 +274,10 @@ and transl_type_aux env policy styp = | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" in - let path = Env.lookup_type lid2 env in - let decl = Env.find_type path env in + let path, decl = Env.find_type_by_name lid2 env in (path, decl, false) with Not_found -> - ignore (find_class env lid.loc lid.txt); assert false + ignore (Env.lookup_class ~loc:lid.loc lid.txt env); assert false in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, env, @@ -598,7 +434,7 @@ and transl_type_aux env policy styp = let row = Btype.row_repr row in row.row_fields | {desc=Tvar _}, Some(p, _) -> - raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p)) + raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p)) | _ -> raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) in @@ -742,7 +578,7 @@ and transl_fields env policy o fields = OTinherit cty end | {desc=Tvar _}, Some p -> - raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p)) + raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p)) | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t)) end in { of_desc; of_loc; of_attributes; } @@ -867,38 +703,6 @@ let transl_type_scheme env styp = open Format open Printtyp -let spellcheck ppf fold env lid = - let choices ~path name = - let env = fold (fun x xs -> x::xs) path env [] in - Misc.spellcheck env name in - match lid with - | Longident.Lapply _ -> () - | Longident.Lident s -> - Misc.did_you_mean ppf (fun () -> choices ~path:None s) - | Longident.Ldot (r, s) -> - Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) - -let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc) -let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc) - -let fold_values f = - (* We only use "real" values while spellchecking (as opposed to "ghost" - values inserted in the environment to trigger the "missing rec" hint). - This is needed in order to avoid dummy suggestions like: - "unbound value x, did you mean x?" *) - Env.fold_values - (fun name _path descr acc -> - match descr.val_kind with - | Val_unbound _ -> acc - | _ -> f name acc) -let fold_types = fold_simple Env.fold_types -let fold_modules = fold_simple Env.fold_modules -let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name) -let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name) -let fold_classes = fold_simple Env.fold_classes -let fold_modtypes = fold_simple Env.fold_modtypes -let fold_cltypes = fold_simple Env.fold_cltypes - let report_error env ppf = function | Unbound_type_variable name -> let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in @@ -906,10 +710,7 @@ let report_error env ppf = function fprintf ppf "The type variable %s is unbound in this type declaration.@ %a" name did_you_mean (fun () -> Misc.spellcheck names name ) - | Unbound_type_constructor lid -> - fprintf ppf "Unbound type constructor %a" longident lid; - spellcheck ppf fold_types env lid; - | Unbound_type_constructor_2 p -> + | Undefined_type_constructor p -> fprintf ppf "The type constructor@ %a@ is not yet completely defined" path p | Type_arity_mismatch(lid, expected, provided) -> @@ -990,58 +791,6 @@ let report_error env ppf = function Printtyp.reset_and_mark_loops_list [ty; ty']; fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" l Printtyp.type_expr ty Printtyp.type_expr ty') - | Unbound_value lid -> - fprintf ppf "Unbound value %a" longident lid; - spellcheck ppf fold_values env lid; - | Unbound_module lid -> - fprintf ppf "Unbound module %a" longident lid; - spellcheck ppf fold_modules env lid; - | Unbound_constructor lid -> - fprintf ppf "Unbound constructor %a" longident lid; - spellcheck ppf fold_constructors env lid; - | Unbound_label lid -> - fprintf ppf "Unbound record field %a" longident lid; - spellcheck ppf fold_labels env lid; - | Unbound_class lid -> - fprintf ppf "Unbound class %a" longident lid; - spellcheck ppf fold_classes env lid; - | Unbound_modtype lid -> - fprintf ppf "Unbound module type %a" longident lid; - spellcheck ppf fold_modtypes env lid; - | Unbound_cltype lid -> - fprintf ppf "Unbound class type %a" longident lid; - spellcheck ppf fold_cltypes env lid; - | Ill_typed_functor_application (flid, mlid, details) -> - (match details with - | None -> - fprintf ppf "@[Ill-typed functor application %a(%a)@]" - longident flid longident mlid - | Some inclusion_error -> - fprintf ppf "@[The type of %a does not match %a's parameter@\n%a@]" - longident mlid longident flid Includemod.report_error inclusion_error) - | Illegal_reference_to_recursive_module -> - fprintf ppf "Illegal recursive module reference" - | Wrong_use_of_module (lid, details) -> - (match details with - | `Structure_used_as_functor -> - fprintf ppf "@[The module %a is a structure, it cannot be applied@]" - longident lid - | `Abstract_used_as_functor -> - fprintf ppf "@[The module %a is abstract, it cannot be applied@]" - longident lid - | `Functor_used_as_structure -> - fprintf ppf "@[The module %a is a functor, \ - it cannot have any components@]" longident lid - | `Abstract_used_as_structure -> - fprintf ppf "@[The module %a is abstract, \ - it cannot have any components@]" longident lid - | `Generative_used_as_applicative -> - fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ - applied@ in@ type@ expressions@]" longident lid) - | Cannot_scrape_alias(lid, p) -> - fprintf ppf - "The module %a is an alias for module %a, which is missing" - longident lid path p | Opened_object nm -> fprintf ppf "Illegal open object type%a" @@ -1052,16 +801,6 @@ let report_error env ppf = function Printtyp.reset_and_mark_loops ty; fprintf ppf "@[The type %a@ is not an object type@]" Printtyp.type_expr ty - | Unbound_value_missing_rec (lid, loc) -> - fprintf ppf - "Unbound value %a" longident lid; - spellcheck ppf fold_values env lid; - let (_, line, _) = Location.get_pos_info loc.Location.loc_start in - fprintf ppf - "@.@[%s@ %s %i@]" - "Hint: If this is a recursive definition," - "you should add the 'rec' keyword on line" - line let () = Location.register_error_of_exn diff --git a/typing/typetexp.mli b/typing/typetexp.mli index d726019b6..5475abbc3 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -42,8 +42,7 @@ exception Already_bound type error = Unbound_type_variable of string - | Unbound_type_constructor of Longident.t - | Unbound_type_constructor_2 of Path.t + | Undefined_type_constructor of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string | Recursive_type @@ -59,26 +58,8 @@ type error = | Cannot_quantify of string * type_expr | Multiple_constraints_on_type of Longident.t | Method_mismatch of string * type_expr * type_expr - | Unbound_value of Longident.t - | Unbound_constructor of Longident.t - | Unbound_label of Longident.t - | Unbound_module of Longident.t - | Unbound_class of Longident.t - | Unbound_modtype of Longident.t - | Unbound_cltype of Longident.t - | Ill_typed_functor_application - of Longident.t * Longident.t * Includemod.error list option - | Illegal_reference_to_recursive_module - | Wrong_use_of_module of Longident.t * [ `Structure_used_as_functor - | `Abstract_used_as_functor - | `Functor_used_as_structure - | `Abstract_used_as_structure - | `Generative_used_as_applicative - ] - | Cannot_scrape_alias of Longident.t * Path.t | Opened_object of Path.t option | Not_an_object of type_expr - | Unbound_value_missing_rec of Longident.t * Location.t exception Error of Location.t * Env.t * error @@ -93,34 +74,3 @@ val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (Longident.t Asttypes.loc * Parsetree.core_type) list * Parsetree.module_type - -val find_type: - Env.t -> Location.t -> Longident.t -> Path.t * type_declaration -val find_constructor: - Env.t -> Location.t -> Longident.t -> constructor_description -val find_all_constructors: - Env.t -> Location.t -> Longident.t -> - (constructor_description * (unit -> unit)) list -val find_label: - Env.t -> Location.t -> Longident.t -> label_description -val find_all_labels: - Env.t -> Location.t -> Longident.t -> - (label_description * (unit -> unit)) list -val find_value: - Env.t -> Location.t -> Longident.t -> Path.t * value_description -val find_class: - Env.t -> Location.t -> Longident.t -> Path.t * class_declaration -val find_module: - Env.t -> Location.t -> Longident.t -> Path.t * module_declaration -val lookup_module: - ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t -val find_modtype: - Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration -val find_class_type: - Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration - -val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a -val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a - -(* To update location from typemod errors *) -val typemod_update_location: (Location.t -> exn -> exn) ref diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 880974fd0..34f465e53 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -108,11 +108,8 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} let fresh_name s env = let rec aux i = let name = s ^ Int.to_string i in - try - let _ = Env.lookup_value (Lident name) env in - name - with - | Not_found -> aux (i+1) + if Env.bound_value name env then aux (i+1) + else name in aux 0 diff --git a/utils/misc.ml b/utils/misc.ml index 681fad1b5..f42b79350 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -918,13 +918,13 @@ module EnvLazy = struct | Raise e -> raise e | Thunk e -> match f e with - | None -> - x := Done None; + | (Error _ as err : _ result) -> + x := Done err; log := Cons(x, e, !log); - None - | Some _ as y -> - x := Done y; - y + err + | Ok _ as res -> + x := Done res; + res | exception e -> x := Raise e; raise e diff --git a/utils/misc.mli b/utils/misc.mli index a112a3663..1e24039af 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -475,11 +475,13 @@ module EnvLazy: sig val create_forced : 'b -> ('a, 'b) t val create_failed : exn -> ('a, 'b) t - (* [force_logged log f t] is equivalent to [force f t] but if [f] returns - [None] then [t] is recorded in [log]. [backtrack log] will then reset all - the recorded [t]s back to their original state. *) + (* [force_logged log f t] is equivalent to [force f t] but if [f] + returns [Error _] then [t] is recorded in [log]. [backtrack log] + will then reset all the recorded [t]s back to their original + state. *) val log : unit -> log - val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option + val force_logged : + log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result val backtrack : log -> unit end