summaryrefslogtreecommitdiffstats
path: root/testlabl/valvirt.diffs
diff options
context:
space:
mode:
Diffstat (limited to 'testlabl/valvirt.diffs')
-rw-r--r--testlabl/valvirt.diffs2349
1 files changed, 0 insertions, 2349 deletions
diff --git a/testlabl/valvirt.diffs b/testlabl/valvirt.diffs
deleted file mode 100644
index 2cf55742b..000000000
--- a/testlabl/valvirt.diffs
+++ /dev/null
@@ -1,2349 +0,0 @@
-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 ]
- ;
-
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-23 14:56:15 +0000