Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Attributes and extension points in class_expr. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13500 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-04-10 17:26:55 +00:00
parent cb38ccc346
commit ee5f754a42
20 changed files with 109 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bytecomp/translcore.ml
View File

@ -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

2
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -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 = []};

2
camlp4/boot/Camlp4.ml
View File

@ -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 = [] }

4
experimental/frisch/extension_points.txt
View File

@ -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]

21
parsing/ast_helper.ml
View File

@ -162,14 +162,21 @@ module Str = struct
end
module Cl = struct
let mk ?(loc = Location.none) d = {pcl_desc = d; pcl_loc = loc}
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 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 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

16
parsing/ast_helper.mli
View File

@ -160,14 +160,16 @@ module Str:
end
module Cl:
sig
val mk: ?loc:Location.t -> class_expr_desc -> 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 -> 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 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

37
parsing/ast_mapper.ml
View File

@ -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} =
{

2
parsing/parser.mly
View File

@ -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

8
parsing/parsetree.mli
View File

@ -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;

3
parsing/pprintast.ml
View File

@ -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

4
parsing/printast.ml
View File

@ -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";

1
tools/depend.ml
View File

@ -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

1
tools/ocamlprof.ml
View File

@ -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

1
tools/untypeast.ml
View File

@ -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 =

1
typing/printtyped.ml
View File

@ -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) ->

35
typing/typeclass.ml
View File

@ -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)

1
typing/typeclass.mli
View File

@ -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

1
typing/typecore.ml
View File

@ -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

11
typing/typedtree.ml
View File

@ -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

11
typing/typedtree.mli
View File

@ -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