Adding extension/attribute on patterns.

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

otherlibs/labltk/browser/searchid.ml

@@ -428,6 +428,8 @@ let rec bound_variables pat =
       bound_variables pat1 @ bound_variables pat2
   | Ppat_constraint (pat,_) -> bound_variables pat
   | Ppat_lazy pat -> bound_variables pat
+  | Ppat_attribute (pat, _) ->  bound_variables pat
+  | Ppat_extension _ -> []
 
 let search_structure str ~name ~kind ~prefix =
   let loc = ref 0 in

parsing/ast_mapper.ml

@@ -362,6 +362,8 @@ module P = struct
   let type_ ?loc a = mk ?loc (Ppat_type a)
   let lazy_ ?loc a = mk ?loc (Ppat_lazy a)
   let unpack ?loc a = mk ?loc (Ppat_unpack a)
+  let attribute ?loc a b = mk ?loc (Ppat_attribute (a, b))
+  let extension ?loc a = mk ?loc (Ppat_extension a)
 
   let map sub {ppat_desc = desc; ppat_loc = loc} =
     let loc = sub # location loc in
@@ -381,6 +383,8 @@ module P = struct
     | Ppat_type s -> type_ ~loc (map_loc sub s)
     | Ppat_lazy p -> lazy_ ~loc (sub # pat p)
     | Ppat_unpack s -> unpack ~loc (map_loc sub s)
+    | Ppat_attribute (body, x) -> attribute ~loc (sub # pat body) (sub # attribute x)
+    | Ppat_extension x -> extension ~loc (sub # extension x)
 end
 
 module CE = struct

parsing/parser.mly

@@ -1079,10 +1079,6 @@ expr:
   | expr attribute
       { mkexp (Pexp_attribute($1, $2)) }
 ;
-opt_expr:
-    expr { $1 }
-  |      { ghunit () }
-;
 simple_expr:
     val_longident
       { mkexp(Pexp_ident (mkrhs $1 1)) }
@@ -1303,6 +1299,8 @@ pattern:
       { expecting 3 "pattern" }
   | LAZY simple_pattern
       { mkpat(Ppat_lazy $2) }
+  | pattern attribute
+      { mkpat(Ppat_attribute($1, $2)) }
 ;
 simple_pattern:
     val_ident %prec below_EQUAL
@@ -1349,6 +1347,8 @@ simple_pattern:
       { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)),ghtyp(Ptyp_package $5))) }
   | LPAREN MODULE UIDENT COLON package_type error
       { unclosed "(" 1 ")" 6 }
+  | extension
+      { mkpat(Ppat_extension $1) }
 ;
 
 pattern_comma_list:
@@ -1900,4 +1900,8 @@ with_attribute:
 extension:
   LPARENCOLON LIDENT opt_expr RPAREN { ($2, $3) }
 ;
+opt_expr:
+    expr { $1 }
+  |      { ghunit () }
+;
 %%

parsing/parsetree.mli

@@ -87,6 +87,8 @@ and pattern_desc =
   | Ppat_type of Longident.t loc
   | Ppat_lazy of pattern
   | Ppat_unpack of string loc
+  | Ppat_attribute of (pattern * attribute)
+  | Ppat_extension of extension
 
 and expression =
   { pexp_desc: expression_desc;

parsing/pprintast.ml

@@ -108,6 +108,7 @@ let rec is_irrefut_patt x =
   | Ppat_or (l,r) -> is_irrefut_patt l || is_irrefut_patt r
   | Ppat_record (ls,_) -> List.for_all (fun (_,x) -> is_irrefut_patt x) ls
   | Ppat_lazy p -> is_irrefut_patt p 
+  | Ppat_extension _ | Ppat_attribute _ -> assert false
   | Ppat_constant _ | Ppat_construct _  | Ppat_variant _ | Ppat_array _ | Ppat_type _-> false (*conservative*)
 class printer  ()= object(self:'self)
   val pipe = false

parsing/printast.ml

@@ -226,6 +226,13 @@ and pattern i ppf x =
       longident_loc i ppf li
   | Ppat_unpack s ->
       line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
+  | Ppat_attribute (body, (s, arg)) ->
+      line i ppf "Ppat_attribute \"%s\"\n" s;
+      expression i ppf arg;
+      pattern i ppf body
+  | Ppat_extension (s, arg) ->
+      line i ppf "Ppat_extension \"%s\"\n" s;
+      expression i ppf arg
 
 and expression i ppf x =
   line i ppf "expression %a\n" fmt_location x.pexp_loc;

tools/depend.ml

@@ -124,6 +124,8 @@ let rec add_pattern bv pat =
   | Ppat_type li -> add bv li
   | Ppat_lazy p -> add_pattern bv p
   | Ppat_unpack id -> pattern_bv := StringSet.add id.txt !pattern_bv
+  | Ppat_attribute (p, _) -> add_pattern bv p
+  | Ppat_extension _ -> ()
 
 let add_pattern bv pat =
   pattern_bv := bv;

typing/typecore.ml

@@ -1099,6 +1099,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
       let (path, p,ty) = build_or_pat !env loc lid.txt in
       unify_pat_types loc !env ty expected_ty;
       { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
+  | Ppat_attribute (p, _attrs) ->
+      type_pat p expected_ty
+  | Ppat_extension (s, _arg) ->
+      raise (Error (loc, !env, Extension s))
 
 let type_pat ?(allow_existentials=false) ?constrs ?labels
     ?(lev=get_current_level()) env sp expected_ty =
@@ -1699,11 +1703,13 @@ let contains_variant_either ty =
 let iter_ppat f p =
   match p.ppat_desc with
   | Ppat_any | Ppat_var _ | Ppat_constant _
+  | Ppat_extension _
   | Ppat_type _ | Ppat_unpack _ -> ()
   | Ppat_array pats -> List.iter f pats
   | Ppat_or (p1,p2) -> f p1; f p2
   | Ppat_variant (_, arg) | Ppat_construct (_, arg, _) -> may f arg
   | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_attribute (p, _)
   | Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p
   | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args