Merge pull request #9861 from trefis/9858

Catch Nondep_cannot_erase

Changes

@@ -554,6 +554,9 @@ Working version
 - #9848, #9855: Fix double free of bytecode in toplevel
   (Stephen Dolan, report by Sampsa Kiiskinen, review by Gabriel Scherer)
 
+- #9858, #9861: Compiler fails with Ctype.Nondep_cannot_erase exception
+  (Thomas Refis, report by @pveber, review by Florian Angeletti)
+
 - #9860: wrong range constraint for subtract immediate on zSystems / s390x
   (Xavier Leroy, review by Stephen Dolan)
 

testsuite/tests/typing-fstclassmod/nondep_instance.ml

@@ -0,0 +1,51 @@
+(* TEST
+   * expect *)
+
+module type Vector_space = sig
+  type t
+  type scalar
+  val scale : scalar -> t -> t
+end;;
+[%%expect{|
+module type Vector_space =
+  sig type t type scalar val scale : scalar -> t -> t end
+|}];;
+
+module type Scalar = sig
+  type t
+  include Vector_space with type t := t
+                        and type scalar = t
+end;;
+[%%expect{|
+module type Scalar =
+  sig type t type scalar = t val scale : scalar -> t -> t end
+|}];;
+
+module type Linear_map = sig
+  type ('a, 'b) t
+  val scale :
+    (module Vector_space with type t = 'a and type scalar = 'l) ->
+    'l -> ('a, 'a) t
+end;;
+[%%expect{|
+module type Linear_map =
+  sig
+    type ('a, 'b) t
+    val scale :
+      (module Vector_space with type scalar = 'l and type t = 'a) ->
+      'l -> ('a, 'a) t
+  end
+|}];;
+
+module Primitive(Linear_map : Linear_map) = struct
+  let f (type s) (s : (module Scalar with type t = s)) x =
+    Linear_map.scale s x
+end;;
+[%%expect{|
+Line 3, characters 21-22:
+3 |     Linear_map.scale s x
+                         ^
+Error: This expression has type (module Scalar with type t = s)
+       but an expression was expected of type
+         (module Vector_space with type scalar = 'a and type t = 'b)
+|}];;

typing/ctype.ml

@@ -2484,6 +2484,8 @@ let eq_package_path env p1 p2 =
 let nondep_type' = ref (fun _ _ _ -> assert false)
 let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false)
 
+exception Nondep_cannot_erase of Ident.t
+
 let rec concat_longident lid1 =
   let open Longident in
   function
@@ -2525,7 +2527,14 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
         match Env.find_type_by_name lid env' with
         | (_, {type_arity = 0; type_kind = Type_abstract;
                type_private = Public; type_manifest = Some t2}) ->
-            (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
+            begin match nondep_instance env' lv2 id2 t2 with
+            | t -> (n, t) :: complete nl ntl2
+            | exception Nondep_cannot_erase _ ->
+                if allow_absent then
+                  complete nl ntl2
+                else
+                  raise Exit
+            end
         | (_, {type_arity = 0; type_kind = Type_abstract;
                type_private = Public; type_manifest = None})
           when allow_absent ->
@@ -4618,8 +4627,6 @@ let nondep_variants = TypeHash.create 17
 let clear_hash ()   =
   TypeHash.clear nondep_hash; TypeHash.clear nondep_variants
 
-exception Nondep_cannot_erase of Ident.t
-
 let rec nondep_type_rec ?(expand_private=false) env ids ty =
   let expand_abbrev env t =
     if expand_private then expand_abbrev_opt env t else expand_abbrev env t