Major changes. First window showed up!

scheme/xlib/color.scm

@@ -0,0 +1,48 @@
+;; Author: David Frese
+
+;; r,g,b should be values between 0.0 to 1.0 inclusive.
+
+(define (make-color r g b)
+  (create-color (floor (* r 65535)) 
+		(floor (* g 65535))
+		(floor (* b 65535))))
+
+(define (color-rgb-values color)
+  (map (lambda (x)
+	 (/ x 65535)) ;; exact<->inexact?
+       (extract-rgb-values color)))
+
+;; ...
+
+(define (query-color colormap pixel)
+  (apply create-color
+	 (%query-color (colormap-Xcolormap colormap)
+		       (pixel-Xpixel pixel)
+		       (display-Xdisplay (colormap-display colormap)))))
+
+(import-lambda-definiton %query-color (Xcolormap Xpixel Xdisplay)
+  "Query_Color")
+
+;; ...
+
+(define (query-colors colormap pixels)
+  (list->vector
+   (map (lambda (pixel)
+	  (query-color colormap pixel))
+	(vector->list pixels))))
+
+;; ...
+
+(define (lookup-color colormap color-name)
+  (let ((r (%lookup-color (colormap-Xcolormap colormap)
+			  (display-Xdisplay (colormap-display colormap))
+			  (if (symbol? color-name)
+			      (symbol->string color-name)
+			      color-name))))
+    (if r
+	(cons (apply create-color (car r))
+	      (apply create-color (cdr r)))
+	(error "no such color:" color-name))))
+
+(import-lambda-definiton %lookup-color (Xcolormap Xdisplay)
+  "Lookup_Color")

scheme/xlib/colormap.scm

@@ -0,0 +1,25 @@
+;; Author: David Frese
+
+(define (alloc-color colormap color)
+  (let ((Xpixel (%alloc-color (colormap-Xcolormap colormap)
+			      (color-Xcolor color)
+			      (display-Xdisplay (colormap-display colormap)))))
+    (if Xpixel
+	(make-pixel Xpixel)
+	Xpixel)))
+
+(import-lambda-definiton %alloc-color (Xcolormap Xcolor Xdisplay)
+  "Alloc_Color")
+
+;; ...
+
+(define (alloc-named-color colormap color-name)
+  (let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
+				  (if (symbol? color-name)
+				      (symbol->string color-name)
+				      color-name))))
+    (if Xres
+	(list (make-pixel (car Xres))
+	      (apply make-color (cadr Xres))
+	      (apply make-color (caddr Xres)))
+	Xres)))

scheme/xlib/display.scm

@@ -1,26 +1,5 @@
 ;; Author: David Frese
 
-(define-record-type display :display 
-  (really-make-display after-function Xdisplay) 
-  display? 
-  (after-function display-after-function display-set-after-function!) 
-  (Xdisplay display-Xdisplay display-set-Xdisplay!))
-
-;; for compatibility with elk:
-(define set-after-function! display-set-after-function!)
-(define after-function display-after-function)
-
-(define (make-display Xdisplay)
-  (let ((maybe-display (display-list-find Xdisplay)))
-    (if maybe-display
-	maybe-display
-	(let ((display (really-make-display #f Xdisplay)))
-	  (add-finalizer! display finalize-display)
-	  (display-list-set! Xdisplay display)
-	  display))))
-
-(define-exported-binding "display-record-type" :display)
-
 (define (open-display . args)
   (let ((display-name (if (null? args)
 			  #f
@@ -35,54 +14,16 @@
 
 (import-lambda-definition %open-display (name) "Open_Display")
 
-;; finalize-display is called, when the garbage collector removes the last
+;; for compatibility with elk:
-;; reference to display from the heap. Then we can savely close the display
+(define set-after-function! display-set-after-function!)
-;; and remove the weak-pointer from out list.
+(define after-function display-after-function)
-
-(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 
-;; effects.
-
-(define (close-display display)
-  (let ((Xdisplay (display-Xdisplay display)))
-    (if (integer? Xdisplay)
-	(begin
-	  ((display-after-function display) display)
-	  (%close-display Xdisplay)
-	  (display-set-Xdisplay display 'already-closed)))))
-
-(import-lambda-definition %close-display (Xdisplay) "Close_Display")
-
-;; All display records need to be saved in a weak-list, to have only one record
-;; for the same Xlib display-structure in the heap.
-
-(define *weak-display-list* (make-integer-table))
-
-(define (display-list-find Xdisplay)
-  (let ((r (table-ref *weak-display-list* Xdisplay)))
-    (if r 
-	(weak-pointer-ref r)
-	r)))
-
-(define (display-list-set! Xdisplay display)
-  (let ((p (make-weak-pointer display)))
-    (table-set! *weak-display-list* Xdisplay p)))
-
-(define (display-list-delete! Xdisplay)
-  (display-list-set! Xdisplay #f))
 
 ;; ...
 
 (define (display-default-root-window display)
   (let* ((Xdisplay (display-Xdisplay display))
 	 (Xwindow (%default-root-window Xdisplay)))
-    (make-window 0 Xdisplay Xwindow)))
+    (make-window 0 Xwindow (make-display Xdisplay))))
 
 (define display-root-window display-default-root-window)
 
@@ -94,7 +35,8 @@
 (define (display-default-colormap display)
   (let* ((Xdisplay (display-Xdisplay display))
 	 (Xcolormap (%default-colormap Xdisplay)))
-    (make-colormap 0 Xdisplay Xcolormap)))
+;**    (make-colormap 0 Xdisplay Xcolormap)))
+    #f))
 
 (define display-colormap display-default-colormap)
 
@@ -106,8 +48,8 @@
 (define (display-default-gcontext display)
   (let* ((Xdisplay (display-Xdisplay display))
 	 (Xgcontext (%default-gcontext Xdisplay)))
-    (make-gcontext 0 Xdisplay Xgcontext)))
+;**    (make-gcontext 0 Xdisplay Xgcontext)))
-
+    #f))
 (import-lambda-definition %default-gcontext (Xdisplay) 
   "Display_Default_Gcontext")
 
@@ -117,7 +59,7 @@
   (let ((Xdisplay (display-Xdisplay display)))
     (%default-depth Xdisplay)))
 
-(import-lambda-defintion %default-depth (Xdisplay)
+(import-lambda-definition %default-depth (Xdisplay)
   "Display_Default_Depth")
 
 ;; ...
@@ -166,7 +108,7 @@
 (define (display-vendor display)
   (%display-vendor (display-Xdisplay display)))
 
-(import-lambda-defintion %display-vendor (Xdisplay)
+(import-lambda-definition %display-vendor (Xdisplay)
   "Display_Vendor")
 
 ;; Display-protocol-version return a pair of major and minor version numbers of
@@ -273,7 +215,7 @@
 (define (display-flush-output display)
   (%display-flush-output (display-Xdisplay display)))
 
-(import-lambda-definiton %display-flush-output (Xdisplay)
+(import-lambda-definition %display-flush-output (Xdisplay)
   "Display_Flush_Output")
 
 ;; ... the result is unspecific
@@ -312,6 +254,8 @@
 (define (display-list-pixmap-formats display)
   (%display-list-pixmap-formats (display-Xdisplay display)))
 
+(define list-pixmap-formats display-list-pixmap-formats) ;; compat./Elk
+
 (import-lambda-definition %display-list-pixmap-formats (Xdisplay)
   "List_Pixmap_Formats")
 

scheme/xlib/pixel.scm

@@ -0,0 +1,13 @@
+(define pixel-value pixel-Xpixel)
+
+(define (black-pixel display)
+  (make-pixel (%black-pixel (display-Xdisplay display))))
+
+(import-lambda-definition %black-pixel (Xdisplay)
+  "Black_Pixel")
+
+(define (white-pixel display)
+  (make-pixel (%white-pixel (display-Xdisplay display))))
+
+(import-lambda-definition %white-pixel (Xdisplay)
+  "White_Pixel")

scheme/xlib/stuff.scm

@@ -0,0 +1,19 @@
+;; named-args->alist does this:
+;; '(a 5 b 6 ((c . 10) (d . 5))) -> '((a . 5) (b . 6) (c . 10) (d . 5))
+;; '(e 3) -> '((e . 3))
+;; '((f . 0)) -> '((f . 0))
+;; (hard to explain :-)
+
+(define (named-args->alist args)
+  (let loop ((alist '())
+	     (args args))
+    (cond
+     ((null? args) (reverse alist))
+     ((null? (cdr args)) (loop (append (car args) alist) '()))
+     (else (let ((sym (car args))
+		 (val (cadr args)))
+	     (loop (cons (cons sym val) alist)
+		   (cddr args)))))))
+
+
+(define-exported-binding "string->symbol" string->symbol)

scheme/xlib/type/color-type.scm

@@ -0,0 +1,73 @@
+;; the color-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type color :color
+  (really-make-color tag Xcolor) 
+  color?
+  (tag color-tag color-set-tag!)
+  (Xcolor color-Xcolor color-set-Xcolor!))
+
+(define (internal-make-color Xcolor)
+  (let ((maybe-color (color-list-find Xcolor)))
+    (if maybe-color
+	maybe-color
+	(let ((color (really-make-color #f Xcolor)))
+	  (add-finalizer! color finalize-color)
+	  (color-list-set! Xcolor color)
+	  color))))
+
+;; r, g, b should be integers from 0 to 65535
+(define (make-color r g b)
+  (let ((maybe-color (color-list-find* r g b)))
+    (if maybe-color
+	maybe-color
+	(internal-make-color (%create-color r g b)))))
+
+(import-lambda-definition %create-color (r g b)
+  "Create_Color")
+
+(define-exported-binding "color-record-type" :color)
+
+;; returns a list of r,g,b as integers
+(define (extract-rgb-values color)
+  (%extract-rgb-values (color-Xcolor)))
+
+(import-lambda-definition %extract-rgb-values (XColor)
+  "Extract_RGB_Values")
+
+;; finalize-color is called, when the garbage collector removes the last
+;; reference to the color from the heap. Then we can savely close the color
+;; and remove the weak-pointer from our list.
+
+(define (finalize-color color)
+  (let ((Xcolor (color-Xcolor color)))
+    ;;(destroy-color color)
+    (color-set-Xcolor! color 'already-destroyed)
+    (color-list-delete! Xcolor)))
+
+;; All color records need to be saved in a weak-list, to have only one record
+;; for the same r,g,b value in the heap.
+
+(define *weak-color-list* (make-integer-table))
+
+(define (color-list-find Xcolor)
+  (let ((r (table-ref *weak-color-list* Xcolor)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (color-list-find* r g b) ;; r,g,b as integers
+  (call/cc (lambda (return)
+	     (table-walk (lambda (key value)
+			  (let ((color (weak-pointer-ref value)))
+			    (if (equal? (list r g b)
+					(extract-rgb-values color))
+				(return key))))
+			 *weak-color-list*)
+	     #f)))
+
+(define (color-list-set! Xcolor color)
+  (let ((p (make-weak-pointer color)))
+    (table-set! *weak-color-list* Xcolor p)))
+
+(define (color-list-delete! Xcolor)
+  (table-set! *weak-color-list* Xcolor #f))

scheme/xlib/type/colormap-type.scm

@@ -0,0 +1,59 @@
+;; the colormap-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type colormap :colormap
+  (really-make-colormap tag Xcolormap display) 
+  colormap? 
+  (tag colormap-tag colormap-set-tag!)
+  (Xcolormap colormap-Xcolormap colormap-set-Xcolormap!)
+  (display colormap-display colormap-set-display!))
+
+(define (make-colormap Xcolormap display)
+  (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)
+	  (colormap-list-set! Xcolormap colormap)
+	  colormap))))
+
+(define-exported-binding "colormap-record-type" :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-set-Xcolormap! colormap 'already-destroyed)
+    (colormap-list-delete! Xcolormap)))
+
+(define (free-colormap colormap)
+  (let ((Xcolormap (colormap-Xcolormap)))
+    (if (integer? Xcolormap)
+	(begin
+	  (%free-colormap Xcolormap 
+			  (display-Xdisplay (colormap-display colormap)))
+	  (colormap-set-Xcolormap! colormap 'already-freed)))))
+
+(import-lambda-definition %free-colormap (Xcolormap Xdisplay)
+  "Free_Colormap")
+
+;; All colormap records need to be saved in a weak-list, to have only one record
+;; for the same XLib colormap
+
+(define *weak-colormap-list* (make-integer-table))
+
+(define (colormap-list-find Xcolormap)
+  (let ((r (table-ref *weak-colormap-list* Xcolormap)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (colormap-list-set! Xcolormap colormap)
+  (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))
+

scheme/xlib/type/display-type.scm

@@ -0,0 +1,61 @@
+;; the display-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type display :display 
+  (really-make-display after-function Xdisplay) 
+  display? 
+  (after-function display-after-function display-set-after-function!) 
+  (Xdisplay display-Xdisplay display-set-Xdisplay!))
+
+(define (make-display Xdisplay)
+  (let ((maybe-display (display-list-find Xdisplay)))
+    (if maybe-display
+	maybe-display
+	(let ((display (really-make-display #f Xdisplay)))
+	  (add-finalizer! display finalize-display)
+	  (display-list-set! Xdisplay display)
+	  display))))
+
+(define-exported-binding "display-record-type" :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 
+;; effects.
+
+(define (close-display display)
+  (let ((Xdisplay (display-Xdisplay display)))
+    (if (integer? Xdisplay)
+	(begin
+	  ((display-after-function display) display)
+	  (%close-display Xdisplay)
+	  (display-set-Xdisplay display 'already-closed)))))
+
+(import-lambda-definition %close-display (Xdisplay) "Close_Display")
+
+;; All display records need to be saved in a weak-list, to have only one record
+;; for the same Xlib display-structure in the heap.
+
+(define *weak-display-list* (make-integer-table))
+
+(define (display-list-find Xdisplay)
+  (let ((r (table-ref *weak-display-list* Xdisplay)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (display-list-set! Xdisplay display)
+  (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))
+

scheme/xlib/type/pixel-type.scm

@@ -0,0 +1,43 @@
+(define-record-type pixel :pixel
+  (really-make-pixel tag Xpixel) 
+  pixel?
+  (tag pixel-tag pixel-set-tag!)
+  (Xpixel pixel-Xpixel pixel-set-Xpixel!))
+
+(define (make-pixel Xpixel display)
+  (let ((maybe-pixel (pixel-list-find Xpixel)))
+    (if maybe-pixel
+	maybe-pixel
+	(let ((pixel (really-make-pixel #f Xpixel display)))
+	  (add-finalizer! pixel finalize-pixel)
+	  (pixel-list-set! Xpixel pixel)
+	  pixel))))
+
+(define-exported-binding "pixel-record-type" :pixel)
+
+;; finalize-pixel is called, when the garbage collector removes the last
+;; reference to the pixel from the heap. Then we can savely close the 
+;; pixel and remove the weak-pointer from our list.
+
+(define (finalize-pixel pixel)
+  (let ((Xpixel (pixel-Xpixel pixel)))
+    (pixel-set-Xpixel! pixel 'already-destroyed)
+    (pixel-list-delete! Xpixel)))
+
+;; All pixel records need to be saved in a weak-list, to have only one record
+;; for the same XLib pixel
+
+(define *weak-pixel-list* (make-integer-table))
+
+(define (pixel-list-find Xpixel)
+  (let ((r (table-ref *weak-pixel-list* Xpixel)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (pixel-list-set! Xpixel pixel)
+  (let ((p (make-weak-pointer pixel)))
+    (table-set! *weak-pixel-list* Xpixel p)))
+
+(define (pixel-list-delete! Xpixel)
+  (table-set! *weak-pixel-list* Xpixel #f))

scheme/xlib/type/window-type.scm

@@ -0,0 +1,64 @@
+;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type window :window
+  (really-make-window tag Xwindow display) 
+  window? 
+  (tag window-tag window-set-tag!)
+  (Xwindow window-Xwindow window-set-Xwindow!)
+  (display window-display window-set-display!))
+
+(define (make-window tag Xwindow display)
+  (let ((maybe-window (window-list-find Xwindow)))
+    (if maybe-window
+	maybe-window
+	(let ((window (really-make-window tag Xwindow display)))
+	  (add-finalizer! window finalize-window)
+	  (window-list-set! Xwindow window)
+	  window))))
+
+(define-exported-binding "window-record-type" :window)
+
+(define (drawable? object)
+  (or (window? object)
+      (pixmap? object)))
+
+;; 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)))
+
+;; ...
+
+(define (destroy-window window)
+  (let ((Xdisplay (display-Xdisplay (window-display window)))
+	(Xwindow (window-Xwindow window)))
+    (if (integer? Xwindow)
+	(begin
+	  (%destroy-window Xdisplay Xwindow)
+	  (window-set-Xwindow! window 'already-destroyed)))))
+
+(import-lambda-definition %destroy-window (Xdisplay Xwindow)
+  "Destroy_Window")
+
+;; All window records need to be saved in a weak-list, to have only one record
+;; for the same Xlib window-structure in the heap.
+
+(define *weak-window-list* (make-integer-table))
+
+(define (window-list-find Xwindow)
+  (let ((r (table-ref *weak-window-list* Xwindow)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (window-list-set! Xwindow window)
+  (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))
+

scheme/xlib/window.scm

@@ -0,0 +1,256 @@
+;; Author: David Frese
+
+; ... 
+
+(define (create-window . args)
+  (let ((alist (named-args->alist args)))
+    ;; filter attributes
+    (let* ((x 0)
+	   (y 0)
+	   (width #f)
+	   (height #f)
+	   (border-width 2)
+	   (parent #f)
+	   (change-win-attr-list '()))
+      (for-each (lambda (name-val)
+		  (let ((val (cdr name-val)))
+		    (case (car name-val)
+		      ((x) (set! x val))
+		      ((y) (set! y val))
+		      ((width) (set! width val))
+		      ((height) (set! height val))
+		      ((parent) (set! parent val))
+		      ((border-width) (set! border-width val))
+		      (else (set! change-win-attr-list
+				  (cons name-val change-win-attr-list))))))
+		alist)
+      (let* ((display (window-display parent))
+	     (Xwindow (%create-window (display-Xdisplay display)
+				      (window-Xwindow parent)
+				      x y width height border-width
+				      change-win-attr-list)))
+	(if (= Xwindow 0)
+	    (error "cannot create window")
+	    (make-window #f Xwindow display))))))
+
+(import-lambda-definition %create-window (Xdisplay Xparent x y width height 
+						   border-width attrAlist)
+  "Create_Window")
+
+
+
+;; change-window-attributes takes an alist of names and values...
+;; names can be: background-pixmap, background-pixel, border-pixmap, 
+;; border-pixel, bit-gravity, gravity, backing-store, backing-planes, 
+;; backing-pixel, save-under, event-mask, do-not-propagate-mask, 
+;; override-redirect, colormap, cursor.
+
+(define (change-window-attributes window . attrs)
+  (let* ((alist (named-args->alist attrs))
+	 (prep-alist 
+	  (map cons
+	       (map car alist)
+	       (map (lambda (value)
+		      (cond
+		       ;; Abstractions ?? :
+		       ((pixmap? value) (pixmap-Xpixmap value))
+		       ((pixel? value) (pixel-Xpixel value))
+		       ((colormap? value) (colormap-Xcolormap value))
+		       ((cursor? value) (cursor-Xcursor value))
+		       (else value)))
+		    (map cdr alist)))))
+    (%change-window-attributes (window-Xwindow window)
+			       (display-Xdisplay (window-display window))
+			       prep-alist)))
+
+(import-lambda-definition %change-window-attributes (Xwindow Xdisplay alist)
+  "Change_Window_Attributes")
+
+;; single functions that use change-window-attributes:
+
+(define (make-win-attr-setter name)
+  (lambda (window value)
+    (change-window-attributes window (cons name value))))
+
+(define set-window-background-pixmap! (make-win-attr-setter 'background-pixmap))
+(define set-window-background-pixel! (make-win-attr-setter 'background-pixel))
+(define set-window-border-pixmap! (make-win-attr-setter 'border-pixmap))
+(define set-window-border-pixel! (make-win-attr-setter 'border-pixel))
+(define set-window-bit-gravity! (make-win-attr-setter 'bit-gravity))
+(define set-window-gravity! (make-win-attr-setter 'gravity))
+(define set-window-backing-store! (make-win-attr-setter 'backing-store))
+(define set-window-backing-planes! (make-win-attr-setter 'backing-planes))
+(define set-window-backing-pixel! (make-win-attr-setter 'backing-pixel))
+(define set-window-save-under! (make-win-attr-setter 'save-under))
+(define set-window-event-mask! (make-win-attr-setter 'event-mask))
+(define set-window-do-not-propagate-mask! 
+  (make-win-attr-setter 'do-not-propagate-mask))
+(define set-window-override-redirect! (make-win-attr-setter 'override-redirect))
+(define set-window-colormap! (make-win-attr-setter 'colormap))
+(define set-window-cursor! (make-win-attr-setter 'cursor))
+
+;; get-window-attributes gives back the same attributes that 
+;; set-window-attributes sets and some more ... 
+
+(define (get-window-attributes window)
+  (let ((Xwindow (window-Xwindow window))
+	(Xdisplay (display-Xdisplay (window-display window))))
+    (let* ((lst (%get-window-attributes Xdisplay Xwindow))
+	   (alist (map cons
+		       '(x y width height border-width depth visual root class 
+			   bit-gravity win-gravity backing-store backing-planes
+			   backing-pixel save-under colormap map-installed
+			   map-state all-event-masks your-event-mask 
+			   do-not-propagate-mask override-redirect screen)
+		       lst))
+	   (mod-alist (map (lambda (name-val)
+			     (case (car name-val)
+			       ;((root) (make-window ...
+			       (else name-val)))
+			   alist)))
+      mod-alist)))
+
+(import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
+  "Get_Window_Attributes")
+
+(define (make-win-attr-getter name)
+  (lambda (window)
+    (cdr (assq name (get-window-attributes window)))))
+
+(define window-x (make-win-attr-getter 'x))
+(define window-y (make-win-attr-getter 'y))
+(define window-width (make-win-attr-getter 'width))
+(define window-height (make-win-attr-getter 'height))
+(define window-border-width (make-win-attr-getter 'border-width))
+(define window-depth (make-win-attr-getter 'depth))
+(define window-visual (make-win-attr-getter 'visual))
+(define window-root (make-win-attr-getter 'root))
+(define window-class (make-win-attr-getter 'class))
+(define window-bit-gravity (make-win-attr-getter 'bit-gravity))
+(define window-backing-store (make-win-attr-getter 'backing-store))
+(define window-backing-planes (make-win-attr-getter 'backing-planes))
+(define window-backing-pixel (make-win-attr-getter 'backing-pixel))
+(define window-save-under (make-win-attr-getter 'save-under))
+(define window-colormap (make-win-attr-getter 'colormap))
+(define window-map-installed (make-win-attr-getter 'map-installed))
+(define window-map-state (make-win-attr-getter 'map-state))
+(define window-all-event-masks (make-win-attr-getter 'all-event-masks))
+(define window-your-event-mask (make-win-attr-getter 'your-event-mask))
+(define window-do-not-propagate-mask 
+  (make-win-attr-getter 'do-not-propagate-mask))
+(define window-override-redirect (make-win-attr-getter 'override-redirect))
+
+;; ...
+
+(define (configure-window window . args)
+  (let* ((args (named-args->alist args))
+	 (prep-alist (map cons
+			  (map car args)
+			  (map (lambda (val)
+				 (if (window? val)
+				     (window-Xwindow val)
+				     val))
+			       (map cdr args)))))
+  (%configure-window (window-Xwindow window)
+		     (display-Xdisplay (window-display))
+		     prep-alist)))
+
+(import-lambda-definition %configure-window (Xwindow Xdisplay alist)
+  "Configure_Window")
+
+;; the following mutators are based on configure-window
+
+(define (make-win-configurer name)
+  (lambda (window value)
+    (configure-window window name value)))
+
+(define set-window-x! (make-win-configurer 'x))
+(define set-window-y! (make-win-configurer 'y))
+(define set-window-width! (make-win-configurer 'width))
+(define set-window-height! (make-win-configurer 'height))
+(define set-window-border-width! (make-win-configurer 'border-width))
+(define set-window-sibling! (make-win-configurer 'sibling))
+(define set-window-stack-mode! (make-win-configurer 'stack-mode))
+
+;; ...
+
+(define (map-window window)
+  (%map-window (window-Xwindow window) 
+	       (display-Xdisplay (window-display window))))
+
+(import-lambda-definition %map-window (Xwindow Xdisplay)
+  "Map_Window")
+
+;; ...
+
+(define (unmap-window window)
+  (%unmap-window (window-Xwindow window)
+		 (display-Xdisplay (window-display window))))
+
+(import-lambda-definition %unmap-window (Xwindow Xdisplay)
+  "Unmap_Window")
+
+;; ...
+
+(define (destroy-subwindows window)
+  (%destroy-subwindows (window-Xwindow window)
+		       (display-Xdisplay (window-display window))))
+
+(import-lambda-definition %destroy-subwindows (Xwindow Xdisplay)
+  "Destroy_Subwindows")
+
+;; ...
+
+(define (map-subwindows window)
+  (%map-subwindows (window-Xwindow window)
+		   (display-Xdisplay (window-display window))))
+
+(import-lambda-definition %map-subwindows (Xwindow Xdisplay)
+  "Map_Subwindows")
+
+;; ...
+
+(define (unmap-subwindows window)
+  (%unmap-subwindows (window-Xwindow window)
+		     (display-Xdisplay (window-display window))))
+
+(import-lambda-definition %unmap-subwindows (Xwindow Xdisplay)
+  "Unmap_Subwindows")
+
+;; ...
+
+(define (circulate-subwindows window direction)
+  (%destroy-subwindows (window-Xwindow window)
+		       (display-Xdisplay (window-display window))
+		       (case direction
+			((raise-lowest) 0)
+			((lower-highest) 1)))) ; else exception??
+
+(import-lambda-definition %circulate-subwindows (Xwindow Xdisplay dir)
+  "Circulate_Subwindows")
+
+;; ...
+
+(define (clear-window window)
+  (clear-area window 0 0 0 0 #f))
+
+;; ...
+
+(define (raise-window window)
+  (set-window-stack-mode! window 'above))
+
+(define (lower-window window)
+  (set-window-stack-mode! window 'below))
+
+;; ...
+
+(define (restack-windows window-list)
+  (let loop ((w (car window-list))
+	     (t (cdr window-list)))
+    (if (not (null? t))
+	(let ((n (car t)))
+	  (set-window-sibling! n w)
+	  (set-window-stack-mode! n 'below)
+	  (loop n (cdr t))))))
+
+;; ...

scheme/xlib/xlib-interfaces.scm

@@ -1,3 +1,68 @@
+;;; A "header" package with all new datatypes
+
+(define-interface xlib-types-interface
+  (export make-display
+	  display?
+	  display-Xdisplay
+	  display-after-function
+	  display-set-after-function!
+	  close-display
+
+	  make-window
+	  destroy-window
+	  window?
+	  drawable?
+	  window-tag
+	  window-set-tag!
+	  window-Xwindow
+	  window-display
+
+	  make-color
+	  color?
+	  color-Xcolor
+	  color-tag
+	  color-set-tag!
+
+	  make-colormap
+	  colormap?
+	  free-colormap
+	  colormap-display
+	  colormap-Xcolormap
+	  colormap-tag
+
+	  make-pixel
+	  pixel?
+	  pixel-Xpixel
+	  pixel-tag
+	  
+	  ))
+
+(define-structure xlib-types xlib-types-interface
+  (open scsh
+	scheme
+	weak
+	general-tables
+	primitives
+	define-record-types
+	external-calls)
+  (files type/display-type 
+	 type/window-type
+	 type/color-type
+	 type/colormap-type
+	 type/pixel-type))
+
+;;; Basic package
+
+(define-interface xlib-basic-interface
+  (export named-args->alist))
+
+(define-structure xlib-basic xlib-basic-interface
+  (open scsh
+	scheme
+	external-calls)
+  (files stuff))
+
+
 ;;; The display structure
 
 (define-interface xlib-display-interface
@@ -45,11 +110,144 @@
 (define-structure xlib-display xlib-display-interface
   (open scsh
 	scheme
-	define-record-types
+	external-calls
-	weak
+	xlib-types
-	general-tables
+	xlib-basic)
-;	xlib-window
+  (files display))
-	primitives)
-  (files "display.scm"))
 
-;;; ...
+(define-interface xlib-window-interface
+  (export window?
+	  drawable?
+	  window-display
+	  create-window	  
+	  destroy-window
+	  change-window-attributes
+	  get-window-attributes
+	  map-window
+	  unmap-window
+
+	  set-window-background-pixmap!
+	  set-window-background-pixel!
+	  set-window-border-pixmap!
+	  set-window-border-pixel!
+	  set-window-bit-gravity!
+	  set-window-gravity!
+	  set-window-backing-store!
+	  set-window-backing-planes!
+	  set-window-backing-pixel!
+	  set-window-save-under!
+	  set-window-event-mask!
+	  set-window-do-not-propagate-mask!
+	  set-window-override-redirect!
+	  set-window-colormap!
+	  set-window-cursor!
+
+	  set-window-x!
+	  set-window-y!
+	  set-window-width!
+	  set-window-height!
+	  set-window-border-width!
+	  set-window-sibling!
+	  set-window-stack-mode!
+
+	  window-x
+	  window-y
+	  window-width
+	  window-height
+	  window-border-width
+	  window-depth
+	  window-visual
+	  window-root
+	  window-class
+	  window-bit-gravity
+	  window-backing-store
+	  window-backing-planes
+	  window-backing-pixel
+	  window-save-under
+	  window-colormap
+	  window-map-installed
+	  window-map-state
+	  window-all-event-masks
+	  window-your-event-mask
+	  window-do-not-propagate-mask 
+	  window-override-redirect
+
+	  destroy-subwindows
+	  map-subwindows
+	  unmap-subwindows
+	  circulate-subwindows
+	  
+	  clear-window
+	  raise-window
+	  lower-window
+	  restack-windows
+	  query-tree
+	  translate-coordinates
+	  query-pointer
+	  ))
+
+(define-structure xlib-window xlib-window-interface
+  (open scsh
+	scheme
+	external-calls
+	xlib-types
+	xlib-basic
+;	xlib-graphics ;; for clear-window
+	)
+  (files window))
+
+;;; the color-interface
+
+(define-interface xlib-color-interface
+  (export make-color
+	  color?
+	  color-rgb-values
+	  color-tag     ;;??
+	  color-set-tag!;;??
+	  query-color
+	  query-colors
+	  lookup-color))
+
+(define-structure xlib-color xlib-color-interface
+  (open scsh
+	scheme
+	external-calls
+	xlib-types
+	xlib-basic)
+  (files color))
+
+;;; the colormap-interface
+
+(define-interface xlib-colormap-interface
+  (export make-colormap
+	  colormap?
+	  free-colormap
+	  colormap-display
+	  alloc-color
+	  alloc-named-color
+	  ))
+
+(define-structure xlib-colormap xlib-colormap-interface
+  (open scsh
+	scheme
+	external-calls
+	xlib-types
+	xlib-basic)
+  (files colormap))
+
+;;; the pixel-interface
+
+(define-interface xlib-pixel-interface
+  (open scsh
+	scheme
+	external-calls
+	xlib-types
+	xlib-basic)
+  (files pixel))
+
+(define-structure xlib-pixel xlib-pixel-interface
+  (export pixel?
+	  pixel-value
+	  black-pixel
+	  white-pixel
+	  ))