Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
ocaml/experimental/garrigue/valvirt.diff

2350 lines
95 KiB
Diff
Raw Blame History

Index: utils/warnings.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v
retrieving revision 1.23
diff -u -r1.23 warnings.ml
--- utils/warnings.ml 15 Sep 2005 03:09:26 -0000 1.23
+++ utils/warnings.ml 5 Apr 2006 02:25:59 -0000
@@ -26,7 +26,7 @@
| Statement_type (* S *)
| Unused_match (* U *)
| Unused_pat
- | Hide_instance_variable of string (* V *)
+ | Instance_variable_override of string (* V *)
| Illegal_backslash (* X *)
| Implicit_public_methods of string list
| Unerasable_optional_argument
@@ -54,7 +54,7 @@
| Statement_type -> 's'
| Unused_match
| Unused_pat -> 'u'
- | Hide_instance_variable _ -> 'v'
+ | Instance_variable_override _ -> 'v'
| Illegal_backslash
| Implicit_public_methods _
| Unerasable_optional_argument
@@ -126,9 +126,9 @@
String.concat " "
("the following methods are overridden \
by the inherited class:\n " :: slist)
- | Hide_instance_variable lab ->
- "this definition of an instance variable " ^ lab ^
- " hides a previously\ndefined instance variable of the same name."
+ | Instance_variable_override lab ->
+ "the instance variable " ^ lab ^ " is overridden.\n" ^
+ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
| Partial_application ->
"this function application is partial,\n\
maybe some arguments are missing."
Index: utils/warnings.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v
retrieving revision 1.16
diff -u -r1.16 warnings.mli
--- utils/warnings.mli 15 Sep 2005 03:09:26 -0000 1.16
+++ utils/warnings.mli 5 Apr 2006 02:25:59 -0000
@@ -26,7 +26,7 @@
| Statement_type (* S *)
| Unused_match (* U *)
| Unused_pat
- | Hide_instance_variable of string (* V *)
+ | Instance_variable_override of string (* V *)
| Illegal_backslash (* X *)
| Implicit_public_methods of string list
| Unerasable_optional_argument
Index: parsing/parser.mly
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
retrieving revision 1.123
diff -u -r1.123 parser.mly
--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123
+++ parsing/parser.mly 5 Apr 2006 02:25:59 -0000
@@ -623,6 +623,8 @@
{ [] }
| class_fields INHERIT class_expr parent_binder
{ Pcf_inher ($3, $4) :: $1 }
+ | class_fields VAL virtual_value
+ { Pcf_valvirt $3 :: $1 }
| class_fields VAL value
{ Pcf_val $3 :: $1 }
| class_fields virtual_method
@@ -638,14 +640,20 @@
AS LIDENT
{ Some $2 }
| /* empty */
- {None}
+ { None }
+;
+virtual_value:
+ MUTABLE VIRTUAL label COLON core_type
+ { $3, Mutable, $5, symbol_rloc () }
+ | VIRTUAL mutable_flag label COLON core_type
+ { $3, $2, $5, symbol_rloc () }
;
value:
- mutable_flag label EQUAL seq_expr
- { $2, $1, $4, symbol_rloc () }
- | mutable_flag label type_constraint EQUAL seq_expr
- { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
- symbol_rloc () }
+ mutable_flag label EQUAL seq_expr
+ { $2, $1, $4, symbol_rloc () }
+ | mutable_flag label type_constraint EQUAL seq_expr
+ { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
+ symbol_rloc () }
;
virtual_method:
METHOD PRIVATE VIRTUAL label COLON poly_type
@@ -711,8 +719,12 @@
| class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 }
;
value_type:
- mutable_flag label COLON core_type
- { $2, $1, Some $4, symbol_rloc () }
+ VIRTUAL mutable_flag label COLON core_type
+ { $3, $2, Virtual, $5, symbol_rloc () }
+ | MUTABLE virtual_flag label COLON core_type
+ { $3, Mutable, $2, $5, symbol_rloc () }
+ | label COLON core_type
+ { $1, Immutable, Concrete, $3, symbol_rloc () }
;
method_type:
METHOD private_flag label COLON poly_type
Index: parsing/parsetree.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
retrieving revision 1.42
diff -u -r1.42 parsetree.mli
--- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42
+++ parsing/parsetree.mli 5 Apr 2006 02:25:59 -0000
@@ -152,7 +152,7 @@
and class_type_field =
Pctf_inher of class_type
- | Pctf_val of (string * mutable_flag * core_type option * Location.t)
+ | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t)
| Pctf_virt of (string * private_flag * core_type * Location.t)
| Pctf_meth of (string * private_flag * core_type * Location.t)
| Pctf_cstr of (core_type * core_type * Location.t)
@@ -179,6 +179,7 @@
and class_field =
Pcf_inher of class_expr * string option
+ | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
| Pcf_val of (string * mutable_flag * expression * Location.t)
| Pcf_virt of (string * private_flag * core_type * Location.t)
| Pcf_meth of (string * private_flag * expression * Location.t)
Index: parsing/printast.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
retrieving revision 1.29
diff -u -r1.29 printast.ml
--- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29
+++ parsing/printast.ml 5 Apr 2006 02:25:59 -0000
@@ -353,10 +353,11 @@
| Pctf_inher (ct) ->
line i ppf "Pctf_inher\n";
class_type i ppf ct;
- | Pctf_val (s, mf, cto, loc) ->
+ | Pctf_val (s, mf, vf, ct, loc) ->
line i ppf
- "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
- option i core_type ppf cto;
+ "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;
| Pctf_virt (s, pf, ct, loc) ->
line i ppf
"Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
@@ -428,6 +429,10 @@
line i ppf "Pcf_inher\n";
class_expr (i+1) ppf ce;
option (i+1) string ppf so;
+ | Pcf_valvirt (s, mf, ct, loc) ->
+ line i ppf
+ "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
+ core_type (i+1) ppf ct;
| Pcf_val (s, mf, e, loc) ->
line i ppf
"Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
Index: typing/btype.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
retrieving revision 1.38
diff -u -r1.38 btype.ml
--- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38
+++ typing/btype.ml 5 Apr 2006 02:25:59 -0000
@@ -330,7 +330,7 @@
let unmark_class_signature sign =
unmark_type sign.cty_self;
- Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars
+ Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars
let rec unmark_class_type =
function
Index: typing/ctype.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
retrieving revision 1.200
diff -u -r1.200 ctype.ml
--- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200
+++ typing/ctype.ml 5 Apr 2006 02:25:59 -0000
@@ -857,7 +857,7 @@
Tcty_signature
{cty_self = copy sign.cty_self;
cty_vars =
- Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
+ Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars;
cty_concr = sign.cty_concr;
cty_inher =
List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
@@ -2354,10 +2354,11 @@
| CM_Val_type_mismatch of string * (type_expr * type_expr) list
| CM_Meth_type_mismatch of string * (type_expr * type_expr) list
| CM_Non_mutable_value of string
+ | CM_Non_concrete_value of string
| CM_Missing_value of string
| CM_Missing_method of string
| CM_Hide_public of string
- | CM_Hide_virtual of string
+ | CM_Hide_virtual of string * string
| CM_Public_method of string
| CM_Private_method of string
| CM_Virtual_method of string
@@ -2390,8 +2391,8 @@
end)
pairs;
Vars.iter
- (fun lab (mut, ty) ->
- let (mut', ty') = Vars.find lab sign1.cty_vars in
+ (fun lab (mut, v, ty) ->
+ let (mut', v', ty') = Vars.find lab sign1.cty_vars in
try moregen true type_pairs env ty' ty with Unify trace ->
raise (Failure [CM_Val_type_mismatch
(lab, expand_trace env trace)]))
@@ -2437,7 +2438,7 @@
end
in
if Concr.mem lab sign1.cty_concr then err
- else CM_Hide_virtual lab::err)
+ else CM_Hide_virtual ("method", lab) :: err)
miss1 []
in
let missing_method = List.map (fun (m, _, _) -> m) miss2 in
@@ -2455,11 +2456,13 @@
in
let error =
Vars.fold
- (fun lab (mut, ty) err ->
+ (fun lab (mut, vr, ty) err ->
try
- let (mut', ty') = Vars.find lab sign1.cty_vars in
+ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
if mut = Mutable && mut' <> Mutable then
CM_Non_mutable_value lab::err
+ else if vr = Concrete && vr' <> Concrete then
+ CM_Non_concrete_value lab::err
else
err
with Not_found ->
@@ -2467,6 +2470,14 @@
sign2.cty_vars error
in
let error =
+ Vars.fold
+ (fun lab (_,vr,_) err ->
+ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
+ CM_Hide_virtual ("instance variable", lab) :: err
+ else err)
+ sign1.cty_vars error
+ in
+ let error =
List.fold_right
(fun e l ->
if List.mem e missing_method then l else CM_Virtual_method e::l)
@@ -2516,8 +2527,8 @@
end)
pairs;
Vars.iter
- (fun lab (mut, ty) ->
- let (mut', ty') = Vars.find lab sign1.cty_vars in
+ (fun lab (_, _, ty) ->
+ let (_, _, ty') = Vars.find lab sign1.cty_vars in
try eqtype true type_pairs subst env ty ty' with Unify trace ->
raise (Failure [CM_Val_type_mismatch
(lab, expand_trace env trace)]))
@@ -2554,7 +2565,7 @@
end
in
if Concr.mem lab sign1.cty_concr then err
- else CM_Hide_virtual lab::err)
+ else CM_Hide_virtual ("method", lab) :: err)
miss1 []
in
let missing_method = List.map (fun (m, _, _) -> m) miss2 in
@@ -2578,11 +2589,13 @@
in
let error =
Vars.fold
- (fun lab (mut, ty) err ->
+ (fun lab (mut, vr, ty) err ->
try
- let (mut', ty') = Vars.find lab sign1.cty_vars in
+ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
if mut = Mutable && mut' <> Mutable then
CM_Non_mutable_value lab::err
+ else if vr = Concrete && vr' <> Concrete then
+ CM_Non_concrete_value lab::err
else
err
with Not_found ->
@@ -2590,6 +2603,14 @@
sign2.cty_vars error
in
let error =
+ Vars.fold
+ (fun lab (_,vr,_) err ->
+ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
+ CM_Hide_virtual ("instance variable", lab) :: err
+ else err)
+ sign1.cty_vars error
+ in
+ let error =
List.fold_right
(fun e l ->
if List.mem e missing_method then l else CM_Virtual_method e::l)
@@ -3279,7 +3300,7 @@
let nondep_class_signature env id sign =
{ cty_self = nondep_type_rec env id sign.cty_self;
cty_vars =
- Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
+ Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
sign.cty_vars;
cty_concr = sign.cty_concr;
cty_inher =
Index: typing/ctype.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
retrieving revision 1.53
diff -u -r1.53 ctype.mli
--- typing/ctype.mli 9 Dec 2004 12:40:53 -0000 1.53
+++ typing/ctype.mli 5 Apr 2006 02:25:59 -0000
@@ -170,10 +170,11 @@
| CM_Val_type_mismatch of string * (type_expr * type_expr) list
| CM_Meth_type_mismatch of string * (type_expr * type_expr) list
| CM_Non_mutable_value of string
+ | CM_Non_concrete_value of string
| CM_Missing_value of string
| CM_Missing_method of string
| CM_Hide_public of string
- | CM_Hide_virtual of string
+ | CM_Hide_virtual of string * string
| CM_Public_method of string
| CM_Private_method of string
| CM_Virtual_method of string
Index: typing/includeclass.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v
retrieving revision 1.7
diff -u -r1.7 includeclass.ml
--- typing/includeclass.ml 6 Mar 2000 22:11:57 -0000 1.7
+++ typing/includeclass.ml 5 Apr 2006 02:25:59 -0000
@@ -78,14 +78,17 @@
| CM_Non_mutable_value lab ->
fprintf ppf
"@[The non-mutable instance variable %s cannot become mutable@]" lab
+ | CM_Non_concrete_value lab ->
+ fprintf ppf
+ "@[The virtual instance variable %s cannot become concrete@]" lab
| CM_Missing_value lab ->
fprintf ppf "@[The first class type has no instance variable %s@]" lab
| CM_Missing_method lab ->
fprintf ppf "@[The first class type has no method %s@]" lab
| CM_Hide_public lab ->
fprintf ppf "@[The public method %s cannot be hidden@]" lab
- | CM_Hide_virtual lab ->
- fprintf ppf "@[The virtual method %s cannot be hidden@]" lab
+ | CM_Hide_virtual (k, lab) ->
+ fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
| CM_Public_method lab ->
fprintf ppf "@[The public method %s cannot become private" lab
| CM_Virtual_method lab ->
Index: typing/oprint.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
retrieving revision 1.22
diff -u -r1.22 oprint.ml
--- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
+++ typing/oprint.ml 5 Apr 2006 02:25:59 -0000
@@ -291,8 +291,10 @@
fprintf ppf "@[<2>method %s%s%s :@ %a@]"
(if priv then "private " else "") (if virt then "virtual " else "")
name !out_type ty
- | Ocsg_value (name, mut, ty) ->
- fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
+ | Ocsg_value (name, mut, vr, ty) ->
+ fprintf ppf "@[<2>val %s%s%s :@ %a@]"
+ (if mut then "mutable " else "")
+ (if vr then "virtual " else "")
name !out_type ty
let out_class_type = ref print_out_class_type
Index: typing/outcometree.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
retrieving revision 1.14
diff -u -r1.14 outcometree.mli
--- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
+++ typing/outcometree.mli 5 Apr 2006 02:25:59 -0000
@@ -71,7 +71,7 @@
and out_class_sig_item =
| Ocsg_constraint of out_type * out_type
| Ocsg_method of string * bool * bool * out_type
- | Ocsg_value of string * bool * out_type
+ | Ocsg_value of string * bool * bool * out_type
type out_module_type =
| Omty_abstract
Index: typing/printtyp.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
retrieving revision 1.140
diff -u -r1.140 printtyp.ml
--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140
+++ typing/printtyp.ml 5 Apr 2006 02:26:00 -0000
@@ -650,7 +650,7 @@
Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
in
List.iter (fun met -> mark_loops (method_type met)) fields;
- Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
+ Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
| Tcty_fun (_, ty, cty) ->
mark_loops ty;
prepare_class_type params cty
@@ -682,13 +682,15 @@
csil (tree_of_constraints params)
in
let all_vars =
- Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in
+ Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars []
+ in
(* Consequence of PR#3607: order of Map.fold has changed! *)
let all_vars = List.rev all_vars in
let csil =
List.fold_left
- (fun csil (l, m, t) ->
- Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil)
+ (fun csil (l, m, v, t) ->
+ Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
+ :: csil)
csil all_vars
in
let csil =
@@ -763,7 +765,9 @@
List.exists
(fun (lab, _, ty) ->
not (lab = dummy_method || Concr.mem lab sign.cty_concr))
- fields in
+ fields
+ || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false
+ in
Osig_class_type
(virt, Ident.name id,
Index: typing/subst.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v
retrieving revision 1.49
diff -u -r1.49 subst.ml
--- typing/subst.ml 4 Jan 2006 16:55:50 -0000 1.49
+++ typing/subst.ml 5 Apr 2006 02:26:00 -0000
@@ -178,7 +178,8 @@
let class_signature s sign =
{ cty_self = typexp s sign.cty_self;
- cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
+ cty_vars =
+ Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars;
cty_concr = sign.cty_concr;
cty_inher =
List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
Index: typing/typeclass.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
retrieving revision 1.85
diff -u -r1.85 typeclass.ml
--- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85
+++ typing/typeclass.ml 5 Apr 2006 02:26:00 -0000
@@ -24,7 +24,7 @@
type error =
Unconsistent_constraint of (type_expr * type_expr) list
- | Method_type_mismatch of string * (type_expr * type_expr) list
+ | Field_type_mismatch of string * string * (type_expr * type_expr) list
| Structure_expected of class_type
| Cannot_apply of class_type
| Apply_wrong_label of label
@@ -36,7 +36,7 @@
| Unbound_class_type_2 of Longident.t
| Abbrev_type_clash of type_expr * type_expr * type_expr
| Constructor_type_mismatch of string * (type_expr * type_expr) list
- | Virtual_class of bool * string list
+ | Virtual_class of bool * string list * string list
| Parameter_arity_mismatch of Longident.t * int * int
| Parameter_mismatch of (type_expr * type_expr) list
| Bad_parameters of Ident.t * type_expr * type_expr
@@ -49,6 +49,7 @@
| Non_collapsable_conjunction of
Ident.t * Types.class_declaration * (type_expr * type_expr) list
| Final_self_clash of (type_expr * type_expr) list
+ | Mutability_mismatch of string * mutable_flag
exception Error of Location.t * error
@@ -90,7 +91,7 @@
generalize_class_type cty
| Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
Ctype.generalize sty;
- Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
+ Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
| Tcty_fun (_, ty, cty) ->
Ctype.generalize ty;
@@ -152,7 +153,7 @@
| Tcty_signature sign ->
Ctype.closed_schema sign.cty_self
&&
- Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
+ Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
sign.cty_vars
true
| Tcty_fun (_, ty, cty) ->
@@ -172,7 +173,7 @@
limited_generalize rv cty
| Tcty_signature sign ->
Ctype.limited_generalize rv sign.cty_self;
- Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
+ Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
sign.cty_vars;
List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
sign.cty_inher
@@ -201,11 +202,25 @@
Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
(* Enter an instance variable in the environment *)
-let enter_val cl_num vars lab mut ty val_env met_env par_env =
- let (id, val_env, met_env, par_env) as result =
- enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
+let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
+ let (id, virt) =
+ try
+ let (id, mut', virt', ty') = Vars.find lab !vars in
+ if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
+ Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
+ (if not inh then Some id else None),
+ (if virt' = Concrete then virt' else virt)
+ with
+ Ctype.Unify tr ->
+ raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
+ | Not_found -> None, virt
+ in
+ let (id, _, _, _) as result =
+ match id with Some id -> (id, val_env, met_env, par_env)
+ | None ->
+ enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
in
- vars := Vars.add lab (id, mut, ty) !vars;
+ vars := Vars.add lab (id, mut, virt, ty) !vars;
result
let inheritance self_type env concr_meths warn_meths loc parent =
@@ -218,7 +233,7 @@
with Ctype.Unify trace ->
match trace with
_::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
- raise(Error(loc, Method_type_mismatch (n, rem)))
+ raise(Error(loc, Field_type_mismatch ("method", n, rem)))
| _ ->
assert false
end;
@@ -243,7 +258,7 @@
in
let ty = transl_simple_type val_env false sty in
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Method_type_mismatch (lab, trace)))
+ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
let delayed_meth_specs = ref []
@@ -253,7 +268,7 @@
in
let unif ty =
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Method_type_mismatch (lab, trace)))
+ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
in
match sty.ptyp_desc, priv with
Ptyp_poly ([],sty), Public ->
@@ -279,6 +294,15 @@
(*******************************)
+let add_val env loc lab (mut, virt, ty) val_sig =
+ let virt =
+ try
+ let (mut', virt', ty') = Vars.find lab val_sig in
+ if virt' = Concrete then virt' else virt
+ with Not_found -> virt
+ in
+ Vars.add lab (mut, virt, ty) val_sig
+
let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
function
Pctf_inher sparent ->
@@ -293,25 +317,12 @@
parent
in
let val_sig =
- Vars.fold
- (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
- cl_sig.cty_vars val_sig
- in
+ Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
(val_sig, concr_meths, inher)
- | Pctf_val (lab, mut, sty_opt, loc) ->
- let (mut, ty) =
- match sty_opt with
- None ->
- let (mut', ty) =
- try Vars.find lab val_sig with Not_found ->
- raise(Error(loc, Unbound_val lab))
- in
- (if mut = Mutable then mut' else Immutable), ty
- | Some sty ->
- mut, transl_simple_type env false sty
- in
- (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
+ | Pctf_val (lab, mut, virt, sty, loc) ->
+ let ty = transl_simple_type env false sty in
+ (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher)
| Pctf_virt (lab, priv, sty, loc) ->
declare_method env meths self_type lab priv sty loc;
@@ -397,7 +408,7 @@
let rec class_field cl_num self_type meths vars
(val_env, met_env, par_env, fields, concr_meths, warn_meths,
- inh_vals, inher) =
+ warn_vals, inher) =
function
Pcf_inher (sparent, super) ->
let parent = class_expr cl_num val_env par_env sparent in
@@ -411,18 +422,23 @@
parent.cl_type
in
(* Variables *)
- let (val_env, met_env, par_env, inh_vars, inh_vals) =
+ let (val_env, met_env, par_env, inh_vars, warn_vals) =
Vars.fold
- (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) ->
+ (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) ->
+ let mut, vr, ty = info in
let (id, val_env, met_env, par_env) =
- enter_val cl_num vars lab mut ty val_env met_env par_env
+ enter_val cl_num vars true lab mut vr ty val_env met_env par_env
+ sparent.pcl_loc
in
- if StringSet.mem lab inh_vals then
- Location.prerr_warning sparent.pcl_loc
- (Warnings.Hide_instance_variable lab);
- (val_env, met_env, par_env, (lab, id) :: inh_vars,
- StringSet.add lab inh_vals))
- cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
+ let warn_vals =
+ if vr = Virtual then warn_vals else
+ if StringSet.mem lab warn_vals then
+ (Location.prerr_warning sparent.pcl_loc
+ (Warnings.Instance_variable_override lab); warn_vals)
+ else StringSet.add lab warn_vals
+ in
+ (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals))
+ cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals)
in
(* Inherited concrete methods *)
let inh_meths =
@@ -443,11 +459,26 @@
in
(val_env, met_env, par_env,
lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
- concr_meths, warn_meths, inh_vals, inher)
+ concr_meths, warn_meths, warn_vals, inher)
+
+ | Pcf_valvirt (lab, mut, styp, loc) ->
+ if !Clflags.principal then Ctype.begin_def ();
+ let ty = Typetexp.transl_simple_type val_env false styp in
+ if !Clflags.principal then begin
+ Ctype.end_def ();
+ Ctype.generalize_structure ty
+ end;
+ let (id, val_env, met_env', par_env) =
+ enter_val cl_num vars false lab mut Virtual ty
+ val_env met_env par_env loc
+ in
+ (val_env, met_env', par_env,
+ lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields,
+ concr_meths, warn_meths, StringSet.remove lab warn_vals, inher)
| Pcf_val (lab, mut, sexp, loc) ->
- if StringSet.mem lab inh_vals then
- Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
+ if StringSet.mem lab warn_vals then
+ Location.prerr_warning loc (Warnings.Instance_variable_override lab);
if !Clflags.principal then Ctype.begin_def ();
let exp =
try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
@@ -457,17 +488,19 @@
Ctype.end_def ();
Ctype.generalize_structure exp.exp_type
end;
- let (id, val_env, met_env, par_env) =
- enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
- in
- (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
- concr_meths, warn_meths, inh_vals, inher)
+ let (id, val_env, met_env', par_env) =
+ enter_val cl_num vars false lab mut Concrete exp.exp_type
+ val_env met_env par_env loc
+ in
+ (val_env, met_env', par_env,
+ lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields,
+ concr_meths, warn_meths, StringSet.add lab warn_vals, inher)
| Pcf_virt (lab, priv, sty, loc) ->
virtual_method val_env meths self_type lab priv sty loc;
let warn_meths = Concr.remove lab warn_meths in
(val_env, met_env, par_env, fields, concr_meths, warn_meths,
- inh_vals, inher)
+ warn_vals, inher)
| Pcf_meth (lab, priv, expr, loc) ->
let (_, ty) =
@@ -493,7 +526,7 @@
end
| _ -> assert false
with Ctype.Unify trace ->
- raise(Error(loc, Method_type_mismatch (lab, trace)))
+ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
end;
let meth_expr = make_method cl_num expr in
(* backup variables for Pexp_override *)
@@ -510,12 +543,12 @@
Cf_meth (lab, texp)
end in
(val_env, met_env, par_env, field::fields,
- Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
+ Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher)
| Pcf_cstr (sty, sty', loc) ->
type_constraint val_env sty sty' loc;
(val_env, met_env, par_env, fields, concr_meths, warn_meths,
- inh_vals, inher)
+ warn_vals, inher)
| Pcf_let (rec_flag, sdefs, loc) ->
let (defs, val_env) =
@@ -545,7 +578,7 @@
([], met_env, par_env)
in
(val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
- concr_meths, warn_meths, inh_vals, inher)
+ concr_meths, warn_meths, warn_vals, inher)
| Pcf_init expr ->
let expr = make_method cl_num expr in
@@ -562,7 +595,7 @@
Cf_init texp
end in
(val_env, met_env, par_env, field::fields,
- concr_meths, warn_meths, inh_vals, inher)
+ concr_meths, warn_meths, warn_vals, inher)
and class_structure cl_num final val_env met_env loc (spat, str) =
(* Environment for substructures *)
@@ -616,7 +649,7 @@
Ctype.unify val_env self_type (Ctype.newvar ());
let sign =
{cty_self = public_self;
- cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
+ cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
cty_concr = concr_meths;
cty_inher = inher} in
let methods = get_methods self_type in
@@ -628,7 +661,11 @@
be modified after this point *)
Ctype.close_object self_type;
let mets = virtual_methods {sign with cty_self = self_type} in
- if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
+ let vals =
+ Vars.fold
+ (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
+ sign.cty_vars [] in
+ if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals)));
let self_methods =
List.fold_right
(fun (lab,kind,ty) rem ->
@@ -1135,9 +1172,14 @@
in
if cl.pci_virt = Concrete then begin
- match virtual_methods (Ctype.signature_of_class_type typ) with
- [] -> ()
- | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
+ let sign = Ctype.signature_of_class_type typ in
+ let mets = virtual_methods sign in
+ let vals =
+ Vars.fold
+ (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
+ sign.cty_vars [] in
+ if mets <> [] || vals <> [] then
+ raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
end;
(* Misc. *)
@@ -1400,10 +1442,10 @@
Printtyp.report_unification_error ppf trace
(fun ppf -> fprintf ppf "Type")
(fun ppf -> fprintf ppf "is not compatible with type")
- | Method_type_mismatch (m, trace) ->
+ | Field_type_mismatch (k, m, trace) ->
Printtyp.report_unification_error ppf trace
(function ppf ->
- fprintf ppf "The method %s@ has type" m)
+ fprintf ppf "The %s %s@ has type" k m)
(function ppf ->
fprintf ppf "but is expected to have type")
| Structure_expected clty ->
@@ -1451,15 +1493,20 @@
fprintf ppf "The expression \"new %s\" has type" c)
(function ppf ->
fprintf ppf "but is used with type")
- | Virtual_class (cl, mets) ->
+ | Virtual_class (cl, mets, vals) ->
let print_mets ppf mets =
List.iter (function met -> fprintf ppf "@ %s" met) mets in
let cl_mark = if cl then "" else " type" in
+ let missings =
+ match mets, vals with
+ [], _ -> "variables"
+ | _, [] -> "methods"
+ | _ -> "methods and variables"
+ in
fprintf ppf
- "@[This class%s should be virtual@ \
- @[<2>The following methods are undefined :%a@]
- @]"
- cl_mark print_mets mets
+ "@[This class%s should be virtual.@ \
+ @[<2>The following %s are undefined :%a@]@]"
+ cl_mark missings print_mets (mets @ vals)
| Parameter_arity_mismatch(lid, expected, provided) ->
fprintf ppf
"@[The class constructor %a@ expects %i type argument(s),@ \
@@ -1532,3 +1579,10 @@
fprintf ppf "This object is expected to have type")
(function ppf ->
fprintf ppf "but has actually type")
+ | Mutability_mismatch (lab, mut) ->
+ let mut1, mut2 =
+ if mut = Immutable then "mutable", "immutable"
+ else "immutable", "mutable" in
+ fprintf ppf
+ "@[The instance variable is %s,@ it cannot be redefined as %s@]"
+ mut1 mut2
Index: typing/typeclass.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v
retrieving revision 1.18
diff -u -r1.18 typeclass.mli
--- typing/typeclass.mli 1 Dec 2003 00:32:11 -0000 1.18
+++ typing/typeclass.mli 5 Apr 2006 02:26:00 -0000
@@ -49,7 +49,7 @@
type error =
Unconsistent_constraint of (type_expr * type_expr) list
- | Method_type_mismatch of string * (type_expr * type_expr) list
+ | Field_type_mismatch of string * string * (type_expr * type_expr) list
| Structure_expected of class_type
| Cannot_apply of class_type
| Apply_wrong_label of label
@@ -61,7 +61,7 @@
| Unbound_class_type_2 of Longident.t
| Abbrev_type_clash of type_expr * type_expr * type_expr
| Constructor_type_mismatch of string * (type_expr * type_expr) list
- | Virtual_class of bool * string list
+ | Virtual_class of bool * string list * string list
| Parameter_arity_mismatch of Longident.t * int * int
| Parameter_mismatch of (type_expr * type_expr) list
| Bad_parameters of Ident.t * type_expr * type_expr
@@ -74,6 +74,7 @@
| Non_collapsable_conjunction of
Ident.t * Types.class_declaration * (type_expr * type_expr) list
| Final_self_clash of (type_expr * type_expr) list
+ | Mutability_mismatch of string * mutable_flag
exception Error of Location.t * error
Index: typing/typecore.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
retrieving revision 1.178
diff -u -r1.178 typecore.ml
--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178
+++ typing/typecore.ml 5 Apr 2006 02:26:00 -0000
@@ -611,11 +611,11 @@
List.for_all
(function
Cf_meth _ -> true
- | Cf_val (_,_,e) -> incr count; is_nonexpansive e
+ | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
| Cf_init e -> is_nonexpansive e
| Cf_inher _ | Cf_let _ -> false)
fields &&
- Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
+ Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
vars true &&
!count = 0
| _ -> false
@@ -1356,7 +1356,7 @@
(path_self, _) ->
let type_override (lab, snewval) =
begin try
- let (id, _, ty) = Vars.find lab !vars in
+ let (id, _, _, ty) = Vars.find lab !vars in
(Path.Pident id, type_expect env snewval (instance ty))
with
Not_found ->
Index: typing/typecore.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v
retrieving revision 1.37
diff -u -r1.37 typecore.mli
--- typing/typecore.mli 4 Mar 2005 14:51:31 -0000 1.37
+++ typing/typecore.mli 5 Apr 2006 02:26:00 -0000
@@ -38,7 +38,8 @@
string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
Typedtree.pattern *
(Ident.t * type_expr) Meths.t ref *
- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
+ (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
+ Vars.t ref *
Env.t * Env.t * Env.t
val type_expect:
?in_function:(Location.t * type_expr) ->
Index: typing/typedtree.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v
retrieving revision 1.36
diff -u -r1.36 typedtree.ml
--- typing/typedtree.ml 25 Nov 2003 09:20:43 -0000 1.36
+++ typing/typedtree.ml 5 Apr 2006 02:26:00 -0000
@@ -106,7 +106,7 @@
and class_field =
Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
- | Cf_val of string * Ident.t * expression
+ | Cf_val of string * Ident.t * expression option * bool
| Cf_meth of string * expression
| Cf_let of rec_flag * (pattern * expression) list *
(Ident.t * expression) list
@@ -140,7 +140,8 @@
| Tstr_recmodule of (Ident.t * module_expr) list
| Tstr_modtype of Ident.t * module_type
| Tstr_open of Path.t
- | Tstr_class of (Ident.t * int * string list * class_expr) list
+ | Tstr_class of
+ (Ident.t * int * string list * class_expr * virtual_flag) list
| Tstr_cltype of (Ident.t * cltype_declaration) list
| Tstr_include of module_expr * Ident.t list
Index: typing/typedtree.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v
retrieving revision 1.34
diff -u -r1.34 typedtree.mli
--- typing/typedtree.mli 25 Nov 2003 09:20:43 -0000 1.34
+++ typing/typedtree.mli 5 Apr 2006 02:26:00 -0000
@@ -107,7 +107,8 @@
and class_field =
Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
(* Inherited instance variables and concrete methods *)
- | Cf_val of string * Ident.t * expression
+ | Cf_val of string * Ident.t * expression option * bool
+ (* None = virtual, true = override *)
| Cf_meth of string * expression
| Cf_let of rec_flag * (pattern * expression) list *
(Ident.t * expression) list
@@ -141,7 +142,8 @@
| Tstr_recmodule of (Ident.t * module_expr) list
| Tstr_modtype of Ident.t * module_type
| Tstr_open of Path.t
- | Tstr_class of (Ident.t * int * string list * class_expr) list
+ | Tstr_class of
+ (Ident.t * int * string list * class_expr * virtual_flag) list
| Tstr_cltype of (Ident.t * cltype_declaration) list
| Tstr_include of module_expr * Ident.t list
Index: typing/typemod.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v
retrieving revision 1.73
diff -u -r1.73 typemod.ml
--- typing/typemod.ml 8 Aug 2005 09:41:51 -0000 1.73
+++ typing/typemod.ml 5 Apr 2006 02:26:00 -0000
@@ -17,6 +17,7 @@
open Misc
open Longident
open Path
+open Asttypes
open Parsetree
open Types
open Typedtree
@@ -667,8 +668,9 @@
let (classes, new_env) = Typeclass.class_declarations env cl in
let (str_rem, sig_rem, final_env) = type_struct new_env srem in
(Tstr_class
- (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) ->
- (i, s, m, c)) classes) ::
+ (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
+ let vf = if d.cty_new = None then Virtual else Concrete in
+ (i, s, m, c, vf)) classes) ::
Tstr_cltype
(List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
Tstr_type
Index: typing/types.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
retrieving revision 1.25
diff -u -r1.25 types.ml
--- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25
+++ typing/types.ml 5 Apr 2006 02:26:00 -0000
@@ -90,7 +90,8 @@
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of (Ident.t * type_expr) Meths.t ref *
- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
+ (Ident.t * Asttypes.mutable_flag *
+ Asttypes.virtual_flag * type_expr) Vars.t ref *
string * type_expr
(* Self *)
| Val_anc of (string * Ident.t) list * string
@@ -156,7 +157,8 @@
and class_signature =
{ cty_self: type_expr;
- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
+ cty_vars:
+ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
cty_concr: Concr.t;
cty_inher: (Path.t * type_expr list) list }
Index: typing/types.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
retrieving revision 1.25
diff -u -r1.25 types.mli
--- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25
+++ typing/types.mli 5 Apr 2006 02:26:00 -0000
@@ -91,7 +91,8 @@
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of (Ident.t * type_expr) Meths.t ref *
- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
+ (Ident.t * Asttypes.mutable_flag *
+ Asttypes.virtual_flag * type_expr) Vars.t ref *
string * type_expr
(* Self *)
| Val_anc of (string * Ident.t) list * string
@@ -158,7 +159,8 @@
and class_signature =
{ cty_self: type_expr;
- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
+ cty_vars:
+ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
cty_concr: Concr.t;
cty_inher: (Path.t * type_expr list) list }
Index: typing/unused_var.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
retrieving revision 1.5
diff -u -r1.5 unused_var.ml
--- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5
+++ typing/unused_var.ml 5 Apr 2006 02:26:00 -0000
@@ -245,7 +245,7 @@
match cf with
| Pcf_inher (ce, _) -> class_expr ppf tbl ce;
| Pcf_val (_, _, e, _) -> expression ppf tbl e;
- | Pcf_virt _ -> ()
+ | Pcf_virt _ | Pcf_valvirt _ -> ()
| Pcf_meth (_, _, e, _) -> expression ppf tbl e;
| Pcf_cstr _ -> ()
| Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
Index: bytecomp/translclass.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
retrieving revision 1.38
diff -u -r1.38 translclass.ml
--- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38
+++ bytecomp/translclass.ml 5 Apr 2006 02:26:00 -0000
@@ -133,10 +133,10 @@
(fun _ -> lambda_unit) cl
in
(inh_init, lsequence obj_init' obj_init, true)
- | Cf_val (_, id, exp) ->
+ | Cf_val (_, id, Some exp, _) ->
(inh_init, lsequence (set_inst_var obj id exp) obj_init,
has_init)
- | Cf_meth _ ->
+ | Cf_meth _ | Cf_val _ ->
(inh_init, obj_init, has_init)
| Cf_init _ ->
(inh_init, obj_init, true)
@@ -213,27 +213,17 @@
if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
let ids = Ident.create "ids" in
- let i = ref len in
- let getter, names, cl_init =
- match vals with [] -> "get_method_labels", [], cl_init
- | (_,id0)::vals' ->
- incr i;
- let i = ref (List.length vals) in
- "new_methods_variables",
- [transl_meth_list (List.map fst vals)],
- Llet(Strict, id0, lfield ids 0,
- List.fold_right
- (fun (name,id) rem ->
- decr i;
- Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
- vals' cl_init)
+ let i = ref (len + nvals) in
+ let getter, names =
+ if nvals = 0 then "get_method_labels", [] else
+ "new_methods_variables", [transl_meth_list (List.map fst vals)]
in
Llet(StrictOpt, ids,
Lapply (oo_prim getter,
[Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
List.fold_right
(fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
- methl cl_init)
+ (methl @ vals) cl_init)
let output_methods tbl methods lam =
match methods with
@@ -283,8 +273,9 @@
(vals, meths_super cla str.cl_meths meths)
inh_init cl_init msubst top cl in
(inh_init, cl_init, [], values)
- | Cf_val (name, id, exp) ->
- (inh_init, cl_init, methods, (name, id)::values)
+ | Cf_val (name, id, exp, over) ->
+ let values = if over then values else (name, id) :: values in
+ (inh_init, cl_init, methods, values)
| Cf_meth (name, exp) ->
let met_code = msubst true (transl_exp exp) in
let met_code =
@@ -342,27 +333,24 @@
assert (Path.same path path');
let lpath = transl_path path in
let inh = Ident.create "inh"
- and inh_vals = Ident.create "vals"
- and inh_meths = Ident.create "meths"
+ and ofs = List.length vals + 1
and valids, methids = super in
let cl_init =
List.fold_left
(fun init (nm, id, _) ->
- Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
+ Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
init))
cl_init methids in
let cl_init =
List.fold_left
(fun init (nm, id) ->
- Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
+ Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
cl_init valids in
(inh_init,
Llet (Strict, inh,
Lapply(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
- Llet(StrictOpt, obj_init, lfield inh 0,
- Llet(Alias, inh_vals, lfield inh 1,
- Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
+ Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
| _ ->
let core cl_init =
build_class_init cla true super inh_init cl_init msubst top cl
@@ -397,12 +385,16 @@
XXX Il devrait etre peu couteux d'ecrire des classes :
class c x y = d e f
*)
-let rec transl_class_rebind obj_init cl =
+let rec transl_class_rebind obj_init cl vf =
match cl.cl_desc with
Tclass_ident path ->
+ if vf = Concrete then begin
+ try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
+ with Not_found -> raise Exit
+ end;
(path, obj_init)
| Tclass_fun (pat, _, cl, partial) ->
- let path, obj_init = transl_class_rebind obj_init cl in
+ let path, obj_init = transl_class_rebind obj_init cl vf in
let build params rem =
let param = name_pattern "param" [pat, ()] in
Lfunction (Curried, param::params,
@@ -414,14 +406,14 @@
Lfunction (Curried, params, rem) -> build params rem
| rem -> build [] rem)
| Tclass_apply (cl, oexprs) ->
- let path, obj_init = transl_class_rebind obj_init cl in
+ let path, obj_init = transl_class_rebind obj_init cl vf in
(path, transl_apply obj_init oexprs)
| Tclass_let (rec_flag, defs, vals, cl) ->
- let path, obj_init = transl_class_rebind obj_init cl in
+ let path, obj_init = transl_class_rebind obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
| Tclass_structure _ -> raise Exit
| Tclass_constraint (cl', _, _, _) ->
- let path, obj_init = transl_class_rebind obj_init cl' in
+ let path, obj_init = transl_class_rebind obj_init cl' vf in
let rec check_constraint = function
Tcty_constr(path', _, _) when Path.same path path' -> ()
| Tcty_fun (_, _, cty) -> check_constraint cty
@@ -430,21 +422,21 @@
check_constraint cl.cl_type;
(path, obj_init)
-let rec transl_class_rebind_0 self obj_init cl =
+let rec transl_class_rebind_0 self obj_init cl vf =
match cl.cl_desc with
Tclass_let (rec_flag, defs, vals, cl) ->
- let path, obj_init = transl_class_rebind_0 self obj_init cl in
+ let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
| _ ->
- let path, obj_init = transl_class_rebind obj_init cl in
+ let path, obj_init = transl_class_rebind obj_init cl vf in
(path, lfunction [self] obj_init)
-let transl_class_rebind ids cl =
+let transl_class_rebind ids cl vf =
try
let obj_init = Ident.create "obj_init"
and self = Ident.create "self" in
let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
- let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
+ let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));
let id = (obj_init' = lfunction [self] obj_init0) in
@@ -592,9 +584,9 @@
*)
-let transl_class ids cl_id arity pub_meths cl =
+let transl_class ids cl_id arity pub_meths cl vflag =
(* First check if it is not only a rebind *)
- let rebind = transl_class_rebind ids cl in
+ let rebind = transl_class_rebind ids cl vflag in
if rebind <> lambda_unit then rebind else
(* Prepare for heavy environment handling *)
@@ -696,9 +688,7 @@
(* Simplest case: an object defined at toplevel (ids=[]) *)
if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
- let concrete =
- ids = [] ||
- Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
+ let concrete = (vflag = Concrete)
and lclass lam =
let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
@@ -800,11 +790,11 @@
(* Wrapper for class compilation *)
-let transl_class ids cl_id arity pub_meths cl =
- oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
+let transl_class ids cl_id arity pub_meths cl vf =
+ oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf
let () =
- transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
+ transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete)
(* Error report *)
Index: bytecomp/translclass.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v
retrieving revision 1.11
diff -u -r1.11 translclass.mli
--- bytecomp/translclass.mli 12 Aug 2004 12:55:11 -0000 1.11
+++ bytecomp/translclass.mli 5 Apr 2006 02:26:00 -0000
@@ -16,7 +16,8 @@
open Lambda
val transl_class :
- Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
+ Ident.t list -> Ident.t ->
+ int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
type error = Illegal_class_expr | Tags of string * string
Index: bytecomp/translmod.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v
retrieving revision 1.51
diff -u -r1.51 translmod.ml
--- bytecomp/translmod.ml 12 Aug 2004 12:55:11 -0000 1.51
+++ bytecomp/translmod.ml 5 Apr 2006 02:26:00 -0000
@@ -317,10 +317,10 @@
| Tstr_open path :: rem ->
transl_structure fields cc rootpath rem
| Tstr_class cl_list :: rem ->
- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
+ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
Lletrec(List.map
- (fun (id, arity, meths, cl) ->
- (id, transl_class ids id arity meths cl))
+ (fun (id, arity, meths, cl, vf) ->
+ (id, transl_class ids id arity meths cl vf))
cl_list,
transl_structure (List.rev ids @ fields) cc rootpath rem)
| Tstr_cltype cl_list :: rem ->
@@ -414,11 +414,11 @@
| Tstr_open path :: rem ->
transl_store subst rem
| Tstr_class cl_list :: rem ->
- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
+ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
let lam =
Lletrec(List.map
- (fun (id, arity, meths, cl) ->
- (id, transl_class ids id arity meths cl))
+ (fun (id, arity, meths, cl, vf) ->
+ (id, transl_class ids id arity meths cl vf))
cl_list,
store_idents ids) in
Lsequence(subst_lambda subst lam,
@@ -485,7 +485,7 @@
| Tstr_modtype(id, decl) :: rem -> defined_idents rem
| Tstr_open path :: rem -> defined_idents rem
| Tstr_class cl_list :: rem ->
- List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem
+ List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
| Tstr_cltype cl_list :: rem -> defined_idents rem
| Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
@@ -603,14 +603,14 @@
| Tstr_class cl_list ->
(* we need to use unique names for the classes because there might
be a value named identically *)
- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
+ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
List.iter set_toplevel_unique_name ids;
Lletrec(List.map
- (fun (id, arity, meths, cl) ->
- (id, transl_class ids id arity meths cl))
+ (fun (id, arity, meths, cl, vf) ->
+ (id, transl_class ids id arity meths cl vf))
cl_list,
make_sequence
- (fun (id, _, _, _) -> toploop_setvalue_id id)
+ (fun (id, _, _, _, _) -> toploop_setvalue_id id)
cl_list)
| Tstr_cltype cl_list ->
lambda_unit
Index: driver/main_args.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v
retrieving revision 1.48
diff -u -r1.48 main_args.ml
--- driver/main_args.ml 4 Jan 2006 16:55:49 -0000 1.48
+++ driver/main_args.ml 5 Apr 2006 02:26:00 -0000
@@ -136,11 +136,11 @@
\032 E/e enable/disable fragile match\n\
\032 F/f enable/disable partially applied function\n\
\032 L/l enable/disable labels omitted in application\n\
- \032 M/m enable/disable overridden method\n\
+ \032 M/m enable/disable overridden methods\n\
\032 P/p enable/disable partial match\n\
\032 S/s enable/disable non-unit statement\n\
\032 U/u enable/disable unused match case\n\
- \032 V/v enable/disable hidden instance variable\n\
+ \032 V/v enable/disable overridden instance variables\n\
\032 Y/y enable/disable suspicious unused variables\n\
\032 Z/z enable/disable all other unused variables\n\
\032 X/x enable/disable all other warnings\n\
Index: driver/optmain.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v
retrieving revision 1.87
diff -u -r1.87 optmain.ml
--- driver/optmain.ml 4 Jan 2006 16:55:49 -0000 1.87
+++ driver/optmain.ml 5 Apr 2006 02:26:00 -0000
@@ -173,7 +173,7 @@
\032 P/p enable/disable partial match\n\
\032 S/s enable/disable non-unit statement\n\
\032 U/u enable/disable unused match case\n\
- \032 V/v enable/disable hidden instance variables\n\
+ \032 V/v enable/disable overridden instance variables\n\
\032 Y/y enable/disable suspicious unused variables\n\
\032 Z/z enable/disable all other unused variables\n\
\032 X/x enable/disable all other warnings\n\
Index: stdlib/camlinternalOO.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
retrieving revision 1.14
diff -u -r1.14 camlinternalOO.ml
--- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14
+++ stdlib/camlinternalOO.ml 5 Apr 2006 02:26:00 -0000
@@ -206,7 +206,11 @@
(table.methods_by_name, table.methods_by_label, table.hidden_meths,
table.vars, virt_meth_labs, vars)
:: table.previous_states;
- table.vars <- Vars.empty;
+ table.vars <-
+ Vars.fold
+ (fun lab info tvars ->
+ if List.mem lab vars then Vars.add lab info tvars else tvars)
+ table.vars Vars.empty;
let by_name = ref Meths.empty in
let by_label = ref Labs.empty in
List.iter2
@@ -255,9 +259,11 @@
index
let new_variable table name =
- let index = new_slot table in
- table.vars <- Vars.add name index table.vars;
- index
+ try Vars.find name table.vars
+ with Not_found ->
+ let index = new_slot table in
+ table.vars <- Vars.add name index table.vars;
+ index
let to_array arr =
if arr = Obj.magic 0 then [||] else arr
@@ -265,16 +271,17 @@
let new_methods_variables table meths vals =
let meths = to_array meths in
let nmeths = Array.length meths and nvals = Array.length vals in
- let index = new_variable table vals.(0) in
- let res = Array.create (nmeths + 1) index in
- for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done;
+ let res = Array.create (nmeths + nvals) 0 in
for i = 0 to nmeths - 1 do
- res.(i+1) <- get_method_label table meths.(i)
+ res.(i) <- get_method_label table meths.(i)
+ done;
+ for i = 0 to nvals - 1 do
+ res.(i+nmeths) <- new_variable table vals.(i)
done;
res
let get_variable table name =
- Vars.find name table.vars
+ try Vars.find name table.vars with Not_found -> assert false
let get_variables table names =
Array.map (get_variable table) names
@@ -315,9 +322,12 @@
let init =
if top then super cla env else Obj.repr (super cla) in
widen cla;
- (init, Array.map (get_variable cla) (to_array vals),
- Array.map (fun nm -> get_method cla (get_method_label cla nm))
- (to_array concr_meths))
+ Array.concat
+ [[| repr init |];
+ magic (Array.map (get_variable cla) (to_array vals) : int array);
+ Array.map
+ (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
+ (to_array concr_meths) ]
let make_class pub_meths class_init =
let table = create_table pub_meths in
Index: stdlib/camlinternalOO.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
retrieving revision 1.9
diff -u -r1.9 camlinternalOO.mli
--- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9
+++ stdlib/camlinternalOO.mli 5 Apr 2006 02:26:00 -0000
@@ -46,8 +46,7 @@
val init_class : table -> unit
val inherits :
table -> string array -> string array -> string array ->
- (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
- (Obj.t * int array * closure array)
+ (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array
val make_class :
string array -> (table -> Obj.t -> t) ->
(t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
@@ -79,6 +78,7 @@
(** {6 Builtins to reduce code size} *)
+(*
val get_const : t -> closure
val get_var : int -> closure
val get_env : int -> int -> closure
@@ -103,6 +103,7 @@
val send_var : tag -> int -> int -> closure
val send_env : tag -> int -> int -> int -> closure
val send_meth : tag -> label -> int -> closure
+*)
type impl =
GetConst
Index: stdlib/sys.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v
retrieving revision 1.142
diff -u -r1.142 sys.ml
--- stdlib/sys.ml 22 Mar 2006 12:39:39 -0000 1.142
+++ stdlib/sys.ml 5 Apr 2006 02:26:00 -0000
@@ -78,4 +78,4 @@
(* OCaml version string, must be in the format described in sys.mli. *)
-let ocaml_version = "3.10+dev4 (2006-03-22)";;
+let ocaml_version = "3.10+dev5 (2006-04-05)";;
Index: tools/depend.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v
retrieving revision 1.9
diff -u -r1.9 depend.ml
--- tools/depend.ml 23 Mar 2005 03:08:37 -0000 1.9
+++ tools/depend.ml 5 Apr 2006 02:26:00 -0000
@@ -87,7 +87,7 @@
and add_class_type_field bv = function
Pctf_inher cty -> add_class_type bv cty
- | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty
+ | 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
@@ -280,6 +280,7 @@
and add_class_field bv = function
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_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
Index: tools/ocamlprof.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v
retrieving revision 1.38
diff -u -r1.38 ocamlprof.ml
--- tools/ocamlprof.ml 24 Mar 2005 17:20:54 -0000 1.38
+++ tools/ocamlprof.ml 5 Apr 2006 02:26:00 -0000
@@ -328,7 +328,7 @@
rewrite_patexp_list iflag spat_sexp_list
| Pcf_init sexp ->
rewrite_exp iflag sexp
- | Pcf_virt _ | Pcf_cstr _ -> ()
+ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> ()
and rewrite_class_expr iflag cexpr =
match cexpr.pcl_desc with
Index: otherlibs/labltk/browser/searchpos.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v
retrieving revision 1.48
diff -u -r1.48 searchpos.ml
--- otherlibs/labltk/browser/searchpos.ml 23 Mar 2005 03:08:37 -0000 1.48
+++ otherlibs/labltk/browser/searchpos.ml 5 Apr 2006 02:26:01 -0000
@@ -141,9 +141,8 @@
List.iter cfl ~f:
begin function
Pctf_inher cty -> search_pos_class_type cty ~pos ~env
- | Pctf_val (_, _, Some ty, loc) ->
+ | Pctf_val (_, _, _, ty, loc) ->
if in_loc loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_val _ -> ()
| Pctf_virt (_, _, ty, loc) ->
if in_loc loc ~pos then search_pos_type ty ~pos ~env
| Pctf_meth (_, _, ty, loc) ->
@@ -675,7 +674,7 @@
| Tstr_modtype _ -> ()
| Tstr_open _ -> ()
| Tstr_class l ->
- List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
+ List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos)
| Tstr_cltype _ -> ()
| Tstr_include (m, _) -> search_pos_module_expr m ~pos
end
@@ -685,7 +684,8 @@
begin function
Cf_inher (cl, _, _) ->
search_pos_class_expr cl ~pos
- | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
+ | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
+ | Cf_val _ -> ()
| Cf_meth (_, exp) -> search_pos_expr exp ~pos
| Cf_let (_, pel, iel) ->
List.iter pel ~f:
Index: ocamldoc/Makefile
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v
retrieving revision 1.61
diff -u -r1.61 Makefile
--- ocamldoc/Makefile 4 Jan 2006 16:55:49 -0000 1.61
+++ ocamldoc/Makefile 5 Apr 2006 02:26:01 -0000
@@ -31,7 +31,7 @@
MKDIR=mkdir -p
CP=cp -f
OCAMLDOC=ocamldoc
-OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
+OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
OCAMLDOC_OPT=$(OCAMLDOC).opt
OCAMLDOC_LIBCMA=odoc_info.cma
OCAMLDOC_LIBCMI=odoc_info.cmi
@@ -188,12 +188,12 @@
../otherlibs/num/num.mli
all: exe lib
- $(MAKE) manpages
exe: $(OCAMLDOC)
lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
opt.opt: exeopt libopt
+ $(MAKE) manpages
exeopt: $(OCAMLDOC_OPT)
libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
debug:
Index: ocamldoc/odoc_ast.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v
retrieving revision 1.27
diff -u -r1.27 odoc_ast.ml
--- ocamldoc/odoc_ast.ml 4 Jan 2006 16:55:49 -0000 1.27
+++ ocamldoc/odoc_ast.ml 5 Apr 2006 02:26:01 -0000
@@ -88,7 +88,7 @@
ident_type_decl_list
| Typedtree.Tstr_class info_list ->
List.iter
- (fun ((id,_,_,_) as ci) ->
+ (fun ((id,_,_,_,_) as ci) ->
Hashtbl.add table (C (Name.from_ident id))
(Typedtree.Tstr_class [ci]))
info_list
@@ -146,7 +146,7 @@
let search_class_exp table name =
match Hashtbl.find table (C name) with
- | (Typedtree.Tstr_class [(_,_,_,ce)]) ->
+ | (Typedtree.Tstr_class [(_,_,_,ce,_)]) ->
(
try
let type_decl = search_type_declaration table name in
@@ -184,7 +184,7 @@
let rec iter = function
| [] ->
raise Not_found
- | Typedtree.Cf_val (_, ident, exp) :: q
+ | Typedtree.Cf_val (_, ident, Some exp, _) :: q
when Name.from_ident ident = name ->
exp.Typedtree.exp_type
| _ :: q ->
@@ -523,7 +523,8 @@
p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
q
- | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
+ | (Parsetree.Pcf_val (label, mutable_flag, _, loc) |
+ Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q ->
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 =
Index: ocamldoc/odoc_sig.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v
retrieving revision 1.37
diff -u -r1.37 odoc_sig.ml
--- ocamldoc/odoc_sig.ml 4 Jan 2006 16:55:50 -0000 1.37
+++ ocamldoc/odoc_sig.ml 5 Apr 2006 02:26:01 -0000
@@ -107,7 +107,7 @@
| _ -> assert false
let search_attribute_type name class_sig =
- let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
+ let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
type_expr
let search_method_type name class_sig =
@@ -269,7 +269,7 @@
[] -> pos_limit
| ele2 :: _ ->
match ele2 with
- Parsetree.Pctf_val (_, _, _, loc)
+ Parsetree.Pctf_val (_, _, _, _, loc)
| Parsetree.Pctf_virt (_, _, _, loc)
| Parsetree.Pctf_meth (_, _, _, loc)
| Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
@@ -330,7 +330,7 @@
in
([], ele_comments)
- | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q ->
+ | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q ->
(* of (string * mutable_flag * core_type option * Location.t)*)
let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
let complete_name = Name.concat current_class_name name in
Index: camlp4/camlp4/ast2pt.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v
retrieving revision 1.36
diff -u -r1.36 ast2pt.ml
--- camlp4/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36
+++ camlp4/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000
@@ -244,6 +244,7 @@
;
value mkmutable m = if m then Mutable else Immutable;
value mkprivate m = if m then Private else Public;
+value mkvirtual m = if m then Virtual else Concrete;
value mktrecord (loc, n, m, t) =
(n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
@@ -862,8 +863,8 @@
| CgInh loc ct -> [Pctf_inher (class_type ct) :: l]
| CgMth loc s pf t ->
[Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l]
- | CgVal loc s b t ->
- [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l]
+ | CgVal loc s b v t ->
+ [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
| CgVir loc s b t ->
[Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
and class_expr =
@@ -907,7 +908,9 @@
[Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
| CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
| CrVir loc s b t ->
- [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
+ [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l]
+ | CrVvr loc s b t ->
+ [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ]
;
value interf ast = List.fold_right sig_item ast [];
Index: camlp4/camlp4/mLast.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v
retrieving revision 1.18
diff -u -r1.18 mLast.mli
--- camlp4/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.18
+++ camlp4/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000
@@ -180,7 +180,7 @@
| CgDcl of loc and list class_sig_item
| CgInh of loc and class_type
| CgMth of loc and string and bool and ctyp
- | CgVal of loc and string and bool and ctyp
+ | CgVal of loc and string and bool and bool and ctyp
| CgVir of loc and string and bool and ctyp ]
and class_expr =
[ CeApp of loc and class_expr and expr
@@ -196,7 +196,8 @@
| CrIni of loc and expr
| CrMth of loc and string and bool and expr and option ctyp
| CrVal of loc and string and bool and expr
- | CrVir of loc and string and bool and ctyp ]
+ | CrVir of loc and string and bool and ctyp
+ | CrVvr of loc and string and bool and ctyp ]
;
external loc_of_ctyp : ctyp -> loc = "%field0";
Index: camlp4/camlp4/reloc.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v
retrieving revision 1.18
diff -u -r1.18 reloc.ml
--- camlp4/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.18
+++ camlp4/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000
@@ -350,7 +350,7 @@
| CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1)
| CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1)
| CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3)
- | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3)
+ | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4)
| CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ]
and class_expr floc sh =
self where rec self =
@@ -377,5 +377,6 @@
| CrMth loc x1 x2 x3 x4 ->
let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4)
| CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3)
- | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ]
+ | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3)
+ | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ]
;
Index: camlp4/etc/pa_o.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v
retrieving revision 1.66
diff -u -r1.66 pa_o.ml
--- camlp4/etc/pa_o.ml 29 Jun 2005 04:11:26 -0000 1.66
+++ camlp4/etc/pa_o.ml 5 Apr 2006 02:26:01 -0000
@@ -1037,8 +1037,14 @@
class_str_item:
[ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
<:class_str_item< inherit $ce$ $opt:pb$ >>
- | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
+ | "val"; "mutable"; lab = label; e = cvalue_binding ->
+ <:class_str_item< value mutable $lab$ = $e$ >>
+ | "val"; lab = label; e = cvalue_binding ->
+ <:class_str_item< value $lab$ = $e$ >>
+ | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp ->
+ <:class_str_item< value virtual mutable $lab$ : $t$ >>
+ | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp ->
+ <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >>
| "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
<:class_str_item< method virtual private $l$ : $t$ >>
| "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
@@ -1087,8 +1093,9 @@
;
class_sig_item:
[ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
- | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
+ | "val"; mf = OPT "mutable"; vf = OPT "virtual";
+ l = label; ":"; t = ctyp ->
+ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
| "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
<:class_sig_item< method virtual private $l$ : $t$ >>
| "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
Index: camlp4/etc/pr_o.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v
retrieving revision 1.51
diff -u -r1.51 pr_o.ml
--- camlp4/etc/pr_o.ml 5 Jan 2006 10:44:29 -0000 1.51
+++ camlp4/etc/pr_o.ml 5 Apr 2006 02:26:01 -0000
@@ -1768,10 +1768,11 @@
[: `S LR "method"; private_flag pf; `label lab;
`S LR ":" :];
`ctyp t "" k :]
- | MLast.CgVal _ lab mf t ->
+ | MLast.CgVal _ lab mf vf t ->
fun curr next dg k ->
[: `HVbox
- [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :];
+ [: `S LR "val"; mutable_flag mf; virtual_flag vf;
+ `label lab; `S LR ":" :];
`ctyp t "" k :]
| MLast.CgVir _ lab pf t ->
fun curr next dg k ->
Index: camlp4/meta/pa_r.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v
retrieving revision 1.64
diff -u -r1.64 pa_r.ml
--- camlp4/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.64
+++ camlp4/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000
@@ -658,7 +658,9 @@
| "inherit"; ce = class_expr; pb = OPT as_lident ->
<:class_str_item< inherit $ce$ $opt:pb$ >>
| "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
+ <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
+ | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
+ <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >>
| "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
<:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
| "method"; pf = OPT "private"; l = label; topt = OPT polyt;
@@ -701,8 +703,9 @@
[ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
<:class_sig_item< declare $list:st$ end >>
| "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
- | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
+ | "value"; mf = OPT "mutable"; vf = OPT "virtual";
+ l = label; ":"; t = ctyp ->
+ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
| "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
<:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
| "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
Index: camlp4/meta/q_MLast.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v
retrieving revision 1.60
diff -u -r1.60 q_MLast.ml
--- camlp4/meta/q_MLast.ml 29 Jun 2005 04:11:26 -0000 1.60
+++ camlp4/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000
@@ -947,6 +947,8 @@
Qast.Node "CrDcl" [Qast.Loc; st]
| "inherit"; ce = class_expr; pb = SOPT as_lident ->
Qast.Node "CrInh" [Qast.Loc; ce; pb]
+ | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
+ Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t]
| "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
| "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
@@ -992,8 +994,9 @@
[ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
Qast.Node "CgDcl" [Qast.Loc; st]
| "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
- | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
- Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
+ | "value"; mf = SOPT "mutable"; vf = SOPT "virtual";
+ l = label; ":"; t = ctyp ->
+ Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t]
| "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
| "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
Index: camlp4/ocaml_src/camlp4/ast2pt.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v
retrieving revision 1.36
diff -u -r1.36 ast2pt.ml
--- camlp4/ocaml_src/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36
+++ camlp4/ocaml_src/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000
@@ -227,6 +227,7 @@
;;
let mkmutable m = if m then Mutable else Immutable;;
let mkprivate m = if m then Private else Public;;
+let mkvirtual m = if m then Virtual else Concrete;;
let mktrecord (loc, n, m, t) =
n, mkmutable m, ctyp (mkpolytype t), mkloc loc
;;
@@ -878,8 +879,8 @@
| CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
| CgMth (loc, s, pf, t) ->
Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l
- | CgVal (loc, s, b, t) ->
- Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
+ | CgVal (loc, s, b, v, t) ->
+ Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l
| CgVir (loc, s, b, t) ->
Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
and class_expr =
@@ -923,6 +924,8 @@
| CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l
| CrVir (loc, s, b, t) ->
Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
+ | CrVvr (loc, s, b, t) ->
+ Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l
;;
let interf ast = List.fold_right sig_item ast [];;
Index: camlp4/ocaml_src/camlp4/mLast.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v
retrieving revision 1.20
diff -u -r1.20 mLast.mli
--- camlp4/ocaml_src/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.20
+++ camlp4/ocaml_src/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000
@@ -180,7 +180,7 @@
| CgDcl of loc * class_sig_item list
| CgInh of loc * class_type
| CgMth of loc * string * bool * ctyp
- | CgVal of loc * string * bool * ctyp
+ | CgVal of loc * string * bool * bool * ctyp
| CgVir of loc * string * bool * ctyp
and class_expr =
CeApp of loc * class_expr * expr
@@ -197,6 +197,7 @@
| CrMth of loc * string * bool * expr * ctyp option
| CrVal of loc * string * bool * expr
| CrVir of loc * string * bool * ctyp
+ | CrVvr of loc * string * bool * ctyp
;;
external loc_of_ctyp : ctyp -> loc = "%field0";;
Index: camlp4/ocaml_src/camlp4/reloc.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v
retrieving revision 1.20
diff -u -r1.20 reloc.ml
--- camlp4/ocaml_src/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.20
+++ camlp4/ocaml_src/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000
@@ -430,8 +430,8 @@
let nloc = floc loc in CgInh (nloc, class_type floc sh x1)
| CgMth (loc, x1, x2, x3) ->
let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3)
- | CgVal (loc, x1, x2, x3) ->
- let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3)
+ | CgVal (loc, x1, x2, x3, x4) ->
+ let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4)
| CgVir (loc, x1, x2, x3) ->
let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3)
in
@@ -478,6 +478,8 @@
let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3)
| CrVir (loc, x1, x2, x3) ->
let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3)
+ | CrVvr (loc, x1, x2, x3) ->
+ let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3)
in
self
;;
Index: camlp4/ocaml_src/meta/pa_r.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v
retrieving revision 1.59
diff -u -r1.59 pa_r.ml
--- camlp4/ocaml_src/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.59
+++ camlp4/ocaml_src/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000
@@ -2161,6 +2161,15 @@
(fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
(_loc : Lexing.position * Lexing.position) ->
(MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item));
+ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
+ Gramext.Sopt (Gramext.Stoken ("", "mutable"));
+ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
+ Gramext.Stoken ("", ":");
+ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
+ Gramext.action
+ (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item));
[Gramext.Stoken ("", "value");
Gramext.Sopt (Gramext.Stoken ("", "mutable"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
@@ -2338,13 +2347,15 @@
(MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item));
[Gramext.Stoken ("", "value");
Gramext.Sopt (Gramext.Stoken ("", "mutable"));
+ Gramext.Sopt (Gramext.Stoken ("", "virtual"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
+ (fun (t : 'ctyp) _ (l : 'label) (vf : string option)
+ (mf : string option) _
(_loc : Lexing.position * Lexing.position) ->
- (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item));
+ (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item));
[Gramext.Stoken ("", "inherit");
Gramext.Snterm
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
Index: camlp4/ocaml_src/meta/q_MLast.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v
retrieving revision 1.65
diff -u -r1.65 q_MLast.ml
--- camlp4/ocaml_src/meta/q_MLast.ml 12 Jan 2006 08:54:21 -0000 1.65
+++ camlp4/ocaml_src/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000
@@ -3152,9 +3152,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__17))])],
+ (Qast.Str x : 'e__18))])],
Gramext.action
- (fun (a : 'e__17 option)
+ (fun (a : 'e__18 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3191,9 +3191,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__16))])],
+ (Qast.Str x : 'e__17))])],
Gramext.action
- (fun (a : 'e__16 option)
+ (fun (a : 'e__17 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3216,9 +3216,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__15))])],
+ (Qast.Str x : 'e__16))])],
Gramext.action
- (fun (a : 'e__15 option)
+ (fun (a : 'e__16 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3235,6 +3235,31 @@
(_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
'class_str_item));
+ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
+ Gramext.srules
+ [[Gramext.Sopt
+ (Gramext.srules
+ [[Gramext.Stoken ("", "mutable")],
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Str x : 'e__15))])],
+ Gramext.action
+ (fun (a : 'e__15 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
+ Gramext.action
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
+ (a : 'a_opt))];
+ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
+ Gramext.Stoken ("", ":");
+ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
+ Gramext.action
+ (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item));
[Gramext.Stoken ("", "inherit");
Gramext.Snterm
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
@@ -3366,9 +3391,9 @@
Gramext.action
(fun _ (csf : 'class_sig_item)
(_loc : Lexing.position * Lexing.position) ->
- (csf : 'e__18))])],
+ (csf : 'e__19))])],
Gramext.action
- (fun (a : 'e__18 list)
+ (fun (a : 'e__19 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
@@ -3446,9 +3471,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__22))])],
+ (Qast.Str x : 'e__24))])],
Gramext.action
- (fun (a : 'e__22 option)
+ (fun (a : 'e__24 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3471,9 +3496,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__21))])],
+ (Qast.Str x : 'e__23))])],
Gramext.action
- (fun (a : 'e__21 option)
+ (fun (a : 'e__23 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3496,9 +3521,26 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__20))])],
+ (Qast.Str x : 'e__21))])],
Gramext.action
- (fun (a : 'e__20 option)
+ (fun (a : 'e__21 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
+ Gramext.action
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
+ (a : 'a_opt))];
+ Gramext.srules
+ [[Gramext.Sopt
+ (Gramext.srules
+ [[Gramext.Stoken ("", "virtual")],
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Str x : 'e__22))])],
+ Gramext.action
+ (fun (a : 'e__22 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3510,9 +3552,10 @@
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _
+ (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
+ (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) :
+ 'class_sig_item));
[Gramext.Stoken ("", "inherit");
Gramext.Snterm
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
@@ -3531,9 +3574,9 @@
Gramext.action
(fun _ (s : 'class_sig_item)
(_loc : Lexing.position * Lexing.position) ->
- (s : 'e__19))])],
+ (s : 'e__20))])],
Gramext.action
- (fun (a : 'e__19 list)
+ (fun (a : 'e__20 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
@@ -3556,9 +3599,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__23))])],
+ (Qast.Str x : 'e__25))])],
Gramext.action
- (fun (a : 'e__23 option)
+ (fun (a : 'e__25 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3593,9 +3636,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__24))])],
+ (Qast.Str x : 'e__26))])],
Gramext.action
- (fun (a : 'e__24 option)
+ (fun (a : 'e__26 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3713,9 +3756,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__25))])],
+ (Qast.Str x : 'e__27))])],
Gramext.action
- (fun (a : 'e__25 option)
+ (fun (a : 'e__27 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -3922,9 +3965,9 @@
Gramext.action
(fun (x : string)
(_loc : Lexing.position * Lexing.position) ->
- (Qast.Str x : 'e__26))])],
+ (Qast.Str x : 'e__28))])],
Gramext.action
- (fun (a : 'e__26 option)
+ (fun (a : 'e__28 option)
(_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
@@ -4390,9 +4433,9 @@
Gramext.action
(fun _ (e : 'expr)
(_loc : Lexing.position * Lexing.position) ->
- (e : 'e__29))])],
+ (e : 'e__31))])],
Gramext.action
- (fun (a : 'e__29 list)
+ (fun (a : 'e__31 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
@@ -4425,9 +4468,9 @@
Gramext.action
(fun _ (e : 'expr)
(_loc : Lexing.position * Lexing.position) ->
- (e : 'e__28))])],
+ (e : 'e__30))])],
Gramext.action
- (fun (a : 'e__28 list)
+ (fun (a : 'e__30 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
@@ -4454,9 +4497,9 @@
Gramext.action
(fun _ (e : 'expr)
(_loc : Lexing.position * Lexing.position) ->
- (e : 'e__27))])],
+ (e : 'e__29))])],
Gramext.action
- (fun (a : 'e__27 list)
+ (fun (a : 'e__29 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
@@ -4547,9 +4590,9 @@
Gramext.action
(fun _ (cf : 'class_str_item)
(_loc : Lexing.position * Lexing.position) ->
- (cf : 'e__30))])],
+ (cf : 'e__32))])],
Gramext.action
- (fun (a : 'e__30 list)
+ (fun (a : 'e__32 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
@@ -4592,9 +4635,9 @@
Gramext.action
(fun _ (csf : 'class_sig_item)
(_loc : Lexing.position * Lexing.position) ->
- (csf : 'e__32))])],
+ (csf : 'e__34))])],
Gramext.action
- (fun (a : 'e__32 list)
+ (fun (a : 'e__34 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
@@ -4623,9 +4666,9 @@
Gramext.action
(fun _ (csf : 'class_sig_item)
(_loc : Lexing.position * Lexing.position) ->
- (csf : 'e__31))])],
+ (csf : 'e__33))])],
Gramext.action
- (fun (a : 'e__31 list)
+ (fun (a : 'e__33 list)
(_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
Index: camlp4/top/rprint.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v
retrieving revision 1.18
diff -u -r1.18 rprint.ml
--- camlp4/top/rprint.ml 29 Jun 2005 04:11:26 -0000 1.18
+++ camlp4/top/rprint.ml 5 Apr 2006 02:26:01 -0000
@@ -288,8 +288,9 @@
fprintf ppf "@[<2>method %s%s%s :@ %a;@]"
(if priv then "private " else "") (if virt then "virtual " else "")
name Toploop.print_out_type.val ty
- | Ocsg_value name mut ty ->
- fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "")
+ | Ocsg_value name mut virt ty ->
+ fprintf ppf "@[<2>value %s%s%s :@ %a;@]"
+ (if mut then "mutable " else "") (if virt then "virtual " else "")
name Toploop.print_out_type.val ty ]
;
Reference in New Issue View Git Blame Copy Permalink