Fix two bugs: (1) Remove an item from the finalizer prior to running

its finalization procedure.  (2) In REMOVE-ALL-FROM-GC-FINALIZER!,
don't run the finalization procedure if the key object has been
dropped.

diff --git a/v7/src/runtime/gcfinal.scm b/v7/src/runtime/gcfinal.scm
index 9798b53dce546952e59702cd0135eac4f3830c5d..08b00730a4109215cd1fcebbf9dcebb39142c735 100644 (file)
--- a/v7/src/runtime/gcfinal.scm
+++ b/v7/src/runtime/gcfinal.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: gcfinal.scm,v 14.2 2000/04/10 19:10:53 cph Exp $
+$Id: gcfinal.scm,v 14.3 2002/07/08 17:25:29 cph Exp $
 
-Copyright (c) 2000 Massachusetts Institute of Technology
+Copyright (c) 2000, 2002 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -84,11 +84,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        (let loop ()
         (let ((items (gc-finalizer-items finalizer)))
           (if (pair? items)
-              (begin
+              (let ((item (car items)))
                 (set-gc-finalizer-items! finalizer (cdr items))
-                (let ((object (weak-cdr (car items))))
-                  (if object
-                      (procedure object)))
+                (if (weak-pair/car? item)
+                    (procedure (weak-cdr item)))
                 (loop)))))))))
 \f
 (define (search-gc-finalizer finalizer predicate)
@@ -133,13 +132,13 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
         (if (pair? items)
             (if (weak-pair/car? (car items))
                 (loop (cdr items) items)
-                (begin
-                  (procedure (weak-cdr (car items)))
-                  (let ((next (cdr items)))
-                    (if prev
-                        (set-cdr! prev next)
-                        (set-gc-finalizer-items! finalizer next))
-                    (loop next prev))))))))))
+                (let ((context (weak-cdr (car items)))
+                      (next (cdr items)))
+                  (if prev
+                      (set-cdr! prev next)
+                      (set-gc-finalizer-items! finalizer next))
+                  (procedure context)
+                  (loop next prev)))))))))
 
 (define (walk-gc-finalizers-list procedure)
   (let loop ((finalizers gc-finalizers) (prev #f))