summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml2
-rw-r--r--camlp4/boot/Camlp4.ml2
-rw-r--r--experimental/frisch/extension_points.txt8
-rw-r--r--parsing/ast_helper.ml18
-rw-r--r--parsing/ast_helper.mli14
-rw-r--r--parsing/parser.mly4
-rw-r--r--parsing/parsetree.mli1
-rw-r--r--parsing/printast.ml1
-rw-r--r--tools/untypeast.ml1
-rw-r--r--typing/typeclass.ml29
-rw-r--r--typing/typedtree.ml5
-rw-r--r--typing/typedtree.mli5
12 files changed, 51 insertions, 39 deletions
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index 69e708ba8..b06af203e 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -70,7 +70,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};
value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};
value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = []};
- value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; };
+ value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = []};
value mkpolytype t =
match t.ptyp_desc with
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 116996ba1..40c1237b1 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -14191,7 +14191,7 @@ module Struct =
let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = [] }
- let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; }
+ let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = [] }
let mkpolytype t =
match t.ptyp_desc with
diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt
index 3337ef359..492340f16 100644
--- a/experimental/frisch/extension_points.txt
+++ b/experimental/frisch/extension_points.txt
@@ -34,10 +34,10 @@ Attributes on items:
... [@@id expr]
- Items designate class field, signature and structure items, and also
- individual components of multiple declaration (type declarations,
- recursive modules, class declarations, class type
- declarations). (TODO: class type fields?)
+ Items designate signature items, structure items, class fields,
+ class type fields and also individual components of multiple
+ declaration in structures and signatures (type declarations, recursive modules, class
+ declarations, class type declarations).
For instance, consider:
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index f8a64c5ee..ea2f17590 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -181,13 +181,19 @@ module Cty = struct
end
module Ctf = struct
- let mk ?(loc = Location.none) d = {pctf_desc = d; pctf_loc = loc}
+ let mk ?(attrs = []) ?(loc = Location.none) d =
+ {
+ pctf_desc = d;
+ pctf_loc = loc;
+ pctf_attributes = attrs;
+ }
+ let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
- let inher ?loc a = mk ?loc (Pctf_inher a)
- let val_ ?loc a b c d = mk ?loc (Pctf_val (a, b, c, d))
- let virt ?loc a b c = mk ?loc (Pctf_virt (a, b, c))
- let meth ?loc a b c = mk ?loc (Pctf_meth (a, b, c))
- let cstr ?loc a b = mk ?loc (Pctf_cstr (a, b))
+ let inher ?loc ?attrs a = mk ?loc ?attrs (Pctf_inher a)
+ let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
+ let virt ?loc ?attrs a b c = mk ?loc ?attrs (Pctf_virt (a, b, c))
+ let meth ?loc ?attrs a b c = mk ?loc ?attrs (Pctf_meth (a, b, c))
+ let cstr ?loc ?attrs a b = mk ?loc ?attrs (Pctf_cstr (a, b))
end
module Cf = struct
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 7bc80bf73..654ed03d2 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -171,12 +171,14 @@ module Cty:
end
module Ctf:
sig
- val mk: ?loc:Location.t -> class_type_field_desc -> class_type_field
- val inher: ?loc:Location.t -> class_type -> class_type_field
- val val_: ?loc:Location.t -> string -> mutable_flag -> virtual_flag -> core_type -> class_type_field
- val virt: ?loc:Location.t -> string -> private_flag -> core_type -> class_type_field
- val meth: ?loc:Location.t -> string -> private_flag -> core_type -> class_type_field
- val cstr: ?loc:Location.t -> core_type -> core_type -> class_type_field
+ val mk: ?attrs:attribute list -> ?loc:Location.t -> class_type_field_desc -> class_type_field
+ val attr: class_type_field -> attribute -> class_type_field
+
+ val inher: ?loc:Location.t -> ?attrs:attribute list -> class_type -> class_type_field
+ val val_: ?loc:Location.t -> ?attrs:attribute list -> string -> mutable_flag -> virtual_flag -> core_type -> class_type_field
+ val virt: ?loc:Location.t -> ?attrs:attribute list -> string -> private_flag -> core_type -> class_type_field
+ val meth: ?loc:Location.t -> ?attrs:attribute list -> string -> private_flag -> core_type -> class_type_field
+ val cstr: ?loc:Location.t -> ?attrs:attribute list -> core_type -> core_type -> class_type_field
end
module Cf:
sig
diff --git a/parsing/parser.mly b/parsing/parser.mly
index cbdc0429c..11d636096 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -909,6 +909,7 @@ class_sig_field:
| virtual_method_type { mkctf (Pctf_virt $1) }
| method_type { mkctf (Pctf_meth $1) }
| CONSTRAINT constrain_field { mkctf (Pctf_cstr $2) }
+ | class_sig_field post_item_attribute { Ctf.attr $1 $2 }
;
value_type:
VIRTUAL mutable_flag label COLON core_type
@@ -1950,8 +1951,7 @@ attr_id:
| WHEN { "when" }
| WHILE { "while" }
| WITH { "with" }
-/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now,
- and so are keywords followed by digits */
+/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */
;
attribute:
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 14d115b8e..fcbc6ee43 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -193,6 +193,7 @@ and class_signature = {
and class_type_field = {
pctf_desc: class_type_field_desc;
pctf_loc: Location.t;
+ pctf_attributes: attribute list;
}
and class_type_field_desc =
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 5a57541b9..72392c1a6 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -423,6 +423,7 @@ and class_signature i ppf cs =
and class_type_field i ppf x =
line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
let i = i+1 in
+ attributes i ppf x.pctf_attributes;
match x.pctf_desc with
| Pctf_inher (ct) ->
line i ppf "Pctf_inher\n";
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index e82b3cfff..c2d6fc645 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -479,6 +479,7 @@ and untype_class_type_field ctf =
{
pctf_desc = desc;
pctf_loc = ctf.ctf_loc;
+ pctf_attributes = ctf.ctf_attributes;
}
and untype_core_type ct =
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 7a2d01820..3b5683d82 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -54,8 +54,6 @@ let ctyp desc typ env loc =
{ ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] }
let cltyp desc typ env loc =
{ cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env }
-let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc }
-
(**********************)
@@ -367,6 +365,7 @@ let add_val env loc lab (mut, virt, ty) val_sig =
let rec class_type_field env self_type meths
(fields, val_sig, concr_meths, inher) ctf =
let loc = ctf.pctf_loc in
+ let mkctf desc = { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } in
match ctf.pctf_desc with
Pctf_inher sparent ->
let parent = class_type env sparent in
@@ -381,31 +380,31 @@ let rec class_type_field env self_type meths
in
let val_sig =
Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
- (mkctf (Tctf_inher parent) loc :: fields,
+ (mkctf (Tctf_inher parent) :: fields,
val_sig, concr_meths, inher)
| Pctf_val (lab, mut, virt, sty) ->
let cty = transl_simple_type env false sty in
let ty = cty.ctyp_type in
- (mkctf (Tctf_val (lab, mut, virt, cty)) loc :: fields,
+ (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher)
| Pctf_virt (lab, priv, sty) ->
let cty =
declare_method env meths self_type lab priv sty ctf.pctf_loc
in
- (mkctf (Tctf_virt (lab, priv, cty)) loc :: fields,
+ (mkctf (Tctf_virt (lab, priv, cty)) :: fields,
val_sig, concr_meths, inher)
| Pctf_meth (lab, priv, sty) ->
let cty =
declare_method env meths self_type lab priv sty ctf.pctf_loc in
- (mkctf (Tctf_meth (lab, priv, cty)) loc :: fields,
+ (mkctf (Tctf_meth (lab, priv, cty)) :: fields,
val_sig, Concr.add lab concr_meths, inher)
| Pctf_cstr (sty, sty') ->
let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in
- (mkctf (Tctf_cstr (cty, cty')) loc :: fields,
+ (mkctf (Tctf_cstr (cty, cty')) :: fields,
val_sig, concr_meths, inher)
and class_signature env sty sign loc =
@@ -497,7 +496,7 @@ let rec class_field self_loc cl_num self_type meths vars
(val_env, met_env, par_env, fields, concr_meths, warn_vals, inher)
cf =
let loc = cf.pcf_loc in
- let mkcf desc loc = { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes } in
+ let mkcf desc = { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes } in
match cf.pcf_desc with
Pcf_inher (ovf, sparent, super) ->
let parent = class_expr cl_num val_env par_env sparent in
@@ -541,7 +540,7 @@ let rec class_field self_loc cl_num self_type meths vars
(val_env, met_env, par_env)
in
(val_env, met_env, par_env,
- lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)) loc)
+ lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)))
:: fields,
concr_meths, warn_vals, inher)
@@ -559,7 +558,7 @@ let rec class_field self_loc cl_num self_type meths vars
in
(val_env, met_env', par_env,
lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty,
- met_env' == met_env)) loc)
+ met_env' == met_env)))
:: fields,
concr_meths, warn_vals, inher)
@@ -588,14 +587,14 @@ let rec class_field self_loc cl_num self_type meths vars
in
(val_env, met_env', par_env,
lazy (mkcf (Tcf_val (lab.txt, lab, mut, id,
- Tcfk_concrete exp, met_env' == met_env)) loc)
+ Tcfk_concrete exp, met_env' == met_env)))
:: fields,
concr_meths, Concr.add lab.txt warn_vals, inher)
| Pcf_virt (lab, priv, sty) ->
let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
(val_env, met_env, par_env,
- lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)) loc)
+ lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)))
::fields,
concr_meths, warn_vals, inher)
@@ -650,7 +649,7 @@ let rec class_field self_loc cl_num self_type meths vars
mkcf (Tcf_meth (lab.txt, lab, priv, Tcfk_concrete texp,
match ovf with
Override -> true
- | Fresh -> false)) loc
+ | Fresh -> false))
end in
(val_env, met_env, par_env, field::fields,
Concr.add lab.txt concr_meths, warn_vals, inher)
@@ -658,7 +657,7 @@ let rec class_field self_loc cl_num self_type meths vars
| Pcf_constr (sty, sty') ->
let (cty, cty') = type_constraint val_env sty sty' loc in
(val_env, met_env, par_env,
- lazy (mkcf (Tcf_constr (cty, cty')) loc) :: fields,
+ lazy (mkcf (Tcf_constr (cty, cty'))) :: fields,
concr_meths, warn_vals, inher)
| Pcf_init expr ->
@@ -674,7 +673,7 @@ let rec class_field self_loc cl_num self_type meths vars
vars := vars_local;
let texp = type_expect met_env expr meth_type in
Ctype.end_def ();
- mkcf (Tcf_init texp) loc
+ mkcf (Tcf_init texp)
end in
(val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher)
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 3ee04f59b..33af5ef20 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -397,8 +397,9 @@ and class_signature = {
}
and class_type_field = {
- ctf_desc : class_type_field_desc;
- ctf_loc : Location.t;
+ ctf_desc: class_type_field_desc;
+ ctf_loc: Location.t;
+ ctf_attributes: attribute list;
}
and class_type_field_desc =
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 55cec1c6b..41eb1474a 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -397,8 +397,9 @@ and class_signature = {
}
and class_type_field = {
- ctf_desc : class_type_field_desc;
- ctf_loc : Location.t;
+ ctf_desc: class_type_field_desc;
+ ctf_loc: Location.t;
+ ctf_attributes: attribute list;
}
and class_type_field_desc =
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-24 06:34:15 +0000