Add support for floating attributes in class structures and class signatures. (Patch by Leo White.)

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

bytecomp/translclass.ml

@@ -145,7 +145,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
                | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
                    (inh_init, lsequence (set_inst_var obj id exp) obj_init,
                     has_init)
-               | Tcf_method _ | Tcf_val _ | Tcf_constraint _ ->
+               | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _ ->
                    (inh_init, obj_init, has_init)
                | Tcf_initializer _ ->
                    (inh_init, obj_init, true)
@@ -305,7 +305,9 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
                  Lsequence(mkappl (oo_prim "add_initializer",
                                    Lvar cla :: msubst false (transl_exp exp)),
                            cl_init),
-                 methods, values))
+                 methods, values)
+            | Tcf_attribute _ ->
+                (inh_init, cl_init, methods, values))
           str.cstr_fields
           (inh_init, cl_init, [], [])
       in

ocamldoc/odoc_ast.ml

@@ -679,6 +679,9 @@ module Analyser =
         | (Parsetree.Pcf_initializer exp) ->
             iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q
 
+        | Parsetree.Pcf_attribute _ ->
+            iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q
+
         | Parsetree.Pcf_extension _ -> assert false
       in
       iter [] [] last_pos (p_cls.Parsetree.pcstr_fields)

ocamldoc/odoc_sig.ml

@@ -297,7 +297,8 @@ module Analyser =
             match ele2.Parsetree.pctf_desc with
               Parsetree.Pctf_val (_, _, _, _)
             | Parsetree.Pctf_method (_, _, _, _)
-            | Parsetree.Pctf_constraint (_, _) -> loc.Location.loc_start.Lexing.pos_cnum
+            | Parsetree.Pctf_constraint (_, _)
+            | Parsetree.Pctf_attribute _ -> loc.Location.loc_start.Lexing.pos_cnum
             | Parsetree.Pctf_inherit class_type ->
                 class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum
             | Parsetree.Pctf_extension _ -> assert false
@@ -456,6 +457,11 @@ module Analyser =
             in
             let (inher_l, eles) = f (pos_end + maybe_more) q in
             (inh :: inher_l , eles_comments @ eles)
+        | Parsetree.Pctf_attribute _ ->
+            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+            let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in
+            (inher_l, eles_comments @ eles)
+
         | Parsetree.Pctf_extension _ -> assert false
       in
       f last_pos class_type_field_list

parsing/ast_helper.ml

@@ -236,6 +236,7 @@ module Ctf = struct
   let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d))
   let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
+  let attribute ?loc a = mk ?loc (Pctf_attribute a)
 end
 
 module Cf = struct
@@ -253,6 +254,7 @@ module Cf = struct
   let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b))
   let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
+  let attribute ?loc a = mk ?loc (Pcf_attribute a)
 
   let virtual_ ct = Cfk_virtual ct
   let concrete o e = Cfk_concrete (o, e)

parsing/ast_helper.mli

@@ -283,6 +283,7 @@ module Ctf:
     val method_: ?loc:loc -> ?attrs:attrs -> string -> private_flag -> virtual_flag -> core_type -> class_type_field
     val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
+    val attribute: ?loc:loc -> attribute -> class_type_field
   end
 
 (** Class expressions *)
@@ -312,6 +313,7 @@ module Cf:
     val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_field
     val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
+    val attribute: ?loc:loc -> attribute -> class_field
 
     val virtual_: core_type -> class_field_kind
     val concrete: override_flag -> expression -> class_field_kind

parsing/ast_mapper.ml

@@ -157,6 +157,7 @@ module CT = struct
     | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
     | Pctf_constraint (t1, t2) ->
         constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
+    | Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
     | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x)
 
   let map_signature sub {pcsig_self; pcsig_fields} =
@@ -407,6 +408,7 @@ module CE = struct
     | Pcf_constraint (t1, t2) ->
         constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
     | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e)
+    | Pcf_attribute x -> attribute ~loc (sub.attribute sub x)
     | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x)
 
   let map_structure sub {pcstr_self; pcstr_fields} =

parsing/parser.mly

@@ -282,6 +282,12 @@ let wrap_exp_attrs body (ext, attrs) =
 let mkexp_attrs d attrs =
   wrap_exp_attrs (mkexp d) attrs
 
+let mkcf_attrs d attrs =
+  Cf.mk ~loc:(symbol_rloc()) ~attrs d
+
+let mkctf_attrs d attrs =
+  Ctf.mk ~loc:(symbol_rloc()) ~attrs d
+
 %}
 
 /* Tokens */
@@ -863,19 +869,20 @@ class_fields:
       { $2 :: $1 }
 ;
 class_field:
-  | INHERIT override_flag class_expr parent_binder
-      { mkcf (Pcf_inherit ($2, $3, $4)) }
-  | VAL value
-      { mkcf (Pcf_val $2) }
-  | METHOD method_
-      { mkcf (Pcf_method $2) }
-  | CONSTRAINT constrain_field
-      { mkcf (Pcf_constraint $2) }
-  | INITIALIZER seq_expr
-      { mkcf (Pcf_initializer $2) }
-  | class_field post_item_attribute
-      { Cf.attr $1 $2 }
-  | item_extension { mkcf(Pcf_extension $1) }
+  | INHERIT override_flag class_expr parent_binder post_item_attributes
+      { mkcf_attrs (Pcf_inherit ($2, $3, $4)) $5 }
+  | VAL value post_item_attributes
+      { mkcf_attrs (Pcf_val $2) $3 }
+  | METHOD method_ post_item_attributes
+      { mkcf_attrs (Pcf_method $2) $3 }
+  | CONSTRAINT constrain_field post_item_attributes
+      { mkcf_attrs (Pcf_constraint $2) $3 }
+  | INITIALIZER seq_expr post_item_attributes
+      { mkcf_attrs (Pcf_initializer $2) $3 }
+  | item_extension post_item_attributes
+      { mkcf_attrs (Pcf_extension $1) $2 }
+  | floating_attribute
+      { mkcf (Pcf_attribute $1) }
 ;
 parent_binder:
     AS LIDENT
@@ -963,16 +970,21 @@ class_sig_fields:
 | class_sig_fields class_sig_field     { $2 :: $1 }
 ;
 class_sig_field:
-    INHERIT class_signature       { mkctf (Pctf_inherit $2) }
-  | VAL value_type              { mkctf (Pctf_val $2) }
-  | METHOD private_virtual_flags label COLON poly_type
+    INHERIT class_signature post_item_attributes
+      { mkctf_attrs (Pctf_inherit $2) $3 }
+  | VAL value_type post_item_attributes
+      { mkctf_attrs (Pctf_val $2) $3 }
+  | METHOD private_virtual_flags label COLON poly_type post_item_attributes
       {
        let (p, v) = $2 in
-       mkctf (Pctf_method ($3, p, v, $5))
+       mkctf_attrs (Pctf_method ($3, p, v, $5)) $6
       }
-  | CONSTRAINT constrain_field        { mkctf (Pctf_constraint $2) }
-  | class_sig_field post_item_attribute { Ctf.attr $1 $2 }
-  | item_extension { mkctf(Pctf_extension $1) }
+  | CONSTRAINT constrain_field post_item_attributes
+      { mkctf_attrs (Pctf_constraint $2) $3 }
+  | item_extension post_item_attributes
+      { mkctf_attrs (Pctf_extension $1) $2 }
+  | floating_attribute
+      { mkctf(Pctf_attribute $1) }
 ;
 value_type:
     VIRTUAL mutable_flag label COLON core_type

parsing/parsetree.mli

@@ -450,6 +450,8 @@ and class_type_field_desc =
          *)
   | Pctf_constraint  of (core_type * core_type)
         (* constraint T1 = T2 *)
+  | Pctf_attribute of attribute
+        (* [@@@id] *)
   | Pctf_extension of extension
         (* [%%id] *)
 
@@ -543,6 +545,8 @@ and class_field_desc =
         (* constraint T1 = T2 *)
   | Pcf_initializer of expression
         (* initializer E *)
+  | Pcf_attribute of attribute
+        (* [@@@id] *)
   | Pcf_extension of extension
         (* [%%id] *)
 

parsing/pprintast.ml

@@ -728,6 +728,7 @@ class printer  ()= object(self:'self)
       | Pctf_constraint (ct1, ct2) ->
           pp f "@[<2>constraint@ %a@ =@ %a@]"
             self#core_type ct1 self#core_type ct2
+      | Pctf_attribute _ -> ()
       | Pctf_extension _ -> assert false
     in
     pp f "@[<hv0>@[<hv2>object @[<1>%a@]@ %a@]@ end@]"
@@ -802,6 +803,7 @@ class printer  ()= object(self:'self)
         pp f "@[<2>constraint %a =@;%a@]" self#core_type  ct1 self#core_type  ct2
     | Pcf_initializer (e) ->
         pp f "@[<2>initializer@ %a@]" self#expression e
+    | Pcf_attribute _ -> ()
     | Pcf_extension _ -> assert false
 
   method class_structure f { pcstr_self = p; pcstr_fields =  l } =

parsing/printast.ml

@@ -459,6 +459,9 @@ and class_type_field i ppf x =
       line i ppf "Pctf_constraint\n";
       core_type (i+1) ppf ct1;
       core_type (i+1) ppf ct2;
+  | Pctf_attribute (s, arg) ->
+      line i ppf "Pctf_attribute \"%s\"\n" s.txt;
+      payload i ppf arg
   | Pctf_extension (s, arg) ->
       line i ppf "Pctf_extension \"%s\"\n" s.txt;
      payload i ppf arg
@@ -547,6 +550,9 @@ and class_field i ppf x =
   | Pcf_initializer (e) ->
       line i ppf "Pcf_initializer\n";
       expression (i+1) ppf e;
+  | Pcf_attribute (s, arg) ->
+      line i ppf "Pcf_attribute \"%s\"\n" s.txt;
+      payload i ppf arg
   | Pcf_extension (s, arg) ->
       line i ppf "Pcf_extension \"%s\"\n" s.txt;
       payload i ppf arg

tools/depend.ml

@@ -96,6 +96,7 @@ and add_class_type_field bv pctf =
   | Pctf_val(_, _, _, ty) -> add_type bv ty
   | Pctf_method(_, _, _, ty) -> add_type bv ty
   | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pctf_attribute _ -> ()
   | Pctf_extension _ -> ()
 
 let add_class_description bv infos =
@@ -351,7 +352,7 @@ and add_class_field bv pcf =
   | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
   | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
   | Pcf_initializer e -> add_expr bv e
-  | Pcf_extension _ -> ()
+  | Pcf_attribute _ | Pcf_extension _ -> ()
 
 and add_class_declaration bv decl =
   add_class_expr bv decl.pci_expr

tools/ocamlprof.ml

@@ -344,6 +344,7 @@ and rewrite_class_field iflag cf =
   | Pcf_method (_, _, Cfk_virtual _)
   | Pcf_val (_, _, Cfk_virtual _)
   | Pcf_constraint _  -> ()
+  | Pcf_attribute _ -> ()
   | Pcf_extension _ -> ()
 
 and rewrite_class_expr iflag cexpr =

tools/tast_iter.ml

@@ -274,6 +274,7 @@ let class_type_field sub ctf =
   | Tctf_constraint  (ct1, ct2) ->
       sub # core_type ct1;
       sub # core_type ct2
+  | Tctf_attribute _ -> ()
 
 let core_type sub ct =
   match ct.ctyp_desc with
@@ -322,6 +323,7 @@ let class_field sub cf =
       sub # expression exp
   | Tcf_initializer exp ->
       sub # expression exp
+  | Tcf_attribute _ -> ()
 
 let bindings sub (_rec_flag, list) =
   List.iter (sub # binding) list

tools/untypeast.ml

@@ -517,6 +517,7 @@ and untype_class_type_field ctf =
         Pctf_method  (s, priv, virt, untype_core_type ct)
     | Tctf_constraint  (ct1, ct2) ->
         Pctf_constraint (untype_core_type ct1, untype_core_type ct2)
+    | Tctf_attribute x -> Pctf_attribute x
   in
   {
     pctf_desc = desc;
@@ -573,5 +574,6 @@ and untype_class_field cf =
     | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
         Pcf_method (lab, priv, Cfk_concrete (o, untype_expression exp))
     | Tcf_initializer exp -> Pcf_initializer (untype_expression exp)
+    | Tcf_attribute x -> Pcf_attribute x
   in
   { pcf_desc = desc; pcf_loc = cf.cf_loc; pcf_attributes = cf.cf_attributes }

typing/printtyped.ml

@@ -449,6 +449,9 @@ and class_type_field i ppf x =
       line i ppf "Pctf_constraint\n";
       core_type (i+1) ppf ct1;
       core_type (i+1) ppf ct2;
+  | Tctf_attribute (s, arg) ->
+      line i ppf "Pctf_attribute \"%s\"\n" s.txt;
+      Printast.payload i ppf arg
 
 and class_description i ppf x =
   line i ppf "class_description %a\n" fmt_location x.ci_loc;

typing/typeclass.ml

@@ -410,6 +410,10 @@ let rec class_type_field env self_type meths
       (mkctf (Tctf_constraint (cty, cty')) :: fields,
         val_sig, concr_meths, inher)
 
+  | Pctf_attribute x ->
+      (mkctf (Tctf_attribute x) :: fields,
+        val_sig, concr_meths, inher)
+
   | Pctf_extension (s, _arg) ->
       raise (Error (s.loc, env, Extension s.txt))
 
@@ -700,7 +704,10 @@ let rec class_field self_loc cl_num self_type meths vars
         end in
       (val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
        inher, local_meths, local_vals)
-
+  | Pcf_attribute x ->
+      (val_env, met_env, par_env,
+        lazy (mkcf (Tcf_attribute x)) :: fields,
+        concr_meths, warn_vals, inher, local_meths, local_vals)
   | Pcf_extension (s, _arg) ->
       raise (Error (s.loc, val_env, Extension s.txt))
 

typing/typecore.ml

@@ -215,7 +215,7 @@ let iter_expression f e =
     | Pcf_val (_, _, Cfk_concrete (_, e))
     | Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e
     | Pcf_initializer e -> expr e
-    | Pcf_extension _ -> ()
+    | Pcf_attribute _ | Pcf_extension _ -> ()
 
   in
   expr e
@@ -1405,7 +1405,8 @@ let rec is_nonexpansive exp =
               incr count; true
           | Tcf_initializer e -> is_nonexpansive e
           | Tcf_constraint _ -> true
-          | Tcf_inherit _ -> false)
+          | Tcf_inherit _ -> false
+          | Tcf_attribute _ -> true)
         fields &&
       Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
         vars true &&

typing/typedtree.ml

@@ -169,6 +169,7 @@ and class_field_desc =
   | Tcf_method of string loc * private_flag * class_field_kind
   | Tcf_constraint of core_type * core_type
   | Tcf_initializer of expression
+  | Tcf_attribute of attribute
 
 (* Value expressions for the module language *)
 
@@ -454,6 +455,7 @@ and class_type_field_desc =
   | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
   | Tctf_method of (string * private_flag * virtual_flag * core_type)
   | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
 
 and class_declaration =
   class_expr class_infos

typing/typedtree.mli

@@ -168,6 +168,7 @@ and class_field_desc =
   | Tcf_method of string loc * private_flag * class_field_kind
   | Tcf_constraint of core_type * core_type
   | Tcf_initializer of expression
+  | Tcf_attribute of attribute
 
 (* Value expressions for the module language *)
 
@@ -454,6 +455,7 @@ and class_type_field_desc =
   | Tctf_val of (string * mutable_flag * virtual_flag * core_type)
   | Tctf_method of (string * private_flag * virtual_flag * core_type)
   | Tctf_constraint of (core_type * core_type)
+  | Tctf_attribute of attribute
 
 and class_declaration =
   class_expr class_infos

typing/typedtreeIter.ml

@@ -494,6 +494,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tctf_constraint  (ct1, ct2) ->
             iter_core_type ct1;
             iter_core_type ct2
+        | Tctf_attribute _ -> ()
       end;
       Iter.leave_class_type_field ctf
 
@@ -554,6 +555,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
           iter_expression exp
       | Tcf_initializer exp ->
           iter_expression exp
+      | Tcf_attribute _ -> ()
       end;
       Iter.leave_class_field cf;
   end

typing/typedtreeMap.ml

@@ -542,6 +542,7 @@ module MakeMap(Map : MapArgument) = struct
           Tctf_method (s, priv, virt, map_core_type ct)
         | Tctf_constraint (ct1, ct2) ->
           Tctf_constraint (map_core_type ct1, map_core_type ct2)
+        | Tctf_attribute _ as x -> x
     in
     Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
 
@@ -597,6 +598,7 @@ module MakeMap(Map : MapArgument) = struct
         | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
           Tcf_method (lab, priv, Tcfk_concrete (o, map_expression exp))
         | Tcf_initializer exp -> Tcf_initializer (map_expression exp)
+        | Tcf_attribute _ as x -> x
     in
     Map.leave_class_field { cf with cf_desc = cf_desc }
 end