Fix unboxed types check

5 files changed, 24 insertions, 8 deletions

diff --git a/Changes b/Changes
index 9827cf6380..65f531f2d7 100644
--- a/Changes
+++ b/Changes
@@ -690,6 +690,8 @@ Release branch for 4.06:
   in the position of the expression (same behavior as for lists)
   (Christophe Raffalli, review by Gabriel Scherer)
 
+- GPR#1390: fix the [@@unboxed] type check to accept parametrized types
+  (Leo White, review by Damien Doligez)
 
 OCaml 4.05.0 (13 Jul 2017):
 ---------------------------
diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml
index 8e0b337bc8..4391fcbbaa 100644
--- a/testsuite/tests/typing-unboxed-types/test.ml
+++ b/testsuite/tests/typing-unboxed-types/test.ml
@@ -154,3 +154,10 @@ type 'a t = T : 'a s -> 'a t [@@unboxed];;
 type _ s = S : 'a t -> _ s  [@@unboxed]
  and _ t = T : 'a -> 'a s t
 ;;
+
+
+(* Another corner case *)
+type 'a s
+type ('a, 'p) t = private 'a s
+type 'a packed = T : ('a, _) t -> 'a packed [@@unboxed]
+;;
diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference-flat b/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
index 10a118d86f..f6d6aaa19c 100644
--- a/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
@@ -200,4 +200,7 @@ Error: This type cannot be unboxed because
 Error: This type cannot be unboxed because
        it might contain both float and non-float values.
        You should annotate it with [@@ocaml.boxed].
+#             type 'a s
+type ('a, 'p) t = private 'a s
+type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
 # 
diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat b/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
index ca52fed5d6..73c03fd882 100644
--- a/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
@@ -166,4 +166,7 @@ Error: Signature mismatch:
 #     type 'a t = T : 'a s -> 'a t [@@unboxed]
 #           type _ s = S : 'a t -> 'b s [@@unboxed]
 and _ t = T : 'a -> 'a s t
+#             type 'a s
+type ('a, 'p) t = private 'a s
+type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
 # 
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 63cc2b5b1a..2369b84c68 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -267,7 +267,7 @@ let make_constructor env type_path type_params sargs sret_type =
       let args, targs =
         transl_constructor_arguments env true sargs
       in
-        targs, None, args, None
+        targs, None, args, None, type_params
   | Some sret_type ->
       (* if it's a generalized constructor we must first narrow and
          then widen so as to not introduce any new constraints *)
@@ -278,15 +278,16 @@ let make_constructor env type_path type_params sargs sret_type =
       in
       let tret_type = transl_simple_type env false sret_type in
       let ret_type = tret_type.ctyp_type in
-      begin
+      let params =
         match (Ctype.repr ret_type).desc with
-          Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | Tconstr (p', params, _) when Path.same type_path p' ->
+            params
         | _ ->
             raise (Error (sret_type.ptyp_loc, Constraint_failed
                             (ret_type, Ctype.newconstr type_path type_params)))
-      end;
+      in
       widen z;
-      targs, Some tret_type, args, Some ret_type
+      targs, Some tret_type, args, Some ret_type, params
 
 (* Check that the variable [id] is present in the [univ] list. *)
 let check_type_var loc univ id =
@@ -444,7 +445,7 @@ let transl_declaration env sdecl id =
           raise(Error(sdecl.ptype_loc, Too_many_constructors));
         let make_cstr scstr =
           let name = Ident.create scstr.pcd_name.txt in
-          let targs, tret_type, args, ret_type =
+          let targs, tret_type, args, ret_type, cstr_params =
             make_constructor env (Path.Pident id) params
                              scstr.pcd_args scstr.pcd_res
           in
@@ -463,7 +464,7 @@ let transl_declaration env sdecl id =
             match Datarepr.constructor_existentials args ret_type with
             | _, [] -> ()
             | [argty], _ex ->
-                check_unboxed_gadt_arg sdecl.ptype_loc params env argty
+                check_unboxed_gadt_arg sdecl.ptype_loc cstr_params env argty
             | _ -> assert false
           end;
           let tcstr =
@@ -1408,7 +1409,7 @@ let transl_extension_constructor env type_path type_params
   let args, ret_type, kind =
     match sext.pext_kind with
       Pext_decl(sargs, sret_type) ->
-        let targs, tret_type, args, ret_type =
+        let targs, tret_type, args, ret_type, _ =
           make_constructor env type_path typext_params
             sargs sret_type
         in