merging poly_meth2poly_meth2

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

19 files changed, 182 insertions, 75 deletions

diff --git a/byterun/interp.c b/byterun/interp.c
index 599218e487..aed6c053f5 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -790,13 +790,13 @@ value interprete(code_t prog, asize_t prog_size)
     raise_exception:
       if (trapsp >= trap_barrier) debugger(TRAP_BARRIER);
       if (backtrace_active) stash_backtrace(accu, pc, sp);
-      sp = trapsp;
-      if ((char *) sp >= (char *) stack_high - initial_sp_offset) {
+      if ((char *) trapsp >= (char *) stack_high - initial_sp_offset) {
         external_raise = initial_external_raise;
-        extern_sp = sp;
+        extern_sp = (value *) ((char *) stack_high - initial_sp_offset);
         callback_depth--;
         return Make_exception_result(accu);
       }
+      sp = trapsp;
       pc = Trap_pc(sp);
       trapsp = Trap_link(sp);
       env = sp[2];
diff --git a/byterun/io.c b/byterun/io.c
index f473ce7d2b..85f162aa23 100644
--- a/byterun/io.c
+++ b/byterun/io.c
@@ -172,12 +172,19 @@ again:
 
 /* Attempt to flush the buffer. This will make room in the buffer for
    at least one character. Returns true if the buffer is empty at the
-   end of the flush, or false if some data remains in the buffer. */
+   end of the flush, or false if some data remains in the buffer.
+
+   If the channel is closed, DO NOT raise a "bad file descriptor"
+   exception, but do nothing (the buffer is already empty).  See
+   the "at_exit" line of stdlib/format.ml for a good reason to avoid
+   the exception.
+ */
 
 CAMLexport int flush_partial(struct channel *channel)
 {
   int towrite, written;
 
+  if (channel->fd == -1) return 1;
   towrite = channel->curr - channel->buff;
   if (towrite > 0) {
     written = do_write(channel->fd, channel->buff, towrite);
diff --git a/byterun/signals.c b/byterun/signals.c
index 727b87aff7..6fce2115a3 100644
--- a/byterun/signals.c
+++ b/byterun/signals.c
@@ -134,16 +134,20 @@ CAMLexport void enter_blocking_section(void)
 CAMLexport void leave_blocking_section(void)
 {
 #ifdef _WIN32
+  int signal_number;
+#endif
+
+  if (leave_blocking_section_hook != NULL) leave_blocking_section_hook();
+#ifdef _WIN32
   /* Under Win32, asynchronous signals such as ctrl-C are not processed
      immediately (see ctrl_handler in win32.c), but simply set
      pending_signal and let the system call run to completion.
      Hence, test pending_signal here and act upon it, before we get
      a chance to process the result of the system call. */
-  int signal_number = pending_signal;
+  signal_number = pending_signal;
   pending_signal = 0;
   if (signal_number) execute_signal(signal_number, 1);
 #endif
-  if (leave_blocking_section_hook != NULL) leave_blocking_section_hook();
   Assert(async_signal_mode);
   async_signal_mode = 0;
 }
diff --git a/byterun/sys.c b/byterun/sys.c
index f82fce4b3f..6ac6cdbce7 100644
--- a/byterun/sys.c
+++ b/byterun/sys.c
@@ -302,13 +302,18 @@ CAMLprim value sys_time(value unit)
 
 CAMLprim value sys_random_seed (value unit)
 {
+  long seed;
 #ifdef HAS_GETTIMEOFDAY
   struct timeval tv;
   gettimeofday(&tv, NULL);
-  return Val_int(tv.tv_sec ^ tv.tv_usec);
+  seed = tv.tv_sec ^ tv.tv_usec;
 #else
-  return Val_int(time (NULL));
+  seed = time (NULL);
 #endif
+#ifdef HAS_UNISTD
+  seed ^= getppid() << 16 | getpid();
+#endif
+  return Val_long(seed);
 }
 
 CAMLprim value sys_get_config(value unit)
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index 86812de9cb..855c81d612 100644
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -39,6 +39,11 @@ let resize b more =
   let len = b.length in
   let new_len = ref len in
   while b.position + more > !new_len do new_len := 2 * !new_len done;
+  if !new_len > Sys.max_string_length then begin
+    if b.position + more <= Sys.max_string_length
+    then new_len := Sys.max_string_length
+    else failwith "Buffer.add: cannot grow buffer"
+  end;
   let new_buffer = String.create !new_len in
   String.blit b.buffer 0 new_buffer 0 b.position;
   b.buffer <- new_buffer;
diff --git a/stdlib/complex.ml b/stdlib/complex.ml
index fe2e0388d1..3095534bab 100644
--- a/stdlib/complex.ml
+++ b/stdlib/complex.ml
@@ -62,16 +62,21 @@ let arg x = atan2 x.im x.re
 
 let polar n a = { re = cos a *. n; im = sin a *. n }
 
-let sqrt x =
-  (* Avoid cancellation in computing norm x + x.re 
-     when x.re < 0 and x.im is small *)
-  if x.re >= 0.0 then begin
-    let r = sqrt(0.5 *. norm x +. 0.5 *. x.re) in
-    { re = r; im = if r = 0.0 then 0.0 else 0.5 *. x.im /. r }
-  end else begin
-    let s = sqrt(0.5 *. norm x -. 0.5 *. x.re) in
-    { re = if s = 0.0 then 0.0 else 0.5 *. abs_float x.im /. s;
-      im = if x.im >= 0.0 then s else -. s }
+let sqrt x = 
+  if x.re = 0.0 && x.im = 0.0 then { re = 0.0; im = 0.0 }
+  else begin
+    let r = abs_float x.re and i = abs_float x.im in
+    let w =
+      if r >= i then begin
+        let q = i /. r in 
+        sqrt(r) *. sqrt(0.5 *. (1.0 +. sqrt(1.0 +. q *. q))) 
+      end else begin
+        let q = r /. i in
+        sqrt(i) *. sqrt(0.5 *. (q +. sqrt(1.0 +. q *. q)))
+      end in   
+    if x.re >= 0.0
+    then { re = w;  im = 0.5 *. x.im /. w }  
+    else { re = 0.5 *. i /. w;  im = if x.im >= 0.0 then w else -. w }
   end
 
 let exp x =
diff --git a/stdlib/complex.mli b/stdlib/complex.mli
index 72e974a2f7..0fc3696f58 100644
--- a/stdlib/complex.mli
+++ b/stdlib/complex.mli
@@ -55,7 +55,8 @@ val div: t -> t -> t
 (** Division *)
 
 val sqrt: t -> t
-(** Square root.  The result always lies within the semispace [real >= 0].
+(** Square root.  The result [x + i.y] is such that [x > 0] or
+    [x = 0] and [y >= 0].
     This function has a discontinuity along the negative real axis. *)
 
 val norm2: t -> float
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index bf7ad1761a..34853f85dc 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -182,19 +182,40 @@ let chop_extension name =
 
 external open_desc: string -> open_flag list -> int -> int = "sys_open"
 external close_desc: int -> unit = "sys_close"
+external random_seed: unit -> int = "sys_random_seed"
+
+let temp_file_counter = ref 0
+
+let temp_file_name prefix suffix =
+  if !temp_file_counter = 0 then temp_file_counter := random_seed();
+  let name =
+    concat temporary_directory
+           (Printf.sprintf "%s%06x%s"
+                           prefix (!temp_file_counter land 0xFFFFFF) suffix) in
+  (* Linear congruential PRNG *)
+  temp_file_counter := !temp_file_counter * 69069 + 25173;
+  name
 
 let temp_file prefix suffix =
   let rec try_name counter =
     if counter >= 1000 then
-      invalid_arg "Filename.temp_file: temp dir nonexistent or full"
-    else begin
-      let name =
-        concat temporary_directory (prefix ^ string_of_int counter ^ suffix) in
-      try
-        close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o666);
-        name
-      with Sys_error _ ->
-        try_name (counter + 1)
-    end
+      invalid_arg "Filename.temp_file: temp dir nonexistent or full";
+    let name = temp_file_name prefix suffix in
+    try
+      close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o600);
+      name
+    with Sys_error _ ->
+      try_name (counter + 1)
   in try_name 0
 
+let open_temp_file ?(mode = [Open_text]) prefix suffix =
+  let rec try_name counter =
+    if counter >= 1000 then
+      invalid_arg "Filename.open_temp_file: temp dir nonexistent or full";
+    let name = temp_file_name prefix suffix in
+    try
+      (name,
+       open_out_gen (Open_wronly::Open_creat::Open_excl::mode) 0o600 name)
+    with Sys_error _ ->
+      try_name (counter + 1)
+  in try_name 0
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index a0c79976f6..167fb6a789 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -69,9 +69,10 @@ val temp_file : string -> string -> string
    fresh temporary file in the temporary directory.
    The base name of the temporary file is formed by concatenating
    [prefix], then a suitably chosen integer number, then [suffix].
-   The temporary file is created empty, and is guaranteed to be
-   different from any other file that existed when [temp_file]
-   was called.
+   The temporary file is created empty, with permissions [0o600]
+   (readable and writable only by the file owner).  The file is
+   guaranteed to be different from any other file that existed when
+   [temp_file] was called.
    Under Unix, the temporary directory is [/tmp] by default; if set,
    the value of the environment variable [TMPDIR] is used instead.
    Under Windows, the name of the temporary directory is the
@@ -81,6 +82,17 @@ val temp_file : string -> string -> string
    by the environment variable [TempFolder]; if not set,
    temporary files are created in the current directory. *)
 
+val open_temp_file :
+      ?mode: open_flag list -> string -> string -> string * out_channel
+(** Same as {!temp_file}, but returns both the name of a fresh
+   temporary file, and an output channel opened (atomically) on
+   this file.  This function is more secure than [temp_file]: there
+   is no risk that the temporary file will be modified (e.g. replaced
+   by a symbolic link) before the program opens it.  The optional argument
+   [mode] is a list of additional flags to control the opening of the file.
+   It can contain one or several of [Open_append], [Open_binary],
+   and [Open_text].  The default is [[Open_text]] (open in text mode). *)
+
 val quote : string -> string
 (** Return a quoted version of a file name, suitable for use as
    one argument in a shell command line, escaping all shell
diff --git a/stdlib/format.ml b/stdlib/format.ml
index 35e03ebeae..1450be30e8 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -1001,7 +1001,9 @@ let fprintf_out str out ppf format =
          if i >= limit then format_invalid_arg "bad box format" format i else
          begin match format.[i] with
          | 'v' -> Pp_hovbox, succ i
-         | _ -> format_invalid_arg "bad box name ho" format i end
+         | c ->
+            format_invalid_arg
+              ("bad box name ho" ^ String.make 1 c) format i end
       | 'v' -> Pp_hvbox, succ i
       | c -> Pp_hbox, i
       end
diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
index 8307c6f624..baba74ef4e 100644
--- a/stdlib/lexing.ml
+++ b/stdlib/lexing.ml
@@ -60,8 +60,13 @@ let lex_refill read_fun aux_buffer lexbuf =
                   (lexbuf.lex_buffer_len - lexbuf.lex_start_pos)
     end else begin
       (* We must grow the buffer.  Doubling its size will provide enough
-         space since n <= String.length aux_buffer <= String.length buffer *)
-      let newbuf = String.create (2 * String.length lexbuf.lex_buffer) in
+         space since n <= String.length aux_buffer <= String.length buffer.
+         Watch out for string length overflow, though. *)
+      let newlen =
+        min (2 * String.length lexbuf.lex_buffer) Sys.max_string_length in
+      if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n > newlen
+      then failwith "Lexing.lex_refill: cannot grow buffer";
+      let newbuf = String.create newlen in
       (* Copy the valid data to the beginning of the new buffer *)
       String.blit lexbuf.lex_buffer lexbuf.lex_start_pos
                   newbuf 0
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index c7f85f4943..8cdb2f4c0f 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -653,8 +653,8 @@ val output_string : out_channel -> string -> unit
 (** Write the string on the given output channel. *)
 
 val output : out_channel -> string -> int -> int -> unit
-(** Write [len] characters from string [buf], starting at offset
-   [pos], to the given output channel.
+(** [output oc buf pos len] writes [len] characters from string [buf],
+   starting at offset [pos], to the given output channel [oc].
    Raise [Invalid_argument "output"] if [pos] and [len] do not
    designate a valid substring of [buf]. *)
 
@@ -738,8 +738,9 @@ val input_line : in_channel -> string
    at the beginning of line. *)
 
 val input : in_channel -> string -> int -> int -> int
-(** Read up to [len] characters from the given channel,
-   storing them in string [buf], starting at character number [pos].
+(** [input ic buf pos len] reads up to [len] characters from
+   the given channel [ic], storing them in string [buf], starting at
+   character number [pos].
    It returns the actual number of characters read, between 0 and
    [len] (inclusive).
    A return value of 0 means that the end of file was reached.
@@ -754,8 +755,8 @@ val input : in_channel -> string -> int -> int -> int
    do not designate a valid substring of [buf]. *)          
 
 val really_input : in_channel -> string -> int -> int -> unit
-(** Read [len] characters from the given channel, storing them in
-   string [buf], starting at character number [pos].
+(** [really_input ic buf pos len] reads [len] characters from channel [ic],
+   storing them in string [buf], starting at character number [pos].
    Raise [End_of_file] if the end of file is reached before [len]
    characters have been read.
    Raise [Invalid_argument "really_input"] if
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index c4aebc74da..98373b7245 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -78,4 +78,4 @@ let catch_break on =
 (* OCaml version string, moved from utils/config.mlp.
    Must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.04+8 polymorphic methods (2002-03-25)"
+let ocaml_version = "3.04+10 (2002-04-18)"
diff --git a/tools/Makefile.nt b/tools/Makefile.nt
index 7cce3e89ed..77a6ed5b85 100644
--- a/tools/Makefile.nt
+++ b/tools/Makefile.nt
@@ -16,7 +16,7 @@
 
 CAMLRUN=..\boot\ocamlrun
 CAMLC=$(CAMLRUN) ..\boot\ocamlc -I ..\boot
-CAMLOPT==$(CAMLRUN) ../ocamlopt
+CAMLOPT=$(CAMLRUN) ..\ocamlopt
 CAMLLEX=$(CAMLRUN) ..\boot\ocamllex
 INCLUDES=-I ..\utils -I ..\parsing -I ..\typing -I ..\bytecomp -I ..\asmcomp \
          -I ..\driver
diff --git a/typing/btype.ml b/typing/btype.ml
index dd5ec5d4f6..35d18909b4 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -149,6 +149,7 @@ let rec iter_abbrev f = function
   | Mlink rem              -> iter_abbrev f !rem
 
 let copy_row f fixed row keep more =
+  let bound = ref [] in
   let fields = List.map
       (fun (l, fi) -> l,
         match row_field_repr fi with
@@ -156,15 +157,19 @@ let copy_row f fixed row keep more =
         | Reither(c, tl, m, e) ->
             let e = if keep then e else ref None in
             let m = if row.row_fixed then fixed else m in
-            Reither(c, List.map f tl, m , e)
+            let tl = List.map f tl in
+            bound := List.filter
+                (function {desc=Tconstr(_,[],_)} -> false | _ -> true)
+                (List.map repr tl)
+              @ !bound;
+            Reither(c, tl, m, e)
         | _ -> fi)
       row.row_fields in
   let name =
     match row.row_name with None -> None
     | Some (path, tl) -> Some (path, List.map f tl) in
   { row_fields = fields; row_more = more;
-    row_bound = List.map f row.row_bound;
-    row_fixed = row.row_fixed && fixed;
+    row_bound = !bound; row_fixed = row.row_fixed && fixed;
     row_closed = row.row_closed; row_name = name; }
 
 let rec copy_kind = function
@@ -194,6 +199,9 @@ let rec copy_type_desc f = function
   | Tunivar             -> Tunivar
   | Tpoly (ty, tyl)     -> Tpoly (f ty, List.map f tyl)
 
+
+(* Utilities for copying *)
+
 let saved_desc = ref []
   (* Saved association of generic nodes with their description. *)
 
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 3a22b553c1..1bfe2538bf 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -2786,12 +2786,15 @@ let rec normalize_type_rec env ty =
                 f
               else f
             | _ -> f)
-          row.row_fields
+          row.row_fields in
+      let fields =
+        List.sort (fun (p,_) (q,_) -> compare p q)
+          (List.filter (fun (_,fi) -> fi <> Rabsent) fields)
       and bound = List.fold_left
           (fun tyl ty -> if List.memq ty tyl then tyl else ty :: tyl)
           [] (List.map repr row.row_bound)
       in ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound}
-    | Tobject (_, nm) ->
+    | Tobject (fi, nm) ->
         begin match !nm with
         | None -> ()
         | Some (n, v :: l) ->
@@ -2803,7 +2806,12 @@ let rec normalize_type_rec env ty =
             end
         | _ ->
             fatal_error "Ctype.normalize_type_rec"
-        end
+        end;
+        let fi = repr fi in
+        if fi.level < lowest_level then () else
+        let fields, row = flatten_fields fi in
+        let fi' = build_fields fi.level fields row in
+        fi.desc <- fi'.desc
     | _ -> ()
     end;
     iter_type_expr (normalize_type_rec env) ty
diff --git a/typing/env.ml b/typing/env.ml
index 060363b2be..ddaa92e28a 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -719,9 +719,8 @@ let imported_units() =
 
 let save_signature sg modname filename =
   Btype.cleanup_abbrev ();
-  let comps =
-    components_of_module empty Subst.identity
-      (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
+  Subst.reset_for_saving ();
+  let sg = Subst.signature (Subst.for_saving Subst.identity) sg in
   let oc = open_out_bin filename in
   try
     output_string oc cmi_magic_number;
@@ -730,16 +729,19 @@ let save_signature sg modname filename =
     let crc = Digest.file filename in
     let crcs = (modname, crc) :: imported_units() in
     output_value oc crcs;
+    close_out oc;
     (* Enter signature in persistent table so that imported_unit()
        will also return its crc *)
+    let comps =
+      components_of_module empty Subst.identity
+        (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
     let ps =
       { ps_name = modname;
         ps_sig = sg;
         ps_comps = comps;
         ps_crcs = crcs;
         ps_filename = filename } in
-    Hashtbl.add persistent_structures modname ps;
-    close_out oc
+    Hashtbl.add persistent_structures modname ps
   with exn ->
     close_out oc;
     remove_file filename;
diff --git a/typing/subst.ml b/typing/subst.ml
index 45fe325756..66646c157c 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -22,25 +22,20 @@ open Btype
 type t = 
   { types: (Ident.t, Path.t) Tbl.t;
     modules: (Ident.t, Path.t) Tbl.t;
-    modtypes: (Ident.t, module_type) Tbl.t }
+    modtypes: (Ident.t, module_type) Tbl.t;
+    for_saving: bool }
 
 let identity =
-  { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty }
+  { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
+    for_saving = false }
 
-let add_type id p s =
-  { types = Tbl.add id p s.types;
-    modules = s.modules;
-    modtypes = s.modtypes }
+let add_type id p s = { s with types = Tbl.add id p s.types }
 
-let add_module id p s =
-  { types = s.types;
-    modules = Tbl.add id p s.modules;
-    modtypes = s.modtypes }
+let add_module id p s = { s with modules = Tbl.add id p s.modules }
 
-let add_modtype id ty s =
-  { types = s.types;
-    modules = s.modules;
-    modtypes = Tbl.add id ty s.modtypes }
+let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
+
+let for_saving s = { s with for_saving = true }
 
 let rec module_path s = function
     Pident id as p ->
@@ -58,12 +53,23 @@ let type_path s = function
   | Papply(p1, p2) ->
       fatal_error "Subst.type_path"
 
+(* Special type ids for saved signatures *)
+
+let new_id = ref (-1)
+let reset_for_saving () = new_id := -1
+
+let newpersty desc =
+  decr new_id; { desc = desc; level = generic_level; id = !new_id }
+
 (* Similar to [Ctype.nondep_type_rec]. *)
 let rec typexp s ty =
   let ty = repr ty in
   match ty.desc with
     Tvar | Tunivar ->
-      ty
+      if s.for_saving then
+        let ty' = newpersty ty.desc in
+        save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
+      else ty
   | Tsubst ty ->
       ty
 (* cannot do it, since it would omit subsitution
@@ -73,7 +79,8 @@ let rec typexp s ty =
   | _ ->
     let desc = ty.desc in
     save_desc ty desc;
-    let ty' = newgenvar () in     (* Stub *)
+    (* Make a stub *)
+    let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
     ty.desc <- Tsubst ty';
     ty'.desc <-
       begin match desc with
@@ -90,18 +97,27 @@ let rec typexp s ty =
           let more = repr row.row_more in
           (* We must substitute in a subtle way *)
           begin match more.desc with
-            Tsubst ty2 ->
+            Tsubst ({desc=Tvariant _} as ty2) ->
               (* This variant type has been already copied *)
               ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
               Tlink ty2
           | _ ->
               let static = static_row row in
+              (* Various cases for the row variable *)
+              let more' =
+                match more.desc with Tsubst ty -> ty
+                | _ ->
+                    if s.for_saving then newpersty more.desc else
+                    if static then newgenvar () else more
+              in
               (* Register new type first for recursion *)
               save_desc more more.desc;
               more.desc <- ty.desc;
-              let more' = if static then newgenvar () else more in
               (* Return a new copy *)
-              let row = copy_row (typexp s) true row true more' in
+              let row =
+                copy_row (typexp s) true row (not s.for_saving) more' in
+              let row =
+                if s.for_saving then {row with row_bound = []} else row in
               match row.row_name with
                 Some (p, tl) ->
                   Tvariant {row with row_name = Some (type_path s p, tl)}
@@ -115,6 +131,7 @@ let rec typexp s ty =
           | Fabsent ->
               Tlink (typexp s t2)
           | Fvar _ (* {contents = None} *) as k ->
+              let k = if s.for_saving then Fvar(ref None) else k in
               Tfield(label, k, typexp s t1, typexp s t2)
           end
       | _ -> copy_type_desc (typexp s) desc
@@ -183,7 +200,8 @@ let class_declaration s decl =
         | Some ty -> Some (typexp s ty)
         end }
   in
-  cleanup_types ();
+  (* Do not clean up if saving: next is cltype_declaration *)
+  if not s.for_saving then cleanup_types ();
   decl
 
 let cltype_declaration s decl =
@@ -192,7 +210,8 @@ let cltype_declaration s decl =
       clty_type = class_type s decl.clty_type;
       clty_path = type_path s decl.clty_path }
   in
-  cleanup_types ();
+  (* Do not clean up if saving: next is type_declaration *)
+  if not s.for_saving then cleanup_types ();
   decl
 
 let class_type s cty =
diff --git a/typing/subst.mli b/typing/subst.mli
index 1da0cd18c0..b2220bb49e 100644
--- a/typing/subst.mli
+++ b/typing/subst.mli
@@ -35,6 +35,8 @@ val identity: t
 val add_type: Ident.t -> Path.t -> t -> t
 val add_module: Ident.t -> Path.t -> t -> t
 val add_modtype: Ident.t -> module_type -> t -> t
+val for_saving: t -> t
+val reset_for_saving: unit -> unit
 
 val type_expr: t -> type_expr -> type_expr
 val class_type: t -> class_type -> class_type