- completed get-gcontext-values and change/get-window-attributes to

pack/unpack all values correctly.
- added copy-gcontext! and copy-gcontext
- added comments.

c/xlib/gcontext.c

@@ -106,6 +106,16 @@ s48_value scx_Copy_Gc(s48_value Xdisplay, s48_value Xsource, s48_value Xdest) {
   return S48_UNSPECIFIC;
 }
 
+s48_value scx_Copy_Gc_To_Gc(s48_value Xdisplay, s48_value Xfrom, s48_value Xto, 
+			    s48_value attrs) {
+  unsigned long mask = 0;
+  mask = S48_SYMBOL_P(attrs) ? Symbol_To_Bit(attrs, Gcontext_Values_Syms) :
+    Symbols_To_Bits(attrs, Gcontext_Values_Syms);
+  XCopyGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xfrom), 
+	  mask, SCX_EXTRACT_GCONTEXT(Xto));
+  return S48_UNSPECIFIC;
+}
+
 s48_value scx_Free_Gc(s48_value Xgcontext, s48_value Xdisplay) {
   XFreeGC(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_GCONTEXT(Xgcontext));
   return S48_UNSPECIFIC;
@@ -241,6 +251,7 @@ void scx_init_gcontext(void) {
   S48_EXPORT_FUNCTION(scx_Create_Gc);
   S48_EXPORT_FUNCTION(scx_Free_Gc);
   S48_EXPORT_FUNCTION(scx_Copy_Gc);
+  S48_EXPORT_FUNCTION(scx_Copy_Gc_To_Gc);
   S48_EXPORT_FUNCTION(scx_Get_Gc_Values);
   S48_EXPORT_FUNCTION(scx_Change_Gc);
   S48_EXPORT_FUNCTION(scx_Set_Gcontext_Dashlist);

scheme/xlib/gcontext.scm

@@ -1,4 +1,8 @@
-;; ...
+;; create-gcontext returns a newly create graphic context for the
+;; specified drawable (a window or a pixmap). Optional arguments are
+;; all attributes that can be set by the set-gcontext-xyz! functions
+;; below. They can be specified by name: 'function 'xor. Or the last
+;; argument can be an alist of such mappings. See XCreateGC.
 
 (define (create-gcontext drawable . args)
   (let ((alist (named-args->alist args)))
@@ -20,7 +24,8 @@
 (import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist)
   "scx_Create_Gc")
 
-;; ...
+;; copy-gcontext returns a newly create duplicate of the given
+;; gcontext, and assigns it to the specified drawable. See XCopyGC.
 
 (define (copy-gcontext gcontext drawable)
   (let* ((new-gcontext (create-gcontext 'drawable drawable))
@@ -33,23 +38,53 @@
 (import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest)
   "scx_Copy_Gc")
 
-;; ...
+;; copy-gcontext! copies the specified attributes from gc-from to
+;; gc-to. The attributes have to be a list of the names in the
+;; set-gcontext-*! functions. If that argument is not specified, then
+;; all atributes are copied. See XCopyGC.
+
+(define (copy-gcontext! gc-from gc-to . attributes)
+  (let ((attributes (if (null? attributes)
+			'all
+			(car attributes))))
+    (%copy-gcontext! (display-Xdisplay (gcontext-display gc-from))
+		     (gcontext-Xgcontext gc-from)
+		     (gcontext-Xgcontext gc-to)
+		     attributes)))
+
+(import-lambda-definition %copy-gcontext! (Xdisplay Xfrom Xto attrs)
+  "scx_Copy_Gc_To_Gc")
+
+;; get-gontext-values returns an alist of all attributes for the
+;; specified graphic context. See the gcontext-xyz functions
+;; below. See XGetGCValues.
 
 (define (get-gcontext-values gcontext)
-  (let ((Xgcontext (gcontext-Xgcontext gcontext))
+  (let* ((Xgcontext (gcontext-Xgcontext gcontext))
-	(Xdisplay (display-Xdisplay (gcontext-display gcontext))))
+	 (display (gcontext-display gcontext))
+	 (Xdisplay (display-Xdisplay display)))
     (let ((vals (%get-gcontext-values Xgcontext Xdisplay)))
       (if (not vals)
 	  (error "cannot get gcontext values." gcontext)
 	  (let*
-	      ((mod-vals (begin
+	      ((pack (lambda (i fun)
-			   (vector-set! vals 1 ;; plane-mask
+		       (vector-set! vals i (fun (vector-ref vals i)))))
-					(make-pixel (vector-ref vals 1)))
+	       (make-pixmap* (lambda (Xpixmap)
-			   (vector-set! vals 2 ;; foreground
+			       (make-pixmap Xpixmap display #f)))
-					(make-pixel (vector-ref vals 2)))
+	       (make-font* (lambda (Xfont)
-			   (vector-set! vals 3 ;; background
+			     ; this might not work properly, see Xlib Programming
-					(make-pixel (vector-ref vals 3)))
+			     ; Manual chapter 5.12
-			   ;; TODO: tile, stipple, font ...??
+			     (make-font #f Xfont #f display #t)))
+	       (make-pixel* (lambda (Xpixel)
+			      (make-pixel Xpixel #f #f)))
+	       (mod-vals (begin
+			   (pack 1 make-pixel*) ;; plane-mask
+			   (pack 2 make-pixel*) ;; foreground
+			   (pack 3 make-pixel*) ;; background
+			   (pack 11 make-pixmap*) ;; tile
+			   (pack 12 make-pixmap*) ;; stipple
+			   (pack 15 make-font*) ;; font
+			   (pack 20 make-pixmap*) ;; clip-mask
 			   vals))
 	       (alist 
 		(map cons
@@ -64,8 +99,6 @@
 (import-lambda-definition %get-gcontext-values (Xgcontext Xdisplay)
   "scx_Get_Gc_Values")
 
-;;...
-
 (define (make-gcontext-getter name)
   (lambda (gcontext)
     (cdr (assq name (get-gcontext-values gcontext)))))
@@ -94,7 +127,21 @@
 (define gcontext-dash-offset (make-gcontext-getter 'dash-offset))
 (define gcontext-dashes (make-gcontext-getter 'dashes))
 
-;; ...
+;; Alternative definition of gcontext-font. See XGcontextFromGC
+;
+;(define (gcontext-font gcontext)
+;  (let* ((display (gcontext-display gcontext))
+;	 (Xfontstruct (%gcontext-font 
+;		       (display-Xdisplay display)
+;		       (gcontext-Xgcontext gcontext))))
+;    (make-font #f #f Xfontstruct display #f)))
+;
+;(import-lambda-definition %gcontext-font (Xdisplay Xgcontext)
+;  "scx_GContext_Font") ; defined in font.c
+
+;; change-gcontext sets some attributes of the specified graphic
+;; context. The format of the arguments is like for
+;; create-gcontext. See XChangeGC.
 
 (define (change-gcontext gcontext . attrs)
   (let* ((alist (named-args->alist attrs))
@@ -157,7 +204,12 @@
 (import-lambda-definition %set-dashlist (Xgcontext Xdisplay dashoffset dashlist)
   "scx_Set_Gcontext_Dashlist")
 
-;; ...
+;; set-gcontext-clip-rectangles changes the clip-mask in the specified
+;; graphic context to the list of rectangles and sets the clip
+;; origin. Each rectangle has to be a list (x y height width). The
+;; coordinates of the rectangles are interpreted relative to the clip
+;; origin specified by x and y. ordering can be one of 'unsorted,
+;; 'y-sorted, 'xy-sorted or 'xy-banded. See XSetClipRectangles.
 
 (define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
   (%set-gcontext-clip-rectangles! (gcontext-Xgcontext gcontext)
@@ -170,7 +222,12 @@
 							  y v ord)
   "scx_Set_Gcontext_Clip_Rectangles")
 
-;; ...
+;; query-best-size/-cursor/-tile/-stipple function returns the best or
+;; closest size to the specified size. For 'cursor, this is the
+;; largest size that can be fully displayed on the screen specified by
+;; which_screen. For 'tile, this is the size that can be tiled
+;; fastest. For 'stipple, this is the size that can be stippled
+;; fastest. See XQueryBestSize.
 
 (define (query-best-size display width height shape)
   (%query-best-size (display-Xdisplay display)
@@ -187,6 +244,3 @@
 
 (define (query-best-stipple display width height)
   (query-best-size display width height 'stipple))
-
-
-

scheme/xlib/window.scm

@@ -19,7 +19,7 @@
 			   ((pixel? obj) (pixel-Xpixel obj))
 			   ((pixmap? obj) (pixmap-Xpixmap obj))
 			   ((colormap? obj) (colormap-Xcolormap obj))
-			   ;; cursor...??
+			   ((cursor? obj) (cursor-Xcursor obj))
 			   (else obj)))
 			(map cdr change-win-attr-list))))
 	     (display (window-display parent))
@@ -101,7 +101,8 @@
 	  (let*
 	      ((comp (lambda (i f) (vector-set! v i (f (vector-ref v i)))))
 	       (mod-v (begin
-			(comp 13 make-pixel) ;; backing-pixel
+			(comp 13 (lambda (Xpixel) ;; backing-pixel
+				   (make-pixel Xpixel #f #f)))
 			(comp 7 (lambda (Xwin) ;; root
 				  (make-window Xwin (window-display window)
 					       #f)))