From a1bb06a9686493ffa4794ffbba4af82383da0877 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 10 Nov 2003 21:46:35 +0000
Subject: [PATCH] Simplify gc-finalizer interface to guarantee that it is used
 correctly.

---
 v7/src/runtime/crypto.scm   | 41 ++++++++---------
 v7/src/runtime/gcfinal.scm  | 92 +++++++++++++++++++++++--------------
 v7/src/runtime/gdbm.scm     | 25 +++++-----
 v7/src/runtime/io.scm       | 39 ++++++++--------
 v7/src/runtime/os2graph.scm | 21 ++++-----
 v7/src/runtime/pgsql.scm    | 30 ++++++------
 v7/src/runtime/process.scm  | 11 +++--
 v7/src/runtime/string.scm   | 18 +++++---
 v7/src/runtime/x11graph.scm | 66 +++++++++++++-------------
 9 files changed, 186 insertions(+), 157 deletions(-)

diff --git a/v7/src/runtime/crypto.scm b/v7/src/runtime/crypto.scm
index 82670a103..edf700beb 100644
--- a/v7/src/runtime/crypto.scm
+++ b/v7/src/runtime/crypto.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: crypto.scm,v 14.17 2003/11/09 04:40:40 cph Exp $
+$Id: crypto.scm,v 14.18 2003/11/10 21:45:55 cph Exp $
 
 Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology
 
@@ -71,17 +71,13 @@ USA.
        (let ((index ((ucode-primitive mhash_init 1) id)))
 	 (if (not index)
 	     (error "Unable to allocate mhash context:" name))
-	 (let ((context (make-mhash-context index)))
-	   (add-to-gc-finalizer! mhash-contexts context index)
-	   context))))))
+	 (add-to-gc-finalizer! mhash-contexts (make-mhash-context index)))))))
 
 (define (mhash-update context string start end)
   (guarantee-mhash-context context 'MHASH-UPDATE)
   ((ucode-primitive mhash 4) (mhash-context-index context) string start end))
 
 (define (mhash-end context)
-  (guarantee-mhash-context context 'MHASH-END)
-  (set-mhash-context-index! context #f)
   (remove-from-gc-finalizer! mhash-contexts context))
 
 (define (mhash-hmac-init name key)
@@ -92,9 +88,8 @@ USA.
        (let ((index ((ucode-primitive mhash_hmac_init 3) id key pblock)))
 	 (if (not index)
 	     (error "Unable to allocate mhash HMAC context:" name))
-	 (let ((context (make-mhash-hmac-context index)))
-	   (add-to-gc-finalizer! mhash-hmac-contexts context index)
-	   context))))))
+	 (add-to-gc-finalizer! mhash-hmac-contexts
+			       (make-mhash-hmac-context index)))))))
 
 (define (mhash-hmac-update context string start end)
   (guarantee-mhash-hmac-context context 'MHASH-HMAC-UPDATE)
@@ -102,8 +97,6 @@ USA.
 			     string start end))
 
 (define (mhash-hmac-end context)
-  (guarantee-mhash-hmac-context context 'MHASH-HMAC-END)
-  (set-mhash-hmac-context-index! context #f)
   (remove-from-gc-finalizer! mhash-hmac-contexts context))
 
 (define mhash-keygen-names)
@@ -225,9 +218,15 @@ USA.
 		      (ucode-primitive mhash_count 0)
 		      (ucode-primitive mhash_get_hash_name 1)))
 	       (set! mhash-contexts
-		     (make-gc-finalizer (ucode-primitive mhash_end 1)))
+		     (make-gc-finalizer (ucode-primitive mhash_end 1)
+					mhash-context?
+					mhash-context-index
+					set-mhash-context-index!))
 	       (set! mhash-hmac-contexts
-		     (make-gc-finalizer (ucode-primitive mhash_hmac_end 1)))
+		     (make-gc-finalizer (ucode-primitive mhash_hmac_end 1)
+					mhash-hmac-context?
+					mhash-hmac-context-index
+					set-mhash-hmac-context-index!))
 	       (set! mhash-keygen-names
 		     (make-names-vector
 		      (ucode-primitive mhash_keygen_count 0)
@@ -363,8 +362,10 @@ USA.
 	 (if (not mcrypt-initialized?)
 	     (begin
 	       (set! mcrypt-contexts
-		     (make-gc-finalizer
-		      (ucode-primitive mcrypt_generic_end 1)))
+		     (make-gc-finalizer (ucode-primitive mcrypt_generic_end 1)
+					mcrypt-context?
+					mcrypt-context-index
+					set-mcrypt-context-index!))
 	       (set! mcrypt-algorithm-names-vector
 		     ((ucode-primitive mcrypt_list_algorithms 0)))
 	       (set! mcrypt-mode-names-vector
@@ -385,10 +386,10 @@ USA.
 (define (mcrypt-open-module algorithm mode)
   (without-interrupts
    (lambda ()
-     (let ((index ((ucode-primitive mcrypt_module_open 2) algorithm mode)))
-       (let ((context (make-mcrypt-context index)))
-	 (add-to-gc-finalizer! mcrypt-contexts context index)
-	 context)))))
+     (add-to-gc-finalizer! mcrypt-contexts
+			   (make-mcrypt-context
+			    ((ucode-primitive mcrypt_module_open 2) algorithm
+								    mode))))))
 
 (define (mcrypt-init context key init-vector)
   (guarantee-mcrypt-context context 'MCRYPT-INIT)
@@ -419,8 +420,6 @@ USA.
 	       code))))
 
 (define (mcrypt-end context)
-  (guarantee-mcrypt-context context 'MCRYPT-END)
-  (set-mcrypt-context-index! context #f)
   (remove-from-gc-finalizer! mcrypt-contexts context))
 
 (define (mcrypt-generic-unary name context-op module-op)
diff --git a/v7/src/runtime/gcfinal.scm b/v7/src/runtime/gcfinal.scm
index 3a7f25929..cfb8f000f 100644
--- a/v7/src/runtime/gcfinal.scm
+++ b/v7/src/runtime/gcfinal.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gcfinal.scm,v 14.7 2003/06/08 04:21:56 cph Exp $
+$Id: gcfinal.scm,v 14.8 2003/11/10 21:45:59 cph Exp $
 
 Copyright 2000,2002,2003 Massachusetts Institute of Technology
 
@@ -31,58 +31,78 @@ USA.
 
 (declare (usual-integrations))
 
-(define-structure (gc-finalizer (constructor %make-gc-finalizer
-					     (procedure reset-on-restore?)))
+(define-structure (gc-finalizer (constructor %make-gc-finalizer))
   (procedure #f read-only #t)
-  (reset-on-restore? #f read-only #t)
+  (object? #f read-only #t)
+  (object-context #f read-only #t)
+  (set-object-context! #f read-only #t)
   (items '()))
 
 (define (guarantee-gc-finalizer object procedure)
   (if (not (gc-finalizer? object))
       (error:wrong-type-argument object "GC finalizer" procedure)))
 
-(define (make-gc-finalizer procedure #!optional reset-on-restore?)
+(define (make-gc-finalizer procedure
+			   object?
+			   object-context
+			   set-object-context!)
   (if (not (procedure? procedure))
       (error:wrong-type-argument procedure "procedure" 'MAKE-GC-FINALIZER))
   (if (not (procedure-arity-valid? procedure 1))
       (error:bad-range-argument procedure 'MAKE-GC-FINALIZER))
   (let ((finalizer
 	 (%make-gc-finalizer procedure
-			     (if (default-object? reset-on-restore?)
-				 #t
-				 reset-on-restore?))))
+			     object?
+			     object-context
+			     set-object-context!
+			     '())))
     (set! gc-finalizers (weak-cons finalizer gc-finalizers))
     finalizer))
 
-(define (add-to-gc-finalizer! finalizer object context)
+(define (add-to-gc-finalizer! finalizer object)
   (guarantee-gc-finalizer finalizer 'ADD-TO-GC-FINALIZER!)
-  (if (object-pointer? object)
-      (without-interrupts
-       (lambda ()
-	 (set-gc-finalizer-items!
-	  finalizer
-	  (cons (weak-cons object context)
-		(gc-finalizer-items finalizer)))))))
+  (if (not ((gc-finalizer-object? finalizer) object))
+      (error:wrong-type-argument object
+				 "Finalized object"
+				 'ADD-TO-GC-FINALIZER!))
+  (let ((context ((gc-finalizer-object-context finalizer) object)))
+    (without-interrupts
+     (lambda ()
+       (set-gc-finalizer-items! finalizer
+				(cons (weak-cons object context)
+				      (gc-finalizer-items finalizer))))))
+  object)
 
 (define (remove-from-gc-finalizer! finalizer object)
   (guarantee-gc-finalizer finalizer 'REMOVE-FROM-GC-FINALIZER!)
-  (and (object-pointer? object)
-       (let ((procedure (gc-finalizer-procedure finalizer)))
-	 (without-interrupts
-	  (lambda ()
-	    (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
-	      (and (pair? items)
-		   (if (eq? object (weak-car (car items)))
-		       (let ((next (cdr items)))
-			 (if prev
-			     (set-cdr! prev next)
-			     (set-gc-finalizer-items! finalizer next))
-			 (procedure (weak-cdr (car items))))
-		       (loop (cdr items) items)))))))))
+  (if (not ((gc-finalizer-object? finalizer) object))
+      (error:wrong-type-argument object
+				 "Finalized object"
+				 'REMOVE-FROM-GC-FINALIZER!))
+  (let ((procedure (gc-finalizer-procedure finalizer))
+	(object-context (gc-finalizer-object-context finalizer))
+	(set-object-context! (gc-finalizer-set-object-context! finalizer)))
+    (without-interrupts
+     (lambda ()
+       (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
+	 (and (pair? items)
+	      (if (eq? object (weak-car (car items)))
+		  (let ((next (cdr items)))
+		    (if prev
+			(set-cdr! prev next)
+			(set-gc-finalizer-items! finalizer next))
+		    (let ((context (object-context object)))
+		      (if context
+			  (begin
+			    (set-object-context! object #f)
+			    (procedure context)))))
+		  (loop (cdr items) items))))))))
 
 (define (remove-all-from-gc-finalizer! finalizer)
   (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!)
-  (let ((procedure (gc-finalizer-procedure finalizer)))
+  (let ((procedure (gc-finalizer-procedure finalizer))
+	(object-context (gc-finalizer-object-context finalizer))
+	(set-object-context! (gc-finalizer-set-object-context! finalizer)))
     (without-interrupts
      (lambda ()
        (let loop ()
@@ -90,8 +110,13 @@ USA.
 	   (if (pair? items)
 	       (let ((item (car items)))
 		 (set-gc-finalizer-items! finalizer (cdr items))
-		 (if (weak-pair/car? item)
-		     (procedure (weak-cdr item)))
+		 (let ((object (weak-car item)))
+		   (if object
+		       (let ((context (object-context object)))
+			 (if context
+			     (begin
+			       (set-object-context! object #f)
+			       (procedure context))))))
 		 (loop)))))))))
 
 (define (search-gc-finalizer finalizer predicate)
@@ -151,8 +176,7 @@ USA.
    (lambda ()
      (walk-gc-finalizers-list
       (lambda (finalizer)
-	(if (gc-finalizer-reset-on-restore? finalizer)
-	    (set-gc-finalizer-items! finalizer '())))))))
+	(set-gc-finalizer-items! finalizer '()))))))
 
 (define (run-gc-finalizers)
   (walk-gc-finalizers-list
diff --git a/v7/src/runtime/gdbm.scm b/v7/src/runtime/gdbm.scm
index 728d27d47..29b90fbd5 100644
--- a/v7/src/runtime/gdbm.scm
+++ b/v7/src/runtime/gdbm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gdbm.scm,v 1.7 2003/11/09 04:40:43 cph Exp $
+$Id: gdbm.scm,v 1.8 2003/11/10 21:46:03 cph Exp $
 
 Copyright 1996,1999,2000,2003 Massachusetts Institute of Technology
 
@@ -38,7 +38,10 @@ USA.
 	 (if (not gdbm-initialized?)
 	     (begin
 	       (set! gdbf-finalizer
-		     (make-gc-finalizer (ucode-primitive gdbm-close 1)))
+		     (make-gc-finalizer (ucode-primitive gdbm-close 1)
+					gdbf?
+					gdbf-descriptor
+					set-gdbf-descriptor!))
 	       (set! gdbm-initialized? #t)))
 	 #t)))
 
@@ -56,22 +59,16 @@ USA.
   (let ((filename (->namestring (merge-pathnames filename))))
     (without-interrupts
      (lambda ()
-       (let ((descriptor
-	      (gdbm-error ((ucode-primitive gdbm-open 4)
-			   filename block-size flags mode))))
-	 (let ((gdbf (make-gdbf descriptor filename)))
-	   (add-to-gc-finalizer! gdbf-finalizer gdbf descriptor)
-	   gdbf))))))
+       (add-to-gc-finalizer!
+	gdbf-finalizer
+	(make-gdbf (gdbm-error ((ucode-primitive gdbm-open 4)
+				filename block-size flags mode))
+		   filename))))))
 
 (define (gdbm-close gdbf)
   (if (not (gdbf? gdbf))
       (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE))
-  (without-interrupts
-   (lambda ()
-     (if (gdbf-descriptor gdbf)
-	 (begin
-	   (set-gdbf-descriptor! gdbf #f)
-	   (remove-from-gc-finalizer! gdbf-finalizer gdbf))))))
+  (remove-from-gc-finalizer! gdbf-finalizer gdbf))
 
 ;; Parameters to gdbm_store for simple insertion or replacement in the
 ;; case that the key is already in the database.
diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 9b901c567..baf95c5df 100644
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: io.scm,v 14.74 2003/11/07 20:35:48 cph Exp $
+$Id: io.scm,v 14.75 2003/11/10 21:46:07 cph Exp $
 
 Copyright 1986,1987,1988,1990,1991,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1998,1999,2000,2001 Massachusetts Institute of Technology
@@ -35,9 +35,15 @@ USA.
 
 (define (initialize-package!)
   (set! open-channels
-	(make-gc-finalizer (ucode-primitive channel-close 1)))
+	(make-gc-finalizer (ucode-primitive channel-close 1)
+			   channel?
+			   channel-descriptor
+			   set-channel-descriptor!))
   (set! open-directories
-	(make-gc-finalizer (ucode-primitive new-directory-close 1)))
+	(make-gc-finalizer (ucode-primitive new-directory-close 1)
+			   directory-channel?
+			   directory-channel/descriptor
+			   set-directory-channel/descriptor!))
   (initialize-select-registry!))
 
 (define-structure (channel (constructor %make-channel))
@@ -83,7 +89,6 @@ USA.
 	(eq? 'OS/2-CONSOLE type))))
 
 (define (channel-close channel)
-  (set-channel-descriptor! channel #f)
   (remove-from-gc-finalizer! open-channels channel))
 
 (define-integrable (channel-open? channel)
@@ -412,18 +417,12 @@ USA.
 (define (directory-channel-open name)
   (without-interrupts
    (lambda ()
-     (let ((descriptor ((ucode-primitive new-directory-open 1) name)))
-       (let ((channel (make-directory-channel descriptor)))
-	 (add-to-gc-finalizer! open-directories channel descriptor)
-	 channel)))))
+     (add-to-gc-finalizer! open-directories
+			   (make-directory-channel
+			    ((ucode-primitive new-directory-open 1) name))))))
 
 (define (directory-channel-close channel)
-  (without-interrupts
-   (lambda ()
-     (if (directory-channel/descriptor channel)
-	 (begin
-	   (remove-from-gc-finalizer! open-directories channel)
-	   (set-directory-channel/descriptor! channel #f))))))
+  (remove-from-gc-finalizer! open-directories channel))
 
 (define (directory-channel-read channel)
   ((ucode-primitive new-directory-read 1)
@@ -1127,7 +1126,10 @@ USA.
 (define (initialize-select-registry!)
   (set! have-select? ((ucode-primitive have-select? 0)))
   (set! select-registry-finalizer
-	(make-gc-finalizer (ucode-primitive deallocate-select-registry 1)))
+	(make-gc-finalizer (ucode-primitive deallocate-select-registry 1)
+			   select-registry?
+			   select-registry-handle
+			   set-select-registry-handle!))
   (let ((reset-rv!
 	 (lambda ()
 	   (set! select-registry-result-vectors '())
@@ -1147,10 +1149,9 @@ USA.
 (define (make-select-registry)
   (without-interrupts
    (lambda ()
-     (let ((handle ((ucode-primitive allocate-select-registry 0))))
-       (let ((registry (%make-select-registry handle)))
-	 (add-to-gc-finalizer! select-registry-finalizer registry handle)
-	 registry)))))
+     (add-to-gc-finalizer! select-registry-finalizer
+			   (%make-select-registry
+			    ((ucode-primitive allocate-select-registry 0)))))))
 
 (define (add-to-select-registry! registry descriptor mode)
   ((ucode-primitive add-to-select-registry 3)
diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm
index 6e4473f2f..e771db61b 100644
--- a/v7/src/runtime/os2graph.scm
+++ b/v7/src/runtime/os2graph.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2graph.scm,v 1.24 2003/11/09 04:40:47 cph Exp $
+$Id: os2graph.scm,v 1.25 2003/11/10 21:46:16 cph Exp $
 
 Copyright 1995,1996,1997,1999,2000 Massachusetts Institute of Technology
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
@@ -95,8 +95,10 @@ USA.
       (fill-from-byte-vector ,os2-image/fill-from-byte-vector))))
   (set! event-descriptor #f)
   (set! event-previewer-registration #f)
-  (set! window-finalizer (make-gc-finalizer os2win-close))
-  (set! image-finalizer (make-gc-finalizer destroy-memory-ps))
+  (set! window-finalizer
+	(make-gc-finalizer os2win-close window? window/wid set-window/wid!))
+  (set! image-finalizer
+	(make-gc-finalizer destroy-memory-ps image? image/ps set-image/ps!))
   (set! user-event-mask user-event-mask:default)
   (set! user-event-queue (make-queue))
   (initialize-color-table)
@@ -160,14 +162,12 @@ USA.
 		       (exact->inexact (/ (- width 1) 2))
 		       (exact->inexact (/ (- height 1) 2)))))
     (set-window/backing-image! window (create-image width height))
-    (add-to-gc-finalizer! window-finalizer window wid)
-    window))
+    (add-to-gc-finalizer! window-finalizer window)))
 
 (define (close-window window)
   (if (window/wid window)
       (begin
 	(destroy-image (window/backing-image window))
-	(set-window/wid! window #f)
 	(remove-from-gc-finalizer! window-finalizer window))))
 
 (define-integrable (os2-graphics-device/wid device)
@@ -927,9 +927,7 @@ USA.
 (define (create-image width height)
   (let ((ps (os2ps-create-memory-ps)))
     (os2ps-set-bitmap ps (os2ps-create-bitmap ps width height))
-    (let ((image (make-image ps width height #f)))
-      (add-to-gc-finalizer! image-finalizer image ps)
-      image)))
+    (add-to-gc-finalizer! image-finalizer (make-image ps width height #f))))
 
 (define (os2-image/set-colormap image colormap)
   ;; Kludge: IMAGE/FILL-FROM-BYTE-VECTOR doesn't accept a colormap
@@ -943,10 +941,7 @@ USA.
   (destroy-image (image/descriptor image)))
 
 (define (destroy-image image)
-  (if (image/ps image)
-      (begin
-	(set-image/ps! image #f)
-	(remove-from-gc-finalizer! image-finalizer image))))
+  (remove-from-gc-finalizer! image-finalizer image))
 
 (define (destroy-memory-ps ps)
   (let ((bitmap (os2ps-set-bitmap ps #f)))
diff --git a/v7/src/runtime/pgsql.scm b/v7/src/runtime/pgsql.scm
index 8c7fd385a..2f13e3a33 100644
--- a/v7/src/runtime/pgsql.scm
+++ b/v7/src/runtime/pgsql.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pgsql.scm,v 1.6 2003/11/09 04:40:51 cph Exp $
+$Id: pgsql.scm,v 1.7 2003/11/10 21:46:20 cph Exp $
 
 Copyright 2003 Massachusetts Institute of Technology
 
@@ -145,8 +145,16 @@ USA.
        (begin
 	 (if (not pgsql-initialized?)
 	     (begin
-	       (set! connections (make-gc-finalizer pq-finish))
-	       (set! results (make-gc-finalizer pq-clear))
+	       (set! connections
+		     (make-gc-finalizer pq-finish
+					connection?
+					connection-handle
+					set-connection-handle!))
+	       (set! results
+		     (make-gc-finalizer pq-clear
+					result?
+					result-handle
+					set-result-handle!))
 	       (set! pgsql-initialized? #t)))
 	 #t)))
 
@@ -218,13 +226,7 @@ USA.
        (make-connection handle)))))
 
 (define (close-pgsql-conn connection)
-  (guarantee-connection connection 'CLOSE-PGSQL-CONN)
-  (without-interrupts
-   (lambda ()
-     (if (connection-handle connection)
-	 (begin
-	   (set-connection-handle! connection #f)
-	   (remove-from-gc-finalizer! connections connection))))))
+  (remove-from-gc-finalizer! connections connection))
 
 (define (call-with-pgsql-conn parameters procedure)
   (let ((conn))
@@ -323,13 +325,15 @@ USA.
 	 (ill-formed-syntax form)))))
 
 (define-result-accessor result-error-message)
-(define-result-accessor clear)
 (define-result-accessor n-tuples)
 (define-result-accessor n-fields)
 (define-result-accessor cmd-status)
 
-(define (pgsql-result-status result)
-  (index->name (pq-result-status (result->handle result)) exec-status))
+(DEFINE (PGSQL-RESULT-STATUS RESULT)
+  (INDEX->NAME (PQ-RESULT-STATUS (RESULT->HANDLE RESULT)) EXEC-STATUS))
+
+(define (pgsql-clear result)
+  (remove-from-gc-finalizer! results result))
 
 (define (pgsql-field-name result index)
   (pq-field-name (result->handle result) index))
diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm
index 47c72afbf..b1c262d09 100644
--- a/v7/src/runtime/process.scm
+++ b/v7/src/runtime/process.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: process.scm,v 1.30 2003/11/09 04:40:54 cph Exp $
+$Id: process.scm,v 1.31 2003/11/10 21:46:23 cph Exp $
 
 Copyright 1990,1991,1992,1995,1997,1998 Massachusetts Institute of Technology
 Copyright 1999,2000,2003 Massachusetts Institute of Technology
@@ -35,7 +35,10 @@ USA.
 
 (define (initialize-package!)
   (set! subprocess-finalizer
-	(make-gc-finalizer (ucode-primitive process-delete 1) #t))
+	(make-gc-finalizer (ucode-primitive process-delete 1)
+			   subprocess?
+			   subprocess-index
+			   set-subprocess-index!))
   (reset-package!)
   (add-event-receiver! event:after-restore reset-package!)
   (add-event-receiver! event:before-exit delete-all-processes))
@@ -194,8 +197,7 @@ USA.
 		    (set-subprocess-exit-reason!
 		     process
 		     ((ucode-primitive process-reason 1) index))
-		    (add-to-gc-finalizer! subprocess-finalizer process index)
-		    process))))))))
+		    (add-to-gc-finalizer! subprocess-finalizer process)))))))))
     (if (and (eq? ctty 'FOREGROUND)
 	     (eqv? (%subprocess-status process) 0))
 	(subprocess-continue-foreground process))
@@ -206,7 +208,6 @@ USA.
    (lambda ()
      (if (subprocess-index process)
 	 (begin
-	   (set-subprocess-index! process #f)
 	   (remove-from-gc-finalizer! subprocess-finalizer process)
 	   (%close-subprocess-i/o process))))))
 
diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index 687950dda..7cd3598bd 100644
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.53 2003/02/26 00:24:29 cph Exp $
+$Id: string.scm,v 14.54 2003/11/10 21:46:27 cph Exp $
 
 Copyright 1986,1987,1988,1992,1993,1994 Massachusetts Institute of Technology
 Copyright 1995,1997,1999,2000,2001,2002 Massachusetts Institute of Technology
@@ -1337,20 +1337,24 @@ USA.
 (define external-strings)
 (define (initialize-package!)
   (set! external-strings
-	(make-gc-finalizer (ucode-primitive deallocate-external-string)))
+	(make-gc-finalizer (ucode-primitive deallocate-external-string)
+			   external-string?
+			   external-string-descriptor
+			   set-external-string-descriptor!))
   unspecific)
 
 (define-structure external-string
-  (descriptor #f read-only #t)
+  descriptor
   (length #f read-only #t))
 
 (define (allocate-external-string n-bytes)
   (without-interrupts
    (lambda ()
-     (let ((descriptor ((ucode-primitive allocate-external-string) n-bytes)))
-       (let ((xstring (make-external-string descriptor n-bytes)))
-	 (add-to-gc-finalizer! external-strings xstring descriptor)
-	 xstring)))))
+     (add-to-gc-finalizer!
+      external-strings
+      (make-external-string
+       ((ucode-primitive allocate-external-string) n-bytes)
+       n-bytes)))))
 
 (define (xstring? object)
   (or (string? object)
diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm
index b7b97880e..f50ed2341 100644
--- a/v7/src/runtime/x11graph.scm
+++ b/v7/src/runtime/x11graph.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: x11graph.scm,v 1.57 2003/11/09 04:41:02 cph Exp $
+$Id: x11graph.scm,v 1.58 2003/11/10 21:46:35 cph Exp $
 
 Copyright 1989,1990,1991,1992,1993,1995 Massachusetts Institute of Technology
 Copyright 1996,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
@@ -200,7 +200,10 @@ USA.
 	   (visual-info ,x-graphics/visual-info)
 	   (withdraw-window ,x-graphics/withdraw-window))))
   (set! display-finalizer
-	(make-gc-finalizer (ucode-primitive x-close-display 1)))
+	(make-gc-finalizer (ucode-primitive x-close-display 1)
+			   x-display?
+			   x-display/xd
+			   set-x-display/xd!))
   (initialize-image-datatype)
   (initialize-colormap-datatype))
 
@@ -223,7 +226,10 @@ USA.
 			(write (x-display/name display) port)))))
   (name #f read-only #t)
   xd
-  (window-finalizer (make-gc-finalizer (ucode-primitive x-close-window 1))
+  (window-finalizer (make-gc-finalizer (ucode-primitive x-close-window 1)
+				       x-window?
+				       x-window/xw
+				       set-x-window/xw!)
 		    read-only #t)
   (event-queue (make-queue))
   (properties (make-1d-table) read-only #t))
@@ -249,7 +255,7 @@ USA.
 	  (if (not xd)
 	      (error "Unable to open display:" name))
 	  (let ((display (make-x-display name xd)))
-	    (add-to-gc-finalizer! display-finalizer display xd)
+	    (add-to-gc-finalizer! display-finalizer display)
 	    (make-event-previewer display)
 	    display)))))
 
@@ -259,7 +265,6 @@ USA.
      (if (x-display/xd display)
 	 (begin
 	   (remove-all-from-gc-finalizer! (x-display/window-finalizer display))
-	   (set-x-display/xd! display #f)
 	   (remove-from-gc-finalizer! display-finalizer display))))))
 
 (define (x-graphics/open-display? display)
@@ -443,12 +448,9 @@ USA.
      (close-x-window (graphics-device/descriptor device)))))
 
 (define (close-x-window window)
-  (if (x-window/xw window)
-      (begin
-	(set-x-window/xw! window #f)
-	(remove-from-gc-finalizer!
-	 (x-display/window-finalizer (x-window/display window))
-	 window))))
+  (remove-from-gc-finalizer!
+   (x-display/window-finalizer (x-window/display window))
+   window))
 
 (define (x-geometry-string x y width height)
   (string-append (if (and width height)
@@ -490,8 +492,7 @@ USA.
 		 (vector #f resource class))))
 	  (x-window-set-event-mask xw event-mask:normal)
 	  (let ((window (make-x-window xw display)))
-	    (add-to-gc-finalizer! (x-display/window-finalizer display)
-				  window xw)
+	    (add-to-gc-finalizer! (x-display/window-finalizer display) window)
 	    (if map? (map-window window))
 	    (descriptor->device window)))))))
 
@@ -838,25 +839,27 @@ USA.
    (graphics-type-properties x-graphics-device-type)
    'IMAGE-TYPE
    (make-image-type
-    `((create   ,create-x-image) ;;this one returns an IMAGE descriptor
-      (destroy  ,x-graphics-image/destroy)
-      (width    ,x-graphics-image/width)
-      (height   ,x-graphics-image/height)
-      (draw     ,x-graphics-image/draw)
-      (draw-subimage  ,x-graphics-image/draw-subimage)
-      (fill-from-byte-vector  ,x-graphics-image/fill-from-byte-vector))))
-  (set! image-list (make-gc-finalizer x-destroy-image))
+    `((create ,create-x-image)
+      (destroy ,x-graphics-image/destroy)
+      (width ,x-graphics-image/width)
+      (height ,x-graphics-image/height)
+      (draw ,x-graphics-image/draw)
+      (draw-subimage ,x-graphics-image/draw-subimage)
+      (fill-from-byte-vector ,x-graphics-image/fill-from-byte-vector))))
+  (set! image-list
+	(make-gc-finalizer x-destroy-image
+			   x-image?
+			   x-image/descriptor
+			   set-x-image/descriptor!))
   unspecific)
 
 (define (create-x-image device width height)
   (let ((window (x-graphics-device/xw device)))
-    (let ((descriptor (x-create-image window width height)))
-      (let ((image (make-x-image descriptor window width height)))
-	(add-to-gc-finalizer! image-list image descriptor)
-	image))))
+    (add-to-gc-finalizer! image-list
+			  (make-x-image (x-create-image window width height)
+					window width height))))
 
 (define (x-image/destroy image)
-  (set-x-image/descriptor! image #f)
   (remove-from-gc-finalizer! image-list image))
 
 (define (x-image/get-pixel image x y)
@@ -941,13 +944,15 @@ USA.
 (define colormap-list)
 
 (define (initialize-colormap-datatype)
-  (set! colormap-list (make-gc-finalizer x-free-colormap))
+  (set! colormap-list
+	(make-gc-finalizer x-free-colormap
+			   x-colormap?
+			   colormap/descriptor
+			   set-colormap/descriptor!))
   unspecific)
 
 (define (make-colormap descriptor)
-  (let ((colormap (%make-colormap descriptor)))
-    (add-to-gc-finalizer! colormap-list colormap descriptor)
-    colormap))
+  (add-to-gc-finalizer! colormap-list (%make-colormap descriptor)))
 
 (define (x-graphics/get-colormap device)
   (make-colormap (x-window-colormap (x-graphics-device/xw device))))
@@ -964,7 +969,6 @@ USA.
 	(make-colormap descriptor)))))
 
 (define (x-colormap/free colormap)
-  (set-colormap/descriptor! colormap #f)
   (remove-from-gc-finalizer! colormap-list colormap))
 
 (define (x-colormap/allocate-color colormap r g b)
-- 
2.25.1