From: Chris Hanson Date: Mon, 10 Nov 2003 21:46:35 +0000 (+0000) Subject: Simplify gc-finalizer interface to guarantee that it is used X-Git-Tag: 20090517-FFI~1757 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a1bb06a9686493ffa4794ffbba4af82383da0877;p=mit-scheme.git Simplify gc-finalizer interface to guarantee that it is used correctly. --- 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)