From 2912ed4fde14e34b58c482cb81fb88676ab3ffc2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Wed, 27 Apr 2022 14:46:47 +0200 Subject: [PATCH 01/24] Do not trigger warning when calling virtual methods introduced by constraining "self" (#11204) (cherry picked from commit 1e7af3f6261502bb384dc9e23a74ad0990bfd854) --- Changes | 11 ++++++- testsuite/tests/typing-objects/Tests.ml | 15 ++++++++++ typing/typeclass.ml | 40 ++++++++++--------------- 3 files changed, 40 insertions(+), 26 deletions(-) diff --git a/Changes b/Changes index a8ce94bdc6..931a74b8d1 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,13 @@ +OCaml 4.14 maintenance branch +----------------------------- + +### Bug fixes: + +- #11204: Fix regression introduced in 4.14.0 that would trigger Warning 17 when + calling virtual methods introduced by constraining the self type from within + the class definition. + (Nicolás Ojeda Bär, review by Leo White) + OCaml 4.14.0 (28 March 2022) ---------------------------- @@ -62,7 +72,6 @@ OCaml 4.14.0 (28 March 2022) definition-aware operations. (Ulysse Gérard, Thomas Refis and Leo White, review by Florian Angeletti) - ### Language features: - #10462: Add attribute to produce a compiler error for polls. diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index f617bcf1b9..3dcd87c43c 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -955,6 +955,21 @@ Warning 17 [undeclared-virtual-method]: the virtual method m is not declared. class c : object method m : int method n : int end |}];; +class virtual c = object (self : 'c) + constraint 'c = < f : int; .. > +end +[%%expect {| +class virtual c : object method virtual f : int end +|}];; + +class virtual c = object (self : 'c) + constraint 'c = < f : int; .. > + method g = self # f +end +[%%expect {| +class virtual c : object method virtual f : int method g : int end +|}];; + class [ 'a ] c = object (_ : 'a) end;; let o = object method m = 1 diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 048ee998b0..fedbc0e025 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -552,12 +552,11 @@ type first_pass_accummulater = concrete_vals : VarSet.t; local_meths : MethSet.t; local_vals : VarSet.t; - vars : Ident.t Vars.t; - meths : Ident.t Meths.t; } + vars : Ident.t Vars.t; } let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; - local_meths; local_vals; vars; meths } = acc + local_meths; local_vals; vars } = acc in let loc = cf.pcf_loc in let attributes = cf.pcf_attributes in @@ -612,13 +611,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = (val_env, par_env, inherited_vars, vars)) parent_sign.csig_vars (val_env, par_env, [], vars) in - let meths = - Meths.fold - (fun label _ meths -> - if Meths.mem label meths then meths - else Meths.add label (Ident.create_local label) meths) - parent_sign.csig_meths meths - in (* Methods available through super *) let super_meths = MethSet.fold @@ -641,7 +633,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = in let rev_fields = field :: rev_fields in { acc with rev_fields; val_env; par_env; - concrete_meths; concrete_vals; vars; meths }) + concrete_meths; concrete_vals; vars }) | Pcf_val (label, mut, Cfk_virtual styp) -> with_attrs (fun () -> @@ -723,15 +715,11 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let cty = transl_simple_type val_env false sty in let ty = cty.ctyp_type in add_method loc val_env label.txt priv Virtual ty sign; - let meths = - if Meths.mem label.txt meths then meths - else Meths.add label.txt (Ident.create_local label.txt) meths - in let field = Virtual_method { label; priv; cty; loc; attributes } in let rev_fields = field :: rev_fields in - { acc with rev_fields; meths }) + { acc with rev_fields }) | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> with_attrs @@ -785,10 +773,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = raise(Error(loc, val_env, Field_type_mismatch ("method", label.txt, err))) end; - let meths = - if Meths.mem label.txt meths then meths - else Meths.add label.txt (Ident.create_local label.txt) meths - in let sdefinition = make_method self_loc cl_num expr in let warning_state = Warnings.backup () in let field = @@ -799,7 +783,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let rev_fields = field :: rev_fields in let concrete_meths = MethSet.add label.txt concrete_meths in let local_meths = MethSet.add label.txt local_meths in - { acc with rev_fields; concrete_meths; local_meths; meths }) + { acc with rev_fields; concrete_meths; local_meths }) | Pcf_constraint (sty1, sty2) -> with_attrs @@ -837,11 +821,10 @@ and class_fields_first_pass self_loc cl_num sign self_scope let local_meths = MethSet.empty in let local_vals = VarSet.empty in let vars = Vars.empty in - let meths = Meths.empty in let init_acc = { rev_fields; val_env; par_env; concrete_meths; concrete_vals; - local_meths; local_vals; vars; meths } + local_meths; local_vals; vars } in let acc = Builtin_attributes.warning_scope [] @@ -850,7 +833,7 @@ and class_fields_first_pass self_loc cl_num sign self_scope (class_field_first_pass self_loc cl_num sign self_scope) init_acc cfs) in - List.rev acc.rev_fields, acc.vars, acc.meths + List.rev acc.rev_fields, acc.vars and class_field_second_pass cl_num sign met_env field = let mkcf desc loc attrs = @@ -1003,7 +986,7 @@ and class_structure cl_num virt self_scope final val_env met_env loc end; (* Typing of class fields *) - let (fields, vars, meths) = + let (fields, vars) = class_fields_first_pass self_loc cl_num sign self_scope val_env par_env str in @@ -1016,6 +999,13 @@ and class_structure cl_num virt self_scope final val_env met_env loc update_class_signature loc val_env ~warn_implicit_public:false virt kind sign; + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + (* Close the signature if it is final *) begin match final with | Not_final -> () -- 2.37.0.rc2