Ident: ajout de Ident.iter.

Autres: unification sous prefixe lors de l'inference de types, corrige
le bug de Russo:
let x = ref [];; module F(X) = struct type t let _ = (x:t list ref) ... end;;


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

7 files changed, 52 insertions, 55 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index da6fc7cf1..824cf637a 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -25,6 +25,7 @@ let current_level = ref 0
 let global_level = ref 1
 let generic_level = (-1)
 
+let init_def level = current_level := level
 let begin_def () = incr current_level
 let end_def () = decr current_level
 
@@ -406,27 +407,34 @@ let occur env ty0 ty =
     let ty = repr ty in
     if ty == ty0 then raise (Unify []);
     match ty.desc with
-      Tlink ty' ->
-        occur_rec ty'
-    | Tvar ->
+      Tvar ->
         ()
     | Tarrow(t1, t2) ->
         occur_rec t1; occur_rec t2
     | Ttuple tl ->
         List.iter occur_rec tl
-    | Tconstr(p, [], _) ->
-        ()
+    | Tconstr(p, [], abbrev) ->
+        if ty0.level < Path.binding_time p then begin
+          let ty' =
+            try expand_abbrev env p [] abbrev ty.level
+            with Cannot_expand -> raise (Unify []) in
+          occur_rec ty'
+        end
     | Tconstr(p, tl, abbrev) ->
         if not (List.memq ty !visited) then begin
           visited := ty :: !visited;
-          try List.iter occur_rec tl with Unify _ ->
-          try occur_rec (expand_abbrev env p tl abbrev ty.level)
-          with Cannot_expand ->
-          ()
+          try
+            if ty0.level < Path.binding_time p then raise(Unify []);
+            List.iter occur_rec tl
+          with Unify lst ->
+            let ty' =
+              try expand_abbrev env p tl abbrev ty.level
+              with Cannot_expand -> raise (Unify lst) in
+            occur_rec ty'
         end
     | Tobject (_, _) ->
         ()
-    | Tfield (_, _, _) | Tnil ->
+    | _ (* Tfield (_, _, _) | Tnil | Tlink _ *) ->
         fatal_error "Ctype.occur"
   in
     occur_rec ty
@@ -1373,41 +1381,11 @@ let unroll_abbrev id tl ty =
   | _ ->
       ty
 
-let visited = ref []
-
-let closed_schema ty =
-  let rec closed_schema_rec ty =
-    let ty = repr ty in
-    match ty.desc with
-      Tvar -> ty.level = generic_level
-    | Tarrow(t1, t2) -> closed_schema_rec t1 & closed_schema_rec t2
-    | Ttuple tl -> List.for_all closed_schema_rec tl
-    | Tconstr(p, tl, _) ->
-        if not (List.memq ty !visited) then begin
-          visited := ty::!visited;
-          List.for_all closed_schema_rec tl
-        end else
-          true
-    | Tobject(f, _) ->
-        if not (List.memq ty !visited) then begin
-          visited := ty::!visited;
-          closed_schema_rec f
-        end else
-          true
-    | Tfield(_, t1, t2) ->
-        closed_schema_rec t1 & closed_schema_rec t2
-    | Tnil ->
-        true
-    | Tlink _           -> fatal_error "Ctype.closed_schema"
-  in
-    visited := [];
-    let res = closed_schema_rec ty in
-    visited := [];
-    res
-
 type closed_schema_result = Var of type_expr | Row_var of type_expr
 exception Failed of closed_schema_result
 
+let visited = ref []
+
 let rec closed_schema_rec ty =
   let ty = repr ty in
   match ty.desc with
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 12f80e98f..bce610e99 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -17,6 +17,8 @@ open Asttypes
 open Typedtree
 
 val generic_level: int
+val init_def: int -> unit
+        (* Set the initial variable level *)
 val begin_def: unit -> unit
         (* Raise the variable level by one at the beginning of a definition. *)
 val end_def: unit -> unit
diff --git a/typing/ident.ml b/typing/ident.ml
index 9a30a3be3..93612fc0a 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -40,6 +40,10 @@ let same i1 i2 = i1 = i2
        then i1.stamp = i2.stamp
        else i2.stamp = 0 & i1.name = i2.name *)
 
+let binding_time i = i.stamp
+
+let current_time() = !currentstamp
+
 let identify i1 i2 f =
   let name1 = i1.name and stamp1 = i1.stamp in
   try
@@ -154,21 +158,22 @@ let rec find_name name = function
       else
         find_name name (if c < 0 then l else r)
 
+let rec iter fn = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter fn l; iter_node fn k; iter fn r
+and iter_node fn k =
+  fn k.ident k.data;
+  match k.previous with None -> () | Some prev_k -> iter_node fn prev_k
+
 let print_tbl print_elt tbl =
   open_hovbox 2;
   print_string "[[";
-  let rec print_tbl = function
-      Empty -> ()
-    | Node(l, k, r, _) ->
-        print_tbl l;
-        print_entry k;
-        print_tbl r
-  and print_entry k =
-    open_hovbox 2;
-    print k.ident; print_string " ->"; print_space(); print_elt k.data;
-    print_string ";"; close_box(); print_space();
-    match k.previous with None -> () | Some k -> print_entry k in
-  print_tbl tbl;
+  iter (fun id data -> 
+          open_hovbox 2;
+          print id; print_string " ->"; print_space(); print_elt data;
+          print_string ";"; close_box(); print_space())
+       tbl;
   print_string "]]";
   close_box()
 
diff --git a/typing/ident.mli b/typing/ident.mli
index 0e011ad0d..0405eff57 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -40,6 +40,9 @@ val hide: t -> t
 val make_global: t -> unit
 val global: t -> bool
 
+val binding_time: t -> int
+val current_time: unit -> int
+
 val print: t -> unit
 
 type 'a tbl
@@ -50,4 +53,5 @@ val add: t -> 'a -> 'a tbl -> 'a tbl
 val find_same: t -> 'a tbl -> 'a
 val find_name: string -> 'a tbl -> 'a
 
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
 val print_tbl: ('a -> unit) -> 'a tbl -> unit
diff --git a/typing/path.ml b/typing/path.ml
index 2412833eb..1445564a7 100644
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -29,3 +29,8 @@ let rec isfree id = function
     Pident id' -> Ident.same id id'
   | Pdot(p, s, pos) -> isfree id p
   | Papply(p1, p2) -> isfree id p1 or isfree id p2
+
+let rec binding_time = function
+    Pident id -> Ident.binding_time id
+  | Pdot(p, s, pos) -> binding_time p
+  | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)
diff --git a/typing/path.mli b/typing/path.mli
index 89ab84d63..4583c3cf1 100644
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -20,5 +20,6 @@ type t =
 
 val same: t -> t -> bool
 val isfree: Ident.t -> t -> bool
+val binding_time: t -> int
 
 val nopos: int
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 3f0969ca8..7deac508a 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -310,7 +310,9 @@ and type_structure env sstr =
   check_unique_names sstr;
   type_struct env sstr
 
-and type_struct env = function
+and type_struct env sstr =
+  Ctype.init_def(Ident.current_time());
+  match sstr with
     [] ->
       ([], [], env)
   | {pstr_desc = Pstr_eval sexpr} :: srem ->