Item attributes on classes.

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

6 files changed, 59 insertions, 34 deletions

diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index f21d55b62b..fdb325ce7c 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -1126,6 +1126,7 @@ value varify_constructors var_names =
        pci_name = with_loc name nloc;
        pci_expr = class_expr ce;
        pci_loc = mkloc loc;
+       pci_attributes = [];
        pci_variance = variance}
     | ce -> error (loc_of_class_expr ce) "bad class definition" ]
   and class_info_class_type ci =
@@ -1141,6 +1142,7 @@ value varify_constructors var_names =
        pci_params = (params, mkloc loc_params);
        pci_name = with_loc name nloc;
        pci_expr = class_type ct;
+       pci_attributes = [];
        pci_loc = mkloc loc;
        pci_variance = variance}
     | ct -> error (loc_of_class_type ct)
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 48f1596b23..1eca26077b 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -15512,6 +15512,7 @@ module Struct =
                       pci_expr = class_expr ce;
                       pci_loc = mkloc loc;
                       pci_variance = variance;
+                      pci_attributes = [];
                     }
               | ce -> error (loc_of_class_expr ce) "bad class definition"
             and class_info_class_type ci =
@@ -15535,6 +15536,7 @@ module Struct =
                       pci_expr = class_type ct;
                       pci_loc = mkloc loc;
                       pci_variance = variance;
+                      pci_attributes = [];
                     }
               | ct ->
                   error (loc_of_class_type ct)
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index ff983bcacf..4679649ddf 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -472,7 +472,7 @@ module CE = struct
      pcstr_fields = List.map (sub # class_field) pcstr_fields;
     }
 
-  let class_infos sub f {pci_virt; pci_params = (pl, ploc); pci_name; pci_expr; pci_variance; pci_loc} =
+  let class_infos sub f {pci_virt; pci_params = (pl, ploc); pci_name; pci_expr; pci_variance; pci_loc; pci_attributes} =
     {
      pci_virt;
      pci_params = List.map (map_loc sub) pl, sub # location ploc;
@@ -480,6 +480,7 @@ module CE = struct
      pci_expr = f pci_expr;
      pci_variance;
      pci_loc = sub # location pci_loc;
+     pci_attributes = map_attributes sub pci_attributes;
     }
 end
 
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 08dc1313db..1f32e0c648 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -58,6 +58,11 @@ let mkoperator name pos =
 let mkpatvar name pos =
   { ppat_desc = Ppat_var (mkrhs name pos); ppat_loc = rhs_loc pos }
 
+let patch_first_rev l f =
+  match l with
+  | [] -> assert false
+  | hd :: tl -> f hd :: tl
+
 (*
   Ghost expressions and patterns:
   expressions and patterns that do not appear explicitly in the
@@ -611,10 +616,8 @@ structure_item:
                                           pval_loc = symbol_rloc ()})) }
   | pre_item_attributes TYPE type_declarations
       {
-        match List.rev $3 with
-        | [] -> assert false
-        | (name, td) :: tl ->
-              mkstr(Pstr_type((name, {td with ptype_attributes = $1 @ td.ptype_attributes}) :: tl))
+       let l = patch_first_rev $3 (fun (name, td) -> (name, {td with ptype_attributes = $1 @ td.ptype_attributes})) in
+       mkstr(Pstr_type l)
        }
   | pre_item_attributes EXCEPTION UIDENT constructor_arguments post_item_attributes
       { mkstr(Pstr_exception(mkrhs $3 3, {ped_args=$4;ped_attributes=$1 @ $5})) }
@@ -628,10 +631,16 @@ structure_item:
       { mkstr(Pstr_modtype(mkrhs $3 3, $5)) }
   | pre_item_attributes OPEN mod_longident post_item_attributes
       { mkstr(Pstr_open (mkrhs $3 3, $1 @ $4)) }
-  | CLASS class_declarations
-      { mkstr(Pstr_class (List.rev $2)) }
-  | CLASS TYPE class_type_declarations
-      { mkstr(Pstr_class_type (List.rev $3)) }
+  | pre_item_attributes CLASS class_declarations
+      {
+       let l = patch_first_rev $3 (fun x -> {x with pci_attributes = $1 @ x.pci_attributes}) in
+       mkstr(Pstr_class l)
+      }
+  | pre_item_attributes CLASS TYPE class_type_declarations
+      {
+       let l = patch_first_rev $4 (fun x -> {x with pci_attributes = $1 @ x.pci_attributes}) in
+       mkstr(Pstr_class_type l)
+      }
   | pre_item_attributes INCLUDE module_expr post_item_attributes
       { mkstr(Pstr_include ($3, $1 @ $4)) }
   | pre_item_attributes item_extension post_item_attributes
@@ -696,10 +705,8 @@ signature_item:
                                       pval_loc = symbol_rloc()})) }
   | pre_item_attributes TYPE type_declarations
       {
-        match List.rev $3 with
-        | [] -> assert false
-        | (name, td) :: tl ->
-              mksig(Psig_type((name, {td with ptype_attributes = $1 @ td.ptype_attributes}) :: tl))
+       let l = patch_first_rev $3 (fun (name, td) -> (name, {td with ptype_attributes = $1 @ td.ptype_attributes})) in
+       mksig(Psig_type l)
        }
   | pre_item_attributes EXCEPTION UIDENT constructor_arguments post_item_attributes
       { mksig(Psig_exception(mkrhs $3 3, {ped_args = $4; ped_attributes = $1 @ $5})) }
@@ -707,10 +714,8 @@ signature_item:
       { mksig(Psig_module{pmd_name=mkrhs $3 3;pmd_type=$4;pmd_attributes=$1 @ $5}) }
   | pre_item_attributes MODULE REC module_rec_declarations
       {
-       match List.rev $4 with
-        | [] -> assert false
-        | pmd :: tl ->
-              mksig(Psig_recmodule({pmd with pmd_attributes = $1 @ pmd.pmd_attributes} :: tl))
+       let l = patch_first_rev $4 (fun pmd -> {pmd with pmd_attributes = $1 @ pmd.pmd_attributes}) in
+       mksig(Psig_recmodule l)
       }
   | pre_item_attributes MODULE TYPE ident post_item_attributes
       { mksig(Psig_modtype(mkrhs $4 4, Pmodtype_abstract, $1 @ $5)) }
@@ -720,10 +725,16 @@ signature_item:
       { mksig(Psig_open (mkrhs $3 3, $1 @ $4)) }
   | pre_item_attributes INCLUDE module_type post_item_attributes %prec below_WITH
       { mksig(Psig_include ($3, $1 @ $4)) }
-  | CLASS class_descriptions
-      { mksig(Psig_class (List.rev $2)) }
-  | CLASS TYPE class_type_declarations
-      { mksig(Psig_class_type (List.rev $3)) }
+  | pre_item_attributes CLASS class_descriptions
+      {
+        let l = patch_first_rev $3 (fun x -> {x with pci_attributes = $1 @ x.pci_attributes}) in
+        mksig(Psig_class l)
+       }
+  | pre_item_attributes CLASS TYPE class_type_declarations
+      {
+        let l = patch_first_rev $4 (fun x -> {x with pci_attributes = $1 @ x.pci_attributes}) in
+        mksig(Psig_class_type l)
+       }
   | pre_item_attributes item_extension post_item_attributes
       { mksig(Psig_extension ($2, $1 @ $3)) }
 ;
@@ -749,10 +760,11 @@ class_declarations:
   | class_declaration                           { [$1] }
 ;
 class_declaration:
-    virtual_flag class_type_parameters LIDENT class_fun_binding
-      { let params, variance = List.split (fst $2) in
-        {pci_virt = $1; pci_params = params, snd $2;
-         pci_name = mkrhs $3 3; pci_expr = $4; pci_variance = variance;
+    pre_item_attributes virtual_flag class_type_parameters LIDENT class_fun_binding post_item_attributes
+      { let params, variance = List.split (fst $3) in
+        {pci_virt = $2; pci_params = params, snd $3;
+         pci_name = mkrhs $4 4; pci_expr = $5; pci_variance = variance;
+         pci_attributes = $1 @ $6;
          pci_loc = symbol_rloc ()} }
 ;
 class_fun_binding:
@@ -948,10 +960,11 @@ class_descriptions:
   | class_description                           { [$1] }
 ;
 class_description:
-    virtual_flag class_type_parameters LIDENT COLON class_type
-      { let params, variance = List.split (fst $2) in
-        {pci_virt = $1; pci_params = params, snd $2;
-         pci_name = mkrhs $3 3; pci_expr = $5; pci_variance = variance;
+    pre_item_attributes virtual_flag class_type_parameters LIDENT COLON class_type post_item_attributes
+      { let params, variance = List.split (fst $3) in
+        {pci_virt = $2; pci_params = params, snd $3;
+         pci_name = mkrhs $4 4; pci_expr = $6; pci_variance = variance;
+         pci_attributes = $1 @ $7;
          pci_loc = symbol_rloc ()} }
 ;
 class_type_declarations:
@@ -959,10 +972,11 @@ class_type_declarations:
   | class_type_declaration                              { [$1] }
 ;
 class_type_declaration:
-    virtual_flag class_type_parameters LIDENT EQUAL class_signature
-      { let params, variance = List.split (fst $2) in
-        {pci_virt = $1; pci_params = params, snd $2;
-         pci_name = mkrhs $3 3; pci_expr = $5; pci_variance = variance;
+    pre_item_attributes virtual_flag class_type_parameters LIDENT EQUAL class_signature post_item_attributes
+      { let params, variance = List.split (fst $3) in
+        {pci_virt = $2; pci_params = params, snd $3;
+         pci_name = mkrhs $4 4; pci_expr = $6; pci_variance = variance;
+         pci_attributes = $1 @ $7;
          pci_loc = symbol_rloc ()} }
 ;
 
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 011dfd3592..aa959f38ea 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -64,7 +64,9 @@ and 'a class_infos =
     pci_name: string loc;
     pci_expr: 'a;
     pci_variance: (bool * bool) list;
-    pci_loc: Location.t }
+    pci_loc: Location.t;
+    pci_attributes: attribute list;
+   }
 
 (* Value expressions for the core language *)
 
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index c5c6c0b122..dd2e7e9f27 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -73,6 +73,7 @@ and untype_structure_item item =
                 pci_expr = untype_class_expr ci.ci_expr;
                 pci_variance = ci.ci_variance;
                 pci_loc = ci.ci_loc;
+                pci_attributes = [];
               }
           ) list)
     | Tstr_class_type list ->
@@ -84,6 +85,7 @@ and untype_structure_item item =
                 pci_expr = untype_class_type ct.ci_expr;
                 pci_variance = ct.ci_variance;
                 pci_loc = ct.ci_loc;
+                pci_attributes = [];
               }
           ) list)
     | Tstr_include (mexpr, _) ->
@@ -347,6 +349,7 @@ and untype_class_description cd =
     pci_expr = untype_class_type cd.ci_expr;
     pci_variance = cd.ci_variance;
     pci_loc = cd.ci_loc;
+   pci_attributes = [];
   }
 
 and untype_class_type_declaration cd =
@@ -357,6 +360,7 @@ and untype_class_type_declaration cd =
     pci_expr = untype_class_type cd.ci_expr;
     pci_variance = cd.ci_variance;
     pci_loc = cd.ci_loc;
+    pci_attributes = [];
   }
 
 and untype_module_type mty =