recupere les variables de type apres let module

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

5 files changed, 22 insertions, 19 deletions

diff --git a/typing/ctype.mli b/typing/ctype.mli
index b4a0e5753..6e2105b15 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -34,8 +34,10 @@ val end_def: unit -> unit
 val begin_class_def: unit -> unit
 val raise_nongen_level: unit -> unit
 val reset_global_level: unit -> unit
-val increase_global_level: unit -> unit
-val restore_global_level: unit -> unit
+        (* Reset the global level before typing an expression *)
+val increase_global_level: unit -> int
+val restore_global_level: int -> unit
+        (* This pair of functions is only used in Typetexp *)
 
 val newty: type_desc -> type_expr
 val newvar: unit -> type_expr
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 5571d1e97..536ea9527 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -792,12 +792,12 @@ and class_expr cl_num val_env met_env scl =
        cl_type = cl.cl_type}
   | Pcl_constraint (scl', scty) ->
       Ctype.begin_class_def ();
-      Typetexp.narrow ();
+      let context = Typetexp.narrow () in
       let cl = class_expr cl_num val_env met_env scl' in
-      Typetexp.widen ();
-      Typetexp.narrow ();
+      Typetexp.widen context;
+      let context = Typetexp.narrow () in
       let clty = class_type val_env scty in
-      Typetexp.widen ();
+      Typetexp.widen context;
       Ctype.end_def ();
 
       limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 3a37f615f..99dcfe0bc 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1205,9 +1205,11 @@ let rec type_exp env sexp =
   | Pexp_letmodule(name, smodl, sbody) ->
       let ty = newvar() in
       Ident.set_current_time ty.level;
+      let context = Typetexp.narrow () in
       let modl = !type_module env smodl in
       let (id, new_env) = Env.enter_module name modl.mod_type env in
       Ctype.init_def(Ident.current_time());
+      Typetexp.widen context;
       let body = type_exp new_env sbody in
       (* Unification of body.exp_type with the fresh variable ty
          fails if and only if the prefix condition is violated,
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 9040ede19..2a8ac299a 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -42,10 +42,11 @@ type error =
 
 exception Error of Location.t * error
 
+type variable_context = int * (string, type_expr) Tbl.t
+
 (* Translation of type expressions *)
 
 let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
-let saved_type_variables = ref ([] : (string, type_expr) Tbl.t list)
 let univars        = ref ([] : (string * type_expr) list)
 let pre_univars    = ref ([] : type_expr list)
 
@@ -55,18 +56,14 @@ let bindings       = ref ([] : (Location.t * type_expr * type_expr) list)
 
 let reset_type_variables () =
   reset_global_level ();
-  type_variables := Tbl.empty;
-  saved_type_variables := []
+  type_variables := Tbl.empty
 
 let narrow () =
-  increase_global_level ();
-  saved_type_variables := !type_variables :: !saved_type_variables
+  (increase_global_level (), !type_variables)
 
-let widen () =
-  restore_global_level ();
-  match !saved_type_variables with
-    tv :: rem -> type_variables := tv; saved_type_variables := rem
-  | []        -> assert false
+let widen (gl, tv) =
+  restore_global_level gl;
+  type_variables := tv
 
 let enter_type_variable strict name =
   try
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index 23ff76e90..bc3651522 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -28,9 +28,11 @@ val transl_type_scheme:
         Env.t -> Parsetree.core_type -> Types.type_expr
 val reset_type_variables: unit -> unit
 val enter_type_variable: bool -> string -> Types.type_expr
-val type_variable : Location.t -> string -> Types.type_expr
-val narrow: unit -> unit
-val widen: unit -> unit
+val type_variable: Location.t -> string -> Types.type_expr
+
+type variable_context
+val narrow: unit -> variable_context
+val widen: variable_context -> unit
 
 exception Already_bound