summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--man/ocamlc.m2
-rw-r--r--testsuite/tests/typing-misc/records.ml57
-rw-r--r--testsuite/tests/typing-misc/records.ml.principal.reference68
-rw-r--r--testsuite/tests/typing-misc/records.ml.reference52
-rw-r--r--typing/env.ml136
-rw-r--r--typing/env.mli8
-rw-r--r--typing/ident.ml32
-rw-r--r--typing/ident.mli4
-rw-r--r--typing/typecore.ml376
-rw-r--r--typing/typecore.mli1
-rw-r--r--typing/typetexp.ml14
-rw-r--r--typing/typetexp.mli9
-rw-r--r--utils/warnings.ml22
-rw-r--r--utils/warnings.mli2
14 files changed, 553 insertions, 230 deletions
diff --git a/man/ocamlc.m b/man/ocamlc.m
index c102db1bcd..d6f6eb8729 100644
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -752,7 +752,7 @@ mentioned here corresponds to the empty set.
.IP
The default setting is
-.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39 .
+.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39\-41 .
Note that warnings
.BR 5 \ and \ 10
are not always triggered, depending on the internals of the type checker.
diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml
index 0137d646ba..d2a0b57225 100644
--- a/testsuite/tests/typing-misc/records.ml
+++ b/testsuite/tests/typing-misc/records.ml
@@ -20,32 +20,55 @@ let f {M.x; y} = x+y;;
let r = {M.x=1; y=2};;
let z = f r;;
+(* Use type information *)
+type t = {x: int; y: int};;
+type u = {x: bool; y: bool};;
+
+let f (r:t) = r.x;; (* ok *)
+let f r = ignore (r:t); r.x;; (* non principal *)
+
+let f (r: t) =
+ match r with
+ {x; y} -> y + y;; (* ok *)
+let f r =
+ match r with
+ {x; y} -> y + y;; (* fails *)
+let f r =
+ ignore (r: t);
+ match r with
+ {x; y} -> y + y;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+ type t = {x:int}
+ type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+
module M = struct
type t = {x: int; y: int}
- type u = {y: bool}
end;;
-(* path abbreviation is syntactic *)
-let f {M.x; y} = x+y;; (* fails *)
-let r = {M.x=1; y=2};; (* fails *)
+module N = struct
+ type u = {x: bool; y: bool}
+end;;
+open M;;
+open N;;
+let f (r:M.t) = r.x;;
-(* Use type information *)
-let f (x:Complex.t) = x.re;;
-let f x = ignore (x:Complex.t); x.re;; (* non principal *)
module M = struct
type t = {x:int}
module N = struct type s = t = {x:int} end
- type u = { x:bool}
+ type u = {x:bool}
end;;
-let f (r:M.u) = r.x;;
-let f (r:M.t) = r.x;; (* ok *)
open M.N;;
-let f r = r.x;;
-let f (r:M.t) = r.x;; (* ok *)
+let f (r:M.t) = r.x;;
+(* Use field information *)
type u = {x:bool;y:int;z:char};;
type t = {x:int;y:bool};;
-fun {z;x} -> z,x;; (* ok *)
-fun {x;z} -> x,z;; (* fails *)
-fun ({x;z}:u) -> x,z;; (* ok *)
-fun (r:u) -> match r with {x;z} -> x,z;; (* ok *)
-fun r -> ignore (r:u); match r with {x;z} -> x,z;; (* fails for -principal *)
+fun {x;z} -> x,z;;
+
+type u = {x:int;y:bool};;
+type t = {x:bool;y:int;z:char};;
+{x=3; y=true};;
diff --git a/testsuite/tests/typing-misc/records.ml.principal.reference b/testsuite/tests/typing-misc/records.ml.principal.reference
index 09df6bf7af..04c71cb9b4 100644
--- a/testsuite/tests/typing-misc/records.ml.principal.reference
+++ b/testsuite/tests/typing-misc/records.ml.principal.reference
@@ -3,13 +3,11 @@
# Characters 5-6:
{x=3;z=2};;
^
-Error: This record has type t
- which does not include the label z
+Error: Unbound record field label z
# Characters 9-10:
fun {x=3;z=2} -> ();;
^
-Error: This record has type t
- which does not include the label z
+Error: Unbound record field label z
# Characters 26-34:
{x=3; contents=2};;
^^^^^^^^
@@ -28,38 +26,46 @@ Error: Cannot assign field u of the private type u
# val f : M.t -> int = <fun>
# val r : M.t = {M.x = 1; y = 2}
# val z : int = 3
-# module M : sig type t = { x : int; y : int; } type u = { y : bool; } end
-# val f : M.t -> int = <fun>
-# val r : M.t = {M.x = 1; y = 2}
-# val f : Complex.t -> float = <fun>
-# Characters 32-36:
- let f x = ignore (x:Complex.t); x.re;; (* non principal *)
- ^^^^
-Warning 18: this type-based field selection is not principal.
-val f : Complex.t -> float = <fun>
-# module M :
+# type t = { x : int; y : int; }
+# type u = { x : bool; y : bool; }
+# val f : t -> int = <fun>
+# Characters 26-27:
+ let f r = ignore (r:t); r.x;; (* non principal *)
+ ^
+Warning 18: this type-based field disambiguation is not principal.
+val f : t -> int = <fun>
+# val f : t -> int = <fun>
+# Characters 44-45:
+ {x; y} -> y + y;; (* fails *)
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+# Characters 53-59:
+ {x; y} -> y + y;; (* fails for -principal *)
+ ^^^^^^
+Error: This pattern matches values of type u
+ but a pattern was expected which matches values of type t
+# module M : sig type t = { x : int; } type u = { x : bool; } end
+# val f : M.t -> int = <fun>
+# Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x is used out of scope.
+val f : M.t -> int = <fun>
+# module M : sig type t = { x : int; y : int; } end
+# module N : sig type u = { x : bool; y : bool; } end
+# # # val f : M.t -> int = <fun>
+# module M :
sig
type t = { x : int; }
module N : sig type s = t = { x : int; } end
type u = { x : bool; }
end
-# val f : M.u -> bool = <fun>
-# val f : M.t -> int = <fun>
-# # val f : M.N.s -> int = <fun>
-# val f : M.t -> int = <fun>
-# type u = { x : bool; y : int; z : char; }
+# # val f : M.t -> int = <fun>
+# type u = { x : bool; y : int; z : char; }
# type t = { x : int; y : bool; }
-# - : u -> char * bool = <fun>
-# Characters 4-9:
- fun {x;z} -> x,z;; (* fails *)
- ^^^^^
-Error: This pattern matches values of type u
- but a pattern was expected which matches values of type t
# - : u -> bool * char = <fun>
-# - : u -> bool * char = <fun>
-# Characters 36-41:
- fun r -> ignore (r:u); match r with {x;z} -> x,z;; (* fails for -principal *)
- ^^^^^
-Error: This pattern matches values of type u
- but a pattern was expected which matches values of type t
+# type u = { x : int; y : bool; }
+# type t = { x : bool; y : int; z : char; }
+# - : u = {x = 3; y = true}
#
diff --git a/testsuite/tests/typing-misc/records.ml.reference b/testsuite/tests/typing-misc/records.ml.reference
index db54689dd2..8513b49145 100644
--- a/testsuite/tests/typing-misc/records.ml.reference
+++ b/testsuite/tests/typing-misc/records.ml.reference
@@ -3,13 +3,11 @@
# Characters 5-6:
{x=3;z=2};;
^
-Error: This record has type t
- which does not include the label z
+Error: Unbound record field label z
# Characters 9-10:
fun {x=3;z=2} -> ();;
^
-Error: This record has type t
- which does not include the label z
+Error: Unbound record field label z
# Characters 26-34:
{x=3; contents=2};;
^^^^^^^^
@@ -28,30 +26,38 @@ Error: Cannot assign field u of the private type u
# val f : M.t -> int = <fun>
# val r : M.t = {M.x = 1; y = 2}
# val z : int = 3
-# module M : sig type t = { x : int; y : int; } type u = { y : bool; } end
-# val f : M.t -> int = <fun>
-# val r : M.t = {M.x = 1; y = 2}
-# val f : Complex.t -> float = <fun>
-# val f : Complex.t -> float = <fun>
-# module M :
+# type t = { x : int; y : int; }
+# type u = { x : bool; y : bool; }
+# val f : t -> int = <fun>
+# val f : t -> int = <fun>
+# val f : t -> int = <fun>
+# Characters 44-45:
+ {x; y} -> y + y;; (* fails *)
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+# val f : t -> int = <fun>
+# module M : sig type t = { x : int; } type u = { x : bool; } end
+# val f : M.t -> int = <fun>
+# Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x is used out of scope.
+val f : M.t -> int = <fun>
+# module M : sig type t = { x : int; y : int; } end
+# module N : sig type u = { x : bool; y : bool; } end
+# # # val f : M.t -> int = <fun>
+# module M :
sig
type t = { x : int; }
module N : sig type s = t = { x : int; } end
type u = { x : bool; }
end
-# val f : M.u -> bool = <fun>
-# val f : M.t -> int = <fun>
-# # val f : M.N.s -> int = <fun>
-# val f : M.t -> int = <fun>
-# type u = { x : bool; y : int; z : char; }
+# # val f : M.t -> int = <fun>
+# type u = { x : bool; y : int; z : char; }
# type t = { x : int; y : bool; }
-# - : u -> char * bool = <fun>
-# Characters 4-9:
- fun {x;z} -> x,z;; (* fails *)
- ^^^^^
-Error: This pattern matches values of type u
- but a pattern was expected which matches values of type t
-# - : u -> bool * char = <fun>
-# - : u -> bool * char = <fun>
# - : u -> bool * char = <fun>
+# type u = { x : int; y : bool; }
+# type t = { x : bool; y : int; z : char; }
+# - : u = {x = 3; y = true}
#
diff --git a/typing/env.ml b/typing/env.ml
index 5a13086244..a5017f741d 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -132,6 +132,10 @@ module EnvTbl =
slot := true;
x
+ let find_all s tbl =
+ let xs = Ident.find_all s tbl in
+ List.map (fun (x, slot) -> (x, (fun () -> slot := true))) xs
+
let with_slot slot f x =
let old_slot = !current_slot in
current_slot := slot;
@@ -139,8 +143,8 @@ module EnvTbl =
(fun () -> f x)
(fun () -> current_slot := old_slot)
- let keys tbl =
- Ident.keys tbl
+ let fold_name f = Ident.fold_name (fun k (d,_) -> f k d)
+ let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl []
end
type type_descriptions =
@@ -173,8 +177,8 @@ and module_components_repr =
and structure_components = {
mutable comp_values: (string, (value_description * int)) Tbl.t;
mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t;
- mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
- mutable comp_labels: (string, (label_description * int)) Tbl.t;
+ mutable comp_constrs: (string, (constructor_description * int) list) Tbl.t;
+ mutable comp_labels: (string, (label_description * int) list) Tbl.t;
mutable comp_types:
(string, ((type_declaration * type_descriptions) * int)) Tbl.t;
mutable comp_modules:
@@ -572,16 +576,53 @@ let lookup_simple proj1 proj2 lid env =
| Lapply(l1, l2) ->
raise Not_found
+let lookup_all_simple proj1 proj2 shadow lid env =
+ match lid with
+ Lident s ->
+ let xl = EnvTbl.find_all s (proj1 env) in
+ let rec do_shadow =
+ function
+ | [] -> []
+ | ((x, f) :: xs) ->
+ (x, f) ::
+ (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs))
+ in
+ do_shadow xl
+ | Ldot(l, s) ->
+ let (p, desc) = lookup_module_descr l env in
+ begin match EnvLazy.force !components_of_module_maker' desc with
+ Structure_comps c ->
+ let comps =
+ try Tbl.find s (proj2 c) with Not_found -> []
+ in
+ List.map
+ (fun (data, pos) -> (data, (fun () -> ())))
+ comps
+ | Functor_comps f ->
+ raise Not_found
+ end
+ | Lapply(l1, l2) ->
+ raise Not_found
+
let has_local_constraints env = env.local_constraints
+let cstr_shadow cstr1 cstr2 =
+ match cstr1.cstr_tag, cstr2.cstr_tag with
+ Cstr_exception _, Cstr_exception _ -> true
+ | _ -> false
+
+let lbl_shadow lbl1 lbl2 = false
+
let lookup_value =
lookup (fun env -> env.values) (fun sc -> sc.comp_values)
let lookup_annot id e =
lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
-and lookup_constructor =
- lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
-and lookup_label =
- lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
+and lookup_all_constructors =
+ lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+ cstr_shadow
+and lookup_all_labels =
+ lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
+ lbl_shadow
and lookup_type =
lookup (fun env -> env.types) (fun sc -> sc.comp_types)
and lookup_modtype =
@@ -652,9 +693,22 @@ let ty_path t =
| t -> assert false
let lookup_constructor lid env =
- let desc = lookup_constructor lid env in
- mark_type_path env (ty_path desc.cstr_res);
- desc
+ match lookup_all_constructors lid env with
+ [] -> raise Not_found
+ | (desc, use) :: _ ->
+ mark_type_path env (ty_path desc.cstr_res);
+ use ();
+ desc
+
+let lookup_all_constructors lid env =
+ try
+ let cstrs = lookup_all_constructors lid env in
+ let wrap_use desc use () =
+ mark_type_path env (ty_path desc.cstr_res);
+ use ()
+ in
+ List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs
+ with Not_found -> []
let mark_constructor usage env name desc =
match desc.cstr_tag with
@@ -670,9 +724,22 @@ let mark_constructor usage env name desc =
mark_constructor_used usage ty_name ty_decl name
let lookup_label lid env =
- let desc = lookup_label lid env in
- mark_type_path env (ty_path desc.lbl_res);
- desc
+ match lookup_all_labels lid env with
+ [] -> raise Not_found
+ | (desc, use) :: _ ->
+ mark_type_path env (ty_path desc.lbl_res);
+ use ();
+ desc
+
+let lookup_all_label lid env =
+ try
+ let lbls = lookup_all_labels lid env in
+ let wrap_use desc use () =
+ mark_type_path env (ty_path desc.lbl_res);
+ use ()
+ in
+ List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls
+ with Not_found -> []
let lookup_class lid env =
let (_, desc) as r = lookup_class lid env in
@@ -808,6 +875,11 @@ let rec prefix_idents root pos sub = function
(* Compute structure descriptions *)
+let add_to_tbl id decl tbl =
+ let decls =
+ try Tbl.find id tbl with Not_found -> [] in
+ Tbl.add id (decl :: decls) tbl
+
let rec components_of_module env sub path mty =
EnvLazy.create (env, sub, path, mty)
@@ -843,23 +915,26 @@ and components_of_module_maker (env, sub, path, mty) =
let constructors = List.map snd (constructors_of_type path decl') in
let labels = List.map snd (labels_of_type path decl') in
c.comp_types <-
- Tbl.add (Ident.name id) ((decl', (constructors, labels)), nopos) c.comp_types;
+ Tbl.add (Ident.name id)
+ ((decl', (constructors, labels)), nopos)
+ c.comp_types;
List.iter
(fun descr ->
c.comp_constrs <-
- Tbl.add descr.cstr_name (descr, nopos) c.comp_constrs)
+ add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs)
constructors;
List.iter
(fun descr ->
c.comp_labels <-
- Tbl.add descr.lbl_name (descr, nopos) c.comp_labels)
+ add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels)
labels;
env := store_type_infos id path decl !env
| Sig_exception(id, decl) ->
let decl' = Subst.exception_declaration sub decl in
let cstr = Datarepr.exception_descr path decl' in
+ let s = Ident.name id in
c.comp_constrs <-
- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
+ add_to_tbl s (cstr, !pos) c.comp_constrs;
incr pos
| Sig_module(id, mty, _) ->
let mty' = EnvLazy.create (sub, mty) in
@@ -1232,16 +1307,11 @@ let save_signature sg modname filename =
save_signature_with_imports sg modname filename (imported_units())
(* Folding on environments *)
-let ident_tbl_fold f t acc =
- List.fold_right
- (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc)
- (EnvTbl.keys t)
- acc
let find_all proj1 proj2 f lid env acc =
match lid with
| None ->
- ident_tbl_fold
+ EnvTbl.fold_name
(fun id (p, data) acc -> f (Ident.name id) p data acc)
(proj1 env) acc
| Some l ->
@@ -1255,18 +1325,22 @@ let find_all proj1 proj2 f lid env acc =
raise Not_found
end
-let find_all_simple proj1 proj2 f lid env acc =
+let find_all_simple_list proj1 proj2 f lid env acc =
match lid with
| None ->
- ident_tbl_fold
- (fun _id data acc -> f data acc)
+ EnvTbl.fold_name
+ (fun id data acc -> f data acc)
(proj1 env) acc
| Some l ->
let p, desc = lookup_module_descr l env in
begin match EnvLazy.force components_of_module_maker desc with
Structure_comps c ->
Tbl.fold
- (fun s (data, pos) acc -> f data acc)
+ (fun s comps acc ->
+ match comps with
+ [] -> acc
+ | (data, pos) :: _ ->
+ f data acc)
(proj2 c) acc
| Functor_comps _ ->
raise Not_found
@@ -1276,7 +1350,7 @@ let fold_modules f lid env acc =
match lid with
| None ->
let acc =
- ident_tbl_fold
+ EnvTbl.fold_name
(fun id (p, data) acc -> f (Ident.name id) p data acc)
env.modules
acc
@@ -1307,9 +1381,9 @@ let fold_modules f lid env acc =
let fold_values f =
find_all (fun env -> env.values) (fun sc -> sc.comp_values) f
and fold_constructors f =
- find_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
+ find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
and fold_labels f =
- find_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+ find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
and fold_types f =
find_all (fun env -> env.types) (fun sc -> sc.comp_types) f
and fold_modtypes f =
diff --git a/typing/env.mli b/typing/env.mli
index 8ee0ef8ec3..413d174e93 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -64,7 +64,11 @@ val add_gadt_instance_chain: t -> int -> type_expr -> unit
val lookup_value: Longident.t -> t -> Path.t * value_description
val lookup_annot: Longident.t -> t -> Path.t * Annot.ident
val lookup_constructor: Longident.t -> t -> constructor_description
+val lookup_all_constructors:
+ Longident.t -> t -> (constructor_description * (unit -> unit)) list
val lookup_label: Longident.t -> t -> label_description
+val lookup_all_labels:
+ Longident.t -> t -> (label_description * (unit -> unit)) list
val lookup_type: Longident.t -> t -> Path.t * type_declaration
val lookup_module: Longident.t -> t -> Path.t * module_type
val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
@@ -198,10 +202,10 @@ val fold_types:
(string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_constructors:
- (Types.constructor_description -> 'a -> 'a) ->
+ (constructor_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_labels:
- (Types.label_description -> 'a -> 'a) ->
+ (label_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
(** Persistent structures are only traversed if they are already loaded. *)
diff --git a/typing/ident.ml b/typing/ident.ml
index d1e7083669..c448f42505 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -170,13 +170,37 @@ let rec find_name name = function
else
find_name name (if c < 0 then l else r)
-let rec keys_aux stack accu = function
+let rec get_all = function
+ | None -> []
+ | Some k -> k.data :: get_all k.previous
+
+let rec find_all name = function
+ Empty ->
+ []
+ | Node(l, k, r, _) ->
+ let c = compare name k.ident.name in
+ if c = 0 then
+ k.data :: get_all k.previous
+ else
+ find_all name (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
Empty ->
begin match stack with
[] -> accu
- | a :: l -> keys_aux l accu a
+ | a :: l -> fold_aux f l accu a
end
| Node(l, k, r, _) ->
- keys_aux (l :: stack) (k.ident :: accu) r
+ fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+ match d with
+ None -> accu
+ | Some k -> f k.ident k.data (fold_data f k.previous accu)
+
+let fold_all f tbl accu =
+ fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
-let keys tbl = keys_aux [] [] tbl
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
diff --git a/typing/ident.mli b/typing/ident.mli
index 7095cde7ea..05a675d66e 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -54,4 +54,6 @@ val empty: 'a tbl
val add: t -> 'a -> 'a tbl -> 'a tbl
val find_same: t -> 'a tbl -> 'a
val find_name: string -> 'a tbl -> 'a
-val keys: 'a tbl -> t list
+val find_all: string -> 'a tbl -> 'a list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
diff --git a/typing/typecore.ml b/typing/typecore.ml
index e8dc934d71..a076aa6b22 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -24,7 +24,6 @@ type error =
Polymorphic_label of Longident.t
| Constructor_arity_mismatch of Longident.t * int * int
| Label_mismatch of Longident.t * (type_expr * type_expr) list
- | Extra_label of label * type_expr
| Pattern_type_clash of (type_expr * type_expr) list
| Multiply_bound_variable of string
| Orpat_vars of Ident.t
@@ -513,12 +512,7 @@ let build_or_pat env loc lid =
pat pats in
(path, rp { r with pat_loc = loc },ty)
-(* Records *)
-
-let rec find_record_qual = function
- | [] -> None
- | ({ txt = Longident.Ldot _ } as lid, _) :: _ -> Some lid
- | _ :: rest -> find_record_qual rest
+(* Type paths *)
let rec expand_path env p =
let decl =
@@ -532,72 +526,199 @@ let rec expand_path env p =
end
| _ -> p
-let type_label_a_list ?labels env type_lbl_a opath lid_a_list =
- (* Priority order for selecting record type
- 1) use first qualified label
- 2) use first label when compatible with expected type
- 3) use expected type (eventually warning if not principal)
- Then type each unqualified field according to the selected
- record type.
- *)
- let labels' =
- match find_record_qual lid_a_list with
- Some lid ->
- let label = Typetexp.find_label env lid.loc lid.txt in
- begin match label.lbl_res.desc with
- Tconstr (p, _, _) -> snd (Env.find_type_descrs p env)
- | _ -> assert false
- end
- | None ->
- let lid = fst (List.hd lid_a_list) in
- match lid.txt, labels with
- Longident.Lident s, Some labels when Hashtbl.mem labels s ->
- []
- | _ ->
- let lbl_path () =
- match Typetexp.find_label env lid.loc lid.txt with
- | {lbl_res={desc=Tconstr(p, _, _)}} -> p
- | _ -> assert false
- in
- let path =
- match opath with
- Some (p1,pr) ->
- begin try
- if not pr && not (Path.same (expand_path env p1)
- (expand_path env (lbl_path ())))
- then raise Exit
- with Exit | Typetexp.Error _ ->
- Location.prerr_warning lid.loc
- (Warnings.Not_principal "this type-based record selection")
- end;
- p1
- | None -> lbl_path ()
- in
- snd (Env.find_type_descrs path env)
+let get_label_type_path env lbl =
+ match lbl.lbl_res.desc with
+ | Tconstr(p, _, _) -> p
+ | _ -> assert false
+
+let get_constructor_type_path env cstr =
+ match cstr.cstr_res.desc with
+ | Tconstr(p, _, _) -> p
+ | _ -> assert false
+
+let compare_type_path env tpath1 tpath2 =
+ Path.same (expand_path env tpath1) (expand_path env tpath2)
+
+(* Records *)
+
+let lookup_label_from_type env tpath lid =
+ let (_, labels) = Env.find_type_descrs tpath env in
+ Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
+ match lid with
+ Longident.Lident s ->
+ List.find (fun lbl -> lbl.lbl_name = s) labels
+ | _ -> raise Not_found
+
+module NameChoice(Name : sig
+ type t
+ val get_type_path: Env.t -> t -> Path.t
+ val lookup_from_type: Env.t -> Path.t -> Longident.t -> t
+ val unbound_name_error: Env.t -> Longident.t loc -> unit
+end) = struct
+ open Name
+
+ let is_ambiguous env lbl others =
+ let tpath = get_type_path env lbl in
+ let different_tpath (lbl, _) =
+ let lbl_tpath = get_type_path env lbl in
+ not (compare_type_path env tpath lbl_tpath)
+ in
+ let others =
+ List.filter different_tpath others
+ in
+ others <> []
+
+ let disambiguate_by_type env tpath lbls =
+ let check_type (lbl, _) =
+ let lbl_tpath = get_type_path env lbl in
+ compare_type_path env tpath lbl_tpath
+ in
+ List.find check_type lbls
+
+ let disambiguate ?(warn=Location.prerr_warning) lid env opath lbls =
+ try match opath with
+ None -> raise Not_found
+ | Some(tpath, pr) ->
+ try
+ let lbl, use = disambiguate_by_type env tpath lbls in
+ use ();
+ Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
+ if not pr then begin
+ (* Check if non-principal type is affecting result *)
+ match lbls with
+ [] -> assert false
+ | (lbl', use') :: rest ->
+ let lbl_tpath = get_type_path env lbl' in
+ if not (compare_type_path env tpath lbl_tpath) then
+ warn lid.loc
+ (Warnings.Not_principal
+ "this type-based field disambiguation")
+ else
+ if is_ambiguous env lbl' rest then
+ warn lid.loc
+ (Warnings.Ambiguous_name
+ ([Longident.last lid.txt], false))
+ end;
+ lbl
+ with Not_found ->
+ let lbl = lookup_from_type env tpath lid.txt in
+ warn lid.loc
+ (Warnings.Name_out_of_scope
+ ([Longident.last lid.txt], false));
+ if not pr then
+ warn lid.loc
+ (Warnings.Not_principal "this type-based field disambiguation");
+ lbl
+ with Not_found ->
+ match lbls with
+ [] -> unbound_name_error env lid; assert false
+ | (lbl, use) :: rest ->
+ use ();
+ if is_ambiguous env lbl rest then
+ warn lid.loc
+ (Warnings.Ambiguous_name
+ ([Longident.last lid.txt], false));
+ lbl
+end
+
+module Label = NameChoice (struct
+ type t = label_description
+ let get_type_path = get_label_type_path
+ let lookup_from_type = lookup_label_from_type
+ let unbound_name_error = Typetexp.unbound_label_error
+end)
+
+let disambiguate_label_by_ids keep env closed ids labels =
+ let check_ids (lbl, _) =
+ let lbls = Hashtbl.create 8 in
+ Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+ List.for_all (Hashtbl.mem lbls) ids
+ and check_closed (lbl, _) =
+ (not closed || List.length ids = Array.length lbl.lbl_all)
in
- let lbl_a_list =
+ let labels' = List.filter check_ids labels in
+ if keep && labels' = [] then labels else
+ let labels'' = List.filter check_closed labels' in
+ if keep & labels'' = [] then labels' else labels''
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_labels_a_list loc closed env opath lid_a_list =
+ let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+ let labels_by_id =
List.map
- (fun (lid, a) ->
- let label : Types.label_description =
- match lid.txt, labels with
- Longident.Lident s, Some labels when Hashtbl.mem labels s ->
- Hashtbl.find labels s
- | Longident.Lident s, None ->
- begin try
- List.find (fun descr -> descr.lbl_name = s) labels'
- with Not_found ->
- try Env.lookup_label lid.txt env with Not_found ->
- raise (Error (lid.loc, Extra_label
- (s, (List.hd labels').lbl_res)))
- end
- | _ -> (* qualified *)
- Typetexp.find_label env lid.loc lid.txt
- in (lid, label, a)
- ) lid_a_list in
+ (fun (lid,_) ->
+ let labels = Typetexp.find_all_labels env lid.loc lid.txt in
+ if opath = None && labels = [] then
+ Typetexp.unbound_label_error env lid;
+ labels)
+ lid_a_list
+ in
+ let labels =
+ disambiguate_label_by_ids (opath=None) env closed ids
+ (List.hd labels_by_id) in
+ let records =
+ List.map (fun (lbl,use) -> Array.to_list lbl.lbl_all, use) labels in
+ let labels_by_id =
+ List.map2
+ (fun s labels -> List.map
+ (fun (lbls,use) ->
+ try List.find (fun lbl -> lbl.lbl_name = s) lbls, use
+ with Not_found -> List.hd labels)
+ records)
+ ids labels_by_id
+ in
+ let w_pr = ref true and w_amb = ref true and w_scope = ref true in
+ let warn loc msg =
+ let flag =
+ let open Warnings in
+ match msg with
+ | Not_principal _ -> w_pr
+ | Ambiguous_name _ -> w_amb
+ | Name_out_of_scope _ -> w_scope
+ | _ -> ref true
+ in
+ if !flag then begin
+ flag := false;
+ Location.prerr_warning loc msg
+ end
+ in
+ List.map2
+ (fun (lid, a) lbls -> lid, Label.disambiguate lid env opath lbls ~warn, a)
+ lid_a_list labels_by_id
+
+let rec find_record_qual = function
+ | [] -> None
+ | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
+ | _ :: rest -> find_record_qual rest
+
+let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list =
+ let lbl_a_list =
+ match lid_a_list, labels with
+ ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+ (* Special case for rebuilt syntax trees *)
+ List.map
+ (function lid, a -> match lid.txt with
+ Longident.Lident s -> lid, Hashtbl.find labels s, a
+ | _ -> assert false)
+ lid_a_list
+ | _ ->
+ let lid_a_list =
+ match find_record_qual lid_a_list with
+ None -> lid_a_list
+ | Some modname ->
+ List.map
+ (fun (lid, a as lid_a) ->
+ match lid.txt with Longident.Lident s ->
+ {lid with txt=Longident.Ldot (modname, s)}, a
+ | _ -> lid_a)
+ lid_a_list
+ in
+ disambiguate_labels_a_list loc closed env opath lid_a_list
+ in
(* Invariant: records are sorted in the typed tree *)
let lbl_a_list =
List.sort
- (fun (_, lbl1,_) (_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+ (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
lbl_a_list
in
List.map type_lbl_a lbl_a_list
@@ -609,7 +730,23 @@ let lid_of_label label =
Longident.Ldot(lid_of_path mpath, label.lbl_name)
| _ -> Longident.Lident label.lbl_name
-(* Checks over the labels mentioned in a record pattern:
+(* Constructors *)
+
+let lookup_constructor_from_type env tpath lid =
+ let (constructors, _) = Env.find_type_descrs tpath env in
+ match lid with
+ Longident.Lident s ->
+ List.find (fun cstr -> cstr.cstr_name = s) constructors
+ | _ -> raise Not_found
+
+module Constructor = NameChoice (struct
+ type t = constructor_description
+ let get_type_path = get_constructor_type_path
+ let lookup_from_type = lookup_constructor_from_type
+ let unbound_name_error = Typetexp.unbound_constructor_error
+end)
+
+(* Checks over the constructors mentioned in a record pattern:
no duplicate definitions (error); properly closed (warning) *)
let check_recordpat_labels loc lbl_pat_list closed =
@@ -737,12 +874,19 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_type = expected_ty;
pat_env = !env }
| Ppat_construct(lid, sarg, explicit_arity) ->
- let constr =
+ let opath =
+ try
+ let (p,_) = extract_concrete_typedecl !env expected_ty in
+ Some (p, true)
+ with Not_found -> None
+ in
+ let constrs =
match lid.txt, constrs with
Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
- Hashtbl.find constrs s
- | _ -> Typetexp.find_constructor !env loc lid.txt
+ [Hashtbl.find constrs s, (fun () -> ())]
+ | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt
in
+ let constr = Constructor.disambiguate lid !env opath constrs in
Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
if no_existentials && constr.cstr_existentials <> [] then
raise (Error (loc, Unexpected_existential));
@@ -823,7 +967,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
with Not_found -> None
in
let lbl_pat_list =
- type_label_a_list ?labels !env type_label_pat opath lid_sp_list in
+ type_label_a_list ?labels loc false !env type_label_pat opath
+ lid_sp_list in
check_recordpat_labels loc lbl_pat_list closed;
rp {
pat_desc = Tpat_record (lbl_pat_list, closed);
@@ -1845,8 +1990,9 @@ and type_expect ?in_function env sexp ty_expected =
| Some exp -> get_path exp.exp_type)
| op -> op
in
+ let closed = (opt_sexp = None) in
let lbl_exp_list =
- type_label_a_list env (type_label_exp true env loc ty_expected)
+ type_label_a_list loc closed env (type_label_exp true env loc ty_expected)
opath lid_sexp_list in
let rec check_duplicates seen_pos lid_sexp lbl_exp =
match (lid_sexp, lbl_exp) with
@@ -1911,8 +2057,21 @@ and type_expect ?in_function env sexp ty_expected =
exp_type = ty_arg;
exp_env = env }
| Pexp_setfield(srecord, lid, snewval) ->
- let (record, label) =
- type_label_access env loc srecord lid in
+ if !Clflags.principal then begin_def ();
+ let record = type_exp env srecord in
+ if !Clflags.principal then begin
+ end_def ();
+ generalize_structure record.exp_type
+ end;
+ let ty_exp = record.exp_type in
+ let opath =
+ try
+ let (p,_) = extract_concrete_typedecl env ty_exp in
+ Some(p, 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 label = Label.disambiguate lid env opath labels in
let (label_loc, label, newval) =
type_label_exp false env loc record.exp_type
(lid, label, snewval) in
@@ -2431,40 +2590,22 @@ and type_expect ?in_function env sexp ty_expected =
}
and type_label_access env loc srecord lid =
- match lid.txt with Longident.Lident lab ->
- if !Clflags.principal then begin_def ();
- let record = type_exp env srecord in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure record.exp_type
- end;
- let ty_exp = record.exp_type in
- let record = {record with exp_type = instance env record.exp_type} in
- begin try
- let label = Env.lookup_label lid.txt env in
- let ty_res = instance Env.empty label.lbl_res in
- match (expand_head env ty_exp).desc, (expand_head env ty_res).desc with
- Tconstr(p1,_,_), Tconstr(p2,_,_) when not (Path.same p1 p2) ->
- raise Exit
- | _ -> (record, label)
- with exn ->
- let labels =
- try
- let (p,_) = extract_concrete_typedecl env ty_exp in
- snd (Env.find_type_descrs p env)
- with Not_found -> []
- in
- try
- let label = List.find (fun descr -> descr.lbl_name = lab) labels in
- if !Clflags.principal && ty_exp.level <> generic_level then
- Location.prerr_warning loc
- (Warnings.Not_principal "this type-based field selection");
- (record, label)
- with Not_found ->
- raise (Error (loc, Extra_label (lab, record.exp_type)))
- end
- | _ ->
- (type_exp env srecord, Typetexp.find_label env lid.loc lid.txt)
+ if !Clflags.principal then begin_def ();
+ let record = type_exp env srecord in
+ if !Clflags.principal then begin
+ end_def ();
+ generalize_structure record.exp_type
+ end;
+ let ty_exp = record.exp_type in
+ let opath =
+ try
+ let (p,_) = extract_concrete_typedecl env ty_exp in
+ Some(p, 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 label = Label.disambiguate lid env opath labels in
+ (record, label)
and type_label_exp create env loc ty_expected
(lid, label, sarg) =
@@ -2776,7 +2917,14 @@ and type_application env funct sargs =
type_args [] [] ty (instance env ty) ty sargs []
and type_construct env loc lid sarg explicit_arity ty_expected =
- let constr = Typetexp.find_constructor env loc lid.txt in
+ let opath =
+ try
+ let (p,_) = extract_concrete_typedecl env ty_expected in
+ Some(p, ty_expected.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
+ let constr = Constructor.disambiguate lid env opath constrs in
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
let sargs =
match sarg with
@@ -3180,12 +3328,6 @@ let report_error ppf = function
longident lid)
(function ppf ->
fprintf ppf "but is mixed here with labels of type")
- | Extra_label (l, ty) ->
- reset_and_mark_loops ty;
- fprintf ppf
- "@[<v>@[<2>This record has type@ %a@]@ \
- which does not include the label %s@]"
- type_expr ty l
| Pattern_type_clash trace ->
report_unification_error ppf trace
(function ppf ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 2a1ce588ec..b7a1d667ae 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -66,7 +66,6 @@ type error =
Polymorphic_label of Longident.t
| Constructor_arity_mismatch of Longident.t * int * int
| Label_mismatch of Longident.t * (type_expr * type_expr) list
- | Extra_label of label * type_expr
| Pattern_type_clash of (type_expr * type_expr) list
| Multiply_bound_variable of string
| Orpat_vars of Ident.t
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index b892d44f9f..4a3916294d 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -96,9 +96,15 @@ let find_type =
let find_constructor =
find_component Env.lookup_constructor
(fun env lid -> Unbound_constructor (env, lid))
+let find_all_constructors =
+ find_component Env.lookup_all_constructors
+ (fun env lid -> Unbound_constructor (env, lid))
let find_label =
find_component Env.lookup_label
(fun env lid -> Unbound_label (env, lid))
+let find_all_labels =
+ find_component Env.lookup_all_labels
+ (fun env lid -> Unbound_label (env, lid))
let find_class =
find_component Env.lookup_class
(fun env lid -> Unbound_class (env, lid))
@@ -115,6 +121,14 @@ let find_class_type =
find_component Env.lookup_cltype
(fun env lid -> Unbound_cltype (env, lid))
+let unbound_constructor_error env lid =
+ narrow_unbound_lid_error env lid.loc lid.txt
+ (fun env lid -> Unbound_constructor (env, lid))
+
+let unbound_label_error env lid =
+ narrow_unbound_lid_error env lid.loc lid.txt
+ (fun env lid -> Unbound_label (env, lid))
+
(* Support for first-class modules. *)
let transl_modtype_longident = ref (fun _ -> assert false)
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index ec16034f86..2d0e9a1a85 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -80,8 +80,14 @@ val find_type:
Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
val find_constructor:
Env.t -> Location.t -> Longident.t -> Types.constructor_description
+val find_all_constructors:
+ Env.t -> Location.t -> Longident.t ->
+ (Types.constructor_description * (unit -> unit)) list
val find_label:
Env.t -> Location.t -> Longident.t -> Types.label_description
+val find_all_labels:
+ Env.t -> Location.t -> Longident.t ->
+ (Types.label_description * (unit -> unit)) list
val find_value:
Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description
val find_class:
@@ -92,3 +98,6 @@ val find_modtype:
Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration
val find_class_type:
Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration
+
+val unbound_constructor_error: Env.t -> Longident.t Location.loc -> unit
+val unbound_label_error: Env.t -> Longident.t Location.loc -> unit
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 7067e561a2..b235e0205e 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -57,6 +57,8 @@ type t =
| Unused_constructor of string * bool * bool (* 37 *)
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
+ | Name_out_of_scope of string list * bool (* 40 *)
+ | Ambiguous_name of string list * bool (* 41 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@@ -105,9 +107,11 @@ let number = function
| Unused_constructor _ -> 37
| Unused_exception _ -> 38
| Unused_rec_flag -> 39
+ | Name_out_of_scope _ -> 40
+ | Ambiguous_name _ -> 41
;;
-let last_warning_number = 39
+let last_warning_number = 41
(* Must be the max number returned by the [number] function. *)
let letter = function
@@ -202,7 +206,7 @@ let parse_opt flags s =
let parse_options errflag s = parse_opt (if errflag then error else active) s;;
(* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27-29-32..39";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41";;
let defaults_warn_error = "-a";;
let () = parse_options false defaults_w;;
@@ -302,6 +306,18 @@ let message = function
(However, this constructor appears in patterns.)"
| Unused_rec_flag ->
"unused rec flag."
+ | Name_out_of_scope ([s], false) ->
+ s ^ " is used out of scope."
+ | Name_out_of_scope (_, false) -> assert false
+ | Name_out_of_scope (slist, true) ->
+ "this record contains fields that are out of scope:\n "
+ ^ String.concat " " slist ^ "."
+ | Ambiguous_name ([s], false) ->
+ "this use of " ^ s ^ " is ambiguous."
+ | Ambiguous_name (_, false) -> assert false
+ | Ambiguous_name (slist, true) ->
+ "this record contains fields that are ambiguous:\n "
+ ^ String.concat " " slist ^ "."
;;
let nerrors = ref 0;;
@@ -387,6 +403,8 @@ let descriptions =
37, "Unused constructor.";
38, "Unused exception constructor.";
39, "Unused rec flag.";
+ 40, "Constructor or label name used out of scope.";
+ 41, "Ambiguous constructor or label name.";
]
;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
index 23785efde0..cc6426d176 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -52,6 +52,8 @@ type t =
| Unused_constructor of string * bool * bool (* 37 *)
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
+ | Name_out_of_scope of string list * bool (* 40 *)
+ | Ambiguous_name of string list * bool (* 41 *)
;;
val parse_options : bool -> string -> unit;;
View Lorry Controller Status