- removed direct calls to scx_Create_Color

- renamed save-color-cell to store-color
- added store-colors, copy-colormap-and-free,
respect. scx_Store_Colors, scx_Copy_Colormap
- renamed alloc-named-color to query/alloc-named-color
- added new alloc-named-color that can be used like alloc-color!
- changed my-floor definition (color.scm)
- added parse-color
- updated calls to make-pixel

c/xlib/colormap.c

@@ -50,8 +50,16 @@ s48_value scx_Parse_Color (s48_value Xdpy, s48_value cmap, s48_value spec) {
   if (XParseColor (SCX_EXTRACT_DISPLAY(Xdpy),
 		   SCX_EXTRACT_COLORMAP(cmap),
 		   s48_extract_string(spec),
-		   &ret))
+		   &ret)) {
-    return scx_Create_Color (ret.red, ret.green, ret.blue);
+    s48_value res = s48_make_vector(3, S48_FALSE);
+    S48_DECLARE_GC_PROTECT(1);
+    S48_GC_PROTECT_1(res);
+    S48_VECTOR_SET(res, 0, s48_enter_integer(ret.red));
+    S48_VECTOR_SET(res, 1, s48_enter_integer(ret.green));
+    S48_VECTOR_SET(res, 2, s48_enter_integer(ret.blue));
+    S48_GC_UNPROTECT();
+    return res;
+  }
   return S48_FALSE;
 }
 
@@ -93,9 +101,9 @@ s48_value scx_Alloc_Color_Cells (s48_value Xdisplay, s48_value Xcolormap,
     return S48_FALSE;
 }
 
-s48_value scx_Set_Color_Cell(s48_value Xdisplay, s48_value Xcolormap,
+s48_value scx_Store_Color(s48_value Xdisplay, s48_value Xcolormap,
-			     s48_value Xpixel, s48_value Xcolor,
+			  s48_value Xpixel, s48_value Xcolor,
-			     s48_value flags) {
+			  s48_value flags) {
   XColor t;
   XColor* c;
   
@@ -112,6 +120,35 @@ s48_value scx_Set_Color_Cell(s48_value Xdisplay, s48_value Xcolormap,
   return S48_UNSPECIFIC;
 }
 
+s48_value scx_Store_Colors(s48_value Xdisplay, s48_value Xcolormap, 
+			   s48_value cells) {
+  int n = S48_VECTOR_LENGTH(cells);
+  XColor colors[n];
+  XColor* c;
+  int i;
+
+  for (i = 0; i < n; i++) {
+    s48_value def = S48_VECTOR_REF(cells, i);
+    colors[i].pixel = SCX_EXTRACT_PIXEL(S48_VECTOR_REF(def, 0));
+    c = SCX_EXTRACT_COLOR(S48_VECTOR_REF(def, 1));
+    colors[i].red = c->red;
+    colors[i].green = c->green;
+    colors[i].blue = c->blue;
+    colors[i].flags = Symbols_To_Bits(S48_VECTOR_REF(def, 2), Color_Flags_Syms);
+  }
+
+  XStoreColors(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
+	       colors, n);
+
+  return S48_UNSPECIFIC;
+}
+
+s48_value scx_Copy_Colormap_And_Free(s48_value Xdisplay, s48_value Xcolormap) {
+  Colormap cm = XCopyColormapAndFree(SCX_EXTRACT_DISPLAY(Xdisplay), 
+				     SCX_EXTRACT_COLORMAP(Xcolormap));
+  return SCX_ENTER_COLORMAP(cm);
+}
+
 void scx_init_colormap(void) {
   S48_EXPORT_FUNCTION(scx_Free_Colormap);
   S48_EXPORT_FUNCTION(scx_Alloc_Color);
@@ -119,5 +156,7 @@ void scx_init_colormap(void) {
   S48_EXPORT_FUNCTION(scx_Parse_Color);
   S48_EXPORT_FUNCTION(scx_Create_Colormap);
   S48_EXPORT_FUNCTION(scx_Alloc_Color_Cells);
-  S48_EXPORT_FUNCTION(scx_Set_Color_Cell);
+  S48_EXPORT_FUNCTION(scx_Store_Color);
+  S48_EXPORT_FUNCTION(scx_Store_Colors);
+  S48_EXPORT_FUNCTION(scx_Copy_Colormap_And_Free);
 }

scheme/xlib/color.scm

@@ -6,7 +6,7 @@
 (define (my-floor v)
   (if (exact? v)
       (floor v)
-      (my-floor (inexact->exact v))))
+      (floor (inexact->exact v))))
 
 (define (make-color r g b)
   (create-color (my-floor (* r 65535))

scheme/xlib/colormap.scm

@@ -8,18 +8,19 @@
 			      (color-Xcolor color)
 			      (display-Xdisplay (colormap-display colormap)))))
     (if Xpixel
-	(make-pixel Xpixel)
+	(make-pixel Xpixel colormap #t)
 	Xpixel)))
 
 (import-lambda-definition %alloc-color (Xcolormap Xcolor Xdisplay)
   "scx_Alloc_Color")
 
-;; alloc-named-color looks up the named color with respect to the screen that 
+;; query/alloc-named-color looks up the named color with respect to
-;; is associated with the specified colormap. It returns both the exact database
+;; the screen that is associated with the specified colormap. It
-;; definition and the closest color supported by the screen (as a pair).
+;; returns the allocated pixel and both the exact database definition
-;; See XAllocNamedColor. 
+;; and the closest color supported by the screen (as a list).  See
+;; XAllocNamedColor.
 
-(define (alloc-named-color colormap color-name)
+(define (query/alloc-named-color colormap color-name)
   (let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
 				  (if (symbol? color-name)
 				      (symbol->string color-name)
@@ -27,7 +28,7 @@
 				  (display-Xdisplay 
 				   (colormap-display colormap)))))
     (if Xres
-	(list (make-pixel (car Xres))
+	(list (make-pixel (car Xres) colormap #t)
 	      (apply create-color (cadr Xres))
 	      (apply create-color (caddr Xres)))
 	Xres)))
@@ -35,15 +36,30 @@
 (import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
   "scx_Alloc_Named_Color")
 
+;; alloc-named-color only allocates a named color and returns the
+;; allocated pixel (as one might suppose). If the color does not
+;; exists it returns #f.
 
-; added by N. Freudemann
+(define (alloc-named-color colormap color-name)
-; swaped from utility.scm to this file.
+  (let ((c (parse-color colormap color-name)))
+    (if c
+	(alloc-color! colormap c)
+	#f)))
 
-(define (parse-color colormap string)
+;; parse-color looks up the string name of a color and returns the
-  (%parse-color (display-Xdisplay (colormap-display colormap))
+;; exact color value. See XParseColor. See lookup-color.
-		(colormap-Xcolormap colormap)
-		string))
 
+(define (parse-color colormap color-name)
+  (let ((res (%parse-color (display-Xdisplay (colormap-display colormap))
+			   (colormap-Xcolormap colormap)
+			   (if (symbol? color-name)
+			       (symbol->string color-name)
+			       color-name))))
+    (if res
+	(create-color (vector-ref res 0)
+		      (vector-ref res 1)
+		      (vector-ref res 2))
+	#f)))
 
 (import-lambda-definition %parse-color (Xdisplay Xcolormap string)
   "scx_Parse_Color")
@@ -78,7 +94,8 @@
 				 nplanes npixels)))
     (if res
 	(cons (vector->list (car res))
-	      (map make-pixel
+	      (map (lambda (Xpixel)
+		     (make-pixel Xpixel colormap #t))
 		   (vector->list (cdr res))))
 	res)))
 
@@ -86,14 +103,14 @@
 						       nplanes npixels)
   "scx_Alloc_Color_Cells")
 
-;; The set-color-cell function uses XStoreColor(s) to set the content
+;; The store-color function uses XStoreColor(s) to set the content
 ;; of the color cell specified by pixel (a pixel is an index to a
 ;; colormap) to color. An optional parameter is a list of the symbols
 ;; 'do-red 'do-gree and 'do-blue, that specify which components of the
 ;; color should be used. It defaults to '(do-red do-green
 ;; do-blue). See XStoreColors.
 
-(define (set-color-cell colormap pixel color . flags)
+(define (store-color colormap pixel color . flags)
   (%set-color-cell (display-Xdisplay (colormap-display colormap))
 		   (colormap-Xcolormap colormap)
 		   (pixel-Xpixel pixel) (color-Xcolor color)
@@ -103,4 +120,45 @@
 
 (import-lambda-definition %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor 
 						     flags)
-  "scx_Set_Color_Cell")
+  "scx_Store_Color")
+
+;; store-colors does the same as store-color, but for multiple
+;; colorcells. The paramter cells must be a list of lists consisting
+;; of 2 or 3 elements: a pixel, a color and an optional flags list
+;; (see above).
+
+(define (store-colors colormap cells)
+  (let ((cells (list->vector
+		(map (lambda (p-c-f)
+		       (list->vector
+			(list (pixel-Xpixel (car p-c-f))
+			      (color-Xcolor (cadr p-c-f))
+			      (if (null? (cddr p-c-f))
+				  '(do-red do-green do-blue)
+				  (caddr p-c-f)))))
+		     cells))))
+    (%store-colors (display-Xdisplay (colormap-display colormap))
+		   (colormap-Xcolormap colormap)
+		   cells)))
+
+(import-lambda-definition %store-colors (Xdisplay Xcolormap cells)
+  "scx_Store_Colors")
+
+;; copy-colormap-and-free function creates a colormap of the same
+;; visual type and for the same screen as the specified colormap and
+;; returns the new colormap. It also moves all of the client's
+;; existing allocation from the specified colormap to the new colormap
+;; with their color values intact and their read-only or writable
+;; characteristics intact and frees those entries in the specified
+;; colormap. See XCopyColormapAndFree
+
+(define (copy-colormap-and-free colormap)
+  (make-colormap (%copy-colormap-and-free 
+		  (display-Xdisplay (colormap-display colormap))
+		  (colormap-Xcolormap colormap))
+		 (colormap-display colormap)
+		 #t))
+
+(import-lambda-definition %copy-colormap-and-free (Xdisplay Xcolormap)
+  "scx_Copy_Colormap_And_Free")
+