From c32a4c992cbe9b349c414a5d79d7333c158f0c67 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 9 Nov 2003 04:41:02 +0000 Subject: [PATCH] Rationalize treatment of gc-finalized data structures. --- v7/src/runtime/crypto.scm | 33 +++++++++++++++++++++------------ v7/src/runtime/gdbm.scm | 6 +++--- v7/src/runtime/os2graph.scm | 10 +++++----- v7/src/runtime/pgsql.scm | 6 +++--- v7/src/runtime/process.scm | 4 ++-- v7/src/runtime/x11graph.scm | 14 ++++++++------ 6 files changed, 42 insertions(+), 31 deletions(-) diff --git a/v7/src/runtime/crypto.scm b/v7/src/runtime/crypto.scm index 3ac30e4ac..82670a103 100644 --- 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)) (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))))) - + (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)) - + (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))) - + (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))) - + (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 c905a8f19..728d27d47 100644 --- 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 8f628e4a1..6e4473f2f 100644 --- 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 a53b0246f..8c7fd385a 100644 --- 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 e4ece6579..47c72afbf 100644 --- 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)))))) (define (subprocess-status process) diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm index dd5b44006..b7b97880e 100644 --- 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 (%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) -- 2.25.1