summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/translclass.ml6
-rw-r--r--ocamldoc/odoc_ast.ml3
-rw-r--r--ocamldoc/odoc_sig.ml8
-rw-r--r--parsing/ast_helper.ml2
-rw-r--r--parsing/ast_helper.mli2
-rw-r--r--parsing/ast_mapper.ml2
-rw-r--r--parsing/parser.mly52
-rw-r--r--parsing/parsetree.mli4
-rw-r--r--parsing/pprintast.ml2
-rw-r--r--parsing/printast.ml6
-rw-r--r--tools/depend.ml3
-rw-r--r--tools/ocamlprof.ml1
-rw-r--r--tools/tast_iter.ml2
-rw-r--r--tools/untypeast.ml2
-rw-r--r--typing/printtyped.ml3
-rw-r--r--typing/typeclass.ml9
-rw-r--r--typing/typecore.ml5
-rw-r--r--typing/typedtree.ml2
-rw-r--r--typing/typedtree.mli2
-rw-r--r--typing/typedtreeIter.ml2
-rw-r--r--typing/typedtreeMap.ml2
21 files changed, 93 insertions, 27 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 72022a5e3..1f594453f 100644
--- a/bytecomp/translclass.ml
+++ b/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
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 3e0cc83b6..eeabb977f 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/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)
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 13b250315..e56f0eda1 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/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
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 072e686cd..ab11f76fd 100644
--- a/parsing/ast_helper.ml
+++ b/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)
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 0f9a35c54..64cee13c2 100644
--- a/parsing/ast_helper.mli
+++ b/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
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index db8553807..806162fc9 100644
--- a/parsing/ast_mapper.ml
+++ b/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} =
diff --git a/parsing/parser.mly b/parsing/parser.mly
index ad7a47ab6..578d83161 100644
--- a/parsing/parser.mly
+++ b/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
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 9ecd496c8..fd942131b 100644
--- a/parsing/parsetree.mli
+++ b/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] *)
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index dcc4218e6..941ab5903 100644
--- a/parsing/pprintast.ml
+++ b/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 } =
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 2b434cd16..e1ba350f6 100644
--- a/parsing/printast.ml
+++ b/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
diff --git a/tools/depend.ml b/tools/depend.ml
index a5de43737..c4a7dfdac 100644
--- a/tools/depend.ml
+++ b/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
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 478332a6f..457192eb6 100644
--- a/tools/ocamlprof.ml
+++ b/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 =
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
index 4ed5c45ea..80744e703 100644
--- a/tools/tast_iter.ml
+++ b/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
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index caff88f29..1cd176ae0 100644
--- a/tools/untypeast.ml
+++ b/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 }
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 550bb9af4..a434631e9 100644
--- a/typing/printtyped.ml
+++ b/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;
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 79c8bc7ee..2a01cdccc 100644
--- a/typing/typeclass.ml
+++ b/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))
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 03830254d..39d6628c1 100644
--- a/typing/typecore.ml
+++ b/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 &&
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 5d3400d02..6102ee187 100644
--- a/typing/typedtree.ml
+++ b/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
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index fae6ddd33..f9cb64faa 100644
--- a/typing/typedtree.mli
+++ b/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
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 10dc7184b..a03bbac14 100644
--- a/typing/typedtreeIter.ml
+++ b/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
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 30a8e5fa3..6fa70a8ee 100644
--- a/typing/typedtreeMap.ml
+++ b/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
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 12:02:15 +0000