fix PR#3576 (put free methods in environment)

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

bytecomp/lambda.ml

@@ -236,63 +236,88 @@ let name_lambda_list args fn =
       Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
   name_list [] args
 
+let rec iter f = function
+    Lvar _
+  | Lconst _ -> ()
+  | Lapply(fn, args) ->
+      f fn; List.iter f args
+  | Lfunction(kind, params, body) ->
+      f body
+  | Llet(str, id, arg, body) ->
+      f arg; f body
+  | Lletrec(decl, body) ->
+      f body;
+      List.iter (fun (id, exp) -> f exp) decl
+  | Lprim(p, args) ->
+      List.iter f args
+  | Lswitch(arg, sw) ->
+      f arg; 
+      List.iter (fun (key, case) -> f case) sw.sw_consts;
+      List.iter (fun (key, case) -> f case) sw.sw_blocks;
+      begin match sw.sw_failaction with
+      | None -> ()
+      | Some l -> f l
+      end
+  | Lstaticraise (_,args) ->
+      List.iter f args
+  | Lstaticcatch(e1, (_,vars), e2) ->
+      f e1; f e2
+  | Ltrywith(e1, exn, e2) ->
+      f e1; f e2
+  | Lifthenelse(e1, e2, e3) ->
+      f e1; f e2; f e3
+  | Lsequence(e1, e2) ->
+      f e1; f e2
+  | Lwhile(e1, e2) ->
+      f e1; f e2
+  | Lfor(v, e1, e2, dir, e3) -> 
+      f e1; f e2; f e3
+  | Lassign(id, e) ->
+      f e
+  | Lsend (k, met, obj, args) ->
+      List.iter f (met::obj::args)
+  | Levent (lam, evt) ->
+      f lam
+  | Lifused (v, e) ->
+      f e
+
 module IdentSet =
   Set.Make(struct
     type t = Ident.t
     let compare = compare
   end)
 
-let free_variables l =
+let free_ids get l =
   let fv = ref IdentSet.empty in
-  let rec freevars = function
-    Lvar id ->
-      fv := IdentSet.add id !fv
-  | Lconst sc -> ()
-  | Lapply(fn, args) ->
-      freevars fn; List.iter freevars args
-  | Lfunction(kind, params, body) ->
-      freevars body;
-      List.iter (fun param -> fv := IdentSet.remove param !fv) params
-  | Llet(str, id, arg, body) ->
-      freevars arg; freevars body; fv := IdentSet.remove id !fv
-  | Lletrec(decl, body) ->
-      freevars body;
-      List.iter (fun (id, exp) -> freevars exp) decl;
-      List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
-  | Lprim(p, args) ->
-      List.iter freevars args
-  | Lswitch(arg, sw) ->
-      freevars arg; 
-      List.iter (fun (key, case) -> freevars case) sw.sw_consts;
-      List.iter (fun (key, case) -> freevars case) sw.sw_blocks;
-      begin match sw.sw_failaction with
-      | None -> ()
-      | Some l -> freevars l
-      end
-  | Lstaticraise (_,args) ->
-      List.iter freevars args
-  | Lstaticcatch(e1, (_,vars), e2) ->
-      freevars e1; freevars e2 ;
-      List.iter (fun id -> fv := IdentSet.remove id !fv) vars        
-  | Ltrywith(e1, exn, e2) ->
-      freevars e1; freevars e2; fv := IdentSet.remove exn !fv
-  | Lifthenelse(e1, e2, e3) ->
-      freevars e1; freevars e2; freevars e3
-  | Lsequence(e1, e2) ->
-      freevars e1; freevars e2
-  | Lwhile(e1, e2) ->
-      freevars e1; freevars e2
-  | Lfor(v, e1, e2, dir, e3) -> 
-      freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
-  | Lassign(id, e) ->
-      fv := IdentSet.add id !fv; freevars e
-  | Lsend (k, met, obj, args) ->
-      List.iter freevars (met::obj::args)
-  | Levent (lam, evt) ->
-      freevars lam
-  | Lifused (v, e) ->
-      freevars e
-  in freevars l; !fv
+  let rec free l =
+    iter free l;
+    fv := List.fold_right IdentSet.add (get l) !fv;
+    match l with
+      Lfunction(kind, params, body) ->
+        List.iter (fun param -> fv := IdentSet.remove param !fv) params
+    | Llet(str, id, arg, body) ->
+        fv := IdentSet.remove id !fv
+    | Lletrec(decl, body) ->
+        List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
+    | Lstaticcatch(e1, (_,vars), e2) ->
+        List.iter (fun id -> fv := IdentSet.remove id !fv) vars        
+    | Ltrywith(e1, exn, e2) ->
+        fv := IdentSet.remove exn !fv
+    | Lfor(v, e1, e2, dir, e3) -> 
+        fv := IdentSet.remove v !fv
+    | Lassign(id, e) ->
+        fv := IdentSet.add id !fv
+    | Lvar _ | Lconst _ | Lapply _
+    | Lprim _ | Lswitch _ | Lstaticraise _
+    | Lifthenelse _ | Lsequence _ | Lwhile _
+    | Lsend _ | Levent _ | Lifused _ -> ()
+  in free l; !fv
+
+let free_variables l =
+  free_ids (function Lvar id -> [id] | _ -> []) l
+
+let free_methods l =
+  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
 
 (* Check if an action has a "when" guard *)
 let raise_count = ref 0

bytecomp/lambda.mli

@@ -175,8 +175,10 @@ val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
 val is_guarded: lambda -> bool
 val patch_guarded : lambda -> lambda -> lambda
 
+val iter: (lambda -> unit) -> lambda -> unit
 module IdentSet: Set.S with type elt = Ident.t
 val free_variables: lambda -> IdentSet.t
+val free_methods: lambda -> IdentSet.t
 
 val transl_path: Path.t -> lambda
 val make_sequence: ('a -> lambda) -> 'a list -> lambda

bytecomp/translclass.ml

@@ -383,6 +383,16 @@ let rec build_class_lets cl =
   | _ ->
       (cl.cl_env, fun x -> x)
 
+let rec get_class_meths cl =
+  match cl.cl_desc with
+    Tclass_structure cl ->
+      Meths.fold (fun _ -> IdentSet.add) cl.cl_meths IdentSet.empty
+  | Tclass_ident _ -> IdentSet.empty
+  | Tclass_fun (_, _, cl, _)
+  | Tclass_let (_, _, _, cl)
+  | Tclass_apply (cl, _)
+  | Tclass_constraint (cl, _, _, _) -> get_class_meths cl
+
 (*
    XXX Il devrait etre peu couteux d'ecrire des classes :
      class c x y = d e f
@@ -594,11 +604,18 @@ let transl_class ids cl_id arity pub_meths cl =
   let cl_env, llets = build_class_lets cl in
   let new_ids = if top then [] else Env.diff top_env cl_env in
   let env2 = Ident.create "env" in
+  let meth_ids = get_class_meths cl in
   let subst env lam i0 new_ids' =
     let fv = free_variables lam in
     let fv = List.fold_right IdentSet.remove !new_ids' fv in
-    let fv =
-      IdentSet.filter (fun id -> List.mem id new_ids) fv in
+    (* IdentSet.iter
+      (fun id ->
+        if not (List.mem id new_ids) then prerr_endline (Ident.name id))
+      fv; *)
+    let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in
+    (* need to handle methods specially (PR#3576) *)
+    let fm = IdentSet.diff (free_methods lam) meth_ids in
+    let fv = IdentSet.union fv fm in
     new_ids' := !new_ids' @ IdentSet.elements fv;
     let i = ref (i0-1) in
     List.fold_left