--- /dev/null
+#| -*-Scheme-*-
+
+$Id: gcfinal.scm,v 14.1 2000/04/10 18:32:17 cph Exp $
+
+Copyright (c) 2000 Massachusetts Institute of Technology
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+|#
+
+;;;; Garbage Finalization
+;;; package: (runtime gc-finalizer)
+
+;;; These will cause problems on interpreted systems, due to the
+;;; consing of the interpreter. For now we'll only run this compiled.
+
+(declare (usual-integrations))
+\f
+(define-structure (gc-finalizer (constructor %make-gc-finalizer
+ (procedure reset-on-restore?)))
+ (procedure #f read-only #t)
+ (reset-on-restore? #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?)
+ (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?))))
+ (set! gc-finalizers (weak-cons finalizer gc-finalizers))
+ finalizer))
+
+(define (add-to-gc-finalizer! finalizer object context)
+ (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)))))))
+
+(define (remove-from-gc-finalizer! finalizer object)
+ (guarantee-gc-finalizer finalizer 'REMOVE-FROM-GC-FINALIZER!)
+ (if (object-pointer? object)
+ (let ((procedure (gc-finalizer-procedure finalizer)))
+ (without-interrupts
+ (lambda ()
+ (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
+ (if (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 next prev))
+ (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)))
+ (without-interrupts
+ (lambda ()
+ (let loop ()
+ (let ((items (gc-finalizer-items finalizer)))
+ (if (pair? items)
+ (begin
+ (set-gc-finalizer-items! finalizer (cdr items))
+ (let ((object (weak-cdr (car items))))
+ (if object
+ (procedure object)))
+ (loop)))))))))
+\f
+(define (search-gc-finalizer finalizer predicate)
+ (guarantee-gc-finalizer finalizer 'SEARCH-GC-FINALIZER)
+ (without-interrupts
+ (lambda ()
+ (let loop ((items (gc-finalizer-items finalizer)))
+ (and (pair? items)
+ (let ((object (weak-car (car items))))
+ (if (and object (predicate object))
+ object
+ (loop (cdr items)))))))))
+
+(define (gc-finalizer-elements finalizer)
+ (guarantee-gc-finalizer finalizer 'GC-FINALIZER-ELEMENTS)
+ (without-interrupts
+ (lambda ()
+ (let loop ((items (gc-finalizer-items finalizer)) (objects '()))
+ (if (pair? items)
+ (loop (cdr items)
+ (let ((object (weak-car (car items))))
+ (if object
+ (cons object objects)
+ objects)))
+ (reverse! objects))))))
+
+(define gc-finalizers)
+
+(define (reset-gc-finalizers)
+ (without-interrupts
+ (lambda ()
+ (walk-gc-finalizers-list
+ (lambda (finalizer)
+ (if (gc-finalizer-reset-on-restore? finalizer)
+ (set-gc-finalizer-items! finalizer '())))))))
+
+(define (run-gc-finalizers)
+ (walk-gc-finalizers-list
+ (lambda (finalizer)
+ (let ((procedure (gc-finalizer-procedure finalizer)))
+ (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
+ (if (pair? items)
+ (if (weak-pair/car? (car items))
+ (loop (cdr items) items)
+ (begin
+ (procedure (weak-cdr (car items)))
+ (let ((next (cdr items)))
+ (if prev
+ (set-cdr! prev next)
+ (set-gc-finalizer-items! finalizer next))
+ (loop next prev))))))))))
+
+(define (walk-gc-finalizers-list procedure)
+ (let loop ((finalizers gc-finalizers) (prev #f))
+ (if (weak-pair? finalizers)
+ (let ((finalizer (weak-car finalizers)))
+ (if finalizer
+ (begin
+ (procedure finalizer)
+ (loop (weak-cdr finalizers) finalizers))
+ (let ((next (weak-cdr finalizers)))
+ (if prev
+ (weak-set-cdr! prev next)
+ (set! gc-finalizers next))
+ (loop next prev)))))))
+
+(define (initialize-package!)
+ (set! gc-finalizers '())
+ (add-gc-daemon! run-gc-finalizers))
+
+(define (initialize-events!)
+ (add-event-receiver! event:after-restore reset-gc-finalizers))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: gdbm.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
+$Id: gdbm.scm,v 1.3 2000/04/10 18:32:32 cph Exp $
-Copyright (c) 1996, 1999 Massachusetts Institute of Technology
+Copyright (c) 1996, 1999, 2000 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(gdbm-error ((ucode-primitive gdbm-open 4)
filename block-size flags mode))))
(let ((gdbf (make-gdbf descriptor filename)))
- (add-to-protection-list! gdbf-list gdbf descriptor)
+ (add-to-gc-finalizer! gdbf-finalizer gdbf descriptor)
gdbf))))))
(define (gdbm-close gdbf)
(if (not (gdbf? gdbf))
(error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE))
- (let ((descriptor (gdbf-descriptor gdbf)))
- (if descriptor
- (without-interrupts
- (lambda ()
- ((ucode-primitive gdbm-close 1) descriptor)
- (remove-from-protection-list! gdbf-list gdbf)
+ (without-interrupts
+ (lambda ()
+ (if (gdbf-descriptor gdbf)
+ (begin
+ (remove-from-gc-finalizer! gdbf-finalizer gdbf)
(set-gdbf-descriptor! gdbf #f))))))
;; Parameters to gdbm_store for simple insertion or replacement in the
(if (string? object) (error "gdbm error:" object))
object)
-(define gdbf-list)
+(define gdbf-finalizer)
(define (initialize-package!)
- (set! gdbf-list (make-protection-list))
- (add-gc-daemon!
- (lambda ()
- (clean-lost-protected-objects gdbf-list (ucode-primitive gdbm-close 1))))
- (add-event-receiver! event:after-restore
- (lambda () (drop-all-protected-objects gdbf-list))))
\ No newline at end of file
+ (set! gdbf-finalizer (make-gc-finalizer (ucode-primitive gdbm-close 1)))
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: io.scm,v 14.60 1999/11/08 18:28:11 cph Exp $
+$Id: io.scm,v 14.61 2000/04/10 18:32:34 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2000 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(declare (usual-integrations))
\f
(define open-channels-list)
-(define open-directories-list)
+(define open-directories)
(define have-select?)
(define (initialize-package!)
(set! open-channels-list (list 'OPEN-CHANNELS-LIST))
(add-gc-daemon! close-lost-open-files-daemon)
- (set! open-directories-list (make-protection-list))
- (add-gc-daemon! close-lost-open-directories-daemon)
+ (set! open-directories
+ (make-gc-finalizer (ucode-primitive new-directory-close 1)))
(set! have-select? ((ucode-primitive have-select? 0)))
(add-event-receiver! event:after-restore primitive-io/reset!))
;; This is invoked after disk-restoring.
;; It "cleans" the new runtime system.
(close-all-open-channels-internal (lambda (ignore) ignore))
- (drop-all-protected-objects open-directories-list)
(set! have-select? ((ucode-primitive have-select? 0)))
unspecific)
(lambda ()
(let ((descriptor ((ucode-primitive new-directory-open 1) name)))
(let ((channel (make-directory-channel descriptor)))
- (add-to-protection-list! open-directories-list channel descriptor)
+ (add-to-gc-finalizer! open-directories channel descriptor)
channel)))))
(define (directory-channel-close channel)
(without-interrupts
(lambda ()
- (let ((descriptor (directory-channel/descriptor channel)))
- (if descriptor
- (begin
- ((ucode-primitive new-directory-close 1) descriptor)
- (set-directory-channel/descriptor! channel #f)
- (remove-from-protection-list! open-directories-list channel)))))))
-
-(define (close-lost-open-directories-daemon)
- (clean-lost-protected-objects open-directories-list
- (ucode-primitive new-directory-close 1)))
+ (if (directory-channel/descriptor channel)
+ (begin
+ (remove-from-gc-finalizer! open-directories channel)
+ (set-directory-channel/descriptor! channel #f))))))
(define (directory-channel-read channel)
((ucode-primitive new-directory-read 1)
(directory-channel/descriptor channel)
prefix))
\f
-;;;; Protection lists
-
-;;; These will cause problems on interpreted systems, due to the
-;;; consing of the interpreter. For now we'll only run this compiled.
-
-(define (make-protection-list)
- (list 'PROTECTION-LIST))
-
-;; This is used after a disk-restore, to remove invalid information.
-
-(define (drop-all-protected-objects list)
- (set-cdr! list '()))
-
-(define (add-to-protection-list! list scheme-object microcode-object)
- (without-interrupts
- (lambda ()
- (set-cdr! list
- (cons (weak-cons scheme-object microcode-object)
- (cdr list))))))
-
-(define (remove-from-protection-list! list scheme-object)
- (without-interrupts
- (lambda ()
- (let loop ((associations (cdr list)) (previous list))
- (if (not (null? associations))
- (if (eq? scheme-object (weak-pair/car? (car associations)))
- (set-cdr! previous (cdr associations))
- (loop (cdr associations) associations)))))))
-
-(define (clean-lost-protected-objects list cleaner)
- ;; This assumes that interrupts are disabled. This will normally be
- ;; true because this should be called from a GC daemon.
- (let loop ((associations (cdr list)) (previous list))
- (if (not (null? associations))
- (if (weak-pair/car? (car associations))
- (loop (cdr associations) associations)
- (begin
- (cleaner (weak-cdr (car associations)))
- (let ((next (cdr associations)))
- (set-cdr! previous next)
- (loop next previous)))))))
-
-(define (search-protection-list list predicate)
- (without-interrupts
- (lambda ()
- (let loop ((associations (cdr list)))
- (and (not (null? associations))
- (let ((scheme-object (weak-car (car associations))))
- (if (and scheme-object (predicate scheme-object))
- scheme-object
- (loop (cdr associations)))))))))
-
-(define (protection-list-elements list)
- (without-interrupts
- (lambda ()
- (let loop ((associations (cdr list)))
- (cond ((null? associations)
- '())
- ((weak-car (car associations))
- => (lambda (scheme-object)
- (cons scheme-object
- (loop (cdr associations)))))
- (else
- (loop (cdr associations))))))))
-\f
;;;; Buffered Output
(define-structure (output-buffer
#| -*-Scheme-*-
-$Id: make.scm,v 14.63 1999/01/02 06:06:43 cph Exp $
+$Id: make.scm,v 14.64 2000/04/10 18:32:35 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2000 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(let ((spec (car specs)))
(if (or (not (pair? spec))
(symbol? (car spec)))
- (package-initialize spec 'INITIALIZE-PACKAGE! false)
+ (package-initialize spec 'INITIALIZE-PACKAGE! #f)
(package-initialize (car spec) (cadr spec) (caddr spec)))
(loop (cdr specs))))))
((not optional?)
(fatal-error (string-append "Could not find " filename)))
(else
- false))))
+ #f))))
(define (eval object environment)
(let ((value (scode-eval object environment)))
prim
(lambda (name)
name ; ignored
- false))))
+ #f))))
(define os-name
(intern os-name-string))
(files2
'(("prop1d" . (RUNTIME 1D-PROPERTY))
("events" . (RUNTIME EVENT-DISTRIBUTOR))
- ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
+ ("gdatab" . (RUNTIME GLOBAL-DATABASE))
+ ("gcfinal" . (RUNTIME GC-FINALIZER))))
(load-files
(lambda (files)
(do ((files files (cdr files)))
(eval (file->object (car (car files)) #t #f)
(package-reference (cdr (car files))))))))
(load-files files1)
- (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! true)
- (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! true)
+ (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! #t)
+ (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! #t)
(lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
'CONSTANT-SPACE/BASE
constant-space/base)
- (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+ (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! #t)
(package-initialize '(RUNTIME RANDOM-NUMBER) 'INITIALIZE-PACKAGE! #t)
(package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS!
#t)
- (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
+ (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! #t)
(package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
(package-initialize '(RUNTIME DEFSTRUCT) 'INITIALIZE-STRUCTURE-TYPES! #t)
(load-files files2)
- (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
- (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
- (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true)
- (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true)
- (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true)
+ (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! #t)
+ (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! #t)
+ (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! #t)
+ (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t)
+ (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
+ (package-initialize '(RUNTIME GC-FINALIZER) 'INITIALIZE-PACKAGE! #t)
;; Load everything else.
;; Note: The following code needs MAP* and MEMBER-PROCEDURE
(RUNTIME PRIMITIVE-IO)
(RUNTIME SAVE/RESTORE)
(RUNTIME SYSTEM-CLOCK)
+ ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS! #t)
;; Basic data structures
(RUNTIME NUMBER)
(RUNTIME CHARACTER)
(load/purification-root object)))
fasload-purification-queue)))))))
(set! (access gc-boot-loading? (->environment '(RUNTIME GARBAGE-COLLECTOR)))
- false)
+ #f)
(set! fasload-purification-queue)
(newline console-output-port)
(write-string "purifying..." console-output-port)
;; First, flush whatever we can.
(gc-clean)
;; Then, really purify the rest.
- (purify roots true false)
+ (purify roots #t #f)
(write-string "done" console-output-port))
)
#| -*-Scheme-*-
-$Id: os2graph.scm,v 1.16 1999/11/08 18:28:28 cph Exp $
+$Id: os2graph.scm,v 1.17 2000/04/10 18:32:36 cph Exp $
-Copyright (c) 1995-1999 Massachusetts Institute of Technology
+Copyright (c) 1995-2000 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(fill-from-byte-vector ,os2-image/fill-from-byte-vector))))
(set! event-descriptor #f)
(set! event-previewer-registration #f)
- (set! window-list (make-protection-list))
- (set! image-list (make-protection-list))
+ (set! window-finalizer (make-gc-finalizer os2win-close))
+ (set! image-finalizer (make-gc-finalizer destroy-memory-ps))
(set! user-event-mask user-event-mask:default)
(set! user-event-queue (make-queue))
(initialize-color-table)
- (add-event-receiver! event:before-exit finalize-pm-state!)
- (add-gc-daemon! close-lost-objects-daemon))
+ (add-event-receiver! event:before-exit finalize-pm-state!))
\f
(define os2-graphics-device-type)
(define event-descriptor)
(define event-previewer-registration)
-(define window-list)
-(define image-list)
+(define window-finalizer)
+(define image-finalizer)
(define user-event-mask)
(define user-event-queue)
(define graphics-window-icon)
(begin
(os2win-destroy-pointer graphics-window-icon)
(set! graphics-window-icon)
- (do ((windows (protection-list-elements window-list) (cdr windows)))
- ((null? windows))
- (close-window (car windows)))
- (do ((images (protection-list-elements image-list) (cdr images)))
- ((null? images))
- (destroy-image (car images)))
+ (remove-all-from-gc-finalizer! window-finalizer)
+ (remove-all-from-gc-finalizer! image-finalizer)
(deregister-input-thread-event event-previewer-registration)
(set! event-previewer-registration #f)
(set! user-event-mask user-event-mask:default)
(os2win-close-event-qid event-descriptor)
(set! event-descriptor #f)
unspecific)))
-
-(define (close-lost-objects-daemon)
- (clean-lost-protected-objects window-list os2win-close)
- (clean-lost-protected-objects image-list destroy-memory-ps))
\f
;;;; Window Abstraction
(define (make-window wid width height)
(let ((window (%make-window wid width height)))
(set-window/backing-image! window (create-image width height))
- (add-to-protection-list! window-list window wid)
+ (add-to-gc-finalizer! window-finalizer window wid)
window))
(define (close-window window)
(if (window/wid window)
(begin
(destroy-image (window/backing-image window))
- (os2win-close (window/wid window))
- (set-window/wid! window #f)
- (remove-from-protection-list! window-list window))))
+ (remove-from-gc-finalizer! window-finalizer window)
+ (set-window/wid! window #f))))
(define-integrable (os2-graphics-device/wid device)
(window/wid (graphics-device/descriptor device)))
(without-interrupts
(lambda ()
(let ((window
- (search-protection-list window-list
+ (search-gc-finalizer window-finalizer
(let ((wid (event-wid event)))
(lambda (window)
(eq? (window/wid window) wid))))))
(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-protection-list! image-list image ps)
+ (add-to-gc-finalizer! image-finalizer image ps)
image)))
(define (os2-image/set-colormap image colormap)
(define (destroy-image image)
(if (image/ps image)
(begin
- (destroy-memory-ps (image/ps image))
- (set-image/ps! image #f)
- (remove-from-protection-list! image-list image))))
+ (remove-from-gc-finalizer! image-finalizer image)
+ (set-image/ps! image #f))))
(define (destroy-memory-ps ps)
(let ((bitmap (os2ps-set-bitmap ps #f)))
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.340 2000/04/10 03:34:03 cph Exp $
+$Id: runtime.pkg,v 14.341 2000/04/10 18:32:38 cph Exp $
Copyright (c) 1988-2000 Massachusetts Institute of Technology
trigger-gc-daemons!)
(initialization (initialize-package!)))
+(define-package (runtime gc-finalizer)
+ (files "gcfinal")
+ (parent ())
+ (export ()
+ add-to-gc-finalizer!
+ gc-finalizer-elements
+ gc-finalizer?
+ make-gc-finalizer
+ remove-all-from-gc-finalizer!
+ remove-from-gc-finalizer!
+ search-gc-finalizer)
+ (initialization (initialize-package!)))
+
(define-package (runtime gc-notification)
(files "gcnote")
(parent ())
(files "io")
(parent ())
(export ()
- add-to-protection-list!
all-open-channels
channel-blocking
channel-blocking?
channel-write-char-block
channel-write-string-block
channel?
- clean-lost-protected-objects
close-all-open-channels
close-all-open-files
directory-channel-close
directory-channel-read
directory-channel-read-matching
directory-channel?
- drop-all-protected-objects
file-open-append-channel
file-open-input-channel
file-open-io-channel
file-open-output-channel
make-pipe
- make-protection-list
open-pty-master
- protection-list-elements
pty-master-continue
pty-master-hangup
pty-master-interrupt
pty-master-quit
pty-master-send-signal
pty-master-stop
- remove-from-protection-list!
- search-protection-list
set-terminal-input-baud-rate!
set-terminal-output-baud-rate!
terminal-cooked-input
#| -*-Scheme-*-
-$Id: x11graph.scm,v 1.49 1999/02/24 21:57:17 cph Exp $
+$Id: x11graph.scm,v 1.50 2000/04/10 18:32:39 cph Exp $
-Copyright (c) 1989-1999 Massachusetts Institute of Technology
+Copyright (c) 1989-2000 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
(starbase-filename ,x-graphics/starbase-filename)
(visual-info ,x-graphics/visual-info)
(withdraw-window ,x-graphics/withdraw-window))))
- (set! display-list (make-protection-list))
- (add-gc-daemon! close-lost-displays-daemon)
- (add-event-receiver! event:after-restore drop-all-displays)
+ (set! display-finalizer (make-gc-finalizer x-close-display))
(initialize-image-datatype)
(initialize-colormap-datatype))
\f
;;;; Open/Close Displays
-(define display-list)
+(define display-finalizer)
(define-structure (x-display
(conc-name x-display/)
(lambda (display port)
(write-char #\space port)
(write (x-display/name display) port)))))
- (name false read-only true)
+ (name #f read-only #t)
xd
- (window-list (make-protection-list) read-only true)
+ (window-finalizer (make-gc-finalizer x-close-window) read-only #t)
(event-queue (make-queue))
- (properties (make-1d-table) read-only true))
+ (properties (make-1d-table) read-only #t))
(define (x-graphics/open-display name)
(let ((name
(error:wrong-type-argument name
"string or #f"
x-graphics/open-display)))))
- (or (search-protection-list display-list
+ (or (search-gc-finalizer display-finalizer
(lambda (display)
(string=? (x-display/name display) name)))
(let ((xd (x-open-display name)))
(if (not xd)
(error "Unable to open display:" name))
(let ((display (make-x-display name xd)))
- (add-to-protection-list! display-list display xd)
+ (add-to-gc-finalizer! display-finalizer display xd)
(make-event-previewer display)
display)))))
(lambda ()
(if (x-display/xd display)
(begin
- (do ((windows
- (protection-list-elements (x-display/window-list display))
- (cdr windows)))
- ((null? windows))
- (close-x-window (car windows)))
- (x-close-display (x-display/xd display))
- (set-x-display/xd! display false)
- (remove-from-protection-list! display-list display))))))
-
-(define (close-lost-displays-daemon)
- (clean-lost-protected-objects display-list x-close-display)
- (do ((associations (cdr display-list) (cdr associations)))
- ((null? associations))
- (clean-lost-protected-objects
- (x-display/window-list (weak-car (car associations)))
- x-close-window)))
-
-(define (drop-all-displays)
- (drop-all-protected-objects display-list))
+ (remove-all-from-gc-finalizer! (x-display/window-finalizer display))
+ (remove-from-gc-finalizer! display-finalizer display)
+ (set-x-display/xd! display #f))))))
\f
(define (make-event-previewer display)
(let ((registration))
(without-interrupts
(lambda ()
(let ((window
- (search-protection-list (x-display/window-list display)
+ (search-gc-finalizer (x-display/window-finalizer display)
(let ((xw (vector-ref event 1)))
(lambda (window)
(eq? (x-window/xw window) xw))))))
event)))))))))
(define event-handlers
- (make-vector number-of-event-types false))
+ (make-vector number-of-event-types #f))
(define-integrable (define-event-handler event-type handler)
(vector-set! event-handlers event-type handler))
\f
;;;; Standard Operations
-(define x-graphics:auto-raise? false)
+(define x-graphics:auto-raise? #f)
(define-structure (x-window (conc-name x-window/)
(constructor make-x-window (xw display)))
xw
- (display false read-only true)
+ (display #f read-only #t)
(mapped? 'NEVER)
- (visibility false)
+ (visibility #f)
(user-event-mask user-event-mask:default))
(define-integrable (x-graphics-device/xw device)
(define (close-x-window window)
(if (x-window/xw window)
(begin
- (x-close-window (x-window/xw window))
- (set-x-window/xw! window false)
- (remove-from-protection-list!
- (x-display/window-list (x-window/display window))
- window))))
+ (remove-from-gc-finalizer!
+ (x-display/window-finalizer (x-window/display window))
+ window)
+ (set-x-window/xw! window #f))))
(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-protection-list! (x-display/window-list display) window xw)
+ (add-to-gc-finalizer! (x-display/window-finalizer display)
+ window xw)
(if map? (map-window window))
(descriptor->device window)))))))
(define-structure (x-font-structure (conc-name x-font-structure/)
(type vector))
- (name false read-only true)
- (direction false read-only true)
- (all-chars-exist? false read-only true)
- (default-char false read-only true)
- (min-bounds false read-only true)
- (max-bounds false read-only true)
- (start-index false read-only true)
- (character-bounds false read-only true)
- (max-ascent false read-only true)
- (max-descent false read-only true))
+ (name #f read-only #t)
+ (direction #f read-only #t)
+ (all-chars-exist? #f read-only #t)
+ (default-char #f read-only #t)
+ (min-bounds #f read-only #t)
+ (max-bounds #f read-only #t)
+ (start-index #f read-only #t)
+ (character-bounds #f read-only #t)
+ (max-ascent #f read-only #t)
+ (max-descent #f read-only #t))
(define-structure (x-character-bounds (conc-name x-character-bounds/)
(type vector))
- (lbearing false read-only true)
- (rbearing false read-only true)
- (width false read-only true)
- (ascent false read-only true)
- (descent false read-only true))
+ (lbearing #f read-only #t)
+ (rbearing #f read-only #t)
+ (width #f read-only #t)
+ (ascent #f read-only #t)
+ (descent #f read-only #t))
;;;; Window Management Operations
(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-protection-list))
- (add-gc-daemon! destroy-lost-images-daemon))
+ (set! image-list (make-gc-finalizer x-destroy-image))
+ 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-protection-list! image-list image descriptor)
+ (add-to-gc-finalizer! image-list image descriptor)
image))))
-(define (destroy-lost-images-daemon)
- (clean-lost-protected-objects image-list x-destroy-image))
-
(define (x-image/destroy image)
- (x-destroy-image (x-image/descriptor image))
- (remove-from-protection-list! image-list image))
+ (remove-from-gc-finalizer! image-list image))
(define (x-image/get-pixel image x y)
(x-get-pixel-from-image (x-image/descriptor image) x y))
(set! x-colormap? (record-predicate rtd))
(set! %make-colormap (record-constructor rtd))
(set! colormap/descriptor (record-accessor rtd 'DESCRIPTOR)))
- (set! colormap-list (make-protection-list))
- (add-gc-daemon! destroy-lost-colormaps-daemon))
+ (set! colormap-list (make-gc-finalizer x-free-colormap)))
(define (make-colormap descriptor)
(let ((colormap (%make-colormap descriptor)))
- (add-to-protection-list! colormap-list colormap descriptor)
+ (add-to-gc-finalizer! colormap-list colormap descriptor)
colormap))
(define (x-graphics/get-colormap device)
(x-visual-deallocate visual)
(make-colormap descriptor)))))
-(define (destroy-lost-colormaps-daemon)
- (clean-lost-protected-objects colormap-list x-free-colormap))
-
(define (x-colormap/free colormap)
- (x-free-colormap (colormap/descriptor colormap))
- (remove-from-protection-list! colormap-list colormap))
+ (remove-from-gc-finalizer! colormap-list colormap))
(define (x-colormap/allocate-color colormap r g b)
(x-allocate-color (colormap/descriptor colormap) r g b))
projects / mit-scheme.git / commitdiff