summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/translcore.ml4
-rw-r--r--camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml2
-rw-r--r--camlp4/boot/Camlp4.ml2
-rw-r--r--experimental/frisch/extension_points.txt4
-rw-r--r--parsing/ast_helper.ml23
-rw-r--r--parsing/ast_helper.mli18
-rw-r--r--parsing/ast_mapper.ml37
-rw-r--r--parsing/parser.mly2
-rw-r--r--parsing/parsetree.mli8
-rw-r--r--parsing/pprintast.ml3
-rw-r--r--parsing/printast.ml4
-rw-r--r--tools/depend.ml1
-rw-r--r--tools/ocamlprof.ml1
-rw-r--r--tools/untypeast.ml1
-rw-r--r--typing/printtyped.ml1
-rw-r--r--typing/typeclass.ml35
-rw-r--r--typing/typeclass.mli1
-rw-r--r--typing/typecore.ml1
-rw-r--r--typing/typedtree.ml11
-rw-r--r--typing/typedtree.mli11
20 files changed, 111 insertions, 59 deletions
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 3f541f4a8..d621221f5 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -869,7 +869,9 @@ and transl_exp0 e =
{ cl_desc = Tcl_structure cs;
cl_loc = e.exp_loc;
cl_type = Cty_signature cty;
- cl_env = e.exp_env }
+ cl_env = e.exp_env;
+ cl_attributes = [];
+ }
and transl_list expr_list =
List.map transl_exp expr_list
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index 12cd57698..459002293 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -68,7 +68,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc; pmod_attributes = []};
value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};
value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};
- value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};
+ value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []};
value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = []};
value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = []};
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 4ae04dac8..2ce1832ce 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -14187,7 +14187,7 @@ module Struct =
let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; }
- let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; }
+ let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []}
let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = [] }
diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt
index 41b5a4cd5..33d904f8e 100644
--- a/experimental/frisch/extension_points.txt
+++ b/experimental/frisch/extension_points.txt
@@ -13,7 +13,7 @@ a dots (whitespaces are allowed around the dots). In the Parsetree,
the identifier is represented as a single string (without spaces).
Attributes on expressions, type expressions, module expressions, module type expressions,
-patterns (TODO: class expressions, class type expressions):
+patterns, class expressions (TODO: class type expressions):
... [@id expr]
@@ -84,7 +84,7 @@ expression (written expr below).
Two syntaxes exist for extension node:
As expressions, type expressions, module expressions, module type expressions,
-patterns (TODO: class expressions, class type expressions):
+patterns, class expressions (TODO: class type expressions):
[%id expr]
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index d87353e13..e5720bbf3 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -162,14 +162,21 @@ module Str = struct
end
module Cl = struct
- let mk ?(loc = Location.none) d = {pcl_desc = d; pcl_loc = loc}
-
- let constr ?loc a b = mk ?loc (Pcl_constr (a, b))
- let structure ?loc a = mk ?loc (Pcl_structure a)
- let fun_ ?loc a b c d = mk ?loc (Pcl_fun (a, b, c, d))
- let apply ?loc a b = mk ?loc (Pcl_apply (a, b))
- let let_ ?loc a b c = mk ?loc (Pcl_let (a, b, c))
- let constraint_ ?loc a b = mk ?loc (Pcl_constraint (a, b))
+ let mk ?(loc = Location.none) ?(attrs = []) d =
+ {
+ pcl_desc = d;
+ pcl_loc = loc;
+ pcl_attributes = attrs;
+ }
+ let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]}
+
+ let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
+ let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
+ let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+ let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
+ let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
+ let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
+ let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
end
module Cty = struct
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 4e134982b..5dc4714f3 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -160,14 +160,16 @@ module Str:
end
module Cl:
sig
- val mk: ?loc:Location.t -> class_expr_desc -> class_expr
-
- val constr: ?loc:Location.t -> Longident.t loc -> core_type list -> class_expr
- val structure: ?loc:Location.t -> class_structure -> class_expr
- val fun_: ?loc:Location.t -> label -> expression option -> pattern -> class_expr -> class_expr
- val apply: ?loc:Location.t -> class_expr -> (label * expression) list -> class_expr
- val let_: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> class_expr -> class_expr
- val constraint_: ?loc:Location.t -> class_expr -> class_type -> class_expr
+ val mk: ?loc:Location.t -> ?attrs:attribute list -> class_expr_desc -> class_expr
+ val attr: class_expr -> attribute -> class_expr
+
+ val constr: ?loc:Location.t -> ?attrs:attribute list -> Longident.t loc -> core_type list -> class_expr
+ val structure: ?loc:Location.t -> ?attrs:attribute list -> class_structure -> class_expr
+ val fun_: ?loc:Location.t -> ?attrs:attribute list -> label -> expression option -> pattern -> class_expr -> class_expr
+ val apply: ?loc:Location.t -> ?attrs:attribute list -> class_expr -> (label * expression) list -> class_expr
+ val let_: ?loc:Location.t -> ?attrs:attribute list -> rec_flag -> (pattern * expression) list -> class_expr -> class_expr
+ val constraint_: ?loc:Location.t -> ?attrs:attribute list -> class_expr -> class_type -> class_expr
+ val extension: ?loc:Location.t -> ?attrs:attribute list -> extension -> class_expr
end
module Cty:
sig
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 5656fec9a..36773b802 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -87,14 +87,14 @@ module CT = struct
(sub # typ t)
(sub # class_type ct)
- let map_field sub {pctf_desc = desc; pctf_loc = loc} =
+ let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} =
let open Ctf in
let loc = sub # location loc in
match desc with
- | Pctf_inherit ct -> inherit_ ~loc (sub # class_type ct)
- | Pctf_val (s, m, v, t) -> val_ ~loc s m v (sub # typ t)
- | Pctf_method (s, p, v, t) -> method_ ~loc s p v (sub # typ t)
- | Pctf_constraint (t1, t2) -> constraint_ ~loc (sub # typ t1) (sub # typ t2)
+ | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct)
+ | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t)
+ | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t)
+ | Pctf_constraint (t1, t2) -> constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2)
let map_signature sub {pcsig_self; pcsig_fields; pcsig_loc} =
Csig.mk
@@ -257,40 +257,41 @@ end
module CE = struct
(* Value expressions for the class language *)
- let map sub {pcl_loc = loc; pcl_desc = desc} =
+ let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
let open Cl in
let loc = sub # location loc in
match desc with
- | Pcl_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
+ | Pcl_constr (lid, tys) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys)
| Pcl_structure s ->
- structure ~loc (sub # class_structure s)
+ structure ~loc ~attrs (sub # class_structure s)
| Pcl_fun (lab, e, p, ce) ->
- fun_ ~loc lab
+ fun_ ~loc ~attrs lab
(map_opt (sub # expr) e)
(sub # pat p)
(sub # class_expr ce)
| Pcl_apply (ce, l) ->
- apply ~loc (sub # class_expr ce) (List.map (map_snd (sub # expr)) l)
+ apply ~loc ~attrs (sub # class_expr ce) (List.map (map_snd (sub # expr)) l)
| Pcl_let (r, pel, ce) ->
- let_ ~loc r
+ let_ ~loc ~attrs r
(List.map (map_tuple (sub # pat) (sub # expr)) pel)
(sub # class_expr ce)
| Pcl_constraint (ce, ct) ->
- constraint_ ~loc (sub # class_expr ce) (sub # class_type ct)
+ constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct)
+ | Pcl_extension x -> extension ~loc ~attrs (sub # extension x)
let map_kind sub = function
| Cfk_concrete (o, e) -> Cfk_concrete (o, sub # expr e)
| Cfk_virtual t -> Cfk_virtual (sub # typ t)
- let map_field sub {pcf_desc = desc; pcf_loc = loc} =
+ let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
let open Cf in
let loc = sub # location loc in
match desc with
- | Pcf_inherit (o, ce, s) -> inherit_ ~loc o (sub # class_expr ce) s
- | Pcf_val (s, m, k) -> val_ ~loc (map_loc sub s) m (map_kind sub k)
- | Pcf_method (s, p, k) -> method_ ~loc (map_loc sub s) p (map_kind sub k)
- | Pcf_constraint (t1, t2) -> constraint_ ~loc (sub # typ t1) (sub # typ t2)
- | Pcf_initializer e -> initializer_ ~loc (sub # expr e)
+ | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub # class_expr ce) s
+ | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
+ | Pcf_method (s, p, k) -> method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
+ | Pcf_constraint (t1, t2) -> constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2)
+ | Pcf_initializer e -> initializer_ ~loc ~attrs (sub # expr e)
let map_structure sub {pcstr_self; pcstr_fields} =
{
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 7b56d7f2f..ff62117e8 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -771,6 +771,8 @@ class_expr:
{ mkclass(Pcl_apply($1, List.rev $2)) }
| LET rec_flag let_bindings IN class_expr
{ mkclass(Pcl_let ($2, List.rev $3, $5)) }
+ | class_expr attribute
+ { Cl.attr $1 $2 }
;
class_simple_expr:
LBRACKET core_type_comma_list RBRACKET class_longident
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 7f6e2c1bb..2abc78dcd 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -209,8 +209,11 @@ and class_type_declaration = class_type class_infos
(* Value expressions for the class language *)
and class_expr =
- { pcl_desc: class_expr_desc;
- pcl_loc: Location.t }
+ {
+ pcl_desc: class_expr_desc;
+ pcl_loc: Location.t;
+ pcl_attributes: attribute list;
+ }
and class_expr_desc =
Pcl_constr of Longident.t loc * core_type list
@@ -219,6 +222,7 @@ and class_expr_desc =
| Pcl_apply of class_expr * (label * expression) list
| Pcl_let of rec_flag * (pattern * expression) list * class_expr
| Pcl_constraint of class_expr * class_type
+ | Pcl_extension of extension
and class_structure = {
pcstr_self: pattern;
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index aa812542e..b7c2e5cbd 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -818,8 +818,7 @@ class printer ()= object(self:'self)
pp f "(%a@ :@ %a)"
self#class_expr ce
self#class_type ct
-
-
+ | Pcl_extension _ -> assert false
method module_type f x =
match x.pmty_desc with
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 731fa48d9..87d9ee23d 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -463,6 +463,7 @@ and class_type_declaration i ppf x =
and class_expr i ppf x =
line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
+ attributes i ppf x.pcl_attributes;
let i = i+1 in
match x.pcl_desc with
| Pcl_constr (li, l) ->
@@ -489,6 +490,9 @@ and class_expr i ppf x =
line i ppf "Pcl_constraint\n";
class_expr i ppf ce;
class_type i ppf ct;
+ | Pcl_extension (s, arg) ->
+ line i ppf "Pcl_extension \"%s\"\n" s;
+ expression i ppf arg
and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
line i ppf "class_structure\n";
diff --git a/tools/depend.ml b/tools/depend.ml
index 4c5e020c3..aa2c51839 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -318,6 +318,7 @@ and add_class_expr bv ce =
let bv = add_bindings rf bv pel in add_class_expr bv ce
| Pcl_constraint(ce, ct) ->
add_class_expr bv ce; add_class_type bv ct
+ | Pcl_extension _ -> ()
and add_class_field bv pcf =
match pcf.pcf_desc with
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index d2f169a34..19b9dca38 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -347,6 +347,7 @@ and rewrite_class_expr iflag cexpr =
rewrite_class_expr iflag cexpr
| Pcl_constraint (cexpr, _) ->
rewrite_class_expr iflag cexpr
+ | Pcl_extension _ -> ()
and rewrite_class_declaration iflag cl =
rewrite_class_expr iflag cl.pci_expr
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index d6a08c04d..4e92f8de2 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -444,6 +444,7 @@ and untype_class_expr cexpr =
in
{ pcl_desc = desc;
pcl_loc = cexpr.cl_loc;
+ pcl_attributes = cexpr.cl_attributes;
}
and untype_class_type ct =
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index ec96b8050..c5905bb8f 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -477,6 +477,7 @@ and class_type_declaration i ppf x =
and class_expr i ppf x =
line i ppf "class_expr %a\n" fmt_location x.cl_loc;
+ attributes i ppf x.cl_attributes;
let i = i+1 in
match x.cl_desc with
| Tcl_ident (li, _, l) ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 28eae0bd6..ceba5435c 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -45,6 +45,7 @@ type error =
| Final_self_clash of (type_expr * type_expr) list
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
+ | Extension of string
exception Error of Location.t * Env.t * error
@@ -817,20 +818,26 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_ident (path, lid, tyl);
cl_loc = scl.pcl_loc;
cl_type = clty';
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
in
let (vals, meths, concrs) = extract_constraints clty in
rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
cl_loc = scl.pcl_loc;
cl_type = clty';
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_structure cl_str ->
let (desc, ty) =
class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
rc {cl_desc = Tcl_structure desc;
cl_loc = scl.pcl_loc;
cl_type = Cty_signature ty;
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_fun (l, Some default, spat, sbody) ->
let loc = default.pexp_loc in
let open Ast_helper in
@@ -909,7 +916,9 @@ and class_expr cl_num val_env met_env scl =
cl_loc = scl.pcl_loc;
cl_type = Cty_fun
(l, Ctype.instance_def pat.pat_type, cl.cl_type);
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_apply (scl', sargs) ->
let cl = class_expr cl_num val_env met_env scl' in
let rec nonopt_labels ls ty_fun =
@@ -1002,7 +1011,9 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_apply (cl, args);
cl_loc = scl.pcl_loc;
cl_type = cty;
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_let (rec_flag, sdefs, scl') ->
let (defs, val_env) =
try
@@ -1045,7 +1056,9 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
cl_loc = scl.pcl_loc;
cl_type = cl.cl_type;
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
| Pcl_constraint (scl', scty) ->
Ctype.begin_class_def ();
let context = Typetexp.narrow () in
@@ -1071,7 +1084,11 @@ and class_expr cl_num val_env met_env scl =
rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
cl_loc = scl.pcl_loc;
cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
- cl_env = val_env}
+ cl_env = val_env;
+ cl_attributes = scl.pcl_attributes;
+ }
+ | Pcl_extension (s, _arg) ->
+ raise (Error (scl.pcl_loc, val_env, Extension s))
(*******************************)
@@ -1727,6 +1744,8 @@ let report_error env ppf = function
"instance variable"
| No_overriding (kind, name) ->
fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
-
+ | Extension s ->
+ fprintf ppf "Uninterpreted extension '%s'." s
+
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index c8f28013d..81e56bd1b 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -103,6 +103,7 @@ type error =
| Final_self_clash of (type_expr * type_expr) list
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
+ | Extension of string
exception Error of Location.t * Env.t * error
diff --git a/typing/typecore.ml b/typing/typecore.ml
index d09d86e7a..18433d26c 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -192,6 +192,7 @@ let iter_expression f e =
| Pcl_let (_, pel, ce) ->
List.iter (fun (_, e) -> expr e) pel; class_expr ce
| Pcl_constraint (ce, _) -> class_expr ce
+ | Pcl_extension _ -> ()
and class_field cf =
match cf.pcf_desc with
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 5ab71c62f..912f60845 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -114,10 +114,13 @@ and meth =
(* Value expressions for the class language *)
and class_expr =
- { cl_desc: class_expr_desc;
- cl_loc: Location.t;
- cl_type: Types.class_type;
- cl_env: Env.t }
+ {
+ cl_desc: class_expr_desc;
+ cl_loc: Location.t;
+ cl_type: Types.class_type;
+ cl_env: Env.t;
+ cl_attributes: attribute list;
+ }
and class_expr_desc =
Tcl_ident of Path.t * Longident.t loc * core_type list
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 5b79ddbeb..b42967884 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -113,10 +113,13 @@ and meth =
(* Value expressions for the class language *)
and class_expr =
- { cl_desc: class_expr_desc;
- cl_loc: Location.t;
- cl_type: Types.class_type;
- cl_env: Env.t }
+ {
+ cl_desc: class_expr_desc;
+ cl_loc: Location.t;
+ cl_type: Types.class_type;
+ cl_env: Env.t;
+ cl_attributes: attribute list;
+ }
and class_expr_desc =
Tcl_ident of Path.t * Longident.t loc * core_type list
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-19 23:09:44 +0000