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))
let rec expression event env = function
E_ident lid ->
begin try
let (p, valdesc) = Env.lookup_value lid env in
(begin match valdesc.val_kind with
Val_ivar (_, cl_num) ->
let (p0, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
in
let v = value_path event env p0 in
let i = value_path event env p in
Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
| _ ->
value_path event env p
end,
Ctype.correct_levels valdesc.val_type)
with Not_found ->
raise(Error(Unbound_long_identifier lid))
end
| E_ident lid -> begin
match Env.find_value_by_name lid env with
| (p, valdesc) ->
let v =
match valdesc.val_kind with
| Val_ivar (_, cl_num) ->
let (p0, _) =
Env.find_value_by_name
(Longident.Lident ("self-" ^ cl_num)) env
in
let v = value_path event env p0 in
let i = value_path event env p in
Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
| _ ->
value_path event env p
in
let typ = Ctype.correct_levels valdesc.val_type in
v, typ
| exception Not_found ->
raise(Error(Unbound_long_identifier lid))
end
| E_result ->
begin match event with
Some {ev_ev = {ev_kind = Event_after ty; ev_typsubst = subst}}

35
debugger/loadprinter.ml
View File

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

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 env = Env.add_persistent_structure pers Env.empty in
let lid = Longident.Ldot (Longident.Lident mod_name, name) in
match Env.lookup_value lid env with
match Env.find_value_by_name lid env with
| path, _ -> transl_value_path Location.none env path
| exception Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")

2
lambda/matching.ml
View File

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

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

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

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

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

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

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

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

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

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

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

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

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
to happen while this module exists.
The only operations that happen are:
- Env.lookup_type
- Env.find_type
- Env.find_type_by_name
- nondep_instance
None of which check the scope.
@ -2435,23 +2434,22 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
| n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 ->
nt2 :: complete (if n = n2 then nl else nl1) ntl'
| n :: nl, _ ->
try
let path =
Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env'
in
match Env.find_type path env' with
{type_arity = 0; type_kind = Type_abstract;
type_private = Public; type_manifest = Some t2} ->
(n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
| {type_arity = 0; type_kind = Type_abstract;
type_private = Public; type_manifest = None} when allow_absent ->
complete nl ntl2
| _ -> raise Exit
with
| Not_found when allow_absent -> complete nl ntl2
| Exit -> raise Not_found
let lid = concat_longident (Longident.Lident "Pkg") n in
match Env.find_type_by_name lid env' with
| (_, {type_arity = 0; type_kind = Type_abstract;
type_private = Public; type_manifest = Some t2}) ->
(n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
| (_, {type_arity = 0; type_kind = Type_abstract;
type_private = Public; type_manifest = None})
when allow_absent ->
complete nl ntl2
| _ -> raise Exit
| exception Not_found when allow_absent->
complete nl ntl2
in
complete nl1 (List.combine nl2 tl2)
match complete nl1 (List.combine nl2 tl2) with
| res -> res
| exception Exit -> raise Not_found
(* raise Not_found rather than Unify if the module types are incompatible *)
let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
@ -3942,18 +3940,8 @@ let rec filter_visited = function
let memq_warn t visited =
if List.memq t visited then (warn := true; true) else false
let rec lid_of_path ?(hash="") = function
Path.Pident id ->
Longident.Lident (hash ^ Ident.name id)
| Path.Pdot (p1, s) ->
Longident.Ldot (lid_of_path p1, hash ^ s)
| Path.Papply (p1, p2) ->
Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2)
let find_cltype_for_path env p =
let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in
let cl_abbr = Env.find_type cl_path env in
let cl_abbr = Env.find_hash_type p env in
match cl_abbr.type_manifest with
Some ty ->
begin match (repr ty).desc with

1
typing/ctype.mli
View File

@ -149,7 +149,6 @@ val set_object_name:
val remove_object_name: type_expr -> unit
val hide_private_methods: type_expr -> unit
val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
val lid_of_path: ?hash:string -> Path.t -> Longident.t
val sort_row_fields: (label * row_field) list -> (label * row_field) list
val merge_row_fields:

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 Misc
type value_unbound_reason =
| Val_unbound_instance_variable
| Val_unbound_self
| Val_unbound_ancestor
| Val_unbound_ghost_recursive of Location.t
type module_unbound_reason =
| Mod_unbound_illegal_recursion
type summary =
Env_empty
| Env_value of summary * Ident.t * value_description
@ -34,6 +43,8 @@ type summary =
| Env_constraints of summary * type_declaration Path.Map.t
| Env_copy_types of summary
| Env_persistent of summary * Ident.t
| Env_value_unbound of summary * string * value_unbound_reason
| Env_module_unbound of summary * string * module_unbound_reason
type address =
| Aident of Ident.t
@ -53,7 +64,7 @@ type type_descriptions =
(* For short-paths *)
type iter_cont
val iter_types:
(Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) ->
(Path.t -> Path.t * type_declaration -> unit) ->
t -> iter_cont
val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
val same_types: t -> t -> bool
@ -73,6 +84,9 @@ val find_modtype: Path.t -> t -> modtype_declaration
val find_class: Path.t -> t -> class_declaration
val find_cltype: Path.t -> t -> class_type_declaration
val find_ident_constructor: Ident.t -> t -> constructor_description
val find_ident_label: Ident.t -> t -> label_description
val find_type_expansion:
Path.t -> t -> type_expr list * type_expr * int
val find_type_expansion_opt:
@ -81,6 +95,9 @@ val find_type_expansion_opt:
of the compiler's type-based optimisations. *)
val find_modtype_expansion: Path.t -> t -> module_type
val find_hash_type: Path.t -> t -> type_declaration
(* Find the "#t" type given the path for "t" *)
val find_value_address: Path.t -> t -> address
val find_module_address: Path.t -> t -> address
val find_class_address: Path.t -> t -> address
@ -109,47 +126,137 @@ val add_required_global: Ident.t -> unit
val has_local_constraints: t -> bool
(* Mark definitions as used *)
val mark_value_used: string -> value_description -> unit
val mark_module_used: string -> Location.t -> unit
val mark_type_used: string -> type_declaration -> unit
type constructor_usage = Positive | Pattern | Privatize
val mark_constructor_used:
constructor_usage -> string -> constructor_declaration -> unit
val mark_extension_used:
constructor_usage -> string -> extension_constructor -> unit
(* Lookup by long identifiers *)
(* ?loc is used to report 'deprecated module' warnings and other alerts *)
(* Lookup errors *)
type unbound_value_hint =
| No_hint
| Missing_rec of Location.t
type lookup_error =
| Unbound_value of Longident.t * unbound_value_hint
| Unbound_type of Longident.t
| Unbound_constructor of Longident.t
| Unbound_label of Longident.t
| Unbound_module of Longident.t
| Unbound_class of Longident.t
| Unbound_modtype of Longident.t
| Unbound_cltype of Longident.t
| Unbound_instance_variable of string
| Not_an_instance_variable of string
| Masked_instance_variable of Longident.t
| Masked_self_variable of Longident.t
| Masked_ancestor_variable of Longident.t
| Structure_used_as_functor of Longident.t
| Abstract_used_as_functor of Longident.t
| Functor_used_as_structure of Longident.t
| Abstract_used_as_structure of Longident.t
| Generative_used_as_applicative of Longident.t
| Illegal_reference_to_recursive_module
| Cannot_scrape_alias of Longident.t * Path.t
val lookup_error: Location.t -> t -> lookup_error -> 'a
(* The [lookup_foo] functions will emit proper error messages (by
raising [Error]) if the identifier cannot be found, whereas the
[find_foo_by_name] functions will raise [Not_found] instead.
The [~use] parameters of the [lookup_foo] functions control
whether this lookup should be counted as a use for usage
warnings and alerts.
[Longident.t]s in the program source should be looked up using
[lookup_foo ~use:true] exactly one time -- otherwise warnings may be
emitted the wrong number of times. *)
val lookup_value:
?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> Path.t * value_description
val lookup_constructor:
?loc:Location.t -> ?mark:bool -> Longident.t -> t -> constructor_description
val lookup_all_constructors:
?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> (constructor_description * (unit -> unit)) list
val lookup_label:
?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> label_description
val lookup_all_labels:
?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> (label_description * (unit -> unit)) list
?use:bool -> loc:Location.t -> Longident.t -> t ->
Path.t * value_description
val lookup_type:
?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t
(* Since 4.04, this function no longer returns [type_description].
To obtain it, you should either call [Env.find_type], or replace
it by [Typetexp.find_type] *)
?use:bool -> loc:Location.t -> Longident.t -> t ->
Path.t * type_declaration
val lookup_module:
load:bool -> ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t
?use:bool -> loc:Location.t -> Longident.t -> t ->
Path.t * module_declaration
val lookup_modtype:
?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> Path.t * modtype_declaration
?use:bool -> loc:Location.t -> Longident.t -> t ->
Path.t * modtype_declaration
val lookup_class:
?loc:Location.t -> ?mark:bool ->
Longident.t -> t -> Path.t * class_declaration
?use:bool -> loc:Location.t -> Longident.t -> t ->
Path.t * class_declaration
val lookup_cltype:
?loc:Location.t -> ?mark:bool ->
?use:bool -> loc:Location.t -> Longident.t -> t ->
Path.t * class_type_declaration
val lookup_module_path:
?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t
val lookup_constructor:
?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
constructor_description
val lookup_all_constructors:
?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t ->
((constructor_description * (unit -> unit)) list,
Location.t * t * lookup_error) result
val lookup_all_constructors_from_type:
?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t ->
(constructor_description * (unit -> unit)) list
val lookup_label:
?use:bool -> loc:Location.t -> Longident.t -> t ->
label_description
val lookup_all_labels:
?use:bool -> loc:Location.t -> Longident.t -> t ->
((label_description * (unit -> unit)) list,
Location.t * t * lookup_error) result
val lookup_all_labels_from_type:
?use:bool -> loc:Location.t -> Path.t -> t ->
(label_description * (unit -> unit)) list
val lookup_instance_variable:
?use:bool -> loc:Location.t -> string -> t ->
Path.t * Asttypes.mutable_flag * string * type_expr
val find_value_by_name:
Longident.t -> t -> Path.t * value_description
val find_type_by_name:
Longident.t -> t -> Path.t * type_declaration
val find_module_by_name:
Longident.t -> t -> Path.t * module_declaration
val find_modtype_by_name:
Longident.t -> t -> Path.t * modtype_declaration
val find_class_by_name:
Longident.t -> t -> Path.t * class_declaration
val find_cltype_by_name:
Longident.t -> t -> Path.t * class_type_declaration
val make_copy_of_types: t -> (t -> t)
val find_constructor_by_name:
Longident.t -> t -> constructor_description
val find_label_by_name:
Longident.t -> t -> label_description
exception Recmodule
(* Raise by lookup_module when the identifier refers
to one of the modules of a recursive definition
during the computation of its approximation (see #5965). *)
(* Check if a name is bound *)
val bound_value: string -> t -> bool
val bound_module: string -> t -> bool
val bound_type: string -> t -> bool
val bound_modtype: string -> t -> bool
val bound_class: string -> t -> bool
val bound_cltype: string -> t -> bool
val make_copy_of_types: t -> (t -> t)
(* Insertion by identifier *)
@ -224,6 +331,10 @@ val enter_cltype:
in the process. *)
val enter_signature: scope:int -> signature -> t -> signature * t
val enter_unbound_value : string -> value_unbound_reason -> t -> t
val enter_unbound_module : string -> module_unbound_reason -> t -> t
(* Initialize the cache of in-core module interfaces. *)
val reset_cache: unit -> unit
@ -276,6 +387,7 @@ val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
type error =
| Missing_module of Location.t * Path.t * Path.t
| Illegal_value_name of Location.t * string
| Lookup_error of Location.t * t * lookup_error
exception Error of error
@ -283,18 +395,7 @@ open Format
val report_error: formatter -> error -> unit
val mark_value_used: string -> value_description -> unit
val mark_module_used: string -> Location.t -> unit
val mark_type_used: string -> type_declaration -> unit
type constructor_usage = Positive | Pattern | Privatize
val mark_constructor_used:
constructor_usage -> string -> type_declaration -> string -> unit
val mark_constructor:
constructor_usage -> t -> string -> constructor_description -> unit
val mark_extension_used:
constructor_usage -> extension_constructor -> string -> unit
val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit
val in_signature: bool -> t -> t
@ -306,8 +407,9 @@ val set_type_used_callback:
string -> type_declaration -> ((unit -> unit) -> unit) -> unit
(* Forward declaration to break mutual recursion with Includemod. *)
val check_modtype_inclusion:
(loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref
val check_functor_application:
(errors:bool -> loc:Location.t -> t -> module_type ->
Path.t -> module_type -> Path.t -> unit) ref
(* Forward declaration to break mutual recursion with Typemod. *)
val check_well_formed_module:
(t -> Location.t -> string -> module_type -> unit) ref
@ -318,36 +420,10 @@ val strengthen:
(aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
(* Forward declaration to break mutual recursion with Ctype. *)
val same_constr: (t -> type_expr -> type_expr -> bool) ref
(** Folding over all identifiers (for analysis purpose) *)
val fold_values:
(string -> Path.t -> value_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_types:
(string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_constructors:
(constructor_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_labels:
(label_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
(** Persistent structures are only traversed if they are already loaded. *)
val fold_modules:
(string -> Path.t -> module_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_modtypes:
(string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_classes:
(string -> Path.t -> class_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_cltypes:
(string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
(* Forward declaration to break mutual recursion with Printtyp. *)
val print_longident: (Format.formatter -> Longident.t -> unit) ref
(* Forward declaration to break mutual recursion with Printtyp. *)
val print_path: (Format.formatter -> Path.t -> unit) ref
(** Utilities *)
val scrape_alias: t -> module_type -> module_type

6
typing/envaux.ml
View File

@ -86,6 +86,12 @@ let rec env_from_summary sum subst =
| Env_persistent (s, id) ->
let env = env_from_summary s subst in
Env.add_persistent_structure id env
| Env_value_unbound (s, str, reason) ->
let env = env_from_summary s subst in
Env.enter_unbound_value str reason env
| Env_module_unbound (s, str, reason) ->
let env = env_from_summary s subst in
Env.enter_unbound_module str reason env
in
Hashtbl.add env_cache (sum, subst) env;
env

21
typing/includecore.ml
View File

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

19
typing/includemod.ml
View File

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

8
typing/predef.mli
View File

@ -57,6 +57,14 @@ val path_match_failure: Path.t
val path_assert_failure : Path.t
val path_undefined_recursive_module : Path.t
val ident_false : Ident.t
val ident_true : Ident.t
val ident_void : Ident.t
val ident_nil : Ident.t
val ident_cons : Ident.t
val ident_none : Ident.t
val ident_some : Ident.t
(* To build the initial environment. Since there is a nasty mutual
recursion between predef and env, we break it by parameterizing
over Env.t, Env.add_type and Env.add_extension. *)

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

37
typing/typeclass.ml
View File

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

338
typing/typecore.ml
View File

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

7
typing/typecore.mli
View File

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

31
typing/typedecl.ml
View File

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

64
typing/typemod.ml
View File

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

5
typing/types.ml
View File

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

5
typing/types.mli
View File

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

277
typing/typetexp.ml
View File

@ -28,8 +28,7 @@ exception Already_bound
type error =
Unbound_type_variable of string
| Unbound_type_constructor of Longident.t
| Unbound_type_constructor_2 of Path.t
| Undefined_type_constructor of Path.t
| Type_arity_mismatch of Longident.t * int * int
| Bound_type_variable of string
| Recursive_type
@ -45,26 +44,8 @@ type error =
| Cannot_quantify of string * type_expr
| Multiple_constraints_on_type of Longident.t
| Method_mismatch of string * type_expr * type_expr
| Unbound_value of Longident.t
| Unbound_constructor of Longident.t
| Unbound_label of Longident.t
| Unbound_module of Longident.t
| Unbound_class of Longident.t
| Unbound_modtype of Longident.t
| Unbound_cltype of Longident.t
| Ill_typed_functor_application
of Longident.t * Longident.t * Includemod.error list option
| Illegal_reference_to_recursive_module
| Wrong_use_of_module of Longident.t * [ `Structure_used_as_functor
| `Abstract_used_as_functor
| `Functor_used_as_structure
| `Abstract_used_as_structure
| `Generative_used_as_applicative
]
| Cannot_scrape_alias of Longident.t * Path.t
| Opened_object of Path.t option
| Not_an_object of type_expr
| Unbound_value_missing_rec of Longident.t * Location.t
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
@ -74,149 +55,6 @@ module TyVarMap = Misc.Stdlib.String.Map
type variable_context = int * type_expr TyVarMap.t
(* To update locations from Typemod.check_well_founded_module. *)
let typemod_update_location = ref (fun _ -> assert false)
(* Narrowing unbound identifier errors. *)
let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
fun env loc lid make_error ->
let check_module mlid =
try ignore (Env.lookup_module ~load:true mlid env) with
| Not_found ->
narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid)
| Env.Recmodule ->
raise (Error (loc, env, Illegal_reference_to_recursive_module))
in
let error e = raise (Error (loc, env, e)) in
begin match lid with
| Longident.Lident _ -> ()
| Longident.Ldot (mlid, _) ->
check_module mlid;
let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in
begin match Env.scrape_alias env md.md_type with
| Mty_functor _ ->
error (Wrong_use_of_module (mlid, `Functor_used_as_structure))
| Mty_ident _ ->
error (Wrong_use_of_module (mlid, `Abstract_used_as_structure))
| Mty_alias p -> error (Cannot_scrape_alias(mlid, p))
| Mty_signature _ -> ()
end
| Longident.Lapply (flid, mlid) ->
check_module flid;
let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in
let mty_param =
match Env.scrape_alias env fmd.md_type with
| Mty_signature _ ->
error (Wrong_use_of_module (flid, `Structure_used_as_functor))
| Mty_ident _ ->
error (Wrong_use_of_module (flid, `Abstract_used_as_functor))
| Mty_alias p -> error (Cannot_scrape_alias(flid, p))
| Mty_functor (_, None, _) ->
error (Wrong_use_of_module (flid, `Generative_used_as_applicative))
| Mty_functor (_, Some mty_param, _) -> mty_param
in
check_module mlid;
let mpath = Env.lookup_module ~load:true mlid env in
let mmd = Env.find_module mpath env in
begin match Env.scrape_alias env mmd.md_type with
| Mty_alias p -> error (Cannot_scrape_alias(mlid, p))
| mty_arg ->
let details =
try Includemod.check_modtype_inclusion
~loc env mty_arg mpath mty_param;
None (* should be impossible *)
with Includemod.Error e -> Some e
in
error (Ill_typed_functor_application (flid, mlid, details))
end
end;
error (make_error lid)
let find_component (lookup : ?loc:_ -> ?mark:_ -> _) make_error env loc lid =
try
match lid with
| Longident.Ldot (Longident.Lident "*predef*", s) ->
lookup ~loc (Longident.Lident s) Env.initial_safe_string
| _ ->
lookup ~loc lid env
with Not_found ->
narrow_unbound_lid_error env loc lid make_error
| Env.Recmodule ->
raise (Error (loc, env, Illegal_reference_to_recursive_module))
| err ->
raise (!typemod_update_location loc err)
let find_type env loc lid =
let path =
find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
env loc lid
in
let decl = Env.find_type path env in
Builtin_attributes.check_alerts loc decl.type_attributes (Path.name path);
(path, decl)
let find_constructor =
find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
let find_all_constructors =
find_component Env.lookup_all_constructors
(fun lid -> Unbound_constructor lid)
let find_label =
find_component Env.lookup_label (fun lid -> Unbound_label lid)
let find_all_labels =
find_component Env.lookup_all_labels (fun lid -> Unbound_label lid)
let find_class env loc lid =
let (path, decl) as r =
find_component Env.lookup_class (fun lid -> Unbound_class lid) env loc lid
in
Builtin_attributes.check_alerts loc decl.cty_attributes (Path.name path);
r
let find_value env loc lid =
Env.check_value_name (Longident.last lid) loc;
let (path, decl) as r =
find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid
in
Builtin_attributes.check_alerts loc decl.val_attributes (Path.name path);
r
let lookup_module ?(load=false) env loc lid =
find_component
(fun ?loc ?mark lid env -> (Env.lookup_module ~load ?loc ?mark lid env))
(fun lid -> Unbound_module lid) env loc lid
let find_module env loc lid =
let path = lookup_module ~load:true env loc lid in
let decl = Env.find_module path env in
(* No need to check for alerts here, this is done in Env. *)
(path, decl)
let find_modtype env loc lid =
let (path, decl) as r =
find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
env loc lid
in
Builtin_attributes.check_alerts loc decl.mtd_attributes (Path.name path);
r
let find_class_type env loc lid =
let (path, decl) as r =
find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
env loc lid
in
Builtin_attributes.check_alerts loc decl.clty_attributes (Path.name path);
r
let unbound_constructor_error env lid =
narrow_unbound_lid_error env lid.loc lid.txt
(fun lid -> Unbound_constructor lid)
let unbound_label_error env lid =
narrow_unbound_lid_error env lid.loc lid.txt
(fun lid -> Unbound_label lid)
(* Support for first-class modules. *)
let transl_modtype_longident = ref (fun _ -> assert false)
@ -375,7 +213,7 @@ and transl_type_aux env policy styp =
let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
ctyp (Ttyp_tuple ctys) ty
| Ptyp_constr(lid, stl) ->
let (path, decl) = find_type env lid.loc lid.txt in
let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in
let stl =
match stl with
| [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
@ -415,8 +253,7 @@ and transl_type_aux env policy styp =
| Ptyp_class(lid, stl) ->
let (path, decl, _is_variant) =
try
let path = Env.lookup_type lid.txt env in
let decl = Env.find_type path env in
let path, decl = Env.find_type_by_name lid.txt env in
let rec check decl =
match decl.type_manifest with
None -> raise Not_found
@ -437,11 +274,10 @@ and transl_type_aux env policy styp =
| Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s)
| Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
in
let path = Env.lookup_type lid2 env in
let decl = Env.find_type path env in
let path, decl = Env.find_type_by_name lid2 env in
(path, decl, false)
with Not_found ->
ignore (find_class env lid.loc lid.txt); assert false
ignore (Env.lookup_class ~loc:lid.loc lid.txt env); assert false
in
if List.length stl <> decl.type_arity then
raise(Error(styp.ptyp_loc, env,
@ -598,7 +434,7 @@ and transl_type_aux env policy styp =
let row = Btype.row_repr row in
row.row_fields
| {desc=Tvar _}, Some(p, _) ->
raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p))
raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p))
| _ ->
raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
in
@ -742,7 +578,7 @@ and transl_fields env policy o fields =
OTinherit cty
end
| {desc=Tvar _}, Some p ->
raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p))
raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p))
| _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
end in
{ of_desc; of_loc; of_attributes; }
@ -867,38 +703,6 @@ let transl_type_scheme env styp =
open Format
open Printtyp
let spellcheck ppf fold env lid =
let choices ~path name =
let env = fold (fun x xs -> x::xs) path env [] in
Misc.spellcheck env name in
match lid with
| Longident.Lapply _ -> ()
| Longident.Lident s ->
Misc.did_you_mean ppf (fun () -> choices ~path:None s)
| Longident.Ldot (r, s) ->
Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s)
let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc)
let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc)
let fold_values f =
(* We only use "real" values while spellchecking (as opposed to "ghost"
values inserted in the environment to trigger the "missing rec" hint).
This is needed in order to avoid dummy suggestions like:
"unbound value x, did you mean x?" *)
Env.fold_values
(fun name _path descr acc ->
match descr.val_kind with
| Val_unbound _ -> acc
| _ -> f name acc)
let fold_types = fold_simple Env.fold_types
let fold_modules = fold_simple Env.fold_modules
let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name)
let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name)
let fold_classes = fold_simple Env.fold_classes
let fold_modtypes = fold_simple Env.fold_modtypes
let fold_cltypes = fold_simple Env.fold_cltypes
let report_error env ppf = function
| Unbound_type_variable name ->
let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in
@ -906,10 +710,7 @@ let report_error env ppf = function
fprintf ppf "The type variable %s is unbound in this type declaration.@ %a"
name
did_you_mean (fun () -> Misc.spellcheck names name )
| Unbound_type_constructor lid ->
fprintf ppf "Unbound type constructor %a" longident lid;
spellcheck ppf fold_types env lid;
| Unbound_type_constructor_2 p ->
| Undefined_type_constructor p ->
fprintf ppf "The type constructor@ %a@ is not yet completely defined"
path p
| Type_arity_mismatch(lid, expected, provided) ->
@ -990,58 +791,6 @@ let report_error env ppf = function
Printtyp.reset_and_mark_loops_list [ty; ty'];
fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
l Printtyp.type_expr ty Printtyp.type_expr ty')
| Unbound_value lid ->
fprintf ppf "Unbound value %a" longident lid;
spellcheck ppf fold_values env lid;
| Unbound_module lid ->
fprintf ppf "Unbound module %a" longident lid;
spellcheck ppf fold_modules env lid;
| Unbound_constructor lid ->
fprintf ppf "Unbound constructor %a" longident lid;
spellcheck ppf fold_constructors env lid;
| Unbound_label lid ->
fprintf ppf "Unbound record field %a" longident lid;
spellcheck ppf fold_labels env lid;
| Unbound_class lid ->
fprintf ppf "Unbound class %a" longident lid;
spellcheck ppf fold_classes env lid;
| Unbound_modtype lid ->
fprintf ppf "Unbound module type %a" longident lid;
spellcheck ppf fold_modtypes env lid;
| Unbound_cltype lid ->
fprintf ppf "Unbound class type %a" longident lid;
spellcheck ppf fold_cltypes env lid;
| Ill_typed_functor_application (flid, mlid, details) ->
(match details with
| None ->
fprintf ppf "@[Ill-typed functor application %a(%a)@]"
longident flid longident mlid
| Some inclusion_error ->
fprintf ppf "@[The type of %a does not match %a's parameter@\n%a@]"
longident mlid longident flid Includemod.report_error inclusion_error)
| Illegal_reference_to_recursive_module ->
fprintf ppf "Illegal recursive module reference"
| Wrong_use_of_module (lid, details) ->
(match details with
| `Structure_used_as_functor ->
fprintf ppf "@[The module %a is a structure, it cannot be applied@]"
longident lid
| `Abstract_used_as_functor ->
fprintf ppf "@[The module %a is abstract, it cannot be applied@]"
longident lid
| `Functor_used_as_structure ->
fprintf ppf "@[The module %a is a functor, \
it cannot have any components@]" longident lid
| `Abstract_used_as_structure ->
fprintf ppf "@[The module %a is abstract, \
it cannot have any components@]" longident lid
| `Generative_used_as_applicative ->
fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \
applied@ in@ type@ expressions@]" longident lid)
| Cannot_scrape_alias(lid, p) ->
fprintf ppf
"The module %a is an alias for module %a, which is missing"
longident lid path p
| Opened_object nm ->
fprintf ppf
"Illegal open object type%a"
@ -1052,16 +801,6 @@ let report_error env ppf = function
Printtyp.reset_and_mark_loops ty;
fprintf ppf "@[The type %a@ is not an object type@]"
Printtyp.type_expr ty
| Unbound_value_missing_rec (lid, loc) ->
fprintf ppf
"Unbound value %a" longident lid;
spellcheck ppf fold_values env lid;
let (_, line, _) = Location.get_pos_info loc.Location.loc_start in
fprintf ppf
"@.@[%s@ %s %i@]"
"Hint: If this is a recursive definition,"
"you should add the 'rec' keyword on line"
line
let () =
Location.register_error_of_exn

52
typing/typetexp.mli
View File

@ -42,8 +42,7 @@ exception Already_bound
type error =
Unbound_type_variable of string
| Unbound_type_constructor of Longident.t
| Unbound_type_constructor_2 of Path.t
| Undefined_type_constructor of Path.t
| Type_arity_mismatch of Longident.t * int * int
| Bound_type_variable of string
| Recursive_type
@ -59,26 +58,8 @@ type error =
| Cannot_quantify of string * type_expr
| Multiple_constraints_on_type of Longident.t
| Method_mismatch of string * type_expr * type_expr
| Unbound_value of Longident.t
| Unbound_constructor of Longident.t
| Unbound_label of Longident.t
| Unbound_module of Longident.t
| Unbound_class of Longident.t
| Unbound_modtype of Longident.t
| Unbound_cltype of Longident.t
| Ill_typed_functor_application
of Longident.t * Longident.t * Includemod.error list option
| Illegal_reference_to_recursive_module
| Wrong_use_of_module of Longident.t * [ `Structure_used_as_functor
| `Abstract_used_as_functor
| `Functor_used_as_structure
| `Abstract_used_as_structure
| `Generative_used_as_applicative
]
| Cannot_scrape_alias of Longident.t * Path.t
| Opened_object of Path.t option
| Not_an_object of type_expr
| Unbound_value_missing_rec of Longident.t * Location.t
exception Error of Location.t * Env.t * error
@ -93,34 +74,3 @@ val create_package_mty:
Location.t -> Env.t -> Parsetree.package_type ->
(Longident.t Asttypes.loc * Parsetree.core_type) list *
Parsetree.module_type
val find_type:
Env.t -> Location.t -> Longident.t -> Path.t * type_declaration
val find_constructor:
Env.t -> Location.t -> Longident.t -> constructor_description
val find_all_constructors:
Env.t -> Location.t -> Longident.t ->
(constructor_description * (unit -> unit)) list
val find_label:
Env.t -> Location.t -> Longident.t -> label_description
val find_all_labels:
Env.t -> Location.t -> Longident.t ->
(label_description * (unit -> unit)) list
val find_value:
Env.t -> Location.t -> Longident.t -> Path.t * value_description
val find_class:
Env.t -> Location.t -> Longident.t -> Path.t * class_declaration
val find_module:
Env.t -> Location.t -> Longident.t -> Path.t * module_declaration
val lookup_module:
?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t
val find_modtype:
Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration
val find_class_type:
Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration
val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a
(* To update location from typemod errors *)
val typemod_update_location: (Location.t -> exn -> exn) ref

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 rec aux i =
let name = s ^ Int.to_string i in
try
let _ = Env.lookup_value (Lident name) env in
name
with
| Not_found -> aux (i+1)
if Env.bound_value name env then aux (i+1)
else name
in
aux 0

12
utils/misc.ml
View File

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

10
utils/misc.mli
View File

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