path: root/experimental/garrigue/valvirt.diff

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