correctly.
#| -*-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
(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)
(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)
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))
\f
(define mhash-keygen-names)
(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)
(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
(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))))))
\f
(define (mcrypt-init context key init-vector)
(guarantee-mcrypt-context context 'MCRYPT-INIT)
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)
#| -*-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
(declare (usual-integrations))
\f
-(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))))))))
\f
(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 ()
(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)
(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
#| -*-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
(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)))
(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.
#| -*-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
(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))
(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)
(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)
(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 '())
(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)
#| -*-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
(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)
(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)
(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
(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)))
#| -*-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
(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)))
\f
(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))
(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))
#| -*-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
(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))
(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))
(lambda ()
(if (subprocess-index process)
(begin
- (set-subprocess-index! process #f)
(remove-from-gc-finalizer! subprocess-finalizer process)
(%close-subprocess-i/o process))))))
\f
#| -*-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
(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)
#| -*-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
(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))
(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))
(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)))))
(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)
(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)
(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)))))))
(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)
(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))))
(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)
projects / mit-scheme.git / commitdiff