summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/translclass.ml26
-rw-r--r--camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml22
-rw-r--r--camlp4/boot/Camlp4.ml28
-rw-r--r--experimental/frisch/extension_points.txt25
-rw-r--r--experimental/frisch/genlifter.ml6
-rw-r--r--ocamldoc/odoc_ast.ml23
-rw-r--r--ocamldoc/odoc_sig.ml30
-rw-r--r--otherlibs/labltk/browser/searchpos.ml23
-rw-r--r--parsing/ast_helper.ml22
-rw-r--r--parsing/ast_helper.mli22
-rw-r--r--parsing/ast_mapper.ml22
-rw-r--r--parsing/parser.mly94
-rw-r--r--parsing/parsetree.mli23
-rw-r--r--parsing/pprintast.ml27
-rw-r--r--parsing/printast.ml55
-rw-r--r--tools/depend.ml21
-rw-r--r--tools/ocamlprof.ml15
-rw-r--r--tools/tast_iter.ml22
-rw-r--r--tools/untypeast.ml46
-rw-r--r--typing/printtyped.ml30
-rw-r--r--typing/typeclass.ml66
-rw-r--r--typing/typecore.ml22
-rw-r--r--typing/typedtree.ml25
-rw-r--r--typing/typedtree.mli25
-rw-r--r--typing/typedtreeIter.ml28
-rw-r--r--typing/typedtreeMap.ml42
26 files changed, 380 insertions, 410 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index ec40912c8..4746d96e3 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -126,18 +126,18 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
List.fold_right
(fun field (inh_init, obj_init, has_init) ->
match field.cf_desc with
- Tcf_inher (_, cl, _, _, _) ->
+ Tcf_inherit (_, cl, _, _, _) ->
let (inh_init, obj_init') =
build_object_init cl_table (Lvar obj) [] inh_init
(fun _ -> lambda_unit) cl
in
(inh_init, lsequence obj_init' obj_init, true)
- | Tcf_val (_, _, _, id, Tcfk_concrete exp, _) ->
+ | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
(inh_init, lsequence (set_inst_var obj id exp) obj_init,
has_init)
- | Tcf_meth _ | Tcf_val _ | Tcf_constr _ ->
+ | Tcf_method _ | Tcf_val _ | Tcf_constraint _ ->
(inh_init, obj_init, has_init)
- | Tcf_init _ ->
+ | Tcf_initializer _ ->
(inh_init, obj_init, true)
)
str.cstr_fields
@@ -262,33 +262,33 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
List.fold_right
(fun field (inh_init, cl_init, methods, values) ->
match field.cf_desc with
- Tcf_inher (_, cl, _, vals, meths) ->
+ Tcf_inherit (_, cl, _, vals, meths) ->
let cl_init = output_methods cla methods cl_init in
let inh_init, cl_init =
build_class_init cla false
(vals, meths_super cla str.cstr_meths meths)
inh_init cl_init msubst top cl in
(inh_init, cl_init, [], values)
- | Tcf_val (name, _, _, id, exp, over) ->
- let values = if over then values else (name, id) :: values in
+ | Tcf_val (name, _, id, _, over) ->
+ let values = if over then values else (name.txt, id) :: values in
(inh_init, cl_init, methods, values)
- | Tcf_meth (_, _, _, Tcfk_virtual _, _)
- | Tcf_constr _
+ | Tcf_method (_, _, Tcfk_virtual _)
+ | Tcf_constraint _
->
(inh_init, cl_init, methods, values)
- | Tcf_meth (name, _, _, Tcfk_concrete exp, over) ->
+ | Tcf_method (name, _, Tcfk_concrete (_, exp)) ->
let met_code = msubst true (transl_exp exp) in
let met_code =
if !Clflags.native_code && List.length met_code = 1 then
(* Force correct naming of method for profiles *)
- let met = Ident.create ("method_" ^ name) in
+ let met = Ident.create ("method_" ^ name.txt) in
[Llet(Strict, met, List.hd met_code, Lvar met)]
else met_code
in
(inh_init, cl_init,
- Lvar (Meths.find name str.cstr_meths) :: met_code @ methods,
+ Lvar (Meths.find name.txt str.cstr_meths) :: met_code @ methods,
values)
- | Tcf_init exp ->
+ | Tcf_initializer exp ->
(inh_init,
Lsequence(mkappl (oo_prim "add_initializer",
Lvar cla :: msubst false (transl_exp exp)),
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index ce6d5df7d..12cd57698 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -1152,16 +1152,16 @@ value varify_constructors var_names =
and class_sig_item c l =
match c with
[ <:class_sig_item<>> -> l
- | CgCtr loc t1 t2 -> [mkctf loc (Pctf_cstr (ctyp t1, ctyp t2)) :: l]
+ | CgCtr loc t1 t2 -> [mkctf loc (Pctf_constraint (ctyp t1, ctyp t2)) :: l]
| <:class_sig_item< $csg1$; $csg2$ >> ->
class_sig_item csg1 (class_sig_item csg2 l)
- | CgInh loc ct -> [mkctf loc (Pctf_inher (class_type ct)) :: l]
+ | CgInh loc ct -> [mkctf loc (Pctf_inherit (class_type ct)) :: l]
| CgMth loc s pf t ->
- [mkctf loc (Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t))) :: l]
+ [mkctf loc (Pctf_method (s, mkprivate pf, Concrete, mkpolytype (ctyp t))) :: l]
| CgVal loc s b v t ->
[mkctf loc (Pctf_val (s, mkmutable b, mkvirtual v, ctyp t)) :: l]
| CgVir loc s b t ->
- [mkctf loc (Pctf_virt (s, mkprivate b, mkpolytype (ctyp t))) :: l]
+ [mkctf loc (Pctf_method (s, mkprivate b, Virtual, mkpolytype (ctyp t))) :: l]
| CgAnt _ _ -> assert False ]
and class_expr =
fun
@@ -1204,26 +1204,26 @@ value varify_constructors var_names =
and class_str_item c l =
match c with
[ CrNil _ -> l
- | CrCtr loc t1 t2 -> [mkcf loc (Pcf_constr (ctyp t1, ctyp t2)) :: l]
+ | CrCtr loc t1 t2 -> [mkcf loc (Pcf_constraint (ctyp t1, ctyp t2)) :: l]
| <:class_str_item< $cst1$; $cst2$ >> ->
class_str_item cst1 (class_str_item cst2 l)
| CrInh loc ov ce pb ->
let opb = if pb = "" then None else Some pb in
- [mkcf loc (Pcf_inher (override_flag loc ov) (class_expr ce) opb) :: l]
- | CrIni loc e -> [mkcf loc (Pcf_init (expr e)) :: l]
+ [mkcf loc (Pcf_inherit (override_flag loc ov) (class_expr ce) opb) :: l]
+ | CrIni loc e -> [mkcf loc (Pcf_initializer (expr e)) :: l]
| CrMth loc s ov pf e t ->
let t =
match t with
[ <:ctyp<>> -> None
| t -> Some (mkpolytype (ctyp t)) ] in
let e = mkexp loc (Pexp_poly (expr e) t) in
- [mkcf loc (Pcf_meth (with_loc s loc, mkprivate pf, override_flag loc ov, e)) :: l]
+ [mkcf loc (Pcf_method (with_loc s loc, mkprivate pf, Cfk_concrete (override_flag loc ov, e))) :: l]
| CrVal loc s ov mf e ->
- [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, override_flag loc ov, expr e)) :: l]
+ [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, Cfk_concrete (override_flag loc ov, expr e))) :: l]
| CrVir loc s pf t ->
- [mkcf loc (Pcf_virt (with_loc s loc, mkprivate pf, mkpolytype (ctyp t))) :: l]
+ [mkcf loc (Pcf_method (with_loc s loc, mkprivate pf, Cfk_virtual (mkpolytype (ctyp t)))) :: l]
| CrVvr loc s mf t ->
- [mkcf loc (Pcf_valvirt (with_loc s loc, mkmutable mf, ctyp t)) :: l]
+ [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, Cfk_virtual (ctyp t))) :: l]
| CrAnt _ _ -> assert False ];
value sig_item ast = sig_item ast [];
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 722942896..4ae04dac8 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -15553,14 +15553,14 @@ module Struct =
match c with
| Ast.CgNil _ -> l
| CgCtr (loc, t1, t2) ->
- (mkctf loc (Pctf_cstr (((ctyp t1), (ctyp t2))))) :: l
+ (mkctf loc (Pctf_constraint (((ctyp t1), (ctyp t2))))) :: l
| Ast.CgSem (_, csg1, csg2) ->
class_sig_item csg1 (class_sig_item csg2 l)
| CgInh (loc, ct) ->
- (mkctf loc (Pctf_inher (class_type ct))) :: l
+ (mkctf loc (Pctf_inherit (class_type ct))) :: l
| CgMth (loc, s, pf, t) ->
(mkctf loc
- (Pctf_meth ((s, (mkprivate pf), (mkpolytype (ctyp t)))))) ::
+ (Pctf_method ((s, (mkprivate pf), Concrete, (mkpolytype (ctyp t)))))) ::
l
| CgVal (loc, s, b, v, t) ->
(mkctf loc
@@ -15568,7 +15568,7 @@ module Struct =
l
| CgVir (loc, s, b, t) ->
(mkctf loc
- (Pctf_virt ((s, (mkprivate b), (mkpolytype (ctyp t)))))) ::
+ (Pctf_method ((s, (mkprivate b), Virtual, (mkpolytype (ctyp t)))))) ::
l
| CgAnt (_, _) -> assert false
and class_expr =
@@ -15621,17 +15621,17 @@ module Struct =
match c with
| CrNil _ -> l
| CrCtr (loc, t1, t2) ->
- (mkcf loc (Pcf_constr (((ctyp t1), (ctyp t2))))) :: l
+ (mkcf loc (Pcf_constraint (((ctyp t1), (ctyp t2))))) :: l
| Ast.CrSem (_, cst1, cst2) ->
class_str_item cst1 (class_str_item cst2 l)
| CrInh (loc, ov, ce, pb) ->
let opb = if pb = "" then None else Some pb
in
(mkcf loc
- (Pcf_inher ((override_flag loc ov), (class_expr ce),
+ (Pcf_inherit ((override_flag loc ov), (class_expr ce),
opb))) ::
l
- | CrIni (loc, e) -> (mkcf loc (Pcf_init (expr e))) :: l
+ | CrIni (loc, e) -> (mkcf loc (Pcf_initializer (expr e))) :: l
| CrMth (loc, s, ov, pf, e, t) ->
let t =
(match t with
@@ -15640,26 +15640,26 @@ module Struct =
let e = mkexp loc (Pexp_poly ((expr e), t))
in
(mkcf loc
- (Pcf_meth
+ (Pcf_method
(((with_loc s loc), (mkprivate pf),
- (override_flag loc ov), e)))) ::
+ Cfk_concrete ((override_flag loc ov), e))))) ::
l
| CrVal (loc, s, ov, mf, e) ->
(mkcf loc
(Pcf_val
(((with_loc s loc), (mkmutable mf),
- (override_flag loc ov), (expr e))))) ::
+ Cfk_concrete ((override_flag loc ov), (expr e)))))) ::
l
| CrVir (loc, s, pf, t) ->
(mkcf loc
- (Pcf_virt
+ (Pcf_method
(((with_loc s loc), (mkprivate pf),
- (mkpolytype (ctyp t)))))) ::
+ Cfk_virtual (mkpolytype (ctyp t)))))) ::
l
| CrVvr (loc, s, mf, t) ->
(mkcf loc
- (Pcf_valvirt
- (((with_loc s loc), (mkmutable mf), (ctyp t))))) ::
+ (Pcf_val
+ (((with_loc s loc), (mkmutable mf), Cfk_virtual (ctyp t))))) ::
l
| CrAnt (_, _) -> assert false
diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt
index db0911343..41b5a4cd5 100644
--- a/experimental/frisch/extension_points.txt
+++ b/experimental/frisch/extension_points.txt
@@ -380,6 +380,31 @@ To be discussed: should we segrate simple_poly_type from core_type in the
Parsetree to prevent Ptyp_poly nodes to be inserted in the wrong place?
+--- Use constructor names closer to concrete syntax
+
+E.g. Pcf_cstr -> Pcf_constraint.
+
+Rationale:
+
+ - Make the Parsetree more self-documented.
+
+--- Merge concrete/virtual val and method constructors
+
+As in the Typedtree.
+
+- | Pcf_valvirt of (string loc * mutable_flag * core_type)
+- | Pcf_val of (string loc * mutable_flag * override_flag * expression)
+- | Pcf_virt of (string loc * private_flag * core_type)
+- | Pcf_meth of (string loc * private_flag * override_flag * expression)
++ | Pcf_val of (string loc * mutable_flag * class_field_kind)
++ | Pcf_method of (string loc * private_flag * class_field_kind
+...
++and class_field_kind =
++ | Cfk_virtual of core_type
++ | Cfk_concrete of override_flag * expression
++
+
+
=== More TODOs
- Adapt pprintast.
diff --git a/experimental/frisch/genlifter.ml b/experimental/frisch/genlifter.ml
index 0622f6b5c..5dc73913c 100644
--- a/experimental/frisch/genlifter.ml
+++ b/experimental/frisch/genlifter.ml
@@ -80,7 +80,7 @@ let rec gen ty =
let concrete e =
let e = List.fold_right lam (List.map pvar params) e in
let body = Exp.poly e (Some t) in
- meths := Cf.meth (mknoloc (print_fun ty)) Public Fresh body :: !meths
+ meths := Cf.(method_ (mknoloc (print_fun ty)) Public (concrete Fresh body)) :: !meths
in
match td.type_kind, td.type_manifest with
| Type_record (l, _), _ ->
@@ -106,7 +106,7 @@ let rec gen ty =
concrete (tyexpr_fun env t)
| Type_abstract, None ->
(* Generate an abstract method to lift abstract types *)
- meths := Cf.virt (mknoloc (print_fun ty)) Public t :: !meths
+ meths := Cf.(method_ (mknoloc (print_fun ty)) Public (virtual_ t)) :: !meths
and tuple env tl =
let arg i t =
@@ -185,7 +185,7 @@ let usage =
let () =
Config.load_path := [];
Arg.parse (Arg.align args) gen usage;
- let cl = {Parsetree.pcstr_pat = pvar "this"; pcstr_fields = !meths} in
+ let cl = {Parsetree.pcstr_self = pvar "this"; pcstr_fields = !meths} in
let params = [mknoloc "res", Invariant], Location.none in
let cl = Ci.mk ~virt:Virtual ~params (mknoloc "lifter") (Cl.structure cl) in
let s = [Str.class_ [cl]] in
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 7ea6aca92..166e874e5 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -174,7 +174,7 @@ module Typedtree_search =
let rec iter cpt = function
| [] ->
raise Not_found
- | { cf_desc = Typedtree.Tcf_inher (_, clexp, _, _, _) } :: q ->
+ | { cf_desc = Typedtree.Tcf_inherit (_, clexp, _, _, _) } :: q ->
if n = cpt then clexp else iter (cpt+1) q
| _ :: q ->
iter cpt q
@@ -185,10 +185,10 @@ module Typedtree_search =
let rec iter = function
| [] ->
raise Not_found
- | { cf_desc = Typedtree.Tcf_val (_, _, _, ident, Tcfk_concrete exp, _) } :: q
+ | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_concrete (_, exp), _) } :: q
when Name.from_ident ident = name ->
exp.Typedtree.exp_type
- | { cf_desc = Typedtree.Tcf_val (_, _, _, ident, Tcfk_virtual typ, _) } :: q
+ | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_virtual typ, _) } :: q
when Name.from_ident ident = name ->
typ.Typedtree.ctyp_type
| _ :: q ->
@@ -208,7 +208,7 @@ module Typedtree_search =
let rec iter = function
| [] ->
raise Not_found
- | { cf_desc = Typedtree.Tcf_meth (label, _, _, Tcfk_concrete exp, _) } :: q when label = name ->
+ | { cf_desc = Typedtree.Tcf_method (label, _, Tcfk_concrete (_, exp)) } :: q when label.txt = name ->
exp
| _ :: q ->
iter q
@@ -528,7 +528,7 @@ module Analyser =
| item :: q ->
let loc = item.Parsetree.pcf_loc in
match item.Parsetree.pcf_desc with
- | (Parsetree.Pcf_inher (_, p_clexp, _)) ->
+ | (Parsetree.Pcf_inherit (_, p_clexp, _)) ->
let tt_clexp =
let n = List.length acc_inher in
try Typedtree_search.get_nth_inherit_class_expr tt_cls n
@@ -555,9 +555,8 @@ module Analyser =
p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
q
- | ((Parsetree.Pcf_val ({ txt = label }, mutable_flag, _, _) |
- Parsetree.Pcf_valvirt ({ txt = label }, mutable_flag, _) ) as x) ->
- let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in
+ | Parsetree.Pcf_val ({ txt = label }, mutable_flag, k) ->
+ let virt = match k with Parsetree.Cfk_virtual _ -> true | Parsetree.Cfk_concrete _ -> false in
let complete_name = Name.concat current_class_name label in
let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
let type_exp =
@@ -588,7 +587,7 @@ module Analyser =
in
iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
- | (Parsetree.Pcf_virt ({ txt = label }, private_flag, _)) ->
+ | (Parsetree.Pcf_method ({ txt = label }, private_flag, Parsetree.Cfk_virtual _)) ->
let complete_name = Name.concat current_class_name label in
let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
let met_type =
@@ -630,7 +629,7 @@ module Analyser =
iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
- | (Parsetree.Pcf_meth ({ txt = label }, private_flag, _, _)) ->
+ | (Parsetree.Pcf_method ({ txt = label }, private_flag, Parsetree.Cfk_concrete _)) ->
let complete_name = Name.concat current_class_name label in
let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
let exp =
@@ -671,11 +670,11 @@ module Analyser =
iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
- | Parsetree.Pcf_constr (_, _) ->
+ | Parsetree.Pcf_constraint (_, _) ->
(* don't give a $*%@ ! *)
iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q
- | (Parsetree.Pcf_init exp) ->
+ | (Parsetree.Pcf_initializer exp) ->
iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q
in
iter [] [] last_pos (p_cls.Parsetree.pcstr_fields)
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index f8accef92..18a5bf5c6 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -301,10 +301,9 @@ module Analyser =
let loc = ele2.Parsetree.pctf_loc in
match ele2.Parsetree.pctf_desc with
Parsetree.Pctf_val (_, _, _, _)
- | Parsetree.Pctf_virt (_, _, _)
- | Parsetree.Pctf_meth (_, _, _)
- | Parsetree.Pctf_cstr (_, _) -> loc.Location.loc_start.Lexing.pos_cnum
- | Parsetree.Pctf_inher class_type ->
+ | Parsetree.Pctf_method (_, _, _, _)
+ | Parsetree.Pctf_constraint (_, _) -> loc.Location.loc_start.Lexing.pos_cnum
+ | Parsetree.Pctf_inherit class_type ->
class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum
in
let get_method name comment_opt private_flag loc q =
@@ -402,29 +401,26 @@ module Analyser =
let (inher_l, eles) = f (pos_end + maybe_more) q in
(inher_l, eles_comments @ ((Class_attribute att) :: eles))
- | Parsetree.Pctf_virt (name, private_flag, _) ->
- (* of (string * private_flag * core_type * Location.t) *)
+ | Parsetree.Pctf_method (name, private_flag, virtual_flag, _) ->
+ (* of (string * private_flag * virtual_flag * core_type) *)
let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
let (met, maybe_more) = get_method name comment_opt private_flag loc q in
- let met2 = { met with met_virtual = true } in
+ let met2 =
+ match virtual_flag with
+ | Concrete -> met
+ | Virtual -> { met with met_virtual = true }
+ in
let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
(inher_l, eles_comments @ ((Class_method met2) :: eles))
- | Parsetree.Pctf_meth (name, private_flag, _) ->
- (* of (string * private_flag * core_type * Location.t) *)
- let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let (met, maybe_more) = get_method name comment_opt private_flag loc q in
- let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
- (inher_l, eles_comments @ ((Class_method met) :: eles))
-
- | (Parsetree.Pctf_cstr (_, _)) ->
- (* of (core_type * core_type * Location.t) *)
+ | (Parsetree.Pctf_constraint (_, _)) ->
+ (* of (core_type * core_type) *)
(* A VOIR : cela correspond aux contraintes, non ? on ne les garde pas pour l'instant *)
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_inher class_type ->
+ | Parsetree.Pctf_inherit class_type ->
let loc = class_type.Parsetree.pcty_loc in
let (comment_opt, eles_comments) =
get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 94ee40035..8d252edbd 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -140,14 +140,11 @@ let rec search_pos_class_type cl ~pos ~env =
| Pcty_signature cl ->
List.iter cl.pcsig_fields ~f: (fun fl ->
begin match fl.pctf_desc with
- Pctf_inher cty -> search_pos_class_type cty ~pos ~env
- | Pctf_val (_, _, _, ty) ->
+ Pctf_inherit cty -> search_pos_class_type cty ~pos ~env
+ | Pctf_val (_, _, _, ty)
+ | Pctf_method (_, _, _, ty) ->
if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_virt (_, _, ty) ->
- if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_meth (_, _, ty) ->
- if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_cstr (ty1, ty2) ->
+ | Pctf_constraint (ty1, ty2) ->
if in_loc fl.pctf_loc ~pos then begin
search_pos_type ty1 ~pos ~env;
search_pos_type ty2 ~pos ~env
@@ -689,14 +686,14 @@ let rec search_pos_structure ~pos str =
and search_pos_class_structure ~pos cls =
List.iter cls.cstr_fields ~f:
begin function cf -> match cf.cf_desc with
- Tcf_inher (_, cl, _, _, _) ->
+ Tcf_inherit (_, cl, _, _, _) ->
search_pos_class_expr cl ~pos
- | Tcf_val (_, _, _, _, Tcfk_concrete exp, _) -> search_pos_expr exp ~pos
+ | Tcf_val (_, _, _, Tcfk_concrete (_, exp), _) -> search_pos_expr exp ~pos
| Tcf_val _ -> ()
- | Tcf_meth (_, _, _, Tcfk_concrete exp, _) -> search_pos_expr exp ~pos
- | Tcf_init exp -> search_pos_expr exp ~pos
- | Tcf_constr _
- | Tcf_meth _
+ | Tcf_method (_, _, Tcfk_concrete (_, exp)) -> search_pos_expr exp ~pos
+ | Tcf_initializer exp -> search_pos_expr exp ~pos
+ | Tcf_constraint _
+ | Tcf_method _
-> assert false (* TODO !!!!!!!!!!!!!!!!! *)
end
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index ea2f17590..a03868d3d 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -189,11 +189,10 @@ module Ctf = struct
}
let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
- let inher ?loc ?attrs a = mk ?loc ?attrs (Pctf_inher a)
+ let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit 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))
+ 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))
end
module Cf = struct
@@ -205,13 +204,14 @@ module Cf = struct
}
let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
- let inher ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inher (a, b, c))
- let valvirt ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_valvirt (a, b, c))
- let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcf_val (a, b, c, d))
- let virt ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_virt (a, b, c))
- let meth ?loc ?attrs a b c d = mk ?loc ?attrs (Pcf_meth (a, b, c, d))
- let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constr (a, b))
- let init ?loc ?attrs a = mk ?loc ?attrs (Pcf_init a)
+ let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
+ let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
+ let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c))
+ 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 virtual_ ct = Cfk_virtual ct
+ let concrete o e = Cfk_concrete (o, e)
end
module Val = struct
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 654ed03d2..8b30397be 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -174,24 +174,24 @@ module Ctf:
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 inherit_: ?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
+ val method_: ?loc:Location.t -> ?attrs:attribute list -> string -> private_flag -> virtual_flag -> core_type -> class_type_field
+ val constraint_: ?loc:Location.t -> ?attrs:attribute list -> core_type -> core_type -> class_type_field
end
module Cf:
sig
val mk: ?attrs:attribute list -> ?loc:Location.t -> class_field_desc -> class_field
val attr: class_field -> attribute -> class_field
- val inher: ?loc:Location.t -> ?attrs:attribute list -> override_flag -> class_expr -> string option -> class_field
- val valvirt: ?loc:Location.t -> ?attrs:attribute list -> string loc -> mutable_flag -> core_type -> class_field
- val val_: ?loc:Location.t -> ?attrs:attribute list -> string loc -> mutable_flag -> override_flag -> expression -> class_field
- val virt: ?loc:Location.t -> ?attrs:attribute list -> string loc -> private_flag -> core_type -> class_field
- val meth: ?loc:Location.t -> ?attrs:attribute list -> string loc -> private_flag -> override_flag -> expression -> class_field
- val constr: ?loc:Location.t -> ?attrs:attribute list -> core_type -> core_type -> class_field
- val init: ?loc:Location.t -> ?attrs:attribute list -> expression -> class_field
+ val inherit_: ?loc:Location.t -> ?attrs:attribute list -> override_flag -> class_expr -> string option -> class_field
+ val val_: ?loc:Location.t -> ?attrs:attribute list -> string loc -> mutable_flag -> class_field_kind -> class_field
+ val method_: ?loc:Location.t -> ?attrs:attribute list -> string loc -> private_flag -> class_field_kind -> class_field
+ val constraint_: ?loc:Location.t -> ?attrs:attribute list -> core_type -> core_type -> class_field
+ val initializer_: ?loc:Location.t -> ?attrs:attribute list -> expression -> class_field
+
+ val virtual_: core_type -> class_field_kind
+ val concrete: override_flag -> expression -> class_field_kind
end
module Val:
sig
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index ef6bc80e7..5656fec9a 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -91,11 +91,10 @@ module CT = struct
let open Ctf in
let loc = sub # location loc in
match desc with
- | Pctf_inher ct -> inher ~loc (sub # class_type ct)
+ | Pctf_inherit ct -> inherit_ ~loc (sub # class_type ct)
| Pctf_val (s, m, v, t) -> val_ ~loc s m v (sub # typ t)
- | Pctf_virt (s, p, t) -> virt ~loc s p (sub # typ t)
- | Pctf_meth (s, p, t) -> meth ~loc s p (sub # typ t)
- | Pctf_cstr (t1, t2) -> cstr ~loc (sub # typ t1) (sub # typ t2)
+ | 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)
let map_signature sub {pcsig_self; pcsig_fields; pcsig_loc} =
Csig.mk
@@ -279,18 +278,19 @@ module CE = struct
| Pcl_constraint (ce, ct) ->
constraint_ ~loc (sub # class_expr ce) (sub # class_type ct)
+ 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 open Cf in
let loc = sub # location loc in
match desc with
- | Pcf_inher (o, ce, s) -> inher ~loc o (sub # class_expr ce) s
- | Pcf_valvirt (s, m, t) -> valvirt ~loc (map_loc sub s) m (sub # typ t)
- | Pcf_val (s, m, o, e) -> val_ ~loc (map_loc sub s) m o (sub # expr e)
- | Pcf_virt (s, p, t) -> virt ~loc (map_loc sub s) p (sub # typ t)
- | Pcf_meth (s, p, o, e) -> meth ~loc (map_loc sub s) p o (sub # expr e)
- | Pcf_constr (t1, t2) -> constr ~loc (sub # typ t1) (sub # typ t2)
- | Pcf_init e -> init ~loc (sub # expr e)
+ | 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)
let map_structure sub {pcstr_self; pcstr_fields} =
{
diff --git a/parsing/parser.mly b/parsing/parser.mly
index d4ae24e3e..7b56d7f2f 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -810,19 +810,15 @@ class_fields:
;
class_field:
| INHERIT override_flag class_expr parent_binder
- { mkcf (Pcf_inher ($2, $3, $4)) }
- | VAL virtual_value
- { mkcf (Pcf_valvirt $2) }
+ { mkcf (Pcf_inherit ($2, $3, $4)) }
| VAL value
{ mkcf (Pcf_val $2) }
- | virtual_method
- { mkcf (Pcf_virt $1) }
- | concrete_method
- { mkcf (Pcf_meth $1) }
+ | METHOD method_
+ { mkcf (Pcf_method $2) }
| CONSTRAINT constrain_field
- { mkcf (Pcf_constr $2) }
+ { mkcf (Pcf_constraint $2) }
| INITIALIZER seq_expr
- { mkcf (Pcf_init $2) }
+ { mkcf (Pcf_initializer $2) }
| class_field post_item_attribute
{ Cf.attr $1 $2 }
;
@@ -832,36 +828,38 @@ parent_binder:
| /* empty */
{ None }
;
-virtual_value:
+value:
+/* TODO: factorize these rules (also with method): */
override_flag MUTABLE VIRTUAL label COLON core_type
{ if $1 = Override then syntax_error ();
- mkloc $4 (rhs_loc 4), Mutable, $6 }
+ mkloc $4 (rhs_loc 4), Mutable, Cfk_virtual $6 }
| VIRTUAL mutable_flag label COLON core_type
- { mkrhs $3 3, $2, $5 }
-;
-value:
- override_flag mutable_flag label EQUAL seq_expr
- { mkrhs $3 3, $2, $1, $5 }
+ { mkrhs $3 3, $2, Cfk_virtual $5 }
+ | override_flag mutable_flag label EQUAL seq_expr
+ { mkrhs $3 3, $2, Cfk_concrete ($1, $5) }
| override_flag mutable_flag label type_constraint EQUAL seq_expr
- { mkrhs $3 3, $2, $1, (let (t, t') = $4 in ghexp(Pexp_constraint($6, t, t'))) }
-;
-virtual_method:
- METHOD override_flag PRIVATE VIRTUAL label COLON poly_type
- { if $2 = Override then syntax_error ();
- mkloc $5 (rhs_loc 5), Private, $7 }
- | METHOD override_flag VIRTUAL private_flag label COLON poly_type
- { if $2 = Override then syntax_error ();
- mkloc $5 (rhs_loc 5), $4, $7 }
-;
-concrete_method:
- METHOD override_flag private_flag label strict_binding
- { mkloc $4 (rhs_loc 4), $3, $2, ghexp(Pexp_poly ($5, None)) }
- | METHOD override_flag private_flag label COLON poly_type EQUAL seq_expr
- { mkloc $4 (rhs_loc 4), $3, $2, ghexp(Pexp_poly($8,Some $6)) }
- | METHOD override_flag private_flag label COLON TYPE lident_list
+ {
+ let (t, t') = $4 in
+ let e = ghexp(Pexp_constraint($6, t, t')) in
+ mkrhs $3 3, $2, Cfk_concrete ($1, e)
+ }
+;
+method_:
+/* TODO: factorize those rules... */
+ override_flag PRIVATE VIRTUAL label COLON poly_type
+ { if $1 = Override then syntax_error ();
+ mkloc $4 (rhs_loc 4), Private, Cfk_virtual $6 }
+ | override_flag VIRTUAL private_flag label COLON poly_type
+ { if $1 = Override then syntax_error ();
+ mkloc $4 (rhs_loc 4), $3, Cfk_virtual $6 }
+ | override_flag private_flag label strict_binding
+ { mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly ($4, None))) }
+ | override_flag private_flag label COLON poly_type EQUAL seq_expr
+ { mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly($7, Some $5))) }
+ | override_flag private_flag label COLON TYPE lident_list
DOT core_type EQUAL seq_expr
- { let exp, poly = wrap_type_annotation $7 $9 $11 in
- mkloc $4 (rhs_loc 4), $3, $2, ghexp(Pexp_poly(exp, Some poly)) }
+ { let exp, poly = wrap_type_annotation $6 $8 $10 in
+ mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly))) }
;
/* Class types */
@@ -904,11 +902,14 @@ class_sig_fields:
| class_sig_fields class_sig_field { $2 :: $1 }
;
class_sig_field:
- INHERIT class_signature { mkctf (Pctf_inher $2) }
+ INHERIT class_signature { mkctf (Pctf_inherit $2) }
| VAL value_type { mkctf (Pctf_val $2) }
- | virtual_method_type { mkctf (Pctf_virt $1) }
- | method_type { mkctf (Pctf_meth $1) }
- | CONSTRAINT constrain_field { mkctf (Pctf_cstr $2) }
+ | METHOD private_virtual_flags label COLON poly_type
+ {
+ let (p, v) = $2 in
+ mkctf (Pctf_method ($3, p, v, $5))
+ }
+ | CONSTRAINT constrain_field { mkctf (Pctf_constraint $2) }
| class_sig_field post_item_attribute { Ctf.attr $1 $2 }
;
value_type:
@@ -919,16 +920,6 @@ value_type:
| label COLON core_type
{ $1, Immutable, Concrete, $3 }
;
-method_type:
- METHOD private_flag label COLON poly_type
- { $3, $2, $5 }
-;
-virtual_method_type:
- METHOD PRIVATE VIRTUAL label COLON poly_type
- { $4, Private, $6 }
- | METHOD VIRTUAL private_flag label COLON poly_type
- { $4, $3, $6 }
-;
constrain:
core_type EQUAL core_type { $1, $3, symbol_rloc() }
;
@@ -1877,6 +1868,13 @@ virtual_flag:
/* empty */ { Concrete }
| VIRTUAL { Virtual }
;
+private_virtual_flags:
+ /* empty */ { Public, Concrete }
+ | PRIVATE { Private, Concrete }
+ | VIRTUAL { Public, Virtual }
+ | PRIVATE VIRTUAL { Private, Virtual }
+ | VIRTUAL PRIVATE { Private, Virtual }
+;
override_flag:
/* empty */ { Fresh }
| BANG { Override }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 2bc944f54..7f6e2c1bb 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -197,11 +197,10 @@ and class_type_field = {
}
and class_type_field_desc =
- Pctf_inher of class_type
+ Pctf_inherit of class_type
| Pctf_val of (string * mutable_flag * virtual_flag * core_type)
- | Pctf_virt of (string * private_flag * core_type)
- | Pctf_meth of (string * private_flag * core_type)
- | Pctf_cstr of (core_type * core_type)
+ | Pctf_method of (string * private_flag * virtual_flag * core_type)
+ | Pctf_constraint of (core_type * core_type)
and class_description = class_type class_infos
@@ -233,13 +232,15 @@ and class_field = {
}
and class_field_desc =
- Pcf_inher of override_flag * class_expr * string option
- | Pcf_valvirt of (string loc * mutable_flag * core_type)
- | Pcf_val of (string loc * mutable_flag * override_flag * expression)
- | Pcf_virt of (string loc * private_flag * core_type)
- | Pcf_meth of (string loc * private_flag * override_flag * expression)
- | Pcf_constr of (core_type * core_type)
- | Pcf_init of expression
+ Pcf_inherit of override_flag * class_expr * string option
+ | Pcf_val of (string loc * mutable_flag * class_field_kind)
+ | Pcf_method of (string loc * private_flag * class_field_kind)
+ | Pcf_constraint of (core_type * core_type)
+ | Pcf_initializer of expression
+
+and class_field_kind =
+ | Cfk_virtual of core_type
+ | Cfk_concrete of override_flag * expression
and class_declaration = class_expr class_infos
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index dd41f8f0d..aa812542e 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -708,18 +708,15 @@ class printer ()= object(self:'self)
method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} =
let class_type_field f x =
match x.pctf_desc with
- | Pctf_inher (ct) ->
+ | Pctf_inherit (ct) ->
pp f "@[<2>inherit@ %a@]" self#class_type ct
| Pctf_val (s, mf, vf, ct) ->
pp f "@[<2>val @ %a%a%s@ :@ %a@]"
self#mutable_flag mf self#virtual_flag vf s self#core_type ct
- | Pctf_virt (s, pf, ct) -> (* todo: test this *)
- pp f "@[<2>method@ %a@ virtual@ %s@ :@ %a@]"
- self#private_flag pf s self#core_type ct
- | Pctf_meth (s, pf, ct) ->
- pp f "@[<2>method %a%s :@;%a@]"
- self#private_flag pf s self#core_type ct
- | Pctf_cstr (ct1, ct2) ->
+ | Pctf_method (s, pf, vf, ct) ->
+ pp f "@[<2>method %a %a%s :@;%a@]"
+ self#private_flag pf self#virtual_flag vf s self#core_type ct
+ | Pctf_constraint (ct1, ct2) ->
pp f "@[<2>constraint@ %a@ =@ %a@]"
self#core_type ct1 self#core_type ct2 in
pp f "@[<hv0>@[<hv2>object @[<1>%a@]@ %a@]@ end@]"
@@ -758,22 +755,22 @@ class printer ()= object(self:'self)
method class_field f x =
match x.pcf_desc with
- | Pcf_inher (ovf, ce, so) ->
+ | Pcf_inherit (ovf, ce, so) ->
pp f "@[<2>inherit@ %s@ %a%a@]" (override ovf) self#class_expr ce
(fun f so -> match so with
| None -> ();
| Some (s) -> pp f "@ as %s" s ) so
- | Pcf_val (s, mf, ovf, e) ->
+ | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
pp f "@[<2>val%s %a%s =@;%a@]" (override ovf) self#mutable_flag mf
s.txt self#expression e
- | Pcf_virt (s, pf, ct) ->
+ | Pcf_method (s, pf, Cfk_virtual ct) ->
pp f "@[<2>method virtual %a %s :@;%a@]"
self#private_flag pf s.txt self#core_type ct
- | Pcf_valvirt (s, mf, ct) ->
+ | Pcf_val (s, mf, Cfk_virtual ct) ->
pp f "@[<2>val virtual %a%s :@ %a@]"
self#mutable_flag mf s.txt
self#core_type ct
- | Pcf_meth (s, pf, ovf, e) ->
+ | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
pp f "@[<2>method%s %a%a@]"
(override ovf)
self#private_flag pf
@@ -785,9 +782,9 @@ class printer ()= object(self:'self)
self#binding f ({ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]} ,e)
| _ ->
self#expression f e ) e
- | Pcf_constr (ct1, ct2) ->
+ | Pcf_constraint (ct1, ct2) ->
pp f "@[<2>constraint %a =@;%a@]" self#core_type ct1 self#core_type ct2
- | Pcf_init (e) ->
+ | Pcf_initializer (e) ->
pp f "@[<2>initializer@ %a@]" self#expression e
method class_structure f { pcstr_self = p; pcstr_fields = l } =
diff --git a/parsing/printast.ml b/parsing/printast.ml
index e7d0fc8b7..731fa48d9 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -425,21 +425,18 @@ and class_type_field i ppf x =
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";
+ | Pctf_inherit (ct) ->
+ line i ppf "Pctf_inherit\n";
class_type i ppf ct;
| Pctf_val (s, mf, vf, ct) ->
line i ppf "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
fmt_virtual_flag vf;
core_type (i+1) ppf ct;
- | Pctf_virt (s, pf, ct) ->
- line i ppf "Pctf_virt \"%s\" %a\n" s fmt_private_flag pf;
+ | Pctf_method (s, pf, vf, ct) ->
+ line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf fmt_virtual_flag vf;
core_type (i+1) ppf ct;
- | Pctf_meth (s, pf, ct) ->
- line i ppf "Pctf_meth \"%s\" %a\n" s fmt_private_flag pf;
- core_type (i+1) ppf ct;
- | Pctf_cstr (ct1, ct2) ->
- line i ppf "Pctf_cstr\n";
+ | Pctf_constraint (ct1, ct2) ->
+ line i ppf "Pctf_constraint\n";
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
@@ -503,34 +500,34 @@ and class_field i ppf x =
let i = i + 1 in
attributes i ppf x.pcf_attributes;
match x.pcf_desc with
- | Pcf_inher (ovf, ce, so) ->
- line i ppf "Pcf_inher %a\n" fmt_override_flag ovf;
+ | Pcf_inherit (ovf, ce, so) ->
+ line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
class_expr (i+1) ppf ce;
option (i+1) string ppf so;
- | Pcf_valvirt (s, mf, ct) ->
- line i ppf "Pcf_valvirt %a\n" fmt_mutable_flag mf;
+ | Pcf_val (s, mf, k) ->
+ line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
line (i+1) ppf "%a\n" fmt_string_loc s;
- core_type (i+1) ppf ct;
- | Pcf_val (s, mf, ovf, e) ->
- line i ppf "Pcf_val %a %a\n" fmt_mutable_flag mf fmt_override_flag ovf;
+ class_field_kind (i+1) ppf k
+ | Pcf_method (s, pf, k) ->
+ line i ppf "Pcf_method %a\n" fmt_private_flag pf;
line (i+1) ppf "%a\n" fmt_string_loc s;
- expression (i+1) ppf e;
- | Pcf_virt (s, pf, ct) ->
- line i ppf "Pcf_virt %a\n" fmt_private_flag pf;
- line (i+1) ppf "%a\n" fmt_string_loc s;
- core_type (i+1) ppf ct;
- | Pcf_meth (s, pf, ovf, e) ->
- line i ppf "Pcf_meth %a %a\n" fmt_private_flag pf fmt_override_flag ovf;
- line (i+1) ppf "%a\n" fmt_string_loc s;
- expression (i+1) ppf e;
- | Pcf_constr (ct1, ct2) ->
- line i ppf "Pcf_constr\n";
+ class_field_kind (i+1) ppf k
+ | Pcf_constraint (ct1, ct2) ->
+ line i ppf "Pcf_constraint\n";
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
- | Pcf_init (e) ->
- line i ppf "Pcf_init\n";
+ | Pcf_initializer (e) ->
+ line i ppf "Pcf_initializer\n";
expression (i+1) ppf e;
+and class_field_kind i ppf = function
+ | Cfk_concrete (o, e) ->
+ line i ppf "Concrete %a\n" fmt_override_flag o;
+ expression i ppf e
+ | Cfk_virtual t ->
+ line i ppf "Virtual\n";
+ core_type i ppf t
+
and class_declaration i ppf x =
line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
let i = i+1 in
diff --git a/tools/depend.ml b/tools/depend.ml
index b095f01f8..4c5e020c3 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -91,11 +91,10 @@ let rec add_class_type bv cty =
and add_class_type_field bv pctf =
match pctf.pctf_desc with
- Pctf_inher cty -> add_class_type bv cty
+ Pctf_inherit cty -> add_class_type bv cty
| Pctf_val(_, _, _, ty) -> add_type bv ty
- | Pctf_virt(_, _, ty) -> add_type bv ty
- | Pctf_meth(_, _, ty) -> add_type bv ty
- | Pctf_cstr(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+ | Pctf_method(_, _, _, ty) -> add_type bv ty
+ | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
let add_class_description bv infos =
add_class_type bv infos.pci_expr
@@ -322,13 +321,13 @@ and add_class_expr bv ce =
and add_class_field bv pcf =
match pcf.pcf_desc with
- Pcf_inher(_, ce, _) -> add_class_expr bv ce
- | Pcf_val(_, _, _, e) -> add_expr bv e
- | Pcf_valvirt(_, _, ty)
- | Pcf_virt(_, _, ty) -> add_type bv ty
- | Pcf_meth(_, _, _, e) -> add_expr bv e
- | Pcf_constr(ty1, ty2) -> add_type bv ty1; add_type bv ty2
- | Pcf_init e -> add_expr bv e
+ Pcf_inherit(_, ce, _) -> add_class_expr bv ce
+ | Pcf_val(_, _, Cfk_concrete (_, e))
+ | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
+ | Pcf_val(_, _, Cfk_virtual ty)
+ | 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
and add_class_declaration bv decl =
add_class_expr bv decl.pci_expr
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 92933f756..d2f169a34 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -317,17 +317,20 @@ and rewrite_trymatching l =
and rewrite_class_field iflag cf =
match cf.pcf_desc with
- Pcf_inher (_, cexpr, _) -> rewrite_class_expr iflag cexpr
- | Pcf_val (_, _, _, sexp) -> rewrite_exp iflag sexp
- | Pcf_meth (_, _, _, ({pexp_desc = Pexp_function _} as sexp)) ->
+ Pcf_inherit (_, cexpr, _) -> rewrite_class_expr iflag cexpr
+ | Pcf_val (_, _, Cfk_concrete (_, sexp)) -> rewrite_exp iflag sexp
+ | Pcf_method (_, _,
+ Cfk_concrete (_, ({pexp_desc = Pexp_function _} as sexp))) ->
rewrite_exp iflag sexp
- | Pcf_meth (_, _, _, sexp) ->
+ | Pcf_method (_, _, Cfk_concrete(_, sexp)) ->
let loc = cf.pcf_loc in
if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
else rewrite_exp iflag sexp
- | Pcf_init sexp ->
+ | Pcf_initializer sexp ->
rewrite_exp iflag sexp
- | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> ()
+ | Pcf_method (_, _, Cfk_virtual _)
+ | Pcf_val (_, _, Cfk_virtual _)
+ | Pcf_constraint _ -> ()
and rewrite_class_expr iflag cexpr =
match cexpr.pcl_desc with
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
index 82aae8717..04a7e093b 100644
--- a/tools/tast_iter.ml
+++ b/tools/tast_iter.ml
@@ -271,14 +271,12 @@ let class_signature sub cs =
let class_type_field sub ctf =
match ctf.ctf_desc with
- | Tctf_inher ct -> sub # class_type ct
+ | Tctf_inherit ct -> sub # class_type ct
| Tctf_val (_s, _mut, _virt, ct) ->
sub # core_type ct
- | Tctf_virt (_s, _priv, ct) ->
+ | Tctf_method (_s, _priv, _virt, ct) ->
sub # core_type ct
- | Tctf_meth (_s, _priv, ct) ->
- sub # core_type ct
- | Tctf_cstr (ct1, ct2) ->
+ | Tctf_constraint (ct1, ct2) ->
sub # core_type ct1;
sub # core_type ct2
@@ -314,20 +312,20 @@ let row_field sub rf =
let class_field sub cf =
match cf.cf_desc with
- | Tcf_inher (_ovf, cl, _super, _vals, _meths) ->
+ | Tcf_inherit (_ovf, cl, _super, _vals, _meths) ->
sub # class_expr cl
- | Tcf_constr (cty, cty') ->
+ | Tcf_constraint (cty, cty') ->
sub # core_type cty;
sub # core_type cty'
- | Tcf_val (_lab, _, _, _mut, Tcfk_virtual cty, _override) ->
+ | Tcf_val (_, _, _mut, Tcfk_virtual cty, _override) ->
sub # core_type cty
- | Tcf_val (_lab, _, _, _mut, Tcfk_concrete exp, _override) ->
+ | Tcf_val (_, _, _mut, Tcfk_concrete (_, exp), _override) ->
sub # expression exp
- | Tcf_meth (_lab, _, _priv, Tcfk_virtual cty, _override) ->
+ | Tcf_method (_, _priv, Tcfk_virtual cty) ->
sub # core_type cty
- | Tcf_meth (_lab, _, _priv, Tcfk_concrete exp, _override) ->
+ | Tcf_method (_, _priv, Tcfk_concrete (_, exp)) ->
sub # expression exp
- | Tcf_init exp ->
+ | Tcf_initializer exp ->
sub # expression exp
let bindings sub (_rec_flag, list) =
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 00f22acdf..d6a08c04d 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -466,15 +466,13 @@ and untype_class_signature cs =
and untype_class_type_field ctf =
let desc = match ctf.ctf_desc with
- Tctf_inher ct -> Pctf_inher (untype_class_type ct)
+ Tctf_inherit ct -> Pctf_inherit (untype_class_type ct)
| Tctf_val (s, mut, virt, ct) ->
Pctf_val (s, mut, virt, untype_core_type ct)
- | Tctf_virt (s, priv, ct) ->
- Pctf_virt (s, priv, untype_core_type ct)
- | Tctf_meth (s, priv, ct) ->
- Pctf_meth (s, priv, untype_core_type ct)
- | Tctf_cstr (ct1, ct2) ->
- Pctf_cstr (untype_core_type ct1, untype_core_type ct2)
+ | Tctf_method (s, priv, virt, ct) ->
+ Pctf_method (s, priv, virt, untype_core_type ct)
+ | Tctf_constraint (ct1, ct2) ->
+ Pctf_constraint (untype_core_type ct1, untype_core_type ct2)
in
{
pctf_desc = desc;
@@ -519,26 +517,18 @@ and untype_row_field rf =
and untype_class_field cf =
let desc = match cf.cf_desc with
- Tcf_inher (ovf, cl, super, _vals, _meths) ->
- Pcf_inher (ovf, untype_class_expr cl, super)
- | Tcf_constr (cty, cty') ->
- Pcf_constr (untype_core_type cty, untype_core_type cty')
- | Tcf_val (_lab, name, mut, _, Tcfk_virtual cty, _override) ->
- Pcf_valvirt (name, mut, untype_core_type cty)
- | Tcf_val (_lab, name, mut, _, Tcfk_concrete exp, override) ->
- Pcf_val (name, mut,
- (if override then Override else Fresh),
- untype_expression exp)
- | Tcf_meth (_lab, name, priv, Tcfk_virtual cty, _override) ->
- Pcf_virt (name, priv, untype_core_type cty)
- | Tcf_meth (_lab, name, priv, Tcfk_concrete exp, override) ->
- Pcf_meth (name, priv,
- (if override then Override else Fresh),
- untype_expression exp)
-(* | Tcf_let (rec_flag, bindings, _) ->
- Pcf_let (rec_flag, List.map (fun (pat, exp) ->
- untype_pattern pat, untype_expression exp) bindings)
-*)
- | Tcf_init exp -> Pcf_init (untype_expression exp)
+ Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+ Pcf_inherit (ovf, untype_class_expr cl, super)
+ | Tcf_constraint (cty, cty') ->
+ Pcf_constraint (untype_core_type cty, untype_core_type cty')
+ | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
+ Pcf_val (lab, mut, Cfk_virtual (untype_core_type cty))
+ | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
+ Pcf_val (lab, mut, Cfk_concrete (o, untype_expression exp))
+ | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+ Pcf_method (lab, priv, Cfk_virtual (untype_core_type cty))
+ | 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)
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 e919c98a4..ec96b8050 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -435,28 +435,24 @@ and class_signature i ppf { csig_self = ct; csig_fields = l } =
list (i+1) class_type_field ppf l;
and class_type_field i ppf x =
- let loc = x.ctf_loc in
+ line i ppf "class_type_field %a\n" fmt_location x.ctf_loc;
+ let i = i+1 in
+ attributes i ppf x.ctf_attributes;
match x.ctf_desc with
- | Tctf_inher (ct) ->
- line i ppf "Pctf_inher\n";
+ | Tctf_inherit (ct) ->
+ line i ppf "Pctf_inherit\n";
class_type i ppf ct;
| Tctf_val (s, mf, vf, ct) ->
- line i ppf
- "Pctf_val \"%s\" %a %a %a\n" s
- fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
- core_type (i+1) ppf ct;
- | Tctf_virt (s, pf, ct) ->
- line i ppf
- "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+ line i ppf "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+ fmt_virtual_flag vf;
core_type (i+1) ppf ct;
- | Tctf_meth (s, pf, ct) ->
- line i ppf
- "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+ | Tctf_method (s, pf, vf, ct) ->
+ line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf fmt_virtual_flag vf;
core_type (i+1) ppf ct;
- | Tctf_cstr (ct1, ct2) ->
- line i ppf "Pctf_cstr %a\n" fmt_location loc;
- core_type i ppf ct1;
- core_type i ppf ct2;
+ | Tctf_constraint (ct1, ct2) ->
+ line i ppf "Pctf_constraint\n";
+ core_type (i+1) ppf ct1;
+ core_type (i+1) ppf ct2;
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 ebe1a18ea..28eae0bd6 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -367,7 +367,7 @@ let rec class_type_field env self_type meths
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 ->
+ Pctf_inherit sparent ->
let parent = class_type env sparent in
let inher =
match parent.cltyp_type with
@@ -380,7 +380,7 @@ 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) :: fields,
+ (mkctf (Tctf_inherit parent) :: fields,
val_sig, concr_meths, inher)
| Pctf_val (lab, mut, virt, sty) ->
@@ -389,22 +389,20 @@ let rec class_type_field env self_type meths
(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)) :: fields,
- val_sig, concr_meths, inher)
-
- | Pctf_meth (lab, priv, sty) ->
+ | Pctf_method (lab, priv, virt, sty) ->
let cty =
declare_method env meths self_type lab priv sty ctf.pctf_loc in
- (mkctf (Tctf_meth (lab, priv, cty)) :: fields,
- val_sig, Concr.add lab concr_meths, inher)
+ let concr_meths =
+ match virt with
+ | Concrete -> Concr.add lab concr_meths
+ | Virtual -> concr_meths
+ in
+ (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
+ val_sig, concr_meths, inher)
- | Pctf_cstr (sty, sty') ->
+ | Pctf_constraint (sty, sty') ->
let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in
- (mkctf (Tctf_cstr (cty, cty')) :: fields,
+ (mkctf (Tctf_constraint (cty, cty')) :: fields,
val_sig, concr_meths, inher)
and class_signature env sty sign loc =
@@ -498,7 +496,7 @@ let rec class_field self_loc cl_num self_type meths vars
let loc = cf.pcf_loc 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) ->
+ Pcf_inherit (ovf, sparent, super) ->
let parent = class_expr cl_num val_env par_env sparent in
let inher =
match parent.cl_type with
@@ -540,11 +538,11 @@ 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)))
+ lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
:: fields,
concr_meths, warn_vals, inher)
- | Pcf_valvirt (lab, mut, styp) ->
+ | Pcf_val (lab, mut, Cfk_virtual styp) ->
if !Clflags.principal then Ctype.begin_def ();
let cty = Typetexp.transl_simple_type val_env false styp in
let ty = cty.ctyp_type in
@@ -557,12 +555,11 @@ let rec class_field self_loc cl_num self_type meths vars
val_env met_env par_env loc
in
(val_env, met_env', par_env,
- lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty,
- met_env' == met_env)))
- :: fields,
- concr_meths, warn_vals, inher)
+ lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty, met_env == met_env')))
+ :: fields,
+ concr_meths, warn_vals, inher)
- | Pcf_val (lab, mut, ovf, sexp) ->
+ | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
if Concr.mem lab.txt warn_vals then begin
if ovf = Fresh then
Location.prerr_warning lab.loc
@@ -586,19 +583,19 @@ let rec class_field self_loc cl_num self_type meths vars
val_env met_env par_env loc
in
(val_env, met_env', par_env,
- lazy (mkcf (Tcf_val (lab.txt, lab, mut, id,
- Tcfk_concrete exp, met_env' == met_env)))
+ lazy (mkcf (Tcf_val (lab, mut, id,
+ Tcfk_concrete (ovf, exp), met_env == met_env')))
:: fields,
concr_meths, Concr.add lab.txt warn_vals, inher)
- | Pcf_virt (lab, priv, sty) ->
+ | Pcf_method (lab, priv, Cfk_virtual 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)))
+ lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
::fields,
concr_meths, warn_vals, inher)
- | Pcf_meth (lab, priv, ovf, expr) ->
+ | Pcf_method (lab, priv, Cfk_concrete (ovf, expr)) ->
if Concr.mem lab.txt concr_meths then begin
if ovf = Fresh then
Location.prerr_warning loc (Warnings.Method_override [lab.txt])
@@ -646,21 +643,18 @@ let rec class_field self_loc cl_num self_type meths vars
vars := vars_local;
let texp = type_expect met_env meth_expr meth_type in
Ctype.end_def ();
- mkcf (Tcf_meth (lab.txt, lab, priv, Tcfk_concrete texp,
- match ovf with
- Override -> true
- | Fresh -> false))
+ mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
end in
(val_env, met_env, par_env, field::fields,
Concr.add lab.txt concr_meths, warn_vals, inher)
- | Pcf_constr (sty, sty') ->
+ | Pcf_constraint (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'))) :: fields,
+ lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
concr_meths, warn_vals, inher)
- | Pcf_init expr ->
+ | Pcf_initializer expr ->
let expr = make_method self_loc cl_num expr in
let vars_local = !vars in
let field =
@@ -673,7 +667,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)
+ mkcf (Tcf_initializer texp)
end in
(val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher)
@@ -1546,7 +1540,7 @@ let rec unify_parents env ty cl =
| Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
and unify_parents_struct env ty st =
List.iter
- (function {cf_desc = Tcf_inher (_, cl, _, _, _)} -> unify_parents env ty cl
+ (function {cf_desc = Tcf_inherit (_, cl, _, _, _)} -> unify_parents env ty cl
| _ -> ())
st.cstr_fields
diff --git a/typing/typecore.ml b/typing/typecore.ml
index b8d91f874..d09d86e7a 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -195,10 +195,12 @@ let iter_expression f e =
and class_field cf =
match cf.pcf_desc with
- | Pcf_inher (_, ce, _) -> class_expr ce
- | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> ()
- | Pcf_val (_,_,_,e) | Pcf_meth (_,_,_,e) -> expr e
- | Pcf_init e -> expr e
+ | Pcf_inherit (_, ce, _) -> class_expr ce
+ | Pcf_val (_, _, Cfk_virtual _)
+ | Pcf_method (_, _, Cfk_virtual _ ) | Pcf_constraint _ -> ()
+ | Pcf_val (_, _, Cfk_concrete (_, e))
+ | Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e
+ | Pcf_initializer e -> expr e
in
expr e
@@ -1307,14 +1309,14 @@ let rec is_nonexpansive exp =
let count = ref 0 in
List.for_all
(fun field -> match field.cf_desc with
- Tcf_meth _ -> true
- | Tcf_val (_,_, _, _, Tcfk_concrete e,_) ->
+ Tcf_method _ -> true
+ | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
incr count; is_nonexpansive e
- | Tcf_val (_,_, _, _, Tcfk_virtual _,_) ->
+ | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
incr count; true
- | Tcf_init e -> is_nonexpansive e
- | Tcf_constr _ -> true
- | Tcf_inher _ -> false)
+ | Tcf_initializer e -> is_nonexpansive e
+ | Tcf_constraint _ -> true
+ | Tcf_inherit _ -> false)
fields &&
Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
vars true &&
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 32b60a8e0..5ab71c62f 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -148,22 +148,18 @@ and class_field =
}
and class_field_kind =
- Tcfk_virtual of core_type
-| Tcfk_concrete of expression
+ | Tcfk_virtual of core_type
+ | Tcfk_concrete of override_flag * expression
and class_field_desc =
- Tcf_inher of
+ Tcf_inherit of
override_flag * class_expr * string option * (string * Ident.t) list *
(string * Ident.t) list
(* Inherited instance variables and concrete methods *)
- | Tcf_val of
- string * string loc * mutable_flag * Ident.t * class_field_kind * bool
- (* None = virtual, true = override *)
- | Tcf_meth of string * string loc * private_flag * class_field_kind * bool
- | Tcf_constr of core_type * core_type
-(* | Tcf_let of rec_flag * (pattern * expression) list *
- (Ident.t * string loc * expression) list *)
- | Tcf_init of expression
+ | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+ | Tcf_method of string loc * private_flag * class_field_kind
+ | Tcf_constraint of core_type * core_type
+ | Tcf_initializer of expression
(* Value expressions for the module language *)
@@ -405,11 +401,10 @@ and class_type_field = {
}
and class_type_field_desc =
- Tctf_inher of class_type
+ | Tctf_inherit of class_type
| Tctf_val of (string * mutable_flag * virtual_flag * core_type)
- | Tctf_virt of (string * private_flag * core_type)
- | Tctf_meth of (string * private_flag * core_type)
- | Tctf_cstr of (core_type * core_type)
+ | Tctf_method of (string * private_flag * virtual_flag * core_type)
+ | Tctf_constraint of (core_type * core_type)
and class_declaration =
class_expr class_infos
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 5b77ffa05..5b79ddbeb 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -147,22 +147,18 @@ and class_field =
}
and class_field_kind =
- Tcfk_virtual of core_type
-| Tcfk_concrete of expression
+ | Tcfk_virtual of core_type
+ | Tcfk_concrete of override_flag * expression
and class_field_desc =
- Tcf_inher of
+ Tcf_inherit of
override_flag * class_expr * string option * (string * Ident.t) list *
(string * Ident.t) list
(* Inherited instance variables and concrete methods *)
- | Tcf_val of
- string * string loc * mutable_flag * Ident.t * class_field_kind * bool
- (* None = virtual, true = override *)
- | Tcf_meth of string * string loc * private_flag * class_field_kind * bool
- | Tcf_constr of core_type * core_type
-(* | Tcf_let of rec_flag * (pattern * expression) list *
- (Ident.t * string loc * expression) list *)
- | Tcf_init of expression
+ | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool
+ | Tcf_method of string loc * private_flag * class_field_kind
+ | Tcf_constraint of core_type * core_type
+ | Tcf_initializer of expression
(* Value expressions for the module language *)
@@ -405,11 +401,10 @@ and class_type_field = {
}
and class_type_field_desc =
- Tctf_inher of class_type
+ | Tctf_inherit of class_type
| Tctf_val of (string * mutable_flag * virtual_flag * core_type)
- | Tctf_virt of (string * private_flag * core_type)
- | Tctf_meth of (string * private_flag * core_type)
- | Tctf_cstr of (core_type * core_type)
+ | Tctf_method of (string * private_flag * virtual_flag * core_type)
+ | Tctf_constraint of (core_type * core_type)
and class_declaration =
class_expr class_infos
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 0765b62b9..4392eea82 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -485,14 +485,12 @@ module MakeIterator(Iter : IteratorArgument) : sig
Iter.enter_class_type_field ctf;
begin
match ctf.ctf_desc with
- Tctf_inher ct -> iter_class_type ct
- | Tctf_val (s, mut, virt, ct) ->
+ Tctf_inherit ct -> iter_class_type ct
+ | Tctf_val (s, _mut, _virt, ct) ->
iter_core_type ct
- | Tctf_virt (s, priv, ct) ->
+ | Tctf_method (s, _priv, _virt, ct) ->
iter_core_type ct
- | Tctf_meth (s, priv, ct) ->
- iter_core_type ct
- | Tctf_cstr (ct1, ct2) ->
+ | Tctf_constraint (ct1, ct2) ->
iter_core_type ct1;
iter_core_type ct2
end;
@@ -540,27 +538,23 @@ module MakeIterator(Iter : IteratorArgument) : sig
Iter.enter_class_field cf;
begin
match cf.cf_desc with
- Tcf_inher (ovf, cl, super, _vals, _meths) ->
+ Tcf_inherit (ovf, cl, super, _vals, _meths) ->
iter_class_expr cl
- | Tcf_constr (cty, cty') ->
+ | Tcf_constraint (cty, cty') ->
iter_core_type cty;
iter_core_type cty'
- | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) ->
+ | Tcf_val (lab, _, _, Tcfk_virtual cty, _) ->
iter_core_type cty
- | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) ->
+ | Tcf_val (lab, _, _, Tcfk_concrete (_, exp), _) ->
iter_expression exp
- | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) ->
+ | Tcf_method (lab, _, Tcfk_virtual cty) ->
iter_core_type cty
- | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) ->
+ | Tcf_method (lab, _, Tcfk_concrete (_, exp)) ->
iter_expression exp
-(* | Tcf_let (rec_flag, bindings, exps) ->
- iter_bindings rec_flag bindings;
- List.iter (fun (id, _, exp) -> iter_expression exp) exps; *)
- | Tcf_init exp ->
+ | Tcf_initializer exp ->
iter_expression exp
end;
Iter.leave_class_field cf;
-
end
module DefaultIteratorArgument = struct
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 48f92cacb..f4d56d383 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -528,15 +528,13 @@ module MakeMap(Map : MapArgument) = struct
let ctf = Map.enter_class_type_field ctf in
let ctf_desc =
match ctf.ctf_desc with
- Tctf_inher ct -> Tctf_inher (map_class_type ct)
+ Tctf_inherit ct -> Tctf_inherit (map_class_type ct)
| Tctf_val (s, mut, virt, ct) ->
Tctf_val (s, mut, virt, map_core_type ct)
- | Tctf_virt (s, priv, ct) ->
- Tctf_virt (s, priv, map_core_type ct)
- | Tctf_meth (s, priv, ct) ->
- Tctf_meth (s, priv, map_core_type ct)
- | Tctf_cstr (ct1, ct2) ->
- Tctf_cstr (map_core_type ct1, map_core_type ct2)
+ | Tctf_method (s, priv, virt, ct) ->
+ Tctf_method (s, priv, virt, map_core_type ct)
+ | Tctf_constraint (ct1, ct2) ->
+ Tctf_constraint (map_core_type ct1, map_core_type ct2)
in
Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
@@ -579,23 +577,19 @@ module MakeMap(Map : MapArgument) = struct
let cf = Map.enter_class_field cf in
let cf_desc =
match cf.cf_desc with
- Tcf_inher (ovf, cl, super, vals, meths) ->
- Tcf_inher (ovf, map_class_expr cl, super, vals, meths)
- | Tcf_constr (cty, cty') ->
- Tcf_constr (map_core_type cty, map_core_type cty')
- | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) ->
- Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty),
- override)
- | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) ->
- Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp),
- override)
- | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
- Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty),
- override)
- | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
- Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp),
- override)
- | Tcf_init exp -> Tcf_init (map_expression exp)
+ Tcf_inherit (ovf, cl, super, vals, meths) ->
+ Tcf_inherit (ovf, map_class_expr cl, super, vals, meths)
+ | Tcf_constraint (cty, cty') ->
+ Tcf_constraint (map_core_type cty, map_core_type cty')
+ | Tcf_val (lab, mut, ident, Tcfk_virtual cty, b) ->
+ Tcf_val (lab, mut, ident, Tcfk_virtual (map_core_type cty), b)
+ | Tcf_val (lab, mut, ident, Tcfk_concrete (o, exp), b) ->
+ Tcf_val (lab, mut, ident, Tcfk_concrete (o, map_expression exp), b)
+ | Tcf_method (lab, priv, Tcfk_virtual cty) ->
+ Tcf_method (lab, priv, Tcfk_virtual (map_core_type cty))
+ | 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)
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 19:23:20 +0000