From 4bb84be29e2ea5eb9f979c5e3bcbde1933aa300e Mon Sep 17 00:00:00 2001
From: Florian Angeletti <florian.angeletti@inria.fr>
Date: Mon, 18 Jul 2022 10:08:53 +0200
Subject: [PATCH 14/24] Merge pull request #11417 from
 lpw25/fix-virtual-class-type-constrs

Fix regression allowing virtual methods in non-virtual classes

(cherry picked from commit 4be851ed8ea1f0c6be13dce04dcc97493c6c004b)
---
 Changes                                 | 13 +-----
 testsuite/tests/typing-objects/Tests.ml | 61 +++++++++++++++++++++++++
 typing/typeclass.ml                     | 11 +++++
 3 files changed, 74 insertions(+), 11 deletions(-)

diff --git a/Changes b/Changes
index 6f92ee9965..a9a9ee92f4 100644
--- a/Changes
+++ b/Changes
@@ -25,17 +25,8 @@ OCaml 4.14 maintenance branch
 - #11392, #11392: assertion failure with -rectypes and external definitions
   (Gabriel Scherer, review by Florian Angeletti, report by Dmitrii Kosarev)
 
-### Compiler user-interface and warnings:
-
-- #11184: Stop calling ranlib on created / installed libraries
-  (Sébastien Hinderer, review by Xavier Leroy)
-
-### Manual and documentation:
-
-- #11045, #11409: document that the array argument to `caml_callbackN`
-  must not have been declared by `CAMLlocalN`.
-  (Xavier Leroy, report by Stephen Dolan, review by Gabriel Scherer.)
-
+- #11417: Fix regression allowing virtual methods in non-virtual classes.
+  (Leo White, review by Florian Angeletti)
 
 OCaml 4.14.0 (28 March 2022)
 ----------------------------
diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index 3dcd87c43c..9cab28e432 100644
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -1344,3 +1344,64 @@ let _ = (new foo)#f true
 class foo : object method f : bool -> bool end
 - : bool = true
 |}];;
+
+
+class c : object
+    method virtual m : int
+end = object
+    method m = 9
+  end
+[%%expect {|
+Lines 1-3, characters 10-3:
+1 | ..........object
+2 |     method virtual m : int
+3 | end.........
+Error: This non-virtual class type has virtual methods.
+       The following methods are virtual : m
+|}];;
+
+class virtual c : object
+    method virtual m : int
+end = object
+    method m = 42
+  end
+[%%expect {|
+class virtual c : object method virtual m : int end
+|}];;
+
+class virtual cv = object
+    method virtual m : int
+  end
+
+class c : cv = object
+    method m = 42
+  end
+[%%expect {|
+class virtual cv : object method virtual m : int end
+Line 5, characters 10-12:
+5 | class c : cv = object
+              ^^
+Error: This non-virtual class type has virtual methods.
+       The following methods are virtual : m
+|}];;
+
+class virtual c : cv = object
+    method m = 41
+  end
+[%%expect {|
+class virtual c : cv
+|}];;
+
+class c = cv
+[%%expect {|
+Line 1, characters 10-12:
+1 | class c = cv
+              ^^
+Error: This non-virtual class has virtual methods.
+       The following methods are virtual : m
+|}];;
+
+class virtual c = cv
+[%%expect {|
+class virtual c : cv
+|}];;
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index fedbc0e025..8fa8523cc9 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -177,6 +177,13 @@ let check_virtual loc env virt kind sign =
       | meths, vars ->
           raise(Error(loc, env, Virtual_class(kind, meths, vars)))
 
+let rec check_virtual_clty loc env virt kind clty =
+  match clty with
+  | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) ->
+      check_virtual_clty loc env virt kind clty
+  | Cty_signature sign ->
+      check_virtual loc env virt kind sign
+
 (* Return the constructor type associated to a class type *)
 let rec constructor_type constr cty =
   match cty with
@@ -398,6 +405,8 @@ and class_type_aux env virt self_scope scty =
         )       styl params
       in
       let typ = Cty_constr (path, params, clty) in
+      (* Check for unexpected virtual methods *)
+      check_virtual_clty scty.pcty_loc env virt Class_type typ;
       cltyp (Tcty_constr ( path, lid , ctys)) typ
 
   | Pcty_signature pcsig ->
@@ -1077,6 +1086,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
            try Ctype.unify val_env ty' ty with Ctype.Unify err ->
              raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err)))
         tyl params;
+      (* Check for unexpected virtual methods *)
+      check_virtual_clty scl.pcl_loc val_env virt Class clty';
       let cl =
         rc {cl_desc = Tcl_ident (path, lid, tyl);
             cl_loc = scl.pcl_loc;
-- 
2.37.0.rc2