New modifier in record declaration (after 'mutable'): 'match'. This enables autofocus for patterns which are not wildcard, variable, alias, constraint, or-pattern.autofocus

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

37 files changed, 111 insertions, 60 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 682253fc4a..a92195c3ee 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 25c5166fc4..d009a802ca 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 6ea82a22f4..5452fd6c23 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/debugger/eval.ml b/debugger/eval.ml
index 1e84d92081..c170e3378a 100644
--- a/debugger/eval.ml
+++ b/debugger/eval.ml
@@ -148,7 +148,7 @@ let rec expression event env = function
 and find_label lbl env ty path tydesc pos = function
     [] ->
       raise(Error(Wrong_label(ty, lbl)))
-  | (name, mut, ty_arg) :: rem ->
+  | (name, mut, _, ty_arg) :: rem ->
       if Ident.name name = lbl then begin
         let ty_res =
           Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil))
diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
index 369114d74c..c016773e14 100644
--- a/ocamldoc/odoc_html.ml
+++ b/ocamldoc/odoc_html.ml
@@ -1521,6 +1521,7 @@ class html =
             bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
             bs b "<code>";
             if r.rf_mutable then bs b (self#keyword "mutable&nbsp;") ;
+            if r.rf_focus then bs b (self#keyword "match&nbsp;") ;
             bs b (r.rf_name ^ "&nbsp;: ") ;
             self#html_of_type_expr b father r.rf_type;
             bs b ";</code></td>\n";
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index 0ab1fa815a..d3e5b32451 100644
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -210,6 +210,7 @@ module Type :
         {
           rf_name : string ; (** Name of the field. *)
           rf_mutable : bool ; (** [true] if mutable. *)
+          rf_focus : bool; (** [true] if autofocus. *)
           rf_type : Types.type_expr ; (** Type of the field. *)
           mutable rf_text : text option ; (** Optional description in the associated comment.*)
         }
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index df404fc327..5c05bfc780 100644
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -592,8 +592,9 @@ class latex =
                     (fun r ->
                       let s_field =
                         p fmt2
-                          "@[<h 6>  %s%s :@ %s ;"
+                          "@[<h 6>  %s%s%s :@ %s ;"
                           (if r.rf_mutable then "mutable " else "")
+                          (if r.rf_focus then "match " else "")
                           r.rf_name
                           (self#normal_type mod_name r.rf_type);
                         flush2 ()
diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index 037dee02da..3d9c0d7767 100644
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -514,6 +514,7 @@ class man =
           List.iter
             (fun r ->
               bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n ");
+              bs b (if r.rf_focus then "\n\n.B match \n" else "\n ");
               bs b (r.rf_name^" : ");
               self#man_of_type_expr b father r.rf_type;
               bs b ";";
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 74de957ed6..87d1276a3e 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -201,12 +201,12 @@ module Analyser =
           let rec f = function
               [] ->
                 []
-            | (name, _, ct, xxloc) :: [] ->
+            | (name, _, _, ct, xxloc) :: [] ->
                 let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
                 let s = get_string_of_file pos pos_end in
                 let (_,comment_opt) =  My_ir.just_after_special !file_name s in
                 [name.txt, comment_opt]
-            | (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q ->
+            | (name,_,_,ct,xxloc) :: ((name2,_,_,ct2,xxloc2) as ele2) :: q ->
                 let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
                 let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
                 let s = get_string_of_file pos pos2 in
@@ -239,7 +239,7 @@ module Analyser =
           Odoc_type.Type_variant (List.map f l)
 
       | Types.Type_record (l, _) ->
-          let f (field_name, mutable_flag, type_expr) =
+          let f (field_name, mutable_flag, focus_flag, type_expr) =
             let field_name = Ident.name field_name in
             let comment_opt =
               try
@@ -251,6 +251,7 @@ module Analyser =
             {
               rf_name = field_name ;
               rf_mutable = mutable_flag = Mutable ;
+              rf_focus = focus_flag = AutoFocus ;
               rf_type = Odoc_env.subst_type env type_expr ;
               rf_text = comment_opt
             }
diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
index ee973a01d7..1a15322f33 100644
--- a/ocamldoc/odoc_type.ml
+++ b/ocamldoc/odoc_type.ml
@@ -30,6 +30,7 @@ type variant_constructor = {
 type record_field = {
     rf_name : string ;
     rf_mutable : bool ; (** true if mutable *)
+    rf_focus : bool; (** [true] if autofocus. *)
     rf_type : Types.type_expr ;
     mutable rf_text : Odoc_types.text option ; (** optional user description *)
   }
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index ab66f0f030..9f112efe4e 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -237,7 +237,7 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
               match r with None -> false | Some x -> matches x
             end
           | Type_record(l, rep) ->
-            List.exists l ~f:(fun (_, _, t) -> matches t)
+            List.exists l ~f:(fun (_, _, _, t) -> matches t)
           end
           then [lid_of_id id, Ptype] else []
       | Sig_exception (id, l) ->
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index cf79d940da..41400755ea 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -173,7 +173,7 @@ let search_pos_type_decl td ~pos ~env =
         List.iter dl
           ~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
     | Ptype_record dl ->
-        List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
+        List.iter dl ~f:(fun (_, _, _, t, _) -> search_pos_type t ~pos ~env) in
     search_tkind td.ptype_kind;
     List.iter td.ptype_cstrs ~f:
       begin fun (t1, t2, _) ->
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index ecdfcc5fd4..3cbc5a8212 100644
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -37,6 +37,8 @@ type override_flag = Override | Fresh
 
 type closed_flag = Closed | Open
 
+type focus_flag = AutoFocus | NoFocus
+
 type label = string
 
 type 'a loc = 'a Location.loc = {
diff --git a/parsing/parser.mly b/parsing/parser.mly
index fb7d5745ae..0948ad6c7b 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1446,8 +1446,13 @@ label_declarations:
   | label_declarations SEMI label_declaration   { $3 :: $1 }
 ;
 label_declaration:
-    mutable_flag label COLON poly_type          { (mkrhs $2 2, $1, $4, symbol_rloc()) }
+    mutable_flag focus_flag label COLON poly_type          { (mkrhs $3 3, $1, $2, $5, symbol_rloc()) }
 ;
+focus_flag:
+  |       { NoFocus }
+  | MATCH { AutoFocus}
+;
+
 
 /* "with" constraints (additional type equations over signature components) */
 
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index eeca81acf7..7c59dc017b 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -145,7 +145,7 @@ and type_kind =
   | Ptype_variant of
       (string loc * core_type list * core_type option * Location.t) list
   | Ptype_record of
-      (string loc * mutable_flag * core_type * Location.t) list
+      (string loc * mutable_flag * focus_flag * core_type * Location.t) list
 
 and exception_declaration = core_type list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index e3d5b018f6..bce1e14542 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -58,6 +58,11 @@ let fmt_mutable_flag f x =
   | Mutable -> fprintf f "Mutable";
 ;;
 
+let fmt_focus_flag f = function
+  | AutoFocus -> fprintf f "AutoFocus"
+  | NoFocus -> fprintf f "NoFocus"
+;;
+
 let fmt_virtual_flag f x =
   match x with
   | Virtual -> fprintf f "Virtual";
@@ -364,7 +369,7 @@ and type_kind i ppf x =
       list (i+1) string_x_core_type_list_x_location ppf l;
   | Ptype_record l ->
       line i ppf "Ptype_record\n";
-      list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l;
+      list (i+1) label_definition ppf l;
 
 and exception_declaration i ppf x = list i core_type ppf x
 
@@ -674,8 +679,8 @@ and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) =
   list (i+1) core_type ppf l;
   option (i+1) core_type ppf r_opt;
 
-and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
-  line i ppf "\"%s\" %a %a\n" s.txt fmt_mutable_flag mf fmt_location loc;
+and label_definition i ppf (s, mf, ff, ct, loc) =
+  line i ppf "\"%s\" %a %a %a\n" s.txt fmt_mutable_flag mf fmt_focus_flag ff fmt_location loc;
   core_type (i+1) ppf ct;
 
 and string_list_x_location i ppf (l, loc) =
diff --git a/tools/depend.ml b/tools/depend.ml
index 2015f937e5..5ffe32f7af 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -82,7 +82,7 @@ let add_type_declaration bv td =
   | Ptype_variant cstrs ->
       List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs
   | Ptype_record lbls ->
-      List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
+      List.iter (fun (l, mut, foc, ty, _) -> add_type bv ty) lbls in
   add_tkind td.ptype_kind
 
 let rec add_class_type bv cty =
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index b3bafc0659..d6af81f3a9 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -272,7 +272,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                     | None ->
                         let rec tree_of_fields pos = function
                           | [] -> []
-                          | (lbl_name, _, lbl_arg) :: remainder ->
+                          | (lbl_name, _, _, lbl_arg) :: remainder ->
                               let ty_arg =
                                 try
                                   Ctype.apply env decl.type_params lbl_arg
diff --git a/typing/btype.ml b/typing/btype.ml
index 729ae44cda..0504e7f2df 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -346,7 +346,7 @@ let unmark_type_decl decl =
 	  Misc.may unmark_type ret_type_opt)
 	cstrs
   | Type_record(lbls, rep) ->
-      List.iter (fun (c, mut, t) -> unmark_type t) lbls
+      List.iter (fun (c, mut, focus, t) -> unmark_type t) lbls
   end;
   begin match decl.type_manifest with
     None    -> ()
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 7f75d72913..33f83bf205 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -527,7 +527,7 @@ let closed_type_decl decl =
                 List.iter closed_type tyl)
           v
     | Type_record(r, rep) ->
-        List.iter (fun (_, _, ty) -> closed_type ty) r
+        List.iter (fun (_, _, _, ty) -> closed_type ty) r
     end;
     begin match decl.type_manifest with
       None    -> ()
@@ -1103,7 +1103,7 @@ let instance_declaration decl =
          List.map (fun (s,tl,ot) -> (s, List.map copy tl, may_map copy ot))
            cl)
      | Type_record (fl, rr) ->
-         Type_record (List.map (fun (s,m,ty) -> (s, m, copy ty)) fl, rr)}
+         Type_record (List.map (fun (s,m,f,ty) -> (s, m, f, copy ty)) fl, rr)}
   in
   cleanup_types ();
   decl
@@ -2002,9 +2002,9 @@ and mcomp_variant_description type_pairs subst env =
 and mcomp_record_description type_pairs subst env =
   let rec iter = fun x y ->
     match x, y with
-      (name, mutable_flag, t) :: xs, (name', mutable_flag', t') :: ys ->
+      (name, mutable_flag, focus, t) :: xs, (name', mutable_flag', focus', t') :: ys ->
         mcomp type_pairs subst env t t';
-        if name = name' && mutable_flag = mutable_flag'
+        if name = name' && mutable_flag = mutable_flag' && focus = focus'
         then iter xs ys
         else raise (Unify [])
     | [], [] -> ()
@@ -4020,7 +4020,7 @@ let nondep_type_decl env mid id is_covariant decl =
       | Type_record(lbls, rep) ->
           Type_record
             (List.map
-               (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t))
+               (fun (c, mut, f, t) -> (c, mut, f, nondep_type_rec env mid t))
                lbls,
              rep)
       with Not_found when is_covariant -> Type_abstract
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 5d44504270..f3ffc88984 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -101,6 +101,7 @@ let none = {desc = Ttuple []; level = -1; id = -1}
                                         (* Clearly ill-formed type *)
 let dummy_label =
   { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+    lbl_focus = NoFocus;
     lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
     lbl_private = Public }
 
@@ -108,12 +109,13 @@ let label_descrs ty_res lbls repres priv =
   let all_labels = Array.create (List.length lbls) dummy_label in
   let rec describe_labels num = function
       [] -> []
-    | (name, mut_flag, ty_arg) :: rest ->
+    | (name, mut_flag, focus_flag, ty_arg) :: rest ->
         let lbl =
           { lbl_name = Ident.name name;
             lbl_res = ty_res;
             lbl_arg = ty_arg;
             lbl_mut = mut_flag;
+            lbl_focus = focus_flag;
             lbl_pos = num;
             lbl_all = all_labels;
             lbl_repres = repres;
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index 527fecb573..f8fb7d39cf 100644
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -24,7 +24,7 @@ val constructor_descrs:
 val exception_descr:
   Path.t -> exception_declaration -> constructor_description
 val label_descrs:
-  type_expr -> (Ident.t * mutable_flag * type_expr) list ->
+  type_expr -> (Ident.t * mutable_flag * focus_flag * type_expr) list ->
     record_representation -> private_flag ->
     (Ident.t * label_description) list
 
diff --git a/typing/includecore.ml b/typing/includecore.ml
index f37c57a828..1dbadd7de1 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -191,9 +191,10 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 =
 let rec compare_records env decl1 decl2 n labels1 labels2 =
   match labels1, labels2 with
     [], []           -> []
-  | [], (lab2,_,_)::_ -> [Field_missing (true, lab2)]
-  | (lab1,_,_)::_, [] -> [Field_missing (false, lab1)]
-  | (lab1, mut1, arg1)::rem1, (lab2, mut2, arg2)::rem2 ->
+  | [], (lab2,_,_,_)::_ -> [Field_missing (true, lab2)]
+  | (lab1,_,_,_)::_, [] -> [Field_missing (false, lab1)]
+  | (lab1, mut1, foc1, arg1)::rem1, (lab2, mut2, foc2, arg2)::rem2 ->
+      (* note: we allow foc1 <> foc2 *)
       if Ident.name lab1 <> Ident.name lab2
       then [Field_names (n, lab1, lab2)]
       else if mut1 <> mut2 then [Field_mutable lab1] else
diff --git a/typing/oprint.ml b/typing/oprint.ml
index e894027376..30c94daa33 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -449,8 +449,8 @@ and print_out_constr ppf (name, tyl,ret_type_opt) =
       end
 
 
-and print_out_label ppf (name, mut, arg) =
-  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+and print_out_label ppf (name, mut, focus, arg) =
+  fprintf ppf "@[<2>%s%s%s :@ %a@];" (if mut then "mutable " else "") (if focus then "match " else "") name
     !out_type arg
 
 let _ = out_module_type := print_out_module_type
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 7d95672a0c..c5d0a35e7f 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -52,7 +52,7 @@ type out_type =
   | Otyp_constr of out_ident * out_type list
   | Otyp_manifest of out_type * out_type
   | Otyp_object of (string * out_type) list * bool option
-  | Otyp_record of (string * bool * out_type) list
+  | Otyp_record of (string * bool * bool * out_type) list
   | Otyp_stuff of string
   | Otyp_sum of (string * out_type list * out_type option) list
   | Otyp_tuple of out_type list
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index a0d6722115..1194712d0f 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -135,7 +135,7 @@ let rec get_constr tag ty tenv =
 
 let find_label lbl lbls =
   try
-    let name,_,_ = List.nth lbls lbl.lbl_pos in
+    let name,_,_,_ = List.nth lbls lbl.lbl_pos in
     name
   with Failure "nth" -> Ident.create "*Unknown label*"
 
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 695d225c24..1327a5b015 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -594,7 +594,7 @@ let rec tree_of_type_decl id decl =
 	  may mark_loops ret_type_opt)
 	cstrs
   | Type_record(l, rep) ->
-      List.iter (fun (_, _, ty) -> mark_loops ty) l
+      List.iter (fun (_, _, _, ty) -> mark_loops ty) l
   end;
 
   let type_param =
@@ -663,8 +663,8 @@ and tree_of_constructor_ret =
     | None -> None
     | Some ret_type -> Some (tree_of_typexp false ret_type)
 
-and tree_of_label (name, mut, arg) =
-  (Ident.name name, mut = Mutable, tree_of_typexp false arg)
+and tree_of_label (name, mut, focus, arg) =
+  (Ident.name name, mut = Mutable, focus = AutoFocus, tree_of_typexp false arg)
 
 let tree_of_type_declaration id decl rs =
   Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 6d5bfacc77..7548b10c7c 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -69,6 +69,11 @@ let fmt_mutable_flag f x =
   | Mutable -> fprintf f "Mutable";
 ;;
 
+let fmt_focus_flag f = function
+  | AutoFocus -> fprintf f "AutoFocus"
+  | NoFocus -> fprintf f "NoFocus"
+;;
+
 let fmt_virtual_flag f x =
   match x with
   | Virtual -> fprintf f "Virtual";
@@ -388,7 +393,7 @@ and type_kind i ppf x =
       list (i+1) string_x_core_type_list_x_location ppf l;
   | Ttype_record l ->
       line i ppf "Ptype_record\n";
-      list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l;
+      list (i+1) label_definition ppf l;
 
 and exception_declaration i ppf x = list i core_type ppf x
 
@@ -706,8 +711,8 @@ and string_x_core_type_list_x_location i ppf (s, _, l, r_opt) =
   list (i+1) core_type ppf l;
 (*  option (i+1) core_type ppf r_opt; *)
 
-and string_x_mutable_flag_x_core_type_x_location i ppf (s, _, mf, ct, loc) =
-  line i ppf "\"%a\" %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_location loc;
+and label_definition i ppf (s, _, mf, ff, ct, loc) =
+  line i ppf "\"%a\" %a %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_focus_flag ff fmt_location loc;
   core_type (i+1) ppf ct;
 
 and string_list_x_location i ppf (l, loc) =
diff --git a/typing/subst.ml b/typing/subst.ml
index ce7ec24eda..04532760fe 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -180,7 +180,7 @@ let type_declaration s decl =
                  cstrs)
         | Type_record(lbls, rep) ->
             Type_record
-              (List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls,
+              (List.map (fun (n, mut, focus, arg) -> (n, mut, focus, typexp s arg)) lbls,
                rep)
         end;
       type_manifest =
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 0a311e2dc2..869df8aa46 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -251,7 +251,7 @@ let rec extract_label_names sexp env ty =
       let td = Env.find_type path env in
       begin match td.type_kind with
       | Type_record (fields, _) ->
-          List.map (fun (name, _, _) -> name) fields
+          List.map (fun (name, _, _, _) -> name) fields
       | Type_abstract when td.type_manifest <> None ->
           extract_label_names sexp env (expand_head env ty)
       | _ -> assert false
@@ -602,6 +602,8 @@ type type_pat_mode =
   | Normal
   | Inside_or
 
+let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
+
 (* type_pat propagates the expected type as well as maps for
    constructors and labels.
    Unification may update the typing environment. *)
@@ -609,6 +611,29 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
   let type_pat ?(mode=mode) ?(env=env) =
     type_pat ~constrs ~labels ~no_existentials ~mode ~env in
   let loc = sp.ppat_loc in
+  let record_expected =
+    match (Ctype.expand_head !env expected_ty).desc with
+    | Tconstr (path, _, _) ->
+        begin try
+          match Env.find_type path !env with
+          | {type_kind = Type_record (fields, _)} ->
+              Some
+                (List.find (fun (_, _, focus, _) -> focus = AutoFocus) fields)
+          | _ -> None
+        with Not_found (* Env.find_type, or List.find *) -> None
+        end
+    | _ -> None
+  in
+  let autofocus =
+    match record_expected, sp.ppat_desc with
+    | Some _, (Ppat_any | Ppat_var _ | Ppat_alias _ | Ppat_record _ | Ppat_constraint _ | Ppat_or _) -> None
+    | Some (l, _, _, _), _ -> Some l
+    | _ -> None
+  in
+  match autofocus with
+  | Some lab ->
+      type_pat (mkpat (Ppat_record ([{txt=Longident.Lident (Ident.name lab); loc=Location.none}, sp], Open))) expected_ty
+  | None ->
   match sp.ppat_desc with
     Ppat_any ->
       rp {
@@ -939,8 +964,6 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   let val_env, _ = add_pattern_variables val_env in
   (pat, pv, val_env, met_env)
 
-let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
-
 let type_self_pattern cl_num privty val_env met_env par_env spat =
   let spat =
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")),
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index b51170fe36..6f40d9c3c9 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -195,23 +195,23 @@ let transl_declaration env (name, sdecl) id =
       | Ptype_record lbls ->
         let all_labels = ref StringSet.empty in
         List.iter
-          (fun ({ txt = name }, mut, arg, loc) ->
+          (fun ({ txt = name }, mut, focus, arg, loc) ->
             if StringSet.mem name !all_labels then
               raise(Error(sdecl.ptype_loc, Duplicate_label name));
             all_labels := StringSet.add name !all_labels)
           lbls;
-        let lbls = List.map (fun (name, mut, arg, loc) ->
+        let lbls = List.map (fun (name, mut, focus, arg, loc) ->
           let cty = transl_simple_type env true arg in
-          (Ident.create name.txt, name, mut, cty, loc)
+          (Ident.create name.txt, name, mut, focus, cty, loc)
         ) lbls in
         let lbls' =
           List.map
-            (fun (name, name_loc, mut, cty, loc) ->
+            (fun (name, name_loc, mut, focus, cty, loc) ->
               let ty = cty.ctyp_type in
-              name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
+              name, mut, focus, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
             lbls in
         let rep =
-          if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls'
+          if List.for_all (fun (name, mut, f, arg) -> is_float env arg) lbls'
           then Record_float
           else Record_regular in
         Ttype_record lbls, Type_record(lbls', rep)
@@ -282,7 +282,7 @@ let generalize_decl decl =
 	  may Ctype.generalize ret_type)
 	v
   | Type_record(r, rep) ->
-      List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
+      List.iter (fun (_, _, _, ty) -> Ctype.generalize ty) r
   end;
   begin match decl.type_manifest with
   | None    -> ()
@@ -351,11 +351,11 @@ let check_constraints env (_, sdecl) (_, decl) =
       let pl = find_pl sdecl.ptype_kind in
       let rec get_loc name = function
           [] -> assert false
-        | (name', _, sty, _) :: tl ->
+        | (name', _, _, sty, _) :: tl ->
             if name = name'.txt then sty.ptyp_loc else get_loc name tl
       in
       List.iter
-        (fun (name, _, ty) ->
+        (fun (name, _, _, ty) ->
           check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
         l
   end;
@@ -556,7 +556,7 @@ let whole_type decl =
         (Ttuple (List.map (fun (_, tl, _) -> Btype.newgenty (Ttuple tl)) tll))
   | Type_record (ftl, _) ->
       Btype.newgenty
-        (Ttuple (List.map (fun (_, _, ty) -> ty) ftl))
+        (Ttuple (List.map (fun (_, _, _, ty) -> ty) ftl))
   | Type_abstract ->
       match decl.type_manifest with
         Some ty -> ty
@@ -656,7 +656,7 @@ let compute_variance_decl env check decl (required, loc as rloc) =
       end
   | Type_record (ftl, _) ->
       compute_variance_type env check rloc decl
-        (List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl)
+        (List.map (fun (_, mut, _, ty) -> (mut = Mutable, ty)) ftl)
 
 let is_sharp id =
   let s = Ident.name id in
@@ -730,7 +730,7 @@ let check_duplicates name_sdecl_list =
           cl
     | Ptype_record fl ->
         List.iter
-          (fun (cname, _, _, loc) ->
+          (fun (cname, _, _, _, loc) ->
             try
               let name' = Hashtbl.find labels cname.txt in
               Location.prerr_warning loc
@@ -1125,8 +1125,8 @@ let report_error ppf = function
 	    Btype.newgenty (Ttuple tl))
             "case" (fun (lab,_,_) -> Ident.name lab ^ " of ")
       | Type_record (tl, _), _ ->
-          explain_unbound ppf ty tl (fun (_,_,t) -> t)
-            "field" (fun (lab,_,_) -> Ident.name lab ^ ": ")
+          explain_unbound ppf ty tl (fun (_,_,_,t) -> t)
+            "field" (fun (lab,_,_,_) -> Ident.name lab ^ ": ")
       | Type_abstract, Some ty' ->
           explain_unbound_single ppf ty ty'
       | _ -> ()
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index fda05b0417..8eb4119fda 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -318,7 +318,7 @@ and type_kind =
     Ttype_abstract
   | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
   | Ttype_record of
-      (Ident.t * string loc * mutable_flag * core_type * Location.t) list
+      (Ident.t * string loc * mutable_flag * focus_flag * core_type * Location.t) list
 
 and exception_declaration =
   { exn_params : core_type list;
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 81242993d9..767675e342 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -317,7 +317,7 @@ and type_kind =
     Ttype_abstract
   | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
   | Ttype_record of
-      (Ident.t * string loc * mutable_flag * core_type * Location.t) list
+      (Ident.t * string loc * mutable_flag * focus_flag * core_type * Location.t) list
 
 and exception_declaration =
   { exn_params : core_type list;
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 403c67ff97..0463ba2505 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -177,7 +177,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
                 List.iter iter_core_type cts
             ) list
         | Ttype_record list ->
-            List.iter (fun (s, _, mut, ct, loc) ->
+            List.iter (fun (s, _, mut, foc, ct, loc) ->
                 iter_core_type ct
             ) list
       end;
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 663eea176a..a5d83ed6c2 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -154,8 +154,8 @@ module MakeMap(Map : MapArgument) = struct
 	Ttype_variant list
       | Ttype_record list ->
 	let list =
-          List.map (fun (s, name, mut, ct, loc) ->
-            (s, name, mut, map_core_type ct, loc)
+          List.map (fun (s, name, mut, foc, ct, loc) ->
+            (s, name, mut, foc, map_core_type ct, loc)
           ) list in
 	Ttype_record list
     in
diff --git a/typing/types.ml b/typing/types.ml
index 0ac4a9dab1..666598116f 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -129,6 +129,7 @@ type label_description =
     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_focus: focus_flag;
     lbl_pos: int;                       (* Position in block *)
     lbl_all: label_description array;   (* All the labels in this type *)
     lbl_repres: record_representation;  (* Representation for this record *)
@@ -154,7 +155,7 @@ type type_declaration =
 and type_kind =
     Type_abstract
   | Type_record of
-      (Ident.t * mutable_flag * type_expr) list * record_representation
+      (Ident.t * mutable_flag * focus_flag * type_expr) list * record_representation
   | Type_variant of (Ident.t * type_expr list * type_expr option) list
 
 type exception_declaration =
diff --git a/typing/types.mli b/typing/types.mli
index 731cff2144..972fb8e6f3 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -127,6 +127,7 @@ type label_description =
     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_focus: focus_flag;
     lbl_pos: int;                       (* Position in block *)
     lbl_all: label_description array;   (* All the labels in this type *)
     lbl_repres: record_representation;  (* Representation for this record *)
@@ -153,7 +154,7 @@ type type_declaration =
 and type_kind =
     Type_abstract
   | Type_record of
-      (Ident.t * mutable_flag * type_expr) list * record_representation
+      (Ident.t * mutable_flag * focus_flag * type_expr) list * record_representation
   | Type_variant of (Ident.t * type_expr list * type_expr option) list
 
 type exception_declaration =