From faffbdd4ed1a237424c8e755551572530b5ab154 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Tue, 9 Oct 2001 15:45:26 +0000
Subject: [PATCH] - added finalize? argument to make-pixel, so that allocated
 color-cells (=pixels) are freed correctly.

---
 c/xlib/pixel.c             | 11 +++++++++++
 scheme/xlib/pixel-type.scm | 31 +++++++++++++++++++++++++------
 scheme/xlib/pixel.scm      |  6 ++++--
 3 files changed, 40 insertions(+), 8 deletions(-)

diff --git a/c/xlib/pixel.c b/c/xlib/pixel.c
index 04094b3..7f06472 100644
--- a/c/xlib/pixel.c
+++ b/c/xlib/pixel.c
@@ -11,7 +11,18 @@ s48_value scx_White_Pixel(s48_value Xdisplay) {
   return SCX_ENTER_PIXEL( WhitePixel(dpy, DefaultScreen(dpy)) );
 }
 
+s48_value scx_Free_Pixel(s48_value Xpixel, s48_value Xdisplay, s48_value Xcolormap) {
+  unsigned long pixels[1];
+  pixels[0] = SCX_EXTRACT_PIXEL(Xpixel);
+  
+  XFreeColors(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
+	      pixels, 1, 0);
+
+  return S48_UNSPECIFIC;
+}
+
 void scx_init_pixel(void) {
   S48_EXPORT_FUNCTION(scx_Black_Pixel);
   S48_EXPORT_FUNCTION(scx_White_Pixel);
+  S48_EXPORT_FUNCTION(scx_Free_Pixel);
 }
diff --git a/scheme/xlib/pixel-type.scm b/scheme/xlib/pixel-type.scm
index 418a411..3761f78 100644
--- a/scheme/xlib/pixel-type.scm
+++ b/scheme/xlib/pixel-type.scm
@@ -1,18 +1,37 @@
 (define-record-type pixel :pixel
-  (really-make-pixel tag Xpixel) 
+  (really-make-pixel tag Xpixel colormap) 
   pixel?
   (tag pixel-tag pixel-set-tag!)
-  (Xpixel pixel-Xpixel pixel-set-Xpixel!))
+  (Xpixel pixel-Xpixel pixel-set-Xpixel!)
+  (colormap pixel-colormap pixel-set-colormap!))
 
-(define (make-pixel Xpixel)
+;; Attention: colormap can be #f if finalize? is #f
+(define (make-pixel Xpixel colormap finalize?)
   (let ((maybe-pixel (pixel-list-find Xpixel)))
     (if maybe-pixel
-	maybe-pixel
-	(let ((pixel (really-make-pixel #f Xpixel)))
-	  (add-finalizer! pixel pixel-list-delete!)
+	(begin
+	  ;; now free the Xpixel if it has been allocated
+	  (if finalize?
+	      (%free-pixel Xpixel 
+			   (display-Xdisplay (colormap-display colormap))
+			   (colormap-Xcolormap colormap)))
+	  maybe-pixel)
+	(let ((pixel (really-make-pixel #f Xpixel colormap)))
+	  (if finalize?
+	      (add-finalizer! pixel free-pixel)
+	      (add-finalizer! pixel pixel-list-delete!))
 	  (pixel-list-set! Xpixel pixel)
 	  pixel))))
 
+(define (free-pixel pixel)
+  (%free-pixel (pixel-Xpixel pixel)
+	       (display-Xdisplay (colormap-display (pixel-colormap pixel)))
+	       (colormap-Xcolormap (pixel-colormap pixel)))
+  (pixel-list-delete! pixel))
+
+(import-lambda-definition %free-pixel (Xpixel Xdisplay Xcolormap)
+  "scx_Free_Pixel")
+
 ;; All pixel records need to be saved in a weak-list, to have only one record
 ;; for the same XLib pixel
 
diff --git a/scheme/xlib/pixel.scm b/scheme/xlib/pixel.scm
index c12f67d..425e8db 100644
--- a/scheme/xlib/pixel.scm
+++ b/scheme/xlib/pixel.scm
@@ -1,13 +1,15 @@
 (define pixel-value pixel-Xpixel)
 
 (define (black-pixel display)
-  (make-pixel (%black-pixel (display-Xdisplay display))))
+  (make-pixel (%black-pixel (display-Xdisplay display))
+	      #f #f))
 
 (import-lambda-definition %black-pixel (Xdisplay)
   "scx_Black_Pixel")
 
 (define (white-pixel display)
-  (make-pixel (%white-pixel (display-Xdisplay display))))
+  (make-pixel (%white-pixel (display-Xdisplay display))
+	      #f #f))
 
 (import-lambda-definition %white-pixel (Xdisplay)
   "scx_White_Pixel")
\ No newline at end of file