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.txt4
-rw-r--r--ocamldoc/odoc_sig.ml1
-rw-r--r--otherlibs/labltk/browser/searchpos.ml1
-rw-r--r--parsing/ast_helper.ml15
-rw-r--r--parsing/ast_helper.mli10
-rw-r--r--parsing/ast_mapper.ml9
-rw-r--r--parsing/parser.mly6
-rw-r--r--parsing/parsetree.mli8
-rw-r--r--parsing/pprintast.ml1
-rw-r--r--parsing/printast.ml4
-rw-r--r--tools/depend.ml1
-rw-r--r--tools/untypeast.ml4
-rw-r--r--typing/printtyped.ml1
-rw-r--r--typing/typeclass.ml23
-rw-r--r--typing/typedtree.ml11
-rw-r--r--typing/typedtree.mli11
18 files changed, 79 insertions, 35 deletions
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index 459002293..e8231caff 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -67,7 +67,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
value mksig loc d = {psig_desc = d; psig_loc = mkloc loc};
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 mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []};
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 2ce1832ce..dadd2d133 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -14185,7 +14185,7 @@ module Struct =
let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; }
- let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; }
+ let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []}
let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []}
diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt
index 33d904f8e..da24f7452 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, class expressions (TODO: class type expressions):
+patterns, class expressions, 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, class expressions (TODO: class type expressions):
+patterns, class expressions, class type expressions:
[%id expr]
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 18a5bf5c6..4d361ad2b 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -456,6 +456,7 @@ module Analyser =
ic_class = None ;
ic_text = text_opt ;
}
+ | Parsetree.Pcty_extension _ -> assert false
in
let (inher_l, eles) = f (pos_end + maybe_more) q in
(inh :: inher_l , eles_comments @ eles)
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 8d252edbd..7dda53ba0 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -153,6 +153,7 @@ let rec search_pos_class_type cl ~pos ~env =
| Pcty_fun (_, ty, cty) ->
search_pos_type ty ~pos ~env;
search_pos_class_type cty ~pos ~env
+ | Pcty_extension _ -> ()
end
let search_pos_type_decl td ~pos ~env =
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index e5720bbf3..853c647f0 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -180,11 +180,18 @@ module Cl = struct
end
module Cty = struct
- let mk ?(loc = Location.none) d = {pcty_desc = d; pcty_loc = loc}
+ let mk ?(loc = Location.none) ?(attrs = []) d =
+ {
+ pcty_desc = d;
+ pcty_loc = loc;
+ pcty_attributes = attrs;
+ }
+ let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}
- let constr ?loc a b = mk ?loc (Pcty_constr (a, b))
- let signature ?loc a = mk ?loc (Pcty_signature a)
- let fun_ ?loc a b c = mk ?loc (Pcty_fun (a, b, c))
+ let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
+ let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
+ let fun_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_fun (a, b, c))
+ let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
end
module Ctf = struct
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 5dc4714f3..13fa0a720 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -173,11 +173,13 @@ module Cl:
end
module Cty:
sig
- val mk: ?loc:Location.t -> class_type_desc -> class_type
+ val mk: ?loc:Location.t -> ?attrs:attribute list -> class_type_desc -> class_type
+ val attr: class_type -> attribute -> class_type
- val constr: ?loc:Location.t -> Longident.t loc -> core_type list -> class_type
- val signature: ?loc:Location.t -> class_signature -> class_type
- val fun_: ?loc:Location.t -> label -> core_type -> class_type -> class_type
+ val constr: ?loc:Location.t -> ?attrs:attribute list -> Longident.t loc -> core_type list -> class_type
+ val signature: ?loc:Location.t -> ?attrs:attribute list -> class_signature -> class_type
+ val fun_: ?loc:Location.t -> ?attrs:attribute list -> label -> core_type -> class_type -> class_type
+ val extension: ?loc:Location.t -> ?attrs:attribute list -> extension -> class_type
end
module Ctf:
sig
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 36773b802..b83d29547 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -76,16 +76,17 @@ end
module CT = struct
(* Type expressions for the class language *)
- let map sub {pcty_loc = loc; pcty_desc = desc} =
+ let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
let open Cty in
let loc = sub # location loc in
match desc with
- | Pcty_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
- | Pcty_signature x -> signature ~loc (sub # class_signature x)
+ | Pcty_constr (lid, tys) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys)
+ | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x)
| Pcty_fun (lab, t, ct) ->
- fun_ ~loc lab
+ fun_ ~loc ~attrs lab
(sub # typ t)
(sub # class_type ct)
+ | Pcty_extension x -> extension ~loc ~attrs (sub # extension x)
let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} =
let open Ctf in
diff --git a/parsing/parser.mly b/parsing/parser.mly
index ff62117e8..526ca84f1 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -773,6 +773,8 @@ class_expr:
{ mkclass(Pcl_let ($2, List.rev $3, $5)) }
| class_expr attribute
{ Cl.attr $1 $2 }
+ | extension
+ { mkclass(Pcl_extension $1) }
;
class_simple_expr:
LBRACKET core_type_comma_list RBRACKET class_longident
@@ -877,6 +879,10 @@ class_type:
{ mkcty(Pcty_fun($1, $3, $5)) }
| simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_fun("", $1, $3)) }
+ | class_type attribute
+ { Cty.attr $1 $2 }
+ | extension
+ { mkcty(Pcty_extension $1) }
;
class_signature:
LBRACKET core_type_comma_list RBRACKET clty_longident
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 2abc78dcd..68ce63300 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -176,13 +176,17 @@ and constructor_declaration =
(* Type expressions for the class language *)
and class_type =
- { pcty_desc: class_type_desc;
- pcty_loc: Location.t }
+ {
+ pcty_desc: class_type_desc;
+ pcty_loc: Location.t;
+ pcty_attributes: attribute list;
+ }
and class_type_desc =
Pcty_constr of Longident.t loc * core_type list
| Pcty_signature of class_signature
| Pcty_fun of label * core_type * class_type
+ | Pcty_extension of extension
and class_signature = {
pcsig_self: core_type;
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index b7c2e5cbd..25e3bd6a0 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -738,6 +738,7 @@ class printer ()= object(self:'self)
| Pcty_fun (l, co, cl) ->
pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
self#type_with_label (l,co) self#class_type cl
+ | Pcty_extension _ -> assert false
(* [class type a = object end] *)
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 87d9ee23d..8f9b52672 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -402,6 +402,7 @@ and type_kind i ppf x =
and class_type i ppf x =
line i ppf "class_type %a\n" fmt_location x.pcty_loc;
+ attributes i ppf x.pcty_attributes;
let i = i+1 in
match x.pcty_desc with
| Pcty_constr (li, l) ->
@@ -414,6 +415,9 @@ and class_type i ppf x =
line i ppf "Pcty_fun \"%s\"\n" l;
core_type i ppf co;
class_type i ppf cl;
+ | Pcty_extension (s, arg) ->
+ line i ppf "Pcty_extension \"%s\"\n" s;
+ expression i ppf arg
and class_signature i ppf cs =
line i ppf "class_signature %a\n" fmt_location cs.pcsig_loc;
diff --git a/tools/depend.ml b/tools/depend.ml
index aa2c51839..bec72ecec 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -88,6 +88,7 @@ let rec add_class_type bv cty =
List.iter (add_class_type_field bv) fieldl
| Pcty_fun(_, ty1, cty2) ->
add_type bv ty1; add_class_type bv cty2
+ | Pcty_extension _ -> ()
and add_class_type_field bv pctf =
match pctf.pctf_desc with
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 4e92f8de2..e327af0f6 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -456,7 +456,9 @@ and untype_class_type ct =
Pcty_fun (label, untype_core_type ct, untype_class_type cl)
in
{ pcty_desc = desc;
- pcty_loc = ct.cltyp_loc }
+ pcty_loc = ct.cltyp_loc;
+ pcty_attributes = ct.cltyp_attributes;
+ }
and untype_class_signature cs =
{
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index c5905bb8f..eff21f9d7 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -416,6 +416,7 @@ and type_kind i ppf x =
and class_type i ppf x =
line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+ attributes i ppf x.cltyp_attributes;
let i = i+1 in
match x.cltyp_desc with
| Tcty_constr (li, _, l) ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index ceba5435c..c629d2f1a 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -53,9 +53,6 @@ open Typedtree
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 }
-
(**********************)
(* Useful constants *)
@@ -442,7 +439,15 @@ and class_signature env sty sign loc =
}
and class_type env scty =
- let loc = scty.pcty_loc in
+ let cltyp desc typ =
+ {
+ cltyp_desc = desc;
+ cltyp_type = typ;
+ cltyp_loc = scty.pcty_loc;
+ cltyp_env = env;
+ cltyp_attributes = scty.pcty_attributes;
+ }
+ in
match scty.pcty_desc with
Pcty_constr (lid, styl) ->
let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
@@ -467,20 +472,22 @@ and class_type env scty =
) styl params
in
let typ = Cty_constr (path, params, clty) in
- cltyp (Tcty_constr ( path, lid , ctys)) typ env loc
+ cltyp (Tcty_constr ( path, lid , ctys)) typ
| Pcty_signature pcsig ->
let clsig = class_signature env
pcsig.pcsig_self pcsig.pcsig_fields pcsig.pcsig_loc in
let typ = Cty_signature clsig.csig_type in
- cltyp (Tcty_signature clsig) typ env loc
+ cltyp (Tcty_signature clsig) typ
| Pcty_fun (l, sty, scty) ->
let cty = transl_simple_type env false sty in
let ty = cty.ctyp_type in
let clty = class_type env scty in
let typ = Cty_fun (l, ty, clty.cltyp_type) in
- cltyp (Tcty_fun (l, cty, clty)) typ env loc
+ cltyp (Tcty_fun (l, cty, clty)) typ
+ | Pcty_extension (s, _arg) ->
+ raise (Error (scty.pcty_loc, env, Extension s))
let class_type env scty =
delayed_meth_specs := [];
@@ -827,7 +834,7 @@ and class_expr cl_num val_env met_env scl =
cl_loc = scl.pcl_loc;
cl_type = clty';
cl_env = val_env;
- cl_attributes = scl.pcl_attributes;
+ cl_attributes = []; (* attributes are kept on the inner cl node *)
}
| Pcl_structure cl_str ->
let (desc, ty) =
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 912f60845..8829fabee 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -380,10 +380,13 @@ and constructor_declaration =
}
and class_type =
- { cltyp_desc: class_type_desc;
- cltyp_type : Types.class_type;
- cltyp_env : Env.t; (* BINANNOT ADDED *)
- cltyp_loc: Location.t }
+ {
+ cltyp_desc: class_type_desc;
+ cltyp_type: Types.class_type;
+ cltyp_env: Env.t;
+ cltyp_loc: Location.t;
+ cltyp_attributes: attribute list;
+ }
and class_type_desc =
Tcty_constr of Path.t * Longident.t loc * core_type list
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index b42967884..9b84a6f8d 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -380,10 +380,13 @@ and constructor_declaration =
}
and class_type =
- { cltyp_desc: class_type_desc;
- cltyp_type : Types.class_type;
- cltyp_env : Env.t; (* BINANNOT ADDED *)
- cltyp_loc: Location.t }
+ {
+ cltyp_desc: class_type_desc;
+ cltyp_type: Types.class_type;
+ cltyp_env: Env.t;
+ cltyp_loc: Location.t;
+ cltyp_attributes: attribute list;
+ }
and class_type_desc =
Tcty_constr of Path.t * Longident.t loc * core_type list
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-16 19:04:17 +0000