summaryrefslogtreecommitdiff
path: root/typing
diff options
context:
space:
mode:
Diffstat (limited to 'typing')
-rw-r--r--typing/btype.ml2
-rw-r--r--typing/ctype.ml47
-rw-r--r--typing/ctype.mli3
-rw-r--r--typing/includeclass.ml7
-rw-r--r--typing/oprint.ml6
-rw-r--r--typing/outcometree.mli2
-rw-r--r--typing/printtyp.ml14
-rw-r--r--typing/subst.ml3
-rw-r--r--typing/typeclass.ml182
-rw-r--r--typing/typeclass.mli5
-rw-r--r--typing/typecore.ml6
-rw-r--r--typing/typecore.mli3
-rw-r--r--typing/typedtree.ml5
-rw-r--r--typing/typedtree.mli6
-rw-r--r--typing/typemod.ml6
-rw-r--r--typing/types.ml6
-rw-r--r--typing/types.mli6
-rw-r--r--typing/unused_var.ml2
18 files changed, 204 insertions, 107 deletions
diff --git a/typing/btype.ml b/typing/btype.ml
index 76ec1c4c17..fb7a289a2c 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -330,7 +330,7 @@ let unmark_type_decl decl =
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
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 4ce19f41ff..114ed4f899 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -857,7 +857,7 @@ let instance_class params cty =
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 @@ type class_match_failure =
| 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 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
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 @@ let match_class_types env pat_sch subj_sch =
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 @@ let match_class_types env pat_sch subj_sch =
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 @@ let match_class_types env pat_sch subj_sch =
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 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
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 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
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 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
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 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
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_type_decl env mid id is_covariant decl =
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 =
diff --git a/typing/ctype.mli b/typing/ctype.mli
index a4eca32df6..ffc8b872e2 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -170,10 +170,11 @@ type class_match_failure =
| 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
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 912f64ace8..49e0ce9d2e 100644
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -78,14 +78,17 @@ let include_err ppf =
| 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 ->
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 55178d89b7..bec27b863d 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -291,8 +291,10 @@ and print_out_class_sig_item ppf =
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
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index c7031912be..852a9ee15a 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -71,7 +71,7 @@ type out_class_type =
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
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 5f320b3d93..a1ac5c4830 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -650,7 +650,7 @@ let rec prepare_class_type params = function
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 @@ let rec tree_of_class_type sch params =
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 @@ let tree_of_cltype_declaration id cl rs =
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,
diff --git a/typing/subst.ml b/typing/subst.ml
index c5c3efe9d0..25f557ec52 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -178,7 +178,8 @@ let type_declaration s decl =
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))
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 53e7765d8a..d6439cafae 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -24,7 +24,7 @@ open Format
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 @@ type error =
| 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 @@ type error =
| 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 @@ let rec generalize_class_type =
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 @@ let rec closed_class_type =
| 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 @@ let rec limited_generalize rv =
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 @@ let enter_met_env lab kind ty val_env met_env par_env =
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 @@ let inheritance self_type env concr_meths warn_meths loc parent =
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 @@ let virtual_method val_env meths self_type lab priv sty loc =
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 @@ let declare_method val_env meths self_type lab priv sty loc =
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 make_method cl_num expr =
(*******************************)
+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 @@ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
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 @@ module StringSet = Set.Make(struct type t = string let compare = compare end)
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 @@ let rec class_field cl_num self_type meths vars
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 @@ let rec class_field cl_num self_type meths vars
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 @@ let rec class_field cl_num self_type meths vars
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
+ 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, exp)) :: fields,
- concr_meths, warn_meths, inh_vals, inher)
+ (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 @@ let rec class_field cl_num self_type meths vars
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 @@ let rec class_field cl_num self_type meths vars
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 @@ let rec class_field cl_num self_type meths vars
([], 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 @@ let rec class_field cl_num self_type meths vars
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 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
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 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
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 @@ let class_infos define_class kind
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 @@ let report_error ppf = function
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 @@ let report_error ppf = function
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 @@ let report_error ppf = function
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
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index b26b9e72e7..20d2d32503 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -49,7 +49,7 @@ val virtual_methods: Types.class_signature -> label list
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 @@ type error =
| 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 @@ type error =
| 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
diff --git a/typing/typecore.ml b/typing/typecore.ml
index fe3500a60e..d8c1cb4cc4 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -611,11 +611,11 @@ let rec is_nonexpansive exp =
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 @@ let rec type_exp env sexp =
(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 ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 993bcb9c1e..395a2a0da6 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -38,7 +38,8 @@ val type_self_pattern:
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) ->
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index ab05b564dd..942b4ce000 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -106,7 +106,7 @@ and class_structure =
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 @@ and structure_item =
| 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
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 587b088741..ebf8aba700 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -107,7 +107,8 @@ and class_structure =
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 @@ and structure_item =
| 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
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 23235ea2d7..fffc792798 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -17,6 +17,7 @@
open Misc
open Longident
open Path
+open Asttypes
open Parsetree
open Types
open Typedtree
@@ -667,8 +668,9 @@ and type_structure anchor env sstr =
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
diff --git a/typing/types.ml b/typing/types.ml
index d9c5c1c817..d2512500c5 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -90,7 +90,8 @@ and value_kind =
| 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 @@ type class_type =
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 }
diff --git a/typing/types.mli b/typing/types.mli
index 31a572a54c..6ac6f2ad1e 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -91,7 +91,8 @@ and value_kind =
| 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 @@ type class_type =
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 }
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index 9bf13e4295..d5dd5d2361 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -245,7 +245,7 @@ and class_field ppf tbl cf =
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;
View Lorry Controller Status