Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Refactor environment lookup functions

master
Leo White 2018-10-12 10:20:21 +01:00
parent 27f621da75
commit c19e8b2350
34 changed files with 2133 additions and 1737 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
debugger/eval.ml
View File

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

35
debugger/loadprinter.ml
View File

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

2
lambda/lambda.ml
View File

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

2
lambda/matching.ml
View File

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

52
testsuite/tests/basic/patmatch_split_no_or.ml
View File

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

12
testsuite/tests/generalized-open/gpr1506.ml
View File

@ -100,9 +100,9 @@ include struct open struct type t = T end let x = T end
Line 1, characters 15-41: Line 1, characters 15-41:
1 | include struct open struct type t = T end let x = T end 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: 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 module A = struct
@ -120,9 +120,9 @@ Lines 3-6, characters 4-7:
4 | type t = T 4 | type t = T
5 | let x = T 5 | let x = T
6 | end 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: 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 module A = struct
@ -139,9 +139,9 @@ Lines 3-5, characters 4-7:
3 | ....open struct 3 | ....open struct
4 | type t = T 4 | type t = T
5 | end 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: 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. *) (* It was decided to not allow this anymore. *)

12
testsuite/tests/messages/precise_locations.ml
View File

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

10
testsuite/tests/typing-objects/Tests.ml
View File

@ -931,8 +931,8 @@ class a = object (self) val x = self#m method m = 3 end;;
Line 1, characters 32-36: Line 1, characters 32-36:
1 | class a = object (self) val x = self#m method m = 3 end;; 1 | class a = object (self) val x = self#m method m = 3 end;;
^^^^ ^^^^
Error: The instance variable self Error: The self variable self
cannot be accessed from the definition of another instance variable cannot be accessed from the definition of an instance variable
|}];; |}];;
class a = object method m = 3 end class a = object method m = 3 end
@ -942,8 +942,6 @@ class a : object method m : int end
Line 2, characters 44-49: Line 2, characters 44-49:
2 | class b = object inherit a as super val x = super#m end;; 2 | class b = object inherit a as super val x = super#m end;;
^^^^^ ^^^^^
Error: The instance variable super Error: The ancestor variable super
cannot be accessed from the definition of another instance variable cannot be accessed from the definition of an instance variable
|}];; |}];;

24
testsuite/tests/typing-warnings/open_warnings.ml
View File

@ -43,9 +43,9 @@ Line 2, characters 2-13:
2 | type t0 = A (* unused type and constructor *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^^^^^^^^^^^
Warning 34: unused type t0. Warning 34: unused type t0.
Line 2, characters 2-13: Line 2, characters 12-13:
2 | type t0 = A (* unused type and constructor *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^
Warning 37: unused constructor A. Warning 37: unused constructor A.
module T3 : sig end 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 *) 3 | module M = struct type t = A end (* unused type and constructor *)
^^^^^^^^^^ ^^^^^^^^^^
Warning 34: unused type t. 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 *) 3 | module M = struct type t = A end (* unused type and constructor *)
^^^^^^^^^^ ^
Warning 37: unused constructor A. Warning 37: unused constructor A.
Line 4, characters 2-8: Line 4, characters 2-8:
4 | open M (* unused open; no shadowing (A below refers to the one in t0) *) 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 *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^^^^^^^^^^^
Warning 34: unused type t0. Warning 34: unused type t0.
Line 2, characters 2-13: Line 2, characters 12-13:
2 | type t0 = A (* unused type and constructor *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^
Warning 37: unused constructor A. Warning 37: unused constructor A.
module T5 : sig end module T5 : sig end
|}] |}]
@ -131,9 +131,9 @@ Line 2, characters 2-13:
2 | type t0 = A (* unused type and constructor *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^^^^^^^^^^^
Warning 34: unused type t0. Warning 34: unused type t0.
Line 2, characters 2-13: Line 2, characters 12-13:
2 | type t0 = A (* unused type and constructor *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^
Warning 37: unused constructor A. Warning 37: unused constructor A.
module T3_bis : sig end 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 *) 3 | module M = struct type t = A end (* unused type and constructor *)
^^^^^^^^^^ ^^^^^^^^^^
Warning 34: unused type t. 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 *) 3 | module M = struct type t = A end (* unused type and constructor *)
^^^^^^^^^^ ^
Warning 37: unused constructor A. Warning 37: unused constructor A.
Line 4, characters 2-9: Line 4, characters 2-9:
4 | open! M (* unused open; no shadowing (A below refers to the one in t0) *) 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 *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^^^^^^^^^^^
Warning 34: unused type t0. Warning 34: unused type t0.
Line 2, characters 2-13: Line 2, characters 12-13:
2 | type t0 = A (* unused type and constructor *) 2 | type t0 = A (* unused type and constructor *)
^^^^^^^^^^^ ^
Warning 37: unused constructor A. Warning 37: unused constructor A.
module T5_bis : sig end module T5_bis : sig end
|}] |}]

34
testsuite/tests/typing-warnings/unused_types.ml
View File

@ -40,9 +40,9 @@ Line 3, characters 2-27:
3 | type unused = A of unused 3 | type unused = A of unused
^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 34: unused type unused. Warning 34: unused type unused.
Line 3, characters 2-27: Line 3, characters 16-27:
3 | type unused = A of unused 3 | type unused = A of unused
^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^
Warning 37: unused constructor A. Warning 37: unused constructor A.
module Unused_rec : sig end module Unused_rec : sig end
|}] |}]
@ -66,9 +66,9 @@ end = struct
end end
;; ;;
[%%expect {| [%%expect {|
Line 4, characters 2-12: Line 4, characters 11-12:
4 | type t = T 4 | type t = T
^^^^^^^^^^ ^
Warning 37: unused constructor T. Warning 37: unused constructor T.
module Unused_constructor : sig type t end module Unused_constructor : sig type t end
|}] |}]
@ -83,9 +83,9 @@ end = struct
end end
;; ;;
[%%expect {| [%%expect {|
Line 5, characters 2-12: Line 5, characters 11-12:
5 | type t = T 5 | type t = T
^^^^^^^^^^ ^
Warning 37: constructor T is never used to build values. Warning 37: constructor T is never used to build values.
(However, this constructor appears in patterns.) (However, this constructor appears in patterns.)
module Unused_constructor_outside_patterns : module Unused_constructor_outside_patterns :
@ -99,9 +99,9 @@ end = struct
end end
;; ;;
[%%expect {| [%%expect {|
Line 4, characters 2-12: Line 4, characters 11-12:
4 | type t = T 4 | type t = T
^^^^^^^^^^ ^
Warning 37: constructor T is never used to build values. Warning 37: constructor T is never used to build values.
Its type is exported as a private type. Its type is exported as a private type.
module Unused_constructor_exported_private : sig type t = private T end module Unused_constructor_exported_private : sig type t = private T end
@ -117,11 +117,6 @@ end = struct
end end
;; ;;
[%%expect {| [%%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 module Used_private_constructor : sig type t val nothing : t -> unit end
|}] |}]
@ -132,9 +127,9 @@ end = struct
end end
;; ;;
[%%expect {| [%%expect {|
Line 4, characters 2-20: Line 4, characters 19-20:
4 | type t = private T 4 | type t = private T
^^^^^^^^^^^^^^^^^^ ^
Warning 37: unused constructor T. Warning 37: unused constructor T.
module Unused_private_constructor : sig type t end module Unused_private_constructor : sig type t end
|}] |}]
@ -285,11 +280,6 @@ end = struct
end end
;; ;;
[%%expect {| [%%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 module Used_private_extension : sig type t val nothing : t -> unit end
|}] |}]
@ -337,9 +327,9 @@ end = struct
type t = A [@@warning "-34"] type t = A [@@warning "-34"]
end;; end;;
[%%expect {| [%%expect {|
Line 3, characters 2-30: Line 3, characters 11-12:
3 | type t = A [@@warning "-34"] 3 | type t = A [@@warning "-34"]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^
Warning 37: unused constructor A. Warning 37: unused constructor A.
module Unused_type_disable_warning : sig end module Unused_type_disable_warning : sig end
|}] |}]

21
toplevel/genprintval.ml
View File

@ -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 it comes from. Attempt to omit the prefix if the type comes from
a module that has been opened. *) 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 match ty_path with
| Pident _ -> | Pident _ ->
Oide_ident name Oide_ident name
| Pdot(p, _s) -> | Pdot(p, _s) ->
if try if
match (lookup_fun (Lident (Out_name.print name)) env).desc with match (find (Lident (Out_name.print name)) env).desc with
| Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
| _ -> false | _ -> false
with Not_found -> false | exception Not_found -> false
then Oide_ident name then Oide_ident name
else Oide_dot (Printtyp.tree_of_path p, Out_name.print name) else Oide_dot (Printtyp.tree_of_path p, Out_name.print name)
| Papply _ -> | Papply _ ->
@ -214,10 +214,13 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
let tree_of_constr = let tree_of_constr =
tree_of_qualified 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 = 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 *) (* An abstract type *)
@ -548,7 +551,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
try try
(* Attempt to recover the constructor description for the exn (* Attempt to recover the constructor description for the exn
from its name *) from its name *)
let cstr = Env.lookup_constructor lid env in let cstr = Env.find_constructor_by_name lid env in
let path = let path =
match cstr.cstr_tag with match cstr.cstr_tag with
Cstr_extension(p, _) -> p Cstr_extension(p, _) -> p

42
toplevel/opttopdirs.ml
View File

@ -125,11 +125,15 @@ type 'a printer_type_old = 'a -> unit
let match_printer_type ppf desc typename = let match_printer_type ppf desc typename =
let printer_type = let printer_type =
try match
Env.lookup_type (Ldot(Lident "Opttopdirs", typename)) !toplevel_env Env.find_type_by_name
with Not_found -> (Ldot(Lident "Opttopdirs", typename)) !toplevel_env
fprintf ppf "Cannot find type Topdirs.%s.@." typename; with
raise Exit in | (path, _) -> path
| exception Not_found ->
fprintf ppf "Cannot find type Topdirs.%s.@." typename;
raise Exit
in
Ctype.begin_def(); Ctype.begin_def();
let ty_arg = Ctype.newvar() in let ty_arg = Ctype.newvar() in
Ctype.unify !toplevel_env Ctype.unify !toplevel_env
@ -140,22 +144,22 @@ let match_printer_type ppf desc typename =
ty_arg ty_arg
let find_printer_type ppf lid = let find_printer_type ppf lid =
try match Env.find_value_by_name lid !toplevel_env with
let (path, desc) = Env.lookup_value lid !toplevel_env in | (path, desc) -> begin
let (ty_arg, is_old_style) = match match_printer_type ppf desc "printer_type_new" with
try | ty_arg -> (ty_arg, path, false)
(match_printer_type ppf desc "printer_type_new", false) | exception Ctype.Unify _ -> begin
with Ctype.Unify _ -> match match_printer_type ppf desc "printer_type_old" with
(match_printer_type ppf desc "printer_type_old", true) in | ty_arg -> (ty_arg, path, true)
(ty_arg, path, is_old_style) | exception Ctype.Unify _ ->
with fprintf ppf "%a has a wrong type for a printing function.@."
| Not_found -> Printtyp.longident lid;
raise Exit
end
end
| exception Not_found ->
fprintf ppf "Unbound value %a.@." Printtyp.longident lid; fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
raise Exit 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 = let dir_install_printer ppf lid =
try try

158
toplevel/topdirs.ml
View File

@ -280,11 +280,15 @@ type 'a printer_type_old = 'a -> unit
let printer_type ppf typename = let printer_type ppf typename =
let printer_type = let printer_type =
try match
Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env Env.find_type_by_name
with Not_found -> (Ldot(Lident "Topdirs", typename)) !toplevel_env
fprintf ppf "Cannot find type Topdirs.%s.@." typename; with
raise Exit in | path, _ -> path
| exception Not_found ->
fprintf ppf "Cannot find type Topdirs.%s.@." typename;
raise Exit
in
printer_type printer_type
let match_simple_printer_type desc printer_type = let match_simple_printer_type desc printer_type =
@ -333,18 +337,18 @@ let match_printer_type ppf desc =
false) false)
let find_printer_type ppf lid = let find_printer_type ppf lid =
try match Env.find_value_by_name lid !toplevel_env with
let (path, desc) = Env.lookup_value lid !toplevel_env in | (path, desc) -> begin
let (ty_arg, is_old_style) = match_printer_type ppf desc in match match_printer_type ppf desc with
(ty_arg, path, is_old_style) | (ty_arg, is_old_style) -> (ty_arg, path, is_old_style)
with | exception Ctype.Unify _ ->
| 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.@." fprintf ppf "%a has a wrong type for a printing function.@."
Printtyp.longident lid; Printtyp.longident lid;
raise Exit raise Exit
end
| exception Not_found ->
fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
raise Exit
let dir_install_printer ppf lid = let dir_install_printer ppf lid =
try try
@ -407,59 +411,60 @@ let tracing_function_ptr =
(Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
let dir_trace ppf lid = let dir_trace ppf lid =
try match Env.find_value_by_name lid !toplevel_env with
let (path, desc) = Env.lookup_value lid !toplevel_env in | (path, desc) -> begin
(* Check if this is a primitive *) (* Check if this is a primitive *)
match desc.val_kind with match desc.val_kind with
| Val_prim _ -> | Val_prim _ ->
fprintf ppf "%a is an external function and cannot be traced.@." fprintf ppf "%a is an external function and cannot be traced.@."
Printtyp.longident lid Printtyp.longident lid
| _ -> | _ ->
let clos = eval_value_path !toplevel_env path in let clos = eval_value_path !toplevel_env path in
(* Nothing to do if it's not a closure *) (* Nothing to do if it's not a closure *)
if Obj.is_block clos if Obj.is_block clos
&& (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag)
&& (match Ctype.(repr (expand_head !toplevel_env desc.val_type)) && (match Ctype.(repr (expand_head !toplevel_env desc.val_type))
with {desc=Tarrow _} -> true | _ -> false) with {desc=Tarrow _} -> true | _ -> false)
then begin then begin
match is_traced clos with match is_traced clos with
| Some opath -> | Some opath ->
fprintf ppf "%a is already traced (under the name %a).@." fprintf ppf "%a is already traced (under the name %a).@."
Printtyp.path path Printtyp.path path
Printtyp.path opath Printtyp.path opath
| None -> | None ->
(* Instrument the old closure *) (* Instrument the old closure *)
traced_functions := traced_functions :=
{ path = path; { path = path;
closure = clos; closure = clos;
actual_code = get_code_pointer clos; actual_code = get_code_pointer clos;
instrumented_fun = instrumented_fun =
instrument_closure !toplevel_env lid ppf desc.val_type } instrument_closure !toplevel_env lid ppf desc.val_type }
:: !traced_functions; :: !traced_functions;
(* Redirect the code field of the closure to point (* Redirect the code field of the closure to point
to the instrumentation function *) to the instrumentation function *)
set_code_pointer clos tracing_function_ptr; set_code_pointer clos tracing_function_ptr;
fprintf ppf "%a is now traced.@." Printtyp.longident lid fprintf ppf "%a is now traced.@." Printtyp.longident lid
end else fprintf ppf "%a is not a function.@." Printtyp.longident lid end else fprintf ppf "%a is not a function.@." Printtyp.longident lid
with end
| Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid | exception Not_found ->
fprintf ppf "Unbound value %a.@." Printtyp.longident lid
let dir_untrace ppf lid = let dir_untrace ppf lid =
try match Env.find_value_by_name lid !toplevel_env with
let (path, _desc) = Env.lookup_value lid !toplevel_env in | (path, _desc) ->
let rec remove = function let rec remove = function
| [] -> | [] ->
fprintf ppf "%a was not traced.@." Printtyp.longident lid; fprintf ppf "%a was not traced.@." Printtyp.longident lid;
[] []
| f :: rem -> | f :: rem ->
if Path.same f.path path then begin if Path.same f.path path then begin
set_code_pointer f.closure f.actual_code; set_code_pointer f.closure f.actual_code;
fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; fprintf ppf "%a is no longer traced.@." Printtyp.longident lid;
rem rem
end else f :: remove rem in end else f :: remove rem in
traced_functions := remove !traced_functions traced_functions := remove !traced_functions
with | exception Not_found ->
| Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid fprintf ppf "Unbound value %a.@." Printtyp.longident lid
let dir_untrace_all ppf () = let dir_untrace_all ppf () =
List.iter List.iter
@ -531,7 +536,7 @@ let reg_show_prim name to_sig doc =
let () = let () =
reg_show_prim "show_val" reg_show_prim "show_val"
(fun env loc id lid -> (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) ] [ Sig_value (id, desc, Exported) ]
) )
"Print the signature of the corresponding value." "Print the signature of the corresponding value."
@ -539,7 +544,7 @@ let () =
let () = let () =
reg_show_prim "show_type" reg_show_prim "show_type"
(fun env loc id lid -> (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) ] [ Sig_type (id, desc, Trec_not, Exported) ]
) )
"Print the signature of the corresponding type constructor." "Print the signature of the corresponding type constructor."
@ -547,7 +552,7 @@ let () =
let () = let () =
reg_show_prim "show_exception" reg_show_prim "show_exception"
(fun env loc id lid -> (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 if not (Ctype.equal env true [desc.cstr_res] [Predef.type_exn]) then
raise Not_found; raise Not_found;
let ret_type = let ret_type =
@ -570,26 +575,27 @@ let () =
let () = let () =
reg_show_prim "show_module" reg_show_prim "show_module"
(fun env loc id lid -> (fun env loc id lid ->
let rec accum_aliases path acc = let rec accum_aliases md acc =
let md = Env.find_module path env in
let acc = let acc =
Sig_module (id, Mp_present, Sig_module (id, Mp_present,
{md with md_type = trim_signature md.md_type}, {md with md_type = trim_signature md.md_type},
Trec_not, Exported) :: acc in Trec_not, Exported) :: acc in
match md.md_type with 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 _ -> | Mty_ident _ | Mty_signature _ | Mty_functor _ ->
List.rev acc List.rev acc
in in
let path, _ = Typetexp.find_module env loc lid in let _, md = Env.lookup_module ~loc lid env in
accum_aliases path [] accum_aliases md []
) )
"Print the signature of the corresponding module." "Print the signature of the corresponding module."
let () = let () =
reg_show_prim "show_module_type" reg_show_prim "show_module_type"
(fun env loc id lid -> (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) ] [ Sig_modtype (id, desc, Exported) ]
) )
"Print the signature of the corresponding module type." "Print the signature of the corresponding module type."
@ -597,7 +603,7 @@ let () =
let () = let () =
reg_show_prim "show_class" reg_show_prim "show_class"
(fun env loc id lid -> (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) ] [ Sig_class (id, desc, Trec_not, Exported) ]
) )
"Print the signature of the corresponding class." "Print the signature of the corresponding class."
@ -605,7 +611,7 @@ let () =
let () = let () =
reg_show_prim "show_class_type" reg_show_prim "show_class_type"
(fun env loc id lid -> (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) ] [ Sig_class_type (id, desc, Trec_not, Exported) ]
) )
"Print the signature of the corresponding class type." "Print the signature of the corresponding class type."

46
typing/ctype.ml
View File

@ -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 environment. However no operation which cares about levels/scopes is going
to happen while this module exists. to happen while this module exists.
The only operations that happen are: The only operations that happen are:
- Env.lookup_type - Env.find_type_by_name
- Env.find_type
- nondep_instance - nondep_instance
None of which check the scope. 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 -> | n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
nt2 :: complete (if n = n2 then nl else nl1) ntl' nt2 :: complete (if n = n2 then nl else nl1) ntl'
| n :: nl, _ -> | n :: nl, _ ->
try let lid = concat_longident (Longident.Lident "Pkg") n in
let path = match Env.find_type_by_name lid env' with
Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env' | (_, {type_arity = 0; type_kind = Type_abstract;
in type_private = Public; type_manifest = Some t2}) ->
match Env.find_type path env' with (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
{type_arity = 0; type_kind = Type_abstract; | (_, {type_arity = 0; type_kind = Type_abstract;
type_private = Public; type_manifest = Some t2} -> type_private = Public; type_manifest = None})
(n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 when allow_absent ->
| {type_arity = 0; type_kind = Type_abstract; complete nl ntl2
type_private = Public; type_manifest = None} when allow_absent -> | _ -> raise Exit
complete nl ntl2 | exception Not_found when allow_absent->
| _ -> raise Exit complete nl ntl2
with
| Not_found when allow_absent -> complete nl ntl2
| Exit -> raise Not_found
in 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 *) (* 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 = 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 = let memq_warn t visited =
if List.memq t visited then (warn := true; true) else false 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 find_cltype_for_path env p =
let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in let cl_abbr = Env.find_hash_type p env in
let cl_abbr = Env.find_type cl_path env in
match cl_abbr.type_manifest with match cl_abbr.type_manifest with
Some ty -> Some ty ->
begin match (repr ty).desc with begin match (repr ty).desc with

1
typing/ctype.mli
View File

@ -149,7 +149,6 @@ val set_object_name:
val remove_object_name: type_expr -> unit val remove_object_name: type_expr -> unit
val hide_private_methods: type_expr -> unit val hide_private_methods: type_expr -> unit
val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr 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 sort_row_fields: (label * row_field) list -> (label * row_field) list
val merge_row_fields: val merge_row_fields:

2212
typing/env.ml
View File

File diff suppressed because it is too large Load Diff

224
typing/env.mli
View File

@ -18,6 +18,15 @@
open Types open Types
open Misc 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 = type summary =
Env_empty Env_empty
| Env_value of summary * Ident.t * value_description | Env_value of summary * Ident.t * value_description
@ -34,6 +43,8 @@ type summary =
| Env_constraints of summary * type_declaration Path.Map.t | Env_constraints of summary * type_declaration Path.Map.t
| Env_copy_types of summary | Env_copy_types of summary
| Env_persistent of summary * Ident.t | 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 = type address =
| Aident of Ident.t | Aident of Ident.t
@ -53,7 +64,7 @@ type type_descriptions =
(* For short-paths *) (* For short-paths *)
type iter_cont type iter_cont
val iter_types: val iter_types:
(Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> (Path.t -> Path.t * type_declaration -> unit) ->
t -> iter_cont t -> iter_cont
val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
val same_types: t -> t -> bool 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_class: Path.t -> t -> class_declaration
val find_cltype: Path.t -> t -> class_type_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: val find_type_expansion:
Path.t -> t -> type_expr list * type_expr * int Path.t -> t -> type_expr list * type_expr * int
val find_type_expansion_opt: val find_type_expansion_opt:
@ -81,6 +95,9 @@ val find_type_expansion_opt:
of the compiler's type-based optimisations. *) of the compiler's type-based optimisations. *)
val find_modtype_expansion: Path.t -> t -> module_type 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_value_address: Path.t -> t -> address
val find_module_address: Path.t -> t -> address val find_module_address: Path.t -> t -> address
val find_class_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 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 *) (* 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: val lookup_value:
?loc:Location.t -> ?mark:bool -> ?use:bool -> loc:Location.t -> Longident.t -> t ->
Longident.t -> t -> Path.t * value_description 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
val lookup_type: val lookup_type:
?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t ?use:bool -> loc:Location.t -> Longident.t -> t ->
(* Since 4.04, this function no longer returns [type_description]. Path.t * type_declaration
To obtain it, you should either call [Env.find_type], or replace
it by [Typetexp.find_type] *)
val lookup_module: 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: val lookup_modtype:
?loc:Location.t -> ?mark:bool -> ?use:bool -> loc:Location.t -> Longident.t -> t ->
Longident.t -> t -> Path.t * modtype_declaration Path.t * modtype_declaration
val lookup_class: val lookup_class:
?loc:Location.t -> ?mark:bool -> ?use:bool -> loc:Location.t -> Longident.t -> t ->
Longident.t -> t -> Path.t * class_declaration Path.t * class_declaration
val lookup_cltype: 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 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 (* Check if a name is bound *)
(* Raise by lookup_module when the identifier refers
to one of the modules of a recursive definition val bound_value: string -> t -> bool
during the computation of its approximation (see #5965). *) 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 *) (* Insertion by identifier *)
@ -224,6 +331,10 @@ val enter_cltype:
in the process. *) in the process. *)
val enter_signature: scope:int -> signature -> t -> signature * t 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. *) (* Initialize the cache of in-core module interfaces. *)
val reset_cache: unit -> unit val reset_cache: unit -> unit
@ -276,6 +387,7 @@ val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
type error = type error =
| Missing_module of Location.t * Path.t * Path.t | Missing_module of Location.t * Path.t * Path.t
| Illegal_value_name of Location.t * string | Illegal_value_name of Location.t * string
| Lookup_error of Location.t * t * lookup_error
exception Error of error exception Error of error
@ -283,18 +395,7 @@ open Format
val report_error: formatter -> error -> unit val report_error: formatter -> error -> unit
val report_lookup_error: Location.t -> t -> formatter -> lookup_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 in_signature: bool -> t -> t val in_signature: bool -> t -> t
@ -306,8 +407,9 @@ val set_type_used_callback:
string -> type_declaration -> ((unit -> unit) -> unit) -> unit string -> type_declaration -> ((unit -> unit) -> unit) -> unit
(* Forward declaration to break mutual recursion with Includemod. *) (* Forward declaration to break mutual recursion with Includemod. *)
val check_modtype_inclusion: val check_functor_application:
(loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref (errors:bool -> loc:Location.t -> t -> module_type ->
Path.t -> module_type -> Path.t -> unit) ref
(* Forward declaration to break mutual recursion with Typemod. *) (* Forward declaration to break mutual recursion with Typemod. *)
val check_well_formed_module: val check_well_formed_module:
(t -> Location.t -> string -> module_type -> unit) ref (t -> Location.t -> string -> module_type -> unit) ref
@ -318,36 +420,10 @@ val strengthen:
(aliasable:bool -> t -> module_type -> Path.t -> module_type) ref (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
(* Forward declaration to break mutual recursion with Ctype. *) (* Forward declaration to break mutual recursion with Ctype. *)
val same_constr: (t -> type_expr -> type_expr -> bool) ref val same_constr: (t -> type_expr -> type_expr -> bool) ref
(* Forward declaration to break mutual recursion with Printtyp. *)
(** Folding over all identifiers (for analysis purpose) *) val print_longident: (Format.formatter -> Longident.t -> unit) ref
(* Forward declaration to break mutual recursion with Printtyp. *)
val fold_values: val print_path: (Format.formatter -> Path.t -> unit) ref
(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
(** Utilities *) (** Utilities *)
val scrape_alias: t -> module_type -> module_type val scrape_alias: t -> module_type -> module_type

6
typing/envaux.ml
View File

@ -86,6 +86,12 @@ let rec env_from_summary sum subst =
| Env_persistent (s, id) -> | Env_persistent (s, id) ->
let env = env_from_summary s subst in let env = env_from_summary s subst in
Env.add_persistent_structure id env 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 in
Hashtbl.add env_cache (sum, subst) env; Hashtbl.add env_cache (sum, subst) env;
env env

21
typing/includecore.ml
View File

@ -380,19 +380,18 @@ let type_declarations ?(equality = false) ~loc env ~mark name
(_, Type_abstract) -> None (_, Type_abstract) -> None
| (Type_variant cstrs1, Type_variant cstrs2) -> | (Type_variant cstrs1, Type_variant cstrs2) ->
if mark then begin if mark then begin
let mark cstrs usage name decl = let mark usage name cstrs =
List.iter List.iter
(fun c -> (fun cstr ->
Env.mark_constructor_used usage name decl Env.mark_constructor_used usage name cstr)
(Ident.name c.Types.cd_id))
cstrs cstrs
in in
let usage = let usage =
if decl1.type_private = Private || decl2.type_private = Public if decl2.type_private = Public then Env.Positive
then Env.Positive else Env.Privatize else Env.Privatize
in in
mark cstrs1 usage name decl1; mark usage name cstrs1;
if equality then mark cstrs2 Env.Positive (Path.name path) decl2 if equality then mark Env.Positive (Path.name path) cstrs2
end; end;
Option.map Option.map
(fun var_err -> Variant_mismatch var_err) (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 = let extension_constructors ~loc env ~mark id ext1 ext2 =
if mark then begin if mark then begin
let usage = let usage =
if ext1.ext_private = Private || ext2.ext_private = Public if ext2.ext_private = Public then Env.Positive
then Env.Positive else Env.Privatize else Env.Privatize
in in
Env.mark_extension_used usage ext1 (Ident.name id) Env.mark_extension_used usage (Ident.name id) ext1
end; end;
let ty1 = let ty1 =
Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))

19
typing/includemod.ml
View File

@ -45,6 +45,7 @@ type pos =
type error = pos list * Env.t * symptom type error = pos list * Env.t * symptom
exception Error of error list exception Error of error list
exception Apply_error of Location.t * Path.t * Path.t * error list
type mark = type mark =
| Mark_both | Mark_both
@ -543,9 +544,15 @@ let check_modtype_inclusion ~loc env mty1 path1 mty2 =
(Mtype.strengthen ~aliasable env mty1 path1) mty2) (Mtype.strengthen ~aliasable env mty1 path1) mty2)
let () = let () =
Env.check_modtype_inclusion := (fun ~loc a b c d -> Env.check_functor_application :=
try (check_modtype_inclusion ~loc a b c d : unit) (fun ~errors ~loc env mty1 path1 mty2 path2 ->
with Error _ -> raise Not_found) 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 (* Check that an implementation of a compilation unit meets its
interface. *) interface. *)
@ -841,11 +848,17 @@ let report_error ppf errs =
fprintf ppf "@[<v>%a%a%t@]" print_errs errs include_err err fprintf ppf "@[<v>%a%a%t@]" print_errs errs include_err err
Printtyp.Conflicts.print_explanations 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 (* We could do a better job to split the individual error items
as sub-messages of the main interface mismatch on the whole unit. *) as sub-messages of the main interface mismatch on the whole unit. *)
let () = let () =
Location.register_error_of_exn Location.register_error_of_exn
(function (function
| Error err -> Some (Location.error_of_printer_file report_error err) | 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 | _ -> None
) )

8
typing/predef.mli
View File

@ -57,6 +57,14 @@ val path_match_failure: Path.t
val path_assert_failure : Path.t val path_assert_failure : Path.t
val path_undefined_recursive_module : 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 (* To build the initial environment. Since there is a nasty mutual
recursion between predef and env, we break it by parameterizing recursion between predef and env, we break it by parameterizing
over Env.t, Env.add_type and Env.add_extension. *) over Env.t, Env.add_type and Env.add_extension. *)

45
typing/printtyp.ml
View File

@ -34,6 +34,8 @@ let rec longident ppf = function
| Ldot(p, s) -> fprintf ppf "%a.%s" longident p s | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
| Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
let () = Env.print_longident := longident
(* Print an identifier avoiding name collisions *) (* Print an identifier avoiding name collisions *)
module Out_name = struct module Out_name = struct
@ -79,16 +81,14 @@ module Namespace = struct
let lookup = let lookup =
let to_lookup f lid = 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 function
| Type -> fun id -> | Type -> to_lookup Env.find_type_by_name
Env.lookup_type ?loc:None ~mark:false (Lident id) !printing_env | Module -> to_lookup Env.find_module_by_name
| Module -> fun id -> | Module_type -> to_lookup Env.find_modtype_by_name
Env.lookup_module ~load:true ~mark:false ?loc:None | Class -> to_lookup Env.find_class_by_name
(Lident id) !printing_env | Class_type -> to_lookup Env.find_cltype_by_name
| Module_type -> to_lookup Env.lookup_modtype
| Class -> to_lookup Env.lookup_class
| Class_type -> to_lookup Env.lookup_cltype
| Other -> fun _ -> raise Not_found | Other -> fun _ -> raise Not_found
let location namespace id = let location namespace id =
@ -330,8 +330,9 @@ let ident_stdlib = Ident.create_persistent "Stdlib"
let non_shadowed_pervasive = function let non_shadowed_pervasive = function
| Pdot(Pident id, s) as path -> | Pdot(Pident id, s) as path ->
Ident.same id ident_stdlib && Ident.same id ident_stdlib &&
(try Path.same path (Env.lookup_type (Lident s) !printing_env) (match Env.find_type_by_name (Lident s) !printing_env with
with Not_found -> true) | (path', _) -> Path.same path path'
| exception Not_found -> true)
| _ -> false | _ -> false
let find_double_underscore s = let find_double_underscore s =
@ -374,12 +375,12 @@ let rec rewrite_double_underscore_paths env p =
String.capitalize_ascii String.capitalize_ascii
(String.sub name (i + 2) (String.length name - i - 2))) (String.sub name (i + 2) (String.length name - i - 2)))
in 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 | exception Not_found -> p
| p' -> | p', _ ->
if module_path_is_an_alias_of env p' ~alias_of:p then if module_path_is_an_alias_of env p' ~alias_of:p then
p' p'
else else
p p
let rewrite_double_underscore_paths env 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 let trees = List.map (tree_of_path namespace) p in
List.map (Format.asprintf "%a" !Oprint.out_ident) trees List.map (Format.asprintf "%a" !Oprint.out_ident) trees
let () = Env.print_path := path
(* Print a recursive annotation *) (* Print a recursive annotation *)
let tree_of_rec = function 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 if error then Env.without_cmis (wrap_printing_env env) f
else 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 is_unambiguous path env =
let l = Env.find_shadowed_types path env in let l = Env.find_shadowed_types path env in
List.exists (Path.same path) l || (* concrete paths are ok *) 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) *) (* also allow repeatedly defining and opening (for toplevel) *)
let id = lid_of_path p in let id = lid_of_path p in
List.for_all (fun p -> lid_of_path p = id) rem && 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 = let rec get_best_path r =
match !r with match !r with

37
typing/typeclass.ml
View File

@ -257,22 +257,15 @@ let rc node =
(* Enter a value in the method environment only *) (* Enter a value in the method environment only *)
let enter_met_env ?check loc lab kind ty val_env met_env par_env = let enter_met_env ?check loc lab kind unbound_kind ty val_env met_env par_env =
let (id, val_env) = let val_env = Env.enter_unbound_value lab unbound_kind val_env in
Env.enter_value lab let par_env = Env.enter_unbound_value lab unbound_kind par_env in
{val_type = ty; let (id, met_env) =
val_kind = Val_unbound Val_unbound_instance_variable; Env.enter_value ?check lab
val_attributes = []; {val_type = ty; val_kind = kind;
Types.val_loc = loc} val_env val_attributes = []; Types.val_loc = loc} met_env
in in
(id, val_env, (id, val_env, met_env, par_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)
(* Enter an instance variable in the environment *) (* 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 = 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) match id with Some id -> (id, val_env, met_env, par_env)
| None -> | None ->
enter_met_env Location.none lab (Val_ivar (mut, cl_num)) 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 in
vars := Vars.add lab (id, mut, virt, ty) !vars; vars := Vars.add lab (id, mut, virt, ty) !vars;
result result
@ -536,7 +529,7 @@ and class_type_aux env scty =
in in
match scty.pcty_desc with match scty.pcty_desc with
Pcty_constr (lid, styl) -> 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 if Path.same decl.clty_path unbound_class then
raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
let (params, clty) = let (params, clty) =
@ -641,8 +634,8 @@ and class_field_aux self_loc cl_num self_type meths vars
| Some {txt=name} -> | Some {txt=name} ->
let (_id, val_env, met_env, par_env) = let (_id, val_env, met_env, par_env) =
enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s) enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type sparent.pcl_loc name (Val_anc (inh_meths, cl_num))
val_env met_env par_env Val_unbound_ancestor self_type val_env met_env par_env
in in
(val_env, met_env, par_env,Some name) (val_env, met_env, par_env,Some name)
in 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 = and class_expr_aux cl_num val_env met_env scl =
match scl.pcl_desc with match scl.pcl_desc with
Pcl_constr (lid, styl) -> 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 if Path.same decl.cty_path unbound_class then
raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
let tyl = List.map 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 let ty' = extract_option_type val_env ty
and ty0' = extract_option_type val_env ty0 in and ty0' = extract_option_type val_env ty0 in
let arg = type_argument val_env sarg0 ty' 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 -> with Not_found ->
sargs, more_sargs, sargs, more_sargs,
if Btype.is_optional l if Btype.is_optional l
&& (List.mem_assoc Nolabel sargs && (List.mem_assoc Nolabel sargs
|| List.mem_assoc Nolabel more_sargs) || List.mem_assoc Nolabel more_sargs)
then then
Some (option_none ty0 Location.none) Some (option_none val_env ty0 Location.none)
else None else None
in in
let omitted = if arg = None then (l,ty0) :: omitted else omitted in let omitted = if arg = None then (l,ty0) :: omitted else omitted in

338
typing/typecore.ml
View File

@ -77,7 +77,7 @@ type error =
| Private_label of Longident.t * type_expr | Private_label of Longident.t * type_expr
| Private_constructor of constructor_description * type_expr | Private_constructor of constructor_description * type_expr
| Unbound_instance_variable of string * string list | 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 | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
| Outside_class | Outside_class
| Value_multiply_overridden of string | Value_multiply_overridden of string
@ -86,7 +86,6 @@ type error =
| Too_many_arguments of bool * type_expr * type_forcing_context option | Too_many_arguments of bool * type_expr * type_forcing_context option
| Abstract_wrong_label of arg_label * 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 | Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t
| Not_a_variant_type of Longident.t | Not_a_variant_type of Longident.t
| Incoherent_label_order | Incoherent_label_order
| Less_general of string * Ctype.Unification_trace.t | 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 = let mkexp exp_desc exp_type exp_loc exp_env =
{ exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
let option_none ty loc = let option_none env ty loc =
let lid = Longident.Lident "None" let lid = Longident.Lident "None" in
and env = Env.initial_safe_string in let cnone = Env.find_ident_constructor Predef.ident_none env in
let cnone = Env.lookup_constructor lid env in
mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env 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 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]) ) mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
(type_option texp.exp_type) texp.exp_loc texp.exp_env (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 = let maybe_add_pattern_variables_ghost loc_let env pv =
List.fold_right List.fold_right
(fun {pv_id; pv_type; _} env -> (fun {pv_id; _} env ->
let lid = Longident.Lident (Ident.name pv_id) in let name = Ident.name pv_id in
match Env.lookup_value ~mark:false lid env with if Env.bound_value name env then env
| _ -> env else begin
| exception Not_found -> Env.enter_unbound_value name
Env.add_value pv_id (Val_unbound_ghost_recursive loc_let) env
{ val_type = pv_type; end
val_kind = Val_unbound Val_unbound_ghost_recursive;
val_loc = loc_let;
val_attributes = [];
} env
) pv env ) pv env
let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty 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 | Tpat_array _ | Tpat_lazy _ | Tpat_exception _ -> p.pat_type
let build_or_pat env loc lid = let build_or_pat env loc lid =
let path, decl = Typetexp.find_type env lid.loc lid.txt let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in
in
let tyl = List.map (fun _ -> newvar()) decl.type_params in let tyl = List.map (fun _ -> newvar()) decl.type_params in
let row0 = let row0 =
let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in 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 module NameChoice(Name : sig
type t type t
type usage
val type_kind: string val type_kind: string
val get_name: t -> string val get_name: t -> string
val get_type: t -> type_expr val get_type: t -> type_expr
val get_descrs: Env.type_descriptions -> t list val lookup_all_from_type:
val unbound_name_error: Env.t -> Longident.t loc -> 'a Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list
val in_env: t -> bool val in_env: t -> bool
end) = struct end) = struct
open Name open Name
@ -614,18 +608,21 @@ end) = struct
| Tconstr(p, _, _) -> p | Tconstr(p, _, _) -> p
| _ -> assert false | _ -> assert false
let lookup_from_type env tpath lid = let lookup_from_type env tpath usage lid =
let descrs = get_descrs (Env.find_type_descrs tpath env) in let descrs = lookup_all_from_type lid.loc usage tpath env in
Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
match lid.txt with match lid.txt with
Longident.Lident s -> begin | Longident.Lident s -> begin
try match
List.find (fun nd -> get_name nd = s) descrs List.find (fun (nd, _) -> get_name nd = s) descrs
with Not_found -> with
let names = List.map get_name descrs in | descr, use ->
raise (Error (lid.loc, env, use ();
Wrong_name ("", mk_expected (newvar ()), descr
type_kind, tpath, s, names))) | 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 end
| _ -> raise Not_found | _ -> raise Not_found
@ -647,19 +644,25 @@ end) = struct
reset(); strings_of_paths Type tpaths) reset(); strings_of_paths Type tpaths)
let disambiguate_by_type env tpath lbls = let disambiguate_by_type env tpath lbls =
let check_type (lbl, _) = match lbls with
let lbl_tpath = get_type_path lbl in | (Error _ : _ result) -> raise Not_found
compare_type_path env tpath lbl_tpath | Ok lbls ->
in let check_type (lbl, _) =
List.find check_type lbls 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 scope = match scope with None -> lbls | Some l -> l in
let lbl = match opath with let lbl = match opath with
None -> None ->
begin match lbls with begin match lbls with
[] -> unbound_name_error env lid | (Error(loc', env', err) : _ result) ->
| (lbl, use) :: rest -> Env.lookup_error loc' env' err
| Ok [] -> assert false
| Ok((lbl, use) :: rest) ->
use (); use ();
Printtyp.Conflicts.reset (); Printtyp.Conflicts.reset ();
let paths = ambiguous_types env lbl rest in let paths = ambiguous_types env lbl rest in
@ -684,8 +687,8 @@ end) = struct
if not pr then begin if not pr then begin
(* Check if non-principal type is affecting result *) (* Check if non-principal type is affecting result *)
match lbls with match lbls with
[] -> warn_pr () | (Error _ : _ result) | Ok [] -> warn_pr ()
| (lbl', _use') :: rest -> | Ok ((lbl', _use') :: rest) ->
let lbl_tpath = get_type_path lbl' in let lbl_tpath = get_type_path lbl' in
if not (compare_type_path env tpath lbl_tpath) then warn_pr () if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
else else
@ -701,7 +704,7 @@ end) = struct
end; end;
lbl lbl
with Not_found -> try 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 if in_env lbl then
begin begin
let s = let s =
@ -713,22 +716,25 @@ end) = struct
if not pr then warn_pr (); if not pr then warn_pr ();
lbl lbl
with Not_found -> with Not_found ->
if lbls = [] then unbound_name_error env lid else match lbls with
let tp = (tpath0, expand_path env tpath) in | (Error(loc', env', err) : _ result) ->
let tpl = Env.lookup_error loc' env' err
List.map | Ok lbls ->
(fun (lbl, _) -> let tp = (tpath0, expand_path env tpath) in
let tp0 = get_type_path lbl in let tpl =
let tp = expand_path env tp0 in List.map
(tp0, tp)) (fun (lbl, _) ->
lbls let tp0 = get_type_path lbl in
in let tp = expand_path env tp0 in
raise (Error (lid.loc, env, (tp0, tp))
Name_type_mismatch (type_kind, lid.txt, tp, tpl))) lbls
in
raise (Error (lid.loc, env,
Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
in in
if in_env lbl then if in_env lbl then
begin match scope with begin match scope with
(lab1,_)::_ when lab1 == lbl -> () | Ok ((lab1,_)::_) when lab1 == lbl -> ()
| _ -> | _ ->
Location.prerr_warning lid.loc Location.prerr_warning lid.loc
(Warnings.Disambiguated_name(get_name lbl)) (Warnings.Disambiguated_name(get_name lbl))
@ -742,11 +748,12 @@ let wrap_disambiguate kind ty f x =
module Label = NameChoice (struct module Label = NameChoice (struct
type t = label_description type t = label_description
type usage = unit
let type_kind = "record" let type_kind = "record"
let get_name lbl = lbl.lbl_name let get_name lbl = lbl.lbl_name
let get_type lbl = lbl.lbl_res let get_type lbl = lbl.lbl_res
let get_descrs = snd let lookup_all_from_type loc () path env =
let unbound_name_error = Typetexp.unbound_label_error Env.lookup_all_labels_from_type ~loc path env
let in_env lbl = let in_env lbl =
match lbl.lbl_repres with match lbl.lbl_repres with
| Record_regular | Record_float | Record_unboxed false -> true | 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) there is still at least one candidate (for error message)
* if the reduced list is valid, call Label.disambiguate * if the reduced list is valid, call Label.disambiguate
*) *)
let scope = Typetexp.find_all_labels env lid.loc lid.txt in let scope = Env.lookup_all_labels ~loc:lid.loc lid.txt env in
if opath = None && scope = [] then match opath, scope with
Typetexp.unbound_label_error env lid; | None, Error(loc, env, err) ->
let (ok, labels) = Env.lookup_error loc env err
match opath with | Some _, Error _ ->
Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *) Label.disambiguate () lid env opath scope ~warn ~scope
| _ -> disambiguate_label_by_ids (opath=None) closed ids scope | _, Ok lbls ->
in let (ok, lbls) =
if ok then Label.disambiguate lid env opath labels ~warn ~scope match opath with
else fst (List.hd labels) (* will fail later *) | 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 in
let lbl_a_list = let lbl_a_list =
List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in 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 module Constructor = NameChoice (struct
type t = constructor_description type t = constructor_description
type usage = Env.constructor_usage
let type_kind = "variant" let type_kind = "variant"
let get_name cstr = cstr.cstr_name let get_name cstr = cstr.cstr_name
let get_type cstr = cstr.cstr_res let get_type cstr = cstr.cstr_res
let get_descrs = fst let lookup_all_from_type loc usage path env =
let unbound_name_error = Typetexp.unbound_constructor_error Env.lookup_all_constructors_from_type ~loc usage path env
let in_env _ = true let in_env _ = true
end) end)
@ -1164,19 +1177,17 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
let candidates = let candidates =
match lid.txt, constrs with match lid.txt, constrs with
Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
[Hashtbl.find constrs s, (fun () -> ())] Ok [Hashtbl.find constrs s, (fun () -> ())]
| _ -> Typetexp.find_all_constructors !env lid.loc lid.txt | _ ->
Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env
in in
let constr = let constr =
wrap_disambiguate "This variant pattern is expected to have" wrap_disambiguate "This variant pattern is expected to have"
(mk_expected expected_ty) (mk_expected expected_ty)
(Constructor.disambiguate lid !env opath) candidates (Constructor.disambiguate Env.Pattern lid !env opath) candidates
in in
if constr.cstr_generalized && constrs <> None && mode = Inside_or if constr.cstr_generalized && constrs <> None && mode = Inside_or
then raise Need_backtrack; 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 begin match no_existentials, constr.cstr_existentials with
| None, _ | _, [] -> () | None, _ | _, [] -> ()
| Some r, (_ :: _ as exs) -> | 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 List.fold_right
(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
(val_env, met_env, par_env) -> (val_env, met_env, par_env) ->
(Env.add_value pv_id {val_type = pv_type; let name = Ident.name pv_id in
val_kind = (Env.enter_unbound_value name Val_unbound_self val_env,
Val_unbound Val_unbound_instance_variable;
val_attributes = pv_attributes;
Types.val_loc = pv_loc;
} val_env,
Env.add_value pv_id {val_type = pv_type; Env.add_value pv_id {val_type = pv_type;
val_kind = val_kind =
Val_self (meths, vars, cl_num, privty); 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 ~check:(fun s -> if pv_as_var then Warnings.Unused_var s
else Warnings.Unused_var_strict s) else Warnings.Unused_var_strict s)
met_env, met_env,
Env.add_value pv_id {val_type = pv_type; Env.enter_unbound_value name Val_unbound_self par_env))
val_kind =
Val_unbound Val_unbound_instance_variable;
val_attributes = pv_attributes;
Types.val_loc = pv_loc;
} par_env))
pv (val_env, met_env, par_env) pv (val_env, met_env, par_env)
in in
(pat, meths, vars, val_env, met_env, par_env) (pat, meths, vars, val_env, met_env, par_env)
@ -1821,13 +1823,11 @@ let rec approx_type env sty =
| Ptyp_tuple args -> | Ptyp_tuple args ->
newty (Ttuple (List.map (approx_type env) args)) newty (Ttuple (List.map (approx_type env) args))
| Ptyp_constr (lid, ctl) -> | Ptyp_constr (lid, ctl) ->
begin try let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in
let path = Env.lookup_type lid.txt env in if List.length ctl <> decl.type_arity then newvar ()
let decl = Env.find_type path env in else begin
if List.length ctl <> decl.type_arity then raise Not_found;
let tyl = List.map (approx_type env) ctl in let tyl = List.map (approx_type env) ctl in
newconstr path tyl newconstr path tyl
with Not_found -> newvar ()
end end
| Ptyp_poly (_, sty) -> | Ptyp_poly (_, sty) ->
approx_type env sty approx_type env sty
@ -2189,7 +2189,8 @@ and type_expect_
match desc.val_kind with match desc.val_kind with
| Val_ivar (_, cl_num) -> | Val_ivar (_, cl_num) ->
let (self_path, _) = let (self_path, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env Env.find_value_by_name
(Longident.Lident ("self-" ^ cl_num)) env
in in
Texp_instvar(self_path, path, Texp_instvar(self_path, path,
match lid.txt with match lid.txt with
@ -2197,22 +2198,9 @@ and type_expect_
| _ -> assert false) | _ -> assert false)
| Val_self (_, _, cl_num, _) -> | Val_self (_, _, cl_num, _) ->
let (path, _) = let (path, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
in in
Texp_ident(path, lid, desc) 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) Texp_ident(path, lid, desc)
in in
@ -2602,8 +2590,6 @@ and type_expect_
unify_exp env record ty_record; unify_exp env record ty_record;
if label.lbl_mut = Immutable then if label.lbl_mut = Immutable then
raise(Error(loc, env, Label_not_mutable lid.txt)); raise(Error(loc, env, Label_not_mutable lid.txt));
Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes
(Longident.last lid.txt);
rue { rue {
exp_desc = Texp_setfield(record, label_loc, label, newval); exp_desc = Texp_setfield(record, label_loc, label, newval);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
@ -2815,10 +2801,12 @@ and type_expect_
end end
in in
begin match begin match
Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env, Env.find_value_by_name
Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env (Longident.Lident ("selfpat-" ^ cl_num)) env,
Env.find_value_by_name
(Longident.Lident ("self-" ^cl_num)) env
with with
(_, ({val_kind = Val_self (meths, _, _, privty)} as desc)), | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
(path, _) -> (path, _) ->
obj_meths := Some meths; obj_meths := Some meths;
let (_, typ) = let (_, typ) =
@ -2909,7 +2897,7 @@ and type_expect_
Undefined_method (obj.exp_type, met, valid_methods))) Undefined_method (obj.exp_type, met, valid_methods)))
end end
| Pexp_new cl -> | 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 begin match cl_decl.cty_new with
None -> None ->
raise(Error(loc, env, Virtual_class cl.txt)) raise(Error(loc, env, Virtual_class cl.txt))
@ -2921,37 +2909,27 @@ and type_expect_
exp_attributes = sexp.pexp_attributes; exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
end end
| Pexp_setinstvar (lab, snewval) -> | Pexp_setinstvar (lab, snewval) -> begin
begin try let (path, mut, cl_num, ty) =
let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in Env.lookup_instance_variable ~loc lab.txt env
match desc.val_kind with in
Val_ivar (Mutable, cl_num) -> match mut with
let newval = | Mutable ->
type_expect env snewval (mk_expected (instance desc.val_type)) let newval =
in type_expect env snewval (mk_expected (instance ty))
let (path_self, _) = in
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env let (path_self, _) =
in Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
rue { in
exp_desc = Texp_setinstvar(path_self, path, lab, newval); rue {
exp_loc = loc; exp_extra = []; exp_desc = Texp_setinstvar(path_self, path, lab, newval);
exp_type = instance Predef.type_unit; exp_loc = loc; exp_extra = [];
exp_attributes = sexp.pexp_attributes; exp_type = instance Predef.type_unit;
exp_env = env } exp_attributes = sexp.pexp_attributes;
| Val_ivar _ -> exp_env = env }
raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt))) | _ ->
| _ -> raise(Error(loc, env, Instance_variable_not_mutable lab.txt))
raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt))) end
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_override lst -> | Pexp_override lst ->
let _ = let _ =
List.fold_right List.fold_right
@ -2964,8 +2942,8 @@ and type_expect_
[] in [] in
begin match begin match
try try
Env.lookup_value (Longident.Lident "selfpat-*") env, Env.find_value_by_name (Longident.Lident "selfpat-*") env,
Env.lookup_value (Longident.Lident "self-*") env Env.find_value_by_name (Longident.Lident "self-*") env
with Not_found -> with Not_found ->
raise(Error(loc, env, Outside_class)) raise(Error(loc, env, Outside_class))
with with
@ -3275,7 +3253,10 @@ and type_expect_
Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _) Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
} ] -> } ] ->
let path = 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 | Cstr_extension (path, _) -> path
| _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
in in
@ -3299,7 +3280,7 @@ and type_expect_
exp_env = env } exp_env = env }
and type_ident env ?(recarg=Rejected) lid = 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 if !Clflags.annotations then begin
let dloc = desc.Types.val_loc in let dloc = desc.Types.val_loc in
let annot = let annot =
@ -3331,24 +3312,13 @@ and type_binding_op_ident env s =
let path, desc = type_ident env lid in let path, desc = type_ident env lid in
let path = let path =
match desc.val_kind with match desc.val_kind with
| Val_ivar _ | Val_unbound Val_unbound_instance_variable -> | Val_ivar _ ->
fatal_error "Illegal name for instance variable" fatal_error "Illegal name for instance variable"
| Val_self (_, _, cl_num, _) -> | Val_self (_, _, cl_num, _) ->
let path, _ = let path, _ =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
in in
path 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 | _ -> path
in in
path, desc 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) Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)
with Not_found -> None with Not_found -> None
in 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 = let label =
wrap_disambiguate "This expression has" (mk_expected ty_exp) 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) (record, label, opath)
(* Typing format strings for printing or reading. (* 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 = let rec make_args args ty_fun =
match (expand_head env ty_fun).desc with match (expand_head env ty_fun).desc with
| Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> | 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 make_args ((l, Some ty) :: args) ty_fun
| Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
List.rev args, ty_fun, no_labels ty_res' List.rev args, ty_fun, no_labels ty_res'
@ -3960,9 +3930,10 @@ and type_application env funct sargs =
else begin else begin
may_warn sarg0.pexp_loc may_warn sarg0.pexp_loc
(Warnings.Not_principal "using an optional argument here"); (Warnings.Not_principal "using an optional argument here");
Some (fun () -> option_some (type_argument ~explanation env sarg0 Some (fun () ->
(extract_option_type env ty) option_some env (type_argument ~explanation env sarg0
(extract_option_type env ty0))) (extract_option_type env ty)
(extract_option_type env ty0)))
end end
with Not_found -> with Not_found ->
sargs, more_sargs, sargs, more_sargs,
@ -3973,7 +3944,7 @@ and type_application env funct sargs =
may_warn funct.exp_loc may_warn funct.exp_loc
(Warnings.Without_principality "eliminated optional argument"); (Warnings.Without_principality "eliminated optional argument");
ignored := (l,ty,lv) :: !ignored; 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 end else begin
may_warn funct.exp_loc may_warn funct.exp_loc
(Warnings.Without_principality "commuted an argument"); (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) Some(p0, p, principal)
with Not_found -> None with Not_found -> None
in 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 = let constr =
wrap_disambiguate "This variant expression is expected to have" wrap_disambiguate "This variant expression is expected to have"
ty_expected_explained ty_expected_explained
(Constructor.disambiguate lid env opath) constrs in (Constructor.disambiguate Env.Positive lid env opath) constrs
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; in
Builtin_attributes.check_alerts loc constr.cstr_attributes
constr.cstr_name;
let sargs = let sargs =
match sarg with match sarg with
None -> [] None -> []
@ -4653,8 +4624,9 @@ let type_expression env sexp =
generalize exp.exp_type; generalize exp.exp_type;
match sexp.pexp_desc with match sexp.pexp_desc with
Pexp_ident lid -> Pexp_ident lid ->
let loc = sexp.pexp_loc in
(* Special case for keeping type variables when looking-up a variable *) (* 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 with exp_type = desc.val_type}
| _ -> exp | _ -> exp
@ -4958,11 +4930,8 @@ let report_error ~loc env = function
fprintf ppf "Unbound instance variable %s" var; fprintf ppf "Unbound instance variable %s" var;
spellcheck ppf var valid_vars; spellcheck ppf var valid_vars;
) () ) ()
| Instance_variable_not_mutable (b, v) -> | Instance_variable_not_mutable v ->
if b then Location.errorf ~loc "The instance variable %s is not mutable" v
Location.errorf ~loc "The instance variable %s is not mutable" v
else
Location.errorf ~loc "The value %s is not an instance variable" v
| Not_subtype(tr1, tr2) -> | Not_subtype(tr1, tr2) ->
Location.error_of_printer ~loc (fun ppf () -> Location.error_of_printer ~loc (fun ppf () ->
report_subtyping_error ppf env tr1 "is not a subtype of" tr2 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@ \ "This `let module' expression has type@ %a@ \
In this type, the locally bound module name %s escapes its scope" In this type, the locally bound module name %s escapes its scope"
type_expr ty id 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 -> | Private_type ty ->
Location.errorf ~loc "Cannot create values of the private type %a" Location.errorf ~loc "Cannot create values of the private type %a"
type_expr ty type_expr ty

7
typing/typecore.mli
View File

@ -102,8 +102,8 @@ val type_argument:
Env.t -> Parsetree.expression -> Env.t -> Parsetree.expression ->
type_expr -> type_expr -> Typedtree.expression type_expr -> type_expr -> Typedtree.expression
val option_some: Typedtree.expression -> Typedtree.expression val option_some: Env.t -> Typedtree.expression -> Typedtree.expression
val option_none: type_expr -> Location.t -> Typedtree.expression val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression
val extract_option_type: Env.t -> type_expr -> type_expr val extract_option_type: Env.t -> type_expr -> type_expr
val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit
val generalizable: int -> type_expr -> bool val generalizable: int -> type_expr -> bool
@ -144,7 +144,7 @@ type error =
| Private_label of Longident.t * type_expr | Private_label of Longident.t * type_expr
| Private_constructor of constructor_description * type_expr | Private_constructor of constructor_description * type_expr
| Unbound_instance_variable of string * string list | 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 | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
| Outside_class | Outside_class
| Value_multiply_overridden of string | Value_multiply_overridden of string
@ -153,7 +153,6 @@ type error =
| Too_many_arguments of bool * type_expr * type_forcing_context option | Too_many_arguments of bool * type_expr * type_forcing_context option
| Abstract_wrong_label of arg_label * 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 | Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t
| Not_a_variant_type of Longident.t | Not_a_variant_type of Longident.t
| Incoherent_label_order | Incoherent_label_order
| Less_general of string * Ctype.Unification_trace.t | Less_general of string * Ctype.Unification_trace.t

31
typing/typedecl.ml
View File

@ -508,9 +508,11 @@ let transl_declaration env sdecl id =
Ctype.end_def (); Ctype.end_def ();
(* Add abstract row *) (* Add abstract row *)
if is_fixed_type sdecl then begin if is_fixed_type sdecl then begin
let p = let p, _ =
try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env try Env.find_type_by_name
with Not_found -> assert false in (Longident.Lident(Ident.name id ^ "#row")) env
with Not_found -> assert false
in
set_fixed_row env sdecl.ptype_loc p decl set_fixed_row env sdecl.ptype_loc p decl
end; end;
(* Check for cyclic abbreviations *) (* Check for cyclic abbreviations *)
@ -888,10 +890,15 @@ let transl_type_decl env rec_flag sdecl_list =
let sdecl_list = let sdecl_list =
List.map List.map
(fun sdecl -> (fun sdecl ->
let ptype_name = let ptype_name =
mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in 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 {sdecl with
ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) ptype_name; ptype_kind; ptype_manifest; ptype_loc })
fixed_types fixed_types
@ sdecl_list @ sdecl_list
in in
@ -1023,12 +1030,8 @@ let transl_extension_constructor env type_path type_params
in in
args, ret_type, Text_decl(targs, tret_type) args, ret_type, Text_decl(targs, tret_type)
| Pext_rebind lid -> | Pext_rebind lid ->
let cdescr = Typetexp.find_constructor env lid.loc lid.txt in let usage = if priv = Public then Env.Positive else Env.Privatize in
let usage = let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in
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 (args, cstr_res) = Ctype.instance_constructor cdescr in let (args, cstr_res) = Ctype.instance_constructor cdescr in
let res, ret_type = let res, ret_type =
if cdescr.cstr_generalized then 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 = let transl_type_extension extend env loc styext =
reset_type_variables(); reset_type_variables();
Ctype.begin_def(); Ctype.begin_def();
let (type_path, type_decl) = let type_path, type_decl =
let lid = styext.ptyext_path in let lid = styext.ptyext_path in
Typetexp.find_type env lid.loc lid.txt Env.lookup_type ~loc:lid.loc lid.txt env
in in
begin begin
match type_decl.type_kind with match type_decl.type_kind with

64
typing/typemod.ml
View File

@ -105,11 +105,6 @@ type error =
exception Error of Location.t * Env.t * error exception Error of Location.t * Env.t * error
exception Error_forward of Location.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 open Typedtree
let rec path_concat head p = let rec path_concat head p =
@ -137,7 +132,7 @@ let extract_sig_open env loc mty =
(* Compute the environment after opening a module *) (* Compute the environment after opening a module *)
let type_open_ ?used_slot ?toplevel ovf env loc lid = 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 match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
| Some env -> path, env | Some env -> path, env
| None -> | None ->
@ -529,7 +524,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
update_rec_next rs rem update_rec_next rs rem
| (Sig_module(id, pres, md, rs, priv) :: rem, [s], Pwith_module (_, lid')) | (Sig_module(id, pres, md, rs, priv) :: rem, [s], Pwith_module (_, lid'))
when Ident.name id = s -> 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 = md'.md_type in
let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
let md'' = { md' with md_type = 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, pres, newmd, rs, priv) :: rem
| (Sig_module(id, _, md, rs, _) :: rem, [s], Pwith_modsubst (_, lid')) | (Sig_module(id, _, md, rs, _) :: rem, [s], Pwith_modsubst (_, lid'))
when Ident.name id = s -> 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 aliasable = not (Env.is_functor_arg path env) in
let newmd = Mtype.strengthen_decl ~aliasable env md' path in let newmd = Mtype.strengthen_decl ~aliasable env md' path in
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); 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 in
match type_decl_is_alias sdecl with match type_decl_is_alias sdecl with
| Some lid -> | Some lid ->
let replacement = let replacement, _ =
try Env.lookup_type lid.txt initial_env try Env.find_type_by_name lid.txt initial_env
with Not_found -> assert false with Not_found -> assert false
in in
fun s path -> Subst.add_type_path path replacement s 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 = let rec approx_modtype env smty =
match smty.pmty_desc with match smty.pmty_desc with
Pmty_ident lid -> 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 Mty_ident path
| Pmty_alias lid -> | Pmty_alias lid ->
let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in let path =
Mty_alias path Env.lookup_module_path ~use:false ~load:false
~loc:smty.pmty_loc lid.txt env
in
Mty_alias(path)
| Pmty_signature ssg -> | Pmty_signature ssg ->
Mty_signature(approx_sig env ssg) Mty_signature(approx_sig env ssg)
| Pmty_functor(param, sarg, sres) -> | Pmty_functor(param, sarg, sres) ->
@ -705,9 +705,9 @@ let rec approx_modtype env smty =
| Pwith_module (_, lid') -> | Pwith_module (_, lid') ->
(* Lookup the module to make sure that it is not recursive. (* Lookup the module to make sure that it is not recursive.
(GPR#1626) *) (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') -> | 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; constraints;
body body
| Pmty_typeof smod -> | Pmty_typeof smod ->
@ -749,7 +749,8 @@ and approx_sig env ssg =
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
let id = Ident.create_scoped ~scope pms.pms_name.txt in let id = Ident.create_scoped ~scope pms.pms_name.txt in
let _, md = 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 in
let pres = let pres =
match md.Types.md_type with match md.Types.md_type with
@ -1065,11 +1066,11 @@ let has_remove_aliases_attribute attr =
(* Check and translate a module type expression *) (* Check and translate a module type expression *)
let transl_modtype_longident loc env lid = 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 path
let transl_module_alias loc env lid = 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 mkmty desc typ env loc attrs =
let mty = { let mty = {
@ -1265,7 +1266,8 @@ and transl_signature env sg =
let scope = Ctype.create_scope () in let scope = Ctype.create_scope () in
let id = Ident.create_scoped ~scope pms.pms_name.txt in let id = Ident.create_scoped ~scope pms.pms_name.txt in
let path, md = 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 in
let aliasable = not (Env.is_functor_arg path env) in let aliasable = not (Env.is_functor_arg path env) in
let md = 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 List.map (fun x -> Ident.create_scoped ~scope x.pmd_name.txt) sdecls
in in
let approx_env = 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 List.fold_left
(fun env id -> (fun env id ->
let dummy = (* cf #5965 *)
Mty_ident (Path.Pident (Ident.create_scoped ~scope "#recmod#")) Env.enter_unbound_module (Ident.name id)
in Mod_unbound_illegal_recursion env
Env.add_module ~arg:true id Mp_present dummy env
) )
env ids env ids
in in
@ -1718,16 +1713,14 @@ let rec package_constraints env loc mty constrs =
Mty_signature sg' Mty_signature sg'
let modtype_of_package env loc p nl tl = 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 <> [] -> | Some mty when nl <> [] ->
package_constraints env loc mty package_constraints env loc mty
(List.combine (List.map Longident.flatten nl) tl) (List.combine (List.map Longident.flatten nl) tl)
| _ -> | _ ->
if nl = [] then Mty_ident p if nl = [] then Mty_ident p
else raise(Error(loc, env, Signature_expected)) else raise(Error(loc, env, Signature_expected))
with Not_found -> | exception Not_found -> assert false
let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in
raise(Typetexp.Error(loc, env, error))
let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
let mkmty p nl tl = 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 match smod.pmod_desc with
Pmod_ident lid -> Pmod_ident lid ->
let path = 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); let md = { mod_desc = Tmod_ident (path, lid);
mod_type = Mty_alias path; mod_type = Mty_alias path;
mod_env = env; mod_env = env;
@ -2331,7 +2325,7 @@ let type_module_type_of env smod =
let tmty = let tmty =
match smod.pmod_desc with match smod.pmod_desc with
| Pmod_ident lid -> (* turn off strengthening in this case *) | 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); rm { mod_desc = Tmod_ident (path, lid);
mod_type = md.md_type; mod_type = md.md_type;
mod_env = env; mod_env = env;

5
typing/types.ml
View File

@ -104,11 +104,6 @@ and value_kind =
(* Self *) (* Self *)
| Val_anc of (string * Ident.t) list * string | Val_anc of (string * Ident.t) list * string
(* Ancestor *) (* Ancestor *)
| Val_unbound of value_unbound_reason (* Unbound variable *)
and value_unbound_reason =
| Val_unbound_instance_variable
| Val_unbound_ghost_recursive
(* Variance *) (* Variance *)

5
typing/types.mli
View File

@ -264,11 +264,6 @@ and value_kind =
(* Self *) (* Self *)
| Val_anc of (string * Ident.t) list * string | Val_anc of (string * Ident.t) list * string
(* Ancestor *) (* Ancestor *)
| Val_unbound of value_unbound_reason (* Unbound variable *)
and value_unbound_reason =
| Val_unbound_instance_variable
| Val_unbound_ghost_recursive
(* Variance *) (* Variance *)

277
typing/typetexp.ml
View File

@ -28,8 +28,7 @@ exception Already_bound
type error = type error =
Unbound_type_variable of string Unbound_type_variable of string
| Unbound_type_constructor of Longident.t | Undefined_type_constructor of Path.t
| Unbound_type_constructor_2 of Path.t
| Type_arity_mismatch of Longident.t * int * int | Type_arity_mismatch of Longident.t * int * int
| Bound_type_variable of string | Bound_type_variable of string
| Recursive_type | Recursive_type
@ -45,26 +44,8 @@ type error =
| Cannot_quantify of string * type_expr | Cannot_quantify of string * type_expr
| Multiple_constraints_on_type of Longident.t | Multiple_constraints_on_type of Longident.t
| Method_mismatch of string * type_expr * type_expr | 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 | Opened_object of Path.t option
| Not_an_object of type_expr | 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 of Location.t * Env.t * error
exception Error_forward of Location.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 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. *) (* Support for first-class modules. *)
let transl_modtype_longident = ref (fun _ -> assert false) 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 let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
ctyp (Ttyp_tuple ctys) ty ctyp (Ttyp_tuple ctys) ty
| Ptyp_constr(lid, stl) -> | 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 = let stl =
match stl with match stl with
| [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 -> | [ {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) -> | Ptyp_class(lid, stl) ->
let (path, decl, _is_variant) = let (path, decl, _is_variant) =
try try
let path = Env.lookup_type lid.txt env in let path, decl = Env.find_type_by_name lid.txt env in
let decl = Env.find_type path env in
let rec check decl = let rec check decl =
match decl.type_manifest with match decl.type_manifest with
None -> raise Not_found None -> raise Not_found
@ -437,11 +274,10 @@ and transl_type_aux env policy styp =
| Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s)
| Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
in in
let path = Env.lookup_type lid2 env in let path, decl = Env.find_type_by_name lid2 env in
let decl = Env.find_type path env in
(path, decl, false) (path, decl, false)
with Not_found -> 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 in
if List.length stl <> decl.type_arity then if List.length stl <> decl.type_arity then
raise(Error(styp.ptyp_loc, env, raise(Error(styp.ptyp_loc, env,
@ -598,7 +434,7 @@ and transl_type_aux env policy styp =
let row = Btype.row_repr row in let row = Btype.row_repr row in
row.row_fields row.row_fields
| {desc=Tvar _}, Some(p, _) -> | {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)) raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
in in
@ -742,7 +578,7 @@ and transl_fields env policy o fields =
OTinherit cty OTinherit cty
end end
| {desc=Tvar _}, Some p -> | {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)) | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
end in end in
{ of_desc; of_loc; of_attributes; } { of_desc; of_loc; of_attributes; }
@ -867,38 +703,6 @@ let transl_type_scheme env styp =
open Format open Format
open Printtyp 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 let report_error env ppf = function
| Unbound_type_variable name -> | Unbound_type_variable name ->
let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in 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" fprintf ppf "The type variable %s is unbound in this type declaration.@ %a"
name name
did_you_mean (fun () -> Misc.spellcheck names name ) did_you_mean (fun () -> Misc.spellcheck names name )
| Unbound_type_constructor lid -> | Undefined_type_constructor p ->
fprintf ppf "Unbound type constructor %a" longident lid;
spellcheck ppf fold_types env lid;
| Unbound_type_constructor_2 p ->
fprintf ppf "The type constructor@ %a@ is not yet completely defined" fprintf ppf "The type constructor@ %a@ is not yet completely defined"
path p path p
| Type_arity_mismatch(lid, expected, provided) -> | Type_arity_mismatch(lid, expected, provided) ->
@ -990,58 +791,6 @@ let report_error env ppf = function
Printtyp.reset_and_mark_loops_list [ty; ty']; Printtyp.reset_and_mark_loops_list [ty; ty'];
fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]" fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
l Printtyp.type_expr ty Printtyp.type_expr ty') 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 -> | Opened_object nm ->
fprintf ppf fprintf ppf
"Illegal open object type%a" "Illegal open object type%a"
@ -1052,16 +801,6 @@ let report_error env ppf = function
Printtyp.reset_and_mark_loops ty; Printtyp.reset_and_mark_loops ty;
fprintf ppf "@[The type %a@ is not an object type@]" fprintf ppf "@[The type %a@ is not an object type@]"
Printtyp.type_expr ty 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 () = let () =
Location.register_error_of_exn Location.register_error_of_exn

52
typing/typetexp.mli
View File

@ -42,8 +42,7 @@ exception Already_bound
type error = type error =
Unbound_type_variable of string Unbound_type_variable of string
| Unbound_type_constructor of Longident.t | Undefined_type_constructor of Path.t
| Unbound_type_constructor_2 of Path.t
| Type_arity_mismatch of Longident.t * int * int | Type_arity_mismatch of Longident.t * int * int
| Bound_type_variable of string | Bound_type_variable of string
| Recursive_type | Recursive_type
@ -59,26 +58,8 @@ type error =
| Cannot_quantify of string * type_expr | Cannot_quantify of string * type_expr
| Multiple_constraints_on_type of Longident.t | Multiple_constraints_on_type of Longident.t
| Method_mismatch of string * type_expr * type_expr | 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 | Opened_object of Path.t option
| Not_an_object of type_expr | 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 of Location.t * Env.t * error
@ -93,34 +74,3 @@ val create_package_mty:
Location.t -> Env.t -> Parsetree.package_type -> Location.t -> Env.t -> Parsetree.package_type ->
(Longident.t Asttypes.loc * Parsetree.core_type) list * (Longident.t Asttypes.loc * Parsetree.core_type) list *
Parsetree.module_type 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

7
typing/untypeast.ml
View File

@ -108,11 +108,8 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
let fresh_name s env = let fresh_name s env =
let rec aux i = let rec aux i =
let name = s ^ Int.to_string i in let name = s ^ Int.to_string i in
try if Env.bound_value name env then aux (i+1)
let _ = Env.lookup_value (Lident name) env in else name
name
with
| Not_found -> aux (i+1)
in in
aux 0 aux 0

12
utils/misc.ml
View File

@ -918,13 +918,13 @@ module EnvLazy = struct
| Raise e -> raise e | Raise e -> raise e
| Thunk e -> | Thunk e ->
match f e with match f e with
| None -> | (Error _ as err : _ result) ->
x := Done None; x := Done err;
log := Cons(x, e, !log); log := Cons(x, e, !log);
None err
| Some _ as y -> | Ok _ as res ->
x := Done y; x := Done res;
y res
| exception e -> | exception e ->
x := Raise e; x := Raise e;
raise e raise e

10
utils/misc.mli
View File

@ -475,11 +475,13 @@ module EnvLazy: sig
val create_forced : 'b -> ('a, 'b) t val create_forced : 'b -> ('a, 'b) t
val create_failed : exn -> ('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 (* [force_logged log f t] is equivalent to [force f t] but if [f]
[None] then [t] is recorded in [log]. [backtrack log] will then reset all returns [Error _] then [t] is recorded in [log]. [backtrack log]
the recorded [t]s back to their original state. *) will then reset all the recorded [t]s back to their original
state. *)
val log : unit -> log 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 val backtrack : log -> unit
end end