As discussed at the latest consortium meeting:

Syntactic sugar {x} for {x=x} in record expressions and patterns.
Syntax { lbl=pat; _ } to mark record patterns where the user explicitly wants not to list all labels.
Warning (activated by E, the fragile match warning) to signal record patterns without '; _' that fail to list all labels.
To be done: adjust Camlp4 parser accordingly.


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9331 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

16 files changed, 64 insertions, 24 deletions

diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index fa6deaaad1..a4a904206b 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 ee21729844..abaa0950c7 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 795948da9d..a06257b99e 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 f9824d0590..2b37ca6e87 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 b229fa1a4c..77309e4e49 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 8676fda5f7..8fbf190cbd 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 76bf0bef13..50a422cc1b 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 29ecf80b78..4eda3b0c69 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 881837b44e..3be1c3a06e 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 ddbd9fb276..80b94132d9 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 bd70c1e95a..7e81fa9f11 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 368d50cd8f..cbfb30220f 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 94d7e4d585..1c9162b831 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 fde62a6d49..25f65464d7 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 858bd1172a..79657c1874 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 1610b3c3a6..dd0dd76ed8 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 *)