Verification plus stricte des let rec (bug de Pascal Cuoq)

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

1 files changed, 36 insertions, 13 deletions

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index c7eca4971..a6c7142c2 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -209,29 +209,52 @@ let transl_primitive p =
 (* To check the well-formedness of r.h.s. of "let rec" definitions *)
 
 let check_recursive_lambda idlist lam =
-  let rec check_top = function
+  let rec check_top idlist = function
       Lfunction(kind, params, body) as funct -> true
-    | Lprim(Pmakeblock(tag, mut), args) -> List.for_all check args
-    | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all check args
-    | Llet(str, id, arg, body) -> check arg & check_top body
+    | Lprim(Pmakeblock(tag, mut), args) ->
+        List.for_all (check idlist) args
+    | Lprim(Pmakearray(Paddrarray|Pintarray), args) ->
+        List.for_all (check idlist) args
+    | Llet(str, id, arg, body) ->
+        check idlist arg && check_top (add_let id arg idlist) body
     | Lletrec(bindings, body) ->
-        List.for_all (fun (id, arg) -> check arg) bindings & check_top body
-    | Levent (lam, _) -> check_top lam
+        let idlist' = add_letrec bindings idlist in
+        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
+        check_top idlist' body
+    | Levent (lam, _) -> check_top idlist lam
     | _ -> false
-  and check = function
+
+  and check idlist = function
       Lvar _ -> true
     | Lconst cst -> true
     | Lfunction(kind, params, body) -> true
-    | Llet(str, id, arg, body) -> check arg & check body
+    | Llet(str, id, arg, body) ->
+        check idlist arg && check (add_let id arg idlist) body
     | Lletrec(bindings, body) ->
-        List.for_all (fun (id, arg) -> check arg) bindings & check body
-    | Lprim(Pmakeblock(tag, mut), args) -> List.for_all check args
-    | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all check args
-    | Levent (lam, _) -> check lam
+        let idlist' = add_letrec bindings idlist in
+        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
+        check idlist' body
+    | Lprim(Pmakeblock(tag, mut), args) ->
+        List.for_all (check idlist) args
+    | Lprim(Pmakearray(Paddrarray|Pintarray), args) ->
+        List.for_all (check idlist) args
+    | Levent (lam, _) -> check idlist lam
     | lam ->
         let fv = free_variables lam in
         List.for_all (fun id -> not(IdentSet.mem id fv)) idlist
-  in check_top lam
+
+  and add_let id arg idlist =
+    match arg with
+      Lvar id' -> if List.mem id' idlist then id :: idlist else idlist
+    | Llet(_, _, _, body) -> add_let id body idlist
+    | Lletrec(_, body) -> add_let id body idlist
+    | _ -> idlist
+
+  and add_letrec bindings idlist =
+    List.fold_right (fun (id, arg) idl -> add_let id arg idl)
+                    bindings idlist
+
+  in check_top idlist lam
 
 (* To propagate structured constants *)