diff --git a/scheme/xlib/colormap-type.scm b/scheme/xlib/colormap-type.scm index 4075f4c..e11e4d5 100644 --- a/scheme/xlib/colormap-type.scm +++ b/scheme/xlib/colormap-type.scm @@ -12,26 +12,19 @@ none-resource (real-colormap-Xcolormap colormap))) -(define (make-colormap Xcolormap display) +(define (make-colormap Xcolormap display finalize?) (if (none-resource? Xcolormap) 'none (let ((maybe-colormap (colormap-list-find Xcolormap))) (if maybe-colormap maybe-colormap (let ((colormap (really-make-colormap #f Xcolormap display))) - (add-finalizer! colormap finalize-colormap) + (add-finalizer! colormap colormap-list-delete!) + (if finalize? + (add-finalizer! colormap free-colormap)) (colormap-list-set! Xcolormap colormap) colormap))))) -;; finalize-colormap is called, when the garbage collector removes the last -;; reference to the colormap from the heap. Then we can savely close the -;; colormap and remove the weak-pointer from our list. - -(define (finalize-colormap colormap) - (let ((Xcolormap (colormap-Xcolormap colormap))) - (free-colormap colormap) - (colormap-list-delete! Xcolormap))) - (define (free-colormap colormap) (let ((Xcolormap (colormap-Xcolormap))) (if (integer? Xcolormap) @@ -58,6 +51,7 @@ (let ((p (make-weak-pointer colormap))) (table-set! *weak-colormap-list* Xcolormap p))) -(define (colormap-list-delete! Xcolormap) - (table-set! *weak-colormap-list* Xcolormap #f)) +(define (colormap-list-delete! colormap) + (table-set! *weak-colormap-list* + (colormap-Xcolormap colormap) #f)) diff --git a/scheme/xlib/display-type.scm b/scheme/xlib/display-type.scm index d99d969..2520654 100644 --- a/scheme/xlib/display-type.scm +++ b/scheme/xlib/display-type.scm @@ -6,24 +6,17 @@ (after-function display-after-function display-set-after-function!) (Xdisplay display-Xdisplay display-set-Xdisplay!)) -(define (make-display Xdisplay) +(define (make-display Xdisplay finalize?) (let ((maybe-display (display-list-find Xdisplay))) (if maybe-display maybe-display (let ((display (really-make-display #f Xdisplay))) - (add-finalizer! display finalize-display) + (add-finalizer! display display-list-delete!) + (if finalize? + (add-finalizer! display close-display)) (display-list-set! Xdisplay display) display)))) -;; finalize-display is called, when the garbage collector removes the last -;; reference to the display from the heap. Then we can savely close the display -;; and remove the weak-pointer from our list. - -(define (finalize-display display) - (let ((Xdisplay (display-Xdisplay display))) - (close-display display) - (display-list-delete! Xdisplay))) - ;; close-display closes the corresponding Xlib-display struct, by calling a ;; c-function and marks the scheme-record to be invalid (with the ;; 'already-closed symbol). Calling close-display more than once has no @@ -54,8 +47,9 @@ (let ((p (make-weak-pointer display))) (table-set! *weak-display-list* Xdisplay p))) -(define (display-list-delete! Xdisplay) - (table-set! *weak-display-list* Xdisplay #f)) +(define (display-list-delete! display) + (table-set! *weak-display-list* + (display-Xdisplay display) #f)) ;; The message port is used to efficiently check for pending messages, which ;; are then read normally with XNextEvent. diff --git a/scheme/xlib/font-type.scm b/scheme/xlib/font-type.scm index a8a2e77..243acd0 100644 --- a/scheme/xlib/font-type.scm +++ b/scheme/xlib/font-type.scm @@ -9,17 +9,22 @@ ;; creates a font object. name can be #f. if Xfont is #f then it is obtained ;; from the Xfontstruct. -(define (make-font name Xfont Xfontstruct display) +(define (make-font name Xfont Xfontstruct display finalize?) (let ((maybe-font (font-list-find Xfontstruct))) (if maybe-font maybe-font (let* ((Xfont (if Xfont Xfont (%Get_Xfont Xfontstruct))) (font (really-make-font name Xfont Xfontstruct display))) - (add-finalizer! font unload-font) + (add-finalizer! font font-list-delete!) + (if finalize? + (add-finalizer! font unload-font)) (font-list-set! Xfontstruct font) font)))) +(import-lambda-definition %Get_Xfont (Xfontstruct) + "Get_Xfont") + ;; load-font loads a font by its name. See XLoadQueryFont. (define (load-font display font-name) @@ -27,7 +32,7 @@ (if (symbol? font-name) (symbol->string font-name) font-name)))) - (make-font font-name #f Xfontstruct display))) + (make-font font-name #f Xfontstruct display #t))) (import-lambda-definition %load-font (Xdisplay font_name) "Load_Font") @@ -45,8 +50,8 @@ (if (integer? Xfontstruct) (%free-font Xdisplay Xfontstruct)) (font-set-Xfontstruct! font 'already-freed) - (font-set-Xfont! font 'already-freed) - (font-list-delete! Xfont))) + (font-set-Xfont! font 'already-freed))) + ;; for compatibility with Elk: (define close-font unload-font) @@ -63,15 +68,16 @@ (define *weak-font-list* (make-integer-table)) -(define (font-list-find Xfont) - (let ((r (table-ref *weak-font-list* Xfont))) +(define (font-list-find Xfontstruct) + (let ((r (table-ref *weak-font-list* Xfontstruct))) (if r (weak-pointer-ref r) r))) -(define (font-list-set! Xfont font) +(define (font-list-set! Xfontstruct font) (let ((p (make-weak-pointer font))) - (table-set! *weak-font-list* Xfont p))) + (table-set! *weak-font-list* Xfontstruct p))) -(define (font-list-delete! Xfont) - (table-set! *weak-font-list* Xfont #f)) +(define (font-list-delete! font) + (table-set! *weak-font-list* + (font-Xfontstruct font) #f)) diff --git a/scheme/xlib/gcontext-type.scm b/scheme/xlib/gcontext-type.scm index a1c2d74..c03b350 100644 --- a/scheme/xlib/gcontext-type.scm +++ b/scheme/xlib/gcontext-type.scm @@ -10,27 +10,20 @@ 0 (real-gcontext-Xgcontext gcontext))) -(define (make-gcontext Xgcontext display) +(define (make-gcontext Xgcontext display finalize?) (if (= 0 Xgcontext) none-resource (let ((maybe-gcontext (gcontext-list-find Xgcontext))) (if maybe-gcontext maybe-gcontext (let ((gcontext (really-make-gcontext #f Xgcontext display))) - (add-finalizer! gcontext finalize-gcontext) + (add-finalizer! gcontext gcontext-list-delete!) + (if finalize? + (add-finalizer! gcontext free-gcontext)) (gcontext-list-set! Xgcontext gcontext) gcontext))))) -;; finalize-gcontext is called, when the garbage collector removes the last -;; reference to the gcontext from the heap. Then we can savely close the -;; gcontext and remove the weak-pointer from our list. - -(define (finalize-gcontext gcontext) - (let ((Xgcontext (gcontext-Xgcontext gcontext))) - (gcontext-set-Xgcontext! gcontext 'already-freed) - (gcontext-list-delete! Xgcontext))) - -;; to free the gcontext X-lib ressources call free-gcontext. if gcontext is +;; to free the gcontext X-lib ressources call free-gcontext. if gcontext is ;; already freed, the function does nothing. (define (free-gcontext gcontext) @@ -59,5 +52,6 @@ (let ((p (make-weak-pointer gcontext))) (table-set! *weak-gcontext-list* Xgcontext p))) -(define (gcontext-list-delete! Xgcontext) - (table-set! *weak-gcontext-list* Xgcontext #f)) \ No newline at end of file +(define (gcontext-list-delete! gcontext) + (table-set! *weak-gcontext-list* + (gcontext-Xgcontext gcontext) #f)) \ No newline at end of file diff --git a/scheme/xlib/pixmap-type.scm b/scheme/xlib/pixmap-type.scm index e5ebcf2..b3f71f2 100644 --- a/scheme/xlib/pixmap-type.scm +++ b/scheme/xlib/pixmap-type.scm @@ -12,26 +12,19 @@ 0 (real-pixmap-Xpixmap pixmap))) -(define (make-pixmap Xpixmap display) +(define (make-pixmap Xpixmap display finalize?) (if (= 0 Xpixmap) none-resource (let ((maybe-pixmap (pixmap-list-find Xpixmap))) (if maybe-pixmap maybe-pixmap (let ((pixmap (really-make-pixmap #f Xpixmap display))) - (add-finalizer! pixmap finalize-pixmap) + (add-finalizer! pixmap pixmap-list-delete!) + (if finalize? + (add-finalizer! pixmap free-pixmap)) (pixmap-list-set! Xpixmap pixmap) pixmap))))) -;; finalize-pixmap is called, when the garbage collector removes the last -;; reference to the pixmap from the heap. Then we can savely close the pixmap -;; and remove the weak-pointer from our list. - -(define (finalize-pixmap pixmap) - (let ((Xpixmap (pixmap-Xpixmap pixmap))) - (free-pixmap pixmap) - (pixmap-list-delete! Xpixmap))) - ;; ... (define (free-pixmap pixmap) @@ -60,5 +53,6 @@ (let ((p (make-weak-pointer pixmap))) (table-set! *weak-pixmap-list* Xpixmap p))) -(define (pixmap-list-delete! Xpixmap) - (table-set! *weak-pixmap-list* Xpixmap #f)) \ No newline at end of file +(define (pixmap-list-delete! pixmap) + (table-set! *weak-pixmap-list* + (pixmap-Xpixmap pixmap) #f)) \ No newline at end of file diff --git a/scheme/xlib/window-type.scm b/scheme/xlib/window-type.scm index 5ed4900..40ea98a 100644 --- a/scheme/xlib/window-type.scm +++ b/scheme/xlib/window-type.scm @@ -12,28 +12,19 @@ 0 (real-window-Xwindow window))) -(define (make-window Xwindow display) +(define (make-window Xwindow display finalize?) (if (= 0 Xwindow) none-resource (let ((maybe-window (window-list-find Xwindow))) (if maybe-window maybe-window (let ((window (really-make-window #f Xwindow display))) - (add-finalizer! window finalize-window) + (add-finalizer! window window-list-delete!) + (if finalize? + (add-finalizer! window destroy-window)) (window-list-set! Xwindow window) window))))) - - -;; finalize-window is called, when the garbage collector removes the last -;; reference to the window from the heap. Then we can savely close the window -;; and remove the weak-pointer from our list. - -(define (finalize-window window) - (let ((Xwindow (window-Xwindow window))) - (destroy-window window) - (window-list-delete! Xwindow))) - ;; The destroy-window function destroys the specified window as well as all of ;; its subwindows and causes the X server to generate a destroy-notify event for ;; each window. See XDestroyWindow @@ -64,6 +55,7 @@ (let ((p (make-weak-pointer window))) (table-set! *weak-window-list* Xwindow p))) -(define (window-list-delete! Xwindow) - (table-set! *weak-window-list* Xwindow #f)) +(define (window-list-delete! window) + (table-set! *weak-window-list* + (window-Xwindow window) #f))