added the finalize? parameter to the constructor definitions.

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)
+(define (colormap-list-delete! colormap)
-  (table-set! *weak-colormap-list* Xcolormap #f))
+  (table-set! *weak-colormap-list* 
+	      (colormap-Xcolormap colormap) #f))
 

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)
+(define (display-list-delete! display)
-  (table-set! *weak-display-list* Xdisplay #f))
+  (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.

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-set-Xfont! font 'already-freed)))
-    (font-list-delete! Xfont)))
+
 
 ;; 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)
+(define (font-list-find Xfontstruct)
-  (let ((r (table-ref *weak-font-list* Xfont)))
+  (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)
+(define (font-list-delete! font)
-  (table-set! *weak-font-list* Xfont #f))
+  (table-set! *weak-font-list* 
+	      (font-Xfontstruct font) #f))

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
+;; to free the gcontext X-lib ressources call free-gcontext. if gcontext is
-;; 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 
 ;; 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)
+(define (gcontext-list-delete! gcontext)
-  (table-set! *weak-gcontext-list* Xgcontext #f))
+  (table-set! *weak-gcontext-list* 
+	      (gcontext-Xgcontext gcontext) #f))

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)
+(define (pixmap-list-delete! pixmap)
-  (table-set! *weak-pixmap-list* Xpixmap #f))
+  (table-set! *weak-pixmap-list* 
+	      (pixmap-Xpixmap pixmap) #f))

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)
+(define (window-list-delete! window)
-  (table-set! *weak-window-list* Xwindow #f))
+  (table-set! *weak-window-list* 
+	      (window-Xwindow window) #f))