revert wrong commit of experiments

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12260 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 14 insertions, 21 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 4710b80f2..478143c85 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -3684,7 +3684,7 @@ and subtype_fields env trace ty1 ty2 cstrs =
   let cstrs =
     if rest2.desc = Tnil then cstrs else
     if miss1 = [] then
-      subtype_rec env trace rest1 rest2 cstrs
+      subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs
     else
       (trace, build_fields (repr ty1).level miss1 rest1, rest2,
        !univar_pairs) :: cstrs
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 572873257..84c0d1942 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -936,12 +936,12 @@ let rec trace fst txt ppf = function
        (trace false txt) rem
   | _ -> ()
 
-let rec filter_trace keep_last = function
+let rec filter_trace = function
   | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' ->
       []
   | (t1, t1') :: (t2, t2') :: rem ->
-      let rem' = filter_trace keep_last rem in
-      if t1 == t1' && t2 == t2' && (rem' <> [] || not keep_last)
+      let rem' = filter_trace rem in
+      if t1 == t1' && t2 == t2'
       then rem'
       else (t1, t1') :: (t2, t2') :: rem'
   | _ -> []
@@ -1085,7 +1085,7 @@ let unification_error unif tr txt1 ppf txt2 =
   | [] | _ :: [] -> assert false
   | t1 :: t2 :: tr ->
     try
-      let tr = filter_trace false tr in
+      let tr = filter_trace tr in
       let t1, t1' = may_prepare_expansion (tr = []) t1
       and t2, t2' = may_prepare_expansion (tr = []) t2 in
       print_labels := not !Clflags.classic;
@@ -1108,13 +1108,13 @@ let unification_error unif tr txt1 ppf txt2 =
 let report_unification_error ppf tr txt1 txt2 =
   unification_error true tr txt1 ppf txt2;;
 
-let trace fst txt keep_last ppf tr =
+let trace fst txt ppf tr =
   print_labels := not !Clflags.classic;
   trace_same_names tr;
   try match tr with
     t1 :: t2 :: tr' ->
-      if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr')
-      else trace fst txt ppf (filter_trace keep_last  tr);
+      if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr')
+      else trace fst txt ppf (filter_trace tr);
       print_labels := true
   | _ -> ()
   with exn ->
@@ -1123,12 +1123,10 @@ let trace fst txt keep_last ppf tr =
 
 let report_subtyping_error ppf tr1 txt1 tr2 =
   reset ();
-  fprintf ppf "@[";
   let tr1 = List.map prepare_expansion tr1
   and tr2 = List.map prepare_expansion tr2 in
-  trace true txt1 true ppf tr1;
+  trace true txt1 ppf tr1;
   if tr2 = [] then () else
   let mis = mismatch true tr2 in
-  trace false "is not compatible with type" false ppf tr2;
-  explanation true mis ppf;
-  fprintf ppf "@]"
+  trace false "is not compatible with type" ppf tr2;
+  explanation true mis ppf
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index c9e509211..5417ebf41 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -54,8 +54,7 @@ val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> rec_status -> o
 val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit
 val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
 val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
-val trace: bool -> string -> bool ->
-    formatter -> (type_expr * type_expr) list -> unit
+val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit
 val unification_error:
     bool -> (type_expr * type_expr) list ->
     (formatter -> unit) -> formatter -> (formatter -> unit) ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c6eb108cd..5610c3e94 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -675,12 +675,8 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
   end;
 
   (* Typing of method bodies *)
-  if !Clflags.principal then begin
-    Ctype.raise_nongen_level ();
-    Ctype.init_def (Ctype.get_current_level () - 1);
-    List.iter (fun (_,_,ty) -> Ctype.generalize_structure ty) methods;
-    Ctype.end_def ()
-  end;
+  if !Clflags.principal then
+    List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
   let fields = List.map Lazy.force (List.rev fields) in
   if !Clflags.principal then
     List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ()))