roll back addition of abstract new typesnon-vanishing

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/non-vanishing@13597 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

8 files changed, 9 insertions, 128 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 615e25b416..7c63568398 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1394,15 +1394,7 @@ type_kind:
   | EQUAL PRIVATE core_type
       { (Ptype_abstract, Private, false, Some $3) }
   | EQUAL NEW core_type
-      { (Ptype_abstract, Public, true, Some $3) }
-  | EQUAL NEW
-      { (Ptype_abstract, Public, true, None) }
-  | EQUAL NEW constructor_declarations
-      { (Ptype_variant(List.rev $3), Public, true, None) }
-  | EQUAL NEW BAR constructor_declarations
-      { (Ptype_variant(List.rev $4), Public, true, None) }
-  | EQUAL NEW LBRACE label_declarations opt_semi RBRACE
-      { (Ptype_record(List.rev $4), Public, true, None) }
+      { (Ptype_abstract, Private, true, Some $3) }
   | EQUAL constructor_declarations
       { (Ptype_variant(List.rev $2), Public, false, None) }
   | EQUAL PRIVATE constructor_declarations
diff --git a/testsuite/tests/typing-private/new.ml b/testsuite/tests/typing-private/new.ml
index 09ecf2e1d7..70354a41d3 100644
--- a/testsuite/tests/typing-private/new.ml
+++ b/testsuite/tests/typing-private/new.ml
@@ -1,4 +1,3 @@
-(* Concrete new types *)
 module M1 : sig type 'a t val f : int t -> bool t end =
   struct type 'a t = new int let f x = x+1 end;;
 
@@ -22,45 +21,3 @@ module M8 : sig type 'a t  val f : int t ref -> int end =
 
 module M9 : sig type 'a t  val f : int -> int t ref end =
   struct type 'a t = new int  let f x = ref x end;; (* should be ok *)
-
-(* Abstract new types *)
-module M : sig type t = new type u = new end =
-  struct type t = new int type u = new int end;;
-type (_,_) comp = Eq : ('a,'a) comp | Diff : ('a,'b) comp;;
-fun (x : (M.t,M.u) comp) -> match x with Diff -> false;; (* ok *)
-
-(* new datatypes *)
-module M = struct type t = new T   type u = t = T end;; (* fail *)
-
-module M : sig
-  type t = new   type t' = new
-  type u = new T type u' = new T
-  type v = T     type v' = T     type v2 = V
-  type z         type z'
-end = struct
-  type t = new T type t' = new T
-  type u = new T type u' = new T
-  type v = T     type v' = T     type v2 = V
-  type z = T     type z' = T
-end;;
-fun (x : (M.t,M.t') comp) -> match x with Diff -> false;; (* ok *)
-fun (x : (M.t,M.u) comp)  -> match x with Diff -> false;; (* ok *)
-fun (x : (M.t,M.v) comp)  -> match x with Diff -> false;; (* ok *)
-fun (x : (M.t,M.z) comp)  -> match x with Diff -> false;; (* warn *)
-fun (x : (M.u,M.u') comp) -> match x with Diff -> false;; (* ok *)
-fun (x : (M.u,M.v) comp)  -> match x with Diff -> false;; (* ok *)
-fun (x : (M.u,M.z) comp)  -> match x with Diff -> false;; (* warn *)
-fun (x : (M.v,M.v') comp) -> match x with Diff -> false;; (* warn *)
-fun (x : (M.v,M.v2) comp) -> match x with Diff -> false;; (* ok *)
-fun (x : (M.v,M.z) comp)  -> match x with Diff -> false;; (* warn *)
-fun (x : (M.z,M.z') comp) -> match x with Diff -> false;; (* warn *)
-
-(* Actually, this is broken *)
-module M : sig type t = new type _ is_t = I : ('a,t) comp -> 'a is_t end =
-  struct type t = new int  type _ is_t = I : ('a,t) comp -> 'a is_t end;;
-
-module N = M;;
-
-let e = M.I Eq;;
-let N.I e' = e;;
-match e' with Diff -> false;; (* Should warn! *)
diff --git a/testsuite/tests/typing-private/new.ml.reference b/testsuite/tests/typing-private/new.ml.reference
index cb1fdfb471..5f84c4a5ef 100644
--- a/testsuite/tests/typing-private/new.ml.reference
+++ b/testsuite/tests/typing-private/new.ml.reference
@@ -1,5 +1,5 @@
 
-#     module M1 : sig type 'a t val f : int t -> bool t end
+#   module M1 : sig type 'a t val f : int t -> bool t end
 #     module M2 : sig type 'a t = new int val f : int -> int val r : int ref end
 #   module M3 : sig type 'a t val f : int t -> bool t end
 #   Characters 52-54:
@@ -42,65 +42,4 @@ Error: Signature mismatch:
          val f : 'a -> 'a ref
        is not included in
          val f : int -> int t ref
-#       module M : sig type t = new type u = new end
-# type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
-# - : (M.t, M.u) comp -> bool = <fun>
-#     Characters 61-70:
-  module M = struct type t = new T   type u = t = T end;; (* fail *)
-                                          ^^^^^^^^^
-Error: This variant or record definition does not match that of type t
-       A private or new type would be made transparent.
-#                       module M :
-  sig
-    type t = new
-    type t' = new
-    type u = new T
-    type u' = new T
-    type v = T
-    type v' = T
-    type v2 = V
-    type z
-    type z'
-  end
-# - : (M.t, M.t') comp -> bool = <fun>
-# - : (M.t, M.u) comp -> bool = <fun>
-# - : (M.t, M.v) comp -> bool = <fun>
-# Characters 29-55:
-  fun (x : (M.t,M.z) comp)  -> match x with Diff -> false;; (* warn *)
-                               ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-- : (M.t, M.z) comp -> bool = <fun>
-# - : (M.u, M.u') comp -> bool = <fun>
-# - : (M.u, M.v) comp -> bool = <fun>
-# Characters 29-55:
-  fun (x : (M.u,M.z) comp)  -> match x with Diff -> false;; (* warn *)
-                               ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-- : (M.u, M.z) comp -> bool = <fun>
-# Characters 29-55:
-  fun (x : (M.v,M.v') comp) -> match x with Diff -> false;; (* warn *)
-                               ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-- : (M.v, M.v') comp -> bool = <fun>
-# - : (M.v, M.v2) comp -> bool = <fun>
-# Characters 29-55:
-  fun (x : (M.v,M.z) comp)  -> match x with Diff -> false;; (* warn *)
-                               ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-- : (M.v, M.z) comp -> bool = <fun>
-# Characters 29-55:
-  fun (x : (M.z,M.z') comp) -> match x with Diff -> false;; (* warn *)
-                               ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-- : (M.z, M.z') comp -> bool = <fun>
 # 
diff --git a/typing/ctype.ml b/typing/ctype.ml
index c952e93b21..78d576128e 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1906,7 +1906,6 @@ let is_abstract_newtype env p =
 
 let non_aliasable p decl =
   (* in_pervasives p ||  (subsumed by in_current_module) *)
-  decl.type_transparence = Type_new ||
   in_current_module p && decl.type_newtype_level = None
 
 (* mcomp type_pairs subst env t1 t2 does not raise an
@@ -2042,10 +2041,7 @@ and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 =
       List.iter2
         (fun i (t1,t2) -> if i then mcomp type_pairs subst env t1 t2)
         inj (List.combine tl1 tl2)
-    end
-    else if non_aliasable p1 decl && (non_aliasable p2 decl'||is_datatype decl')
-         || is_datatype decl && non_aliasable p2 decl' then raise (Unify [])
-    else match decl.type_kind, decl'.type_kind with
+    end else match decl.type_kind, decl'.type_kind with
     | Type_record (lst,r), Type_record (lst',r') when r = r' ->
         mcomp_list type_pairs subst env tl1 tl2;
         mcomp_record_description type_pairs subst env lst lst'
@@ -2054,7 +2050,9 @@ and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 =
         mcomp_variant_description type_pairs subst env v1 v2
     | Type_variant _, Type_record _
     | Type_record _, Type_variant _ -> raise (Unify [])
-    | _ -> ()
+    | _ ->
+        if non_aliasable p1 decl && (non_aliasable p2 decl'||is_datatype decl')
+        || is_datatype decl && non_aliasable p2 decl' then raise (Unify [])
   with Not_found -> ()
 
 and mcomp_type_option type_pairs subst env t t' =
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 82da01c77e..95903b91c1 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -46,9 +46,8 @@ and strengthen_sig env sg p =
   | Sig_type(id, decl, rs) :: rem ->
       let newdecl =
         match decl.type_manifest, decl.type_transparence, decl.type_kind with
-          Some _, Type_public, _ -> decl
+          Some _, (Type_public|Type_new), _ -> decl
         | Some _, Type_private, (Type_record _ | Type_variant _) -> decl
-        | _, Type_new, _ -> decl
         | _ ->
             let manif =
               Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 5ef15cac57..271acf5be9 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -430,9 +430,7 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
   | Otr_new -> fprintf ppf " new"
   | Otr_public -> () in
   let print_out_tkind ppf = function
-  | Otyp_abstract ->
-      if priv <> Otr_public then
-        fprintf ppf " =%a" print_private priv
+  | Otyp_abstract -> ()
   | Otyp_record lbls ->
       fprintf ppf " =%a {%a@;<1 -2>}"
         print_private priv
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 7a4e55aaf5..f2c1be1110 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -734,8 +734,7 @@ let rec tree_of_type_decl id decl =
           List.exists (fun (_,_,ret) -> ret <> None) tll
     in
     let abstr' = (* abstract type or private abbreviation *)
-      abstr && decl.type_kind = Type_abstract
-      && decl.type_transparence <> Type_new in 
+      abstr && decl.type_kind = Type_abstract in 
     let vari =
       List.map2
         (fun ty (co,cn,ct,i) ->
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 4cb665892d..7c3ef23634 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -691,7 +691,6 @@ let compute_variance_decl env check decl (required, loc as rloc) =
   if decl.type_kind = Type_abstract && decl.type_manifest = None then
     List.map
       (fun (c, n, i) ->
-        let i = i || decl.type_transparence = Type_new in
         if c || n then (c, n, n, i) else (true, true, true, i))
       required
   else match decl.type_kind with