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 10 Mar 2006 06:41:24 -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 overriden \ 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 overriden.\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 10 Mar 2006 06:41:24 -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 10 Mar 2006 06:41:24 -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 10 Mar 2006 06:41:24 -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 10 Mar 2006 06:41:24 -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 10 Mar 2006 06:41:24 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:25 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 overriden method\n\ + \032 M/m enable/disable overriden 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 overriden 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 10 Mar 2006 06:41:26 -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 overriden 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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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.141 diff -u -r1.141 sys.ml --- stdlib/sys.ml 24 Jan 2006 11:12:26 -0000 1.141 +++ stdlib/sys.ml 10 Mar 2006 06:41:26 -0000 @@ -78,4 +78,4 @@ (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.10+dev3 (2006-01-24)";; +let ocaml_version = "3.10+dev4 (2006-03-09)";; 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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:26 -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 10 Mar 2006 06:41:27 -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 10 Mar 2006 06:41:27 -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 10 Mar 2006 06:41:27 -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 10 Mar 2006 06:41:27 -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 10 Mar 2006 06:41:27 -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 10 Mar 2006 06:41:27 -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 10 Mar 2006 06:41:27 -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 10 Mar 2006 06:41:27 -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 ] ;