summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml2
-rw-r--r--camlp4/boot/Camlp4.ml2
-rw-r--r--otherlibs/labltk/browser/searchid.ml2
-rw-r--r--parsing/asttypes.mli2
-rw-r--r--parsing/parser.mly10
-rw-r--r--parsing/parsetree.mli2
-rw-r--r--parsing/printast.ml2
-rw-r--r--tools/addlabels.ml2
-rw-r--r--tools/depend.ml2
-rw-r--r--typing/datarepr.ml5
-rw-r--r--typing/typecore.ml43
-rw-r--r--typing/types.ml3
-rw-r--r--typing/types.mli3
-rw-r--r--typing/unused_var.ml2
-rw-r--r--utils/warnings.ml5
-rw-r--r--utils/warnings.mli1
16 files changed, 64 insertions, 24 deletions
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index fa6deaaad..a4a904206 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -490,7 +490,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
mkrangepat loc c1 c2
| _ -> error loc "range pattern allowed only for characters" ]
| PaRec loc p ->
- mkpat loc (Ppat_record (List.map mklabpat (list_of_patt p [])))
+ mkpat loc (Ppat_record (List.map mklabpat (list_of_patt p []), Closed))
| PaStr loc s ->
mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s)))
| <:patt@loc< ($p1$, $p2$) >> ->
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index ee2172984..abaa0950c 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -13890,7 +13890,7 @@ module Struct =
error loc "range pattern allowed only for characters")
| PaRec (loc, p) ->
mkpat loc
- (Ppat_record (List.map mklabpat (list_of_patt p [])))
+ (Ppat_record (List.map mklabpat (list_of_patt p []), Closed))
| PaStr (loc, s) ->
mkpat loc
(Ppat_constant
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 795948da9..a06257b99 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -414,7 +414,7 @@ let rec bound_variables pat =
| Ppat_construct (_,Some pat,_) -> bound_variables pat
| Ppat_variant (_,None) -> []
| Ppat_variant (_,Some pat) -> bound_variables pat
- | Ppat_record l ->
+ | Ppat_record (l, _) ->
List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat)
| Ppat_array l ->
List2.flat_map l ~f:bound_variables
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index f9824d059..2b37ca6e8 100644
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -33,4 +33,6 @@ type mutable_flag = Immutable | Mutable
type virtual_flag = Virtual | Concrete
+type closed_flag = Closed | Open
+
type label = string
diff --git a/parsing/parser.mly b/parsing/parser.mly
index b229fa1a4..77309e4e4 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1113,8 +1113,8 @@ simple_pattern:
{ mkpat(Ppat_variant($1, None)) }
| SHARP type_longident
{ mkpat(Ppat_type $2) }
- | LBRACE lbl_pattern_list opt_semi RBRACE
- { mkpat(Ppat_record(List.rev $2)) }
+ | LBRACE lbl_pattern_list record_pattern_end RBRACE
+ { mkpat(Ppat_record(List.rev $2, $3)) }
| LBRACE lbl_pattern_list opt_semi error
{ unclosed "{" 1 "}" 4 }
| LBRACKET pattern_semi_list opt_semi RBRACKET
@@ -1151,7 +1151,11 @@ lbl_pattern_list:
| lbl_pattern_list SEMI label_longident EQUAL pattern { ($3, $5) :: $1 }
| lbl_pattern_list SEMI label_longident { ($3, pat_of_label $3) :: $1 }
;
-
+record_pattern_end:
+ opt_semi { Closed }
+ | SEMI UNDERSCORE opt_semi { Open }
+;
+
/* Primitive declarations */
primitive_declaration:
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 8676fda5f..8fbf190cb 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -70,7 +70,7 @@ and pattern_desc =
| Ppat_tuple of pattern list
| Ppat_construct of Longident.t * pattern option * bool
| Ppat_variant of label * pattern option
- | Ppat_record of (Longident.t * pattern) list
+ | Ppat_record of (Longident.t * pattern) list * closed_flag
| Ppat_array of pattern list
| Ppat_or of pattern * pattern
| Ppat_constraint of pattern * core_type
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 76bf0bef1..50a422cc1 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -176,7 +176,7 @@ and pattern i ppf x =
| Ppat_variant (l, po) ->
line i ppf "Ppat_variant \"%s\"\n" l;
option i pattern ppf po;
- | Ppat_record (l) ->
+ | Ppat_record (l, c) ->
line i ppf "Ppat_record\n";
list i longident_x_pattern ppf l;
| Ppat_array (l) ->
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
index 29ecf80b7..4eda3b0c6 100644
--- a/tools/addlabels.ml
+++ b/tools/addlabels.ml
@@ -58,7 +58,7 @@ let rec pattern_vars pat =
| Ppat_variant (_, Some pat)
| Ppat_constraint (pat, _) ->
pattern_vars pat
- | Ppat_record l ->
+ | Ppat_record(l, _) ->
List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p))
| Ppat_or (pat1, pat2) ->
pattern_vars pat1 @ pattern_vars pat2
diff --git a/tools/depend.ml b/tools/depend.ml
index 881837b44..3be1c3a06 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -105,7 +105,7 @@ let rec add_pattern bv pat =
| Ppat_constant _ -> ()
| Ppat_tuple pl -> List.iter (add_pattern bv) pl
| Ppat_construct(c, op, _) -> add bv c; add_opt add_pattern bv op
- | Ppat_record pl ->
+ | Ppat_record(pl, _) ->
List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
| Ppat_array pl -> List.iter (add_pattern bv) pl
| Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index ddbd9fb27..80b94132d 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -57,7 +57,7 @@ let exception_descr path_exc decl =
let none = {desc = Ttuple []; level = -1; id = -1}
(* Clearly ill-formed type *)
let dummy_label =
- { lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+ { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
lbl_private = Public }
@@ -67,7 +67,8 @@ let label_descrs ty_res lbls repres priv =
[] -> []
| (name, mut_flag, ty_arg) :: rest ->
let lbl =
- { lbl_res = ty_res;
+ { lbl_name = name;
+ lbl_res = ty_res;
lbl_arg = ty_arg;
lbl_mut = mut_flag;
lbl_pos = num;
diff --git a/typing/typecore.ml b/typing/typecore.ml
index bd70c1e95..7e81fa9f1 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -364,6 +364,36 @@ let type_label_a_list type_lid_a lid_a_list =
| lid_a -> type_lid_a lid_a)
lid_a_list
+(* Checks over the labels mentioned in a record pattern:
+ no duplicate definitions (error); properly closed (warning) *)
+
+let check_recordpat_labels loc lbl_pat_list closed =
+ match lbl_pat_list with
+ | [] -> () (* should not happen *)
+ | (label1, _) :: _ ->
+ let all = label1.lbl_all in
+ let defined = Array.make (Array.length all) false in
+ let check_defined (label, _) =
+ if defined.(label.lbl_pos)
+ then raise(Error(loc, Label_multiply_defined
+ (Longident.Lident label.lbl_name)))
+ else defined.(label.lbl_pos) <- true in
+ List.iter check_defined lbl_pat_list;
+ if closed = Closed
+ && Warnings.is_active (Warnings.Non_closed_record_pattern "")
+ then begin
+ let undefined = ref [] in
+ for i = 0 to Array.length all - 1 do
+ if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
+ done;
+ if !undefined <> [] then begin
+ let u = String.concat ", " (List.rev !undefined) in
+ Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)
+ end
+ end
+
+(* Typing of patterns *)
+
let rec type_pat env sp =
let loc = sp.ppat_loc in
match sp.ppat_desc with
@@ -446,14 +476,7 @@ let rec type_pat env sp =
pat_loc = loc;
pat_type = newty (Tvariant row);
pat_env = env }
- | Ppat_record lid_sp_list ->
- let rec check_duplicates = function
- [] -> ()
- | (lid, sarg) :: remainder ->
- if List.mem_assoc lid remainder
- then raise(Error(loc, Label_multiply_defined lid))
- else check_duplicates remainder in
- check_duplicates lid_sp_list;
+ | Ppat_record(lid_sp_list, closed) ->
let ty = newvar() in
let type_label_pat (lid, sarg) =
let label =
@@ -483,8 +506,10 @@ let rec type_pat env sp =
end;
(label, arg)
in
+ let lbl_pat_list = type_label_a_list type_label_pat lid_sp_list in
+ check_recordpat_labels loc lbl_pat_list closed;
rp {
- pat_desc = Tpat_record(type_label_a_list type_label_pat lid_sp_list);
+ pat_desc = Tpat_record lbl_pat_list;
pat_loc = loc;
pat_type = ty;
pat_env = env }
diff --git a/typing/types.ml b/typing/types.ml
index 368d50cd8..cbfb30220 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -120,7 +120,8 @@ and constructor_tag =
(* Record label descriptions *)
type label_description =
- { lbl_res: type_expr; (* Type of the result *)
+ { lbl_name: string; (* Short name *)
+ lbl_res: type_expr; (* Type of the result *)
lbl_arg: type_expr; (* Type of the argument *)
lbl_mut: mutable_flag; (* Is this a mutable field? *)
lbl_pos: int; (* Position in block *)
diff --git a/typing/types.mli b/typing/types.mli
index 94d7e4d58..1c9162b83 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -118,7 +118,8 @@ and constructor_tag =
(* Record label descriptions *)
type label_description =
- { lbl_res: type_expr; (* Type of the result *)
+ { lbl_name: string; (* Short name *)
+ lbl_res: type_expr; (* Type of the result *)
lbl_arg: type_expr; (* Type of the argument *)
lbl_mut: mutable_flag; (* Is this a mutable field? *)
lbl_pos: int; (* Position in block *)
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index fde62a6d4..25f65464d 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -69,7 +69,7 @@ let rec get_vars ((vacc, asacc) as acc) p =
| Ppat_tuple pl -> List.fold_left get_vars acc pl
| Ppat_construct (_, po, _) -> get_vars_option acc po
| Ppat_variant (_, po) -> get_vars_option acc po
- | Ppat_record ipl ->
+ | Ppat_record (ipl, cls) ->
List.fold_left (fun a (_, p) -> get_vars a p) acc ipl
| Ppat_array pl -> List.fold_left get_vars acc pl
| Ppat_or (p1, _p2) -> get_vars acc p1
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 858bd1172..79657c187 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -19,6 +19,7 @@ type t = (* A is all *)
| Comment_not_end
| Deprecated (* D *)
| Fragile_match of string (* E *)
+ | Non_closed_record_pattern of string
| Partial_application (* F *)
| Labels_omitted (* L *)
| Method_override of string list (* M *)
@@ -48,6 +49,7 @@ let letter = function (* 'a' is all *)
| Comment_not_end -> 'c'
| Deprecated -> 'd'
| Fragile_match _ -> 'e'
+ | Non_closed_record_pattern _ -> 'e'
| Partial_application -> 'f'
| Labels_omitted -> 'l'
| Method_override _ -> 'm'
@@ -120,6 +122,9 @@ let message = function
| Fragile_match s ->
"this pattern-matching is fragile.\n\
It will remain exhaustive when constructors are added to type " ^ s ^ "."
+ | Non_closed_record_pattern s ->
+ "the following labels are not bound in this record pattern:\n" ^ s ^
+ "\nEither bind these labels explicitly or add `; _' to the pattern."
| Labels_omitted ->
"labels were omitted in the application of this function."
| Method_override [lab] ->
diff --git a/utils/warnings.mli b/utils/warnings.mli
index 1610b3c3a..dd0dd76ed 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -19,6 +19,7 @@ type t = (* A is all *)
| Comment_not_end
| Deprecated (* D *)
| Fragile_match of string (* E *)
+ | Non_closed_record_pattern of string
| Partial_application (* F *)
| Labels_omitted (* L *)
| Method_override of string list (* M *)
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-22 16:22:21 +0000