Rationalize treatment of gc-finalized data structures.

diff --git a/v7/src/runtime/crypto.scm b/v7/src/runtime/crypto.scm
index 3ac30e4acf9b8d7e126c1a88a09663b489179875..82670a103be65bb111606ce260c54f9c17c4435b 100644 (file)
--- a/v7/src/runtime/crypto.scm
+++ b/v7/src/runtime/crypto.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: crypto.scm,v 14.16 2003/02/14 18:28:32 cph Exp $
+$Id: crypto.scm,v 14.17 2003/11/09 04:40:40 cph Exp $
 
-Copyright (c) 2000-2002 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -42,16 +42,20 @@ USA.
            ((eq? name (vector-ref mhash-algorithm-names i)) i)
            (else (loop (fix:+ i 1)))))))
 
-(define-structure mhash-context (index #f read-only #t))
-(define-structure mhash-hmac-context (index #f read-only #t))
+(define-structure mhash-context index)
+(define-structure mhash-hmac-context index)
 
 (define (guarantee-mhash-context object procedure)
   (if (not (mhash-context? object))
-      (error:wrong-type-argument object "mhash context" procedure)))
+      (error:wrong-type-argument object "mhash context" procedure))
+  (if (not (mhash-context-index object))
+      (error:bad-range-argument object procedure)))
 
 (define (guarantee-mhash-hmac-context object procedure)
   (if (not (mhash-hmac-context? object))
-      (error:wrong-type-argument object "mhash HMAC context" procedure)))
+      (error:wrong-type-argument object "mhash HMAC context" procedure))
+  (if (not (mhash-hmac-context-index object))
+      (error:bad-range-argument object procedure)))
 
 (define (mhash-type-names)
   (names-vector->list mhash-algorithm-names))
@@ -77,6 +81,7 @@ USA.
 
 (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)
@@ -98,6 +103,7 @@ USA.
 
 (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))
 \f
 (define mhash-keygen-names)
@@ -341,11 +347,13 @@ USA.
 (define mcrypt-algorithm-names-vector)
 (define mcrypt-mode-names-vector)
 (define mcrypt-contexts)
-(define-structure mcrypt-context (index #f read-only #t))
+(define-structure mcrypt-context index)
 
 (define (guarantee-mcrypt-context object procedure)
   (if (not (mcrypt-context? object))
-      (error:wrong-type-argument object "mcrypt context" procedure)))
+      (error:wrong-type-argument object "mcrypt context" procedure))
+  (if (not (mcrypt-context-index object))
+      (error:bad-range-argument object procedure)))
 
 (define (mcrypt-available?)
   (load-library-object-file "prmcrypt" #f)
@@ -381,7 +389,7 @@ USA.
        (let ((context (make-mcrypt-context index)))
         (add-to-gc-finalizer! mcrypt-contexts context index)
         context)))))
-
+\f
 (define (mcrypt-init context key init-vector)
   (guarantee-mcrypt-context context 'MCRYPT-INIT)
   (let ((code
@@ -412,8 +420,9 @@ USA.
 
 (define (mcrypt-end context)
   (guarantee-mcrypt-context context 'MCRYPT-END)
+  (set-mcrypt-context-index! context #f)
   (remove-from-gc-finalizer! mcrypt-contexts context))
-\f
+
 (define (mcrypt-generic-unary name context-op module-op)
   (lambda (object)
     (cond ((mcrypt-context? object) (context-op (mcrypt-context-index object)))
@@ -437,7 +446,7 @@ USA.
    'MCRYPT-BLOCK-ALGORITHM?
    (ucode-primitive mcrypt_enc_is_block_algorithm 1)
    (ucode-primitive mcrypt_module_is_block_algorithm 1)))
-
+\f
 (define mcrypt-block-mode?
   (mcrypt-generic-unary
    'MCRYPT-BLOCK-MODE?
@@ -470,7 +479,7 @@ USA.
   (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME)
   ((ucode-primitive mcrypt_enc_get_modes_name 1)
    (mcrypt-context-index context)))
-\f
+
 (define (mcrypt-encrypt-port algorithm mode input output key init-vector
                             encrypt?)
   ;; Assumes that INPUT is in blocking mode.

diff --git a/v7/src/runtime/gdbm.scm b/v7/src/runtime/gdbm.scm
index c905a8f19b0d1745ab9e45db6e20e07d530af066..728d27d47c65b89dfea27e315b9524a2463cfd65 100644 (file)
--- a/v7/src/runtime/gdbm.scm
+++ b/v7/src/runtime/gdbm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gdbm.scm,v 1.6 2003/07/21 03:19:25 cph Exp $
+$Id: gdbm.scm,v 1.7 2003/11/09 04:40:43 cph Exp $
 
 Copyright 1996,1999,2000,2003 Massachusetts Institute of Technology
 
@@ -70,8 +70,8 @@ USA.
    (lambda ()
      (if (gdbf-descriptor gdbf)
         (begin
-          (remove-from-gc-finalizer! gdbf-finalizer gdbf)
-          (set-gdbf-descriptor! gdbf #f))))))
+          (set-gdbf-descriptor! gdbf #f)
+          (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/os2graph.scm b/v7/src/runtime/os2graph.scm
index 8f628e4a151a079046d31b8e3a836b90235538d9..6e4473f2f88b7f7ee47dd1e163dee479c155e7e2 100644 (file)
--- a/v7/src/runtime/os2graph.scm
+++ b/v7/src/runtime/os2graph.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2graph.scm,v 1.23 2003/03/10 20:53:34 cph Exp $
+$Id: os2graph.scm,v 1.24 2003/11/09 04:40:47 cph Exp $
 
 Copyright 1995,1996,1997,1999,2000 Massachusetts Institute of Technology
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
@@ -167,8 +167,8 @@ USA.
   (if (window/wid window)
       (begin
        (destroy-image (window/backing-image window))
-       (remove-from-gc-finalizer! window-finalizer window)
-       (set-window/wid! window #f))))
+       (set-window/wid! window #f)
+       (remove-from-gc-finalizer! window-finalizer window))))
 
 (define-integrable (os2-graphics-device/wid device)
   (window/wid (graphics-device/descriptor device)))
@@ -945,8 +945,8 @@ USA.
 (define (destroy-image image)
   (if (image/ps image)
       (begin
-       (remove-from-gc-finalizer! image-finalizer image)
-       (set-image/ps! image #f))))
+       (set-image/ps! image #f)
+       (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 a53b0246f0cea7c90c578028f080b35d5f1e79ae..8c7fd385a7525fe43261c450db51641f60339f4c 100644 (file)
--- a/v7/src/runtime/pgsql.scm
+++ b/v7/src/runtime/pgsql.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pgsql.scm,v 1.5 2003/11/07 20:07:47 cph Exp $
+$Id: pgsql.scm,v 1.6 2003/11/09 04:40:51 cph Exp $
 
 Copyright 2003 Massachusetts Institute of Technology
 
@@ -223,8 +223,8 @@ USA.
    (lambda ()
      (if (connection-handle connection)
         (begin
-          (remove-from-gc-finalizer! connections connection)
-          (set-connection-handle! connection #f))))))
+          (set-connection-handle! connection #f)
+          (remove-from-gc-finalizer! connections connection))))))
 
 (define (call-with-pgsql-conn parameters procedure)
   (let ((conn))

diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm
index e4ece65794ef52a69a6f03b3b26039c5a353e79a..47c72afbff1545fe101c4a7fd72a422e71fa076f 100644 (file)
--- a/v7/src/runtime/process.scm
+++ b/v7/src/runtime/process.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: process.scm,v 1.29 2003/03/10 20:53:34 cph Exp $
+$Id: process.scm,v 1.30 2003/11/09 04:40:54 cph Exp $
 
 Copyright 1990,1991,1992,1995,1997,1998 Massachusetts Institute of Technology
 Copyright 1999,2000,2003 Massachusetts Institute of Technology
@@ -206,8 +206,8 @@ USA.
    (lambda ()
      (if (subprocess-index process)
         (begin
-          (remove-from-gc-finalizer! subprocess-finalizer process)
           (set-subprocess-index! process #f)
+          (remove-from-gc-finalizer! subprocess-finalizer process)
           (%close-subprocess-i/o process))))))
 \f
 (define (subprocess-status process)

diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm
index dd5b44006aa1786b811019e65d52e9ca69c231cc..b7b97880e6e9401671ecac68864d5ce601cff34a 100644 (file)
--- a/v7/src/runtime/x11graph.scm
+++ b/v7/src/runtime/x11graph.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: x11graph.scm,v 1.56 2003/03/07 20:48:09 cph Exp $
+$Id: x11graph.scm,v 1.57 2003/11/09 04:41:02 cph Exp $
 
 Copyright 1989,1990,1991,1992,1993,1995 Massachusetts Institute of Technology
 Copyright 1996,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
@@ -259,8 +259,8 @@ USA.
      (if (x-display/xd display)
         (begin
           (remove-all-from-gc-finalizer! (x-display/window-finalizer display))
-          (remove-from-gc-finalizer! display-finalizer display)
-          (set-x-display/xd! display #f))))))
+          (set-x-display/xd! display #f)
+          (remove-from-gc-finalizer! display-finalizer display))))))
 
 (define (x-graphics/open-display? display)
   (if (x-display/xd display) #t #f))
@@ -445,10 +445,10 @@ USA.
 (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)
-       (set-x-window/xw! window #f))))
+        window))))
 
 (define (x-geometry-string x y width height)
   (string-append (if (and width height)
@@ -856,6 +856,7 @@ USA.
        image))))
 
 (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)
@@ -935,7 +936,7 @@ USA.
 (define-record-type <colormap>
     (%make-colormap descriptor)
     x-colormap?
-  (descriptor colormap/descriptor))
+  (descriptor colormap/descriptor set-colormap/descriptor!))
 
 (define colormap-list)
 
@@ -963,6 +964,7 @@ 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)