From d6a249c4fe374cb8a6a214393b97b79db2b45848 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Mon, 21 May 2001 15:32:01 +0000
Subject: [PATCH] Untested implementation of the display stuff.

---
 scheme/xlib/display.scm         | 326 ++++++++++++++++++++++++++++++++
 scheme/xlib/xlib-interfaces.scm |  55 ++++++
 2 files changed, 381 insertions(+)
 create mode 100644 scheme/xlib/display.scm
 create mode 100644 scheme/xlib/xlib-interfaces.scm

diff --git a/scheme/xlib/display.scm b/scheme/xlib/display.scm
new file mode 100644
index 0000000..b9ef216
--- /dev/null
+++ b/scheme/xlib/display.scm
@@ -0,0 +1,326 @@
+;; 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
+			  (let ((dpy-name (car args)))
+			    (cond
+			     ((symbol? dpy-name) (symbol->string dpy-name))
+			     (else dpy-name))))))
+    (let ((Xdisplay (%open-display display-name)))
+      (if (= Xdisplay 0)
+	  (error "cannot open display" display-name)
+	  (make-display Xdisplay)))))
+
+(import-lambda-definition %open-display (name) "Open_Display")
+
+;; finalize-display is called, when the garbage collector removes the last
+;; reference to display from the heap. Then we can savely close the display
+;; and remove the weak-pointer from out 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)
+  (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)))
+
+(define display-root-window display-default-root-window)
+
+(import-lambda-definition %default-root-window (Xdisplay) 
+   "Display_Default_Root_Window")
+
+;; ...
+
+(define (display-default-colormap display)
+  (let* ((Xdisplay (display-Xdisplay display))
+	 (Xcolormap (%default-colormap Xdisplay)))
+    (make-colormap 0 Xdisplay Xcolormap)))
+
+(define display-colormap display-default-colormap)
+
+(import-lambda-definition %default-colormap (Xdisplay) 
+   "Display_Default_Colormap")
+
+;; ...
+
+(define (display-default-gcontext display)
+  (let* ((Xdisplay (display-Xdisplay display))
+	 (Xgcontext (%default-gcontext Xdisplay)))
+    (make-gcontext 0 Xdisplay Xgcontext)))
+
+(import-lambda-definition %default-gcontext (Xdisplay) 
+  "Display_Default_Gcontext")
+
+;; ...
+
+(define (display-default-depth display)
+  (let ((Xdisplay (display-Xdisplay display)))
+    (%default-depth Xdisplay)))
+
+(import-lambda-defintion %default-depth (Xdisplay)
+  "Display_Default_Depth")
+
+;; ...
+
+(define (display-default-screen-number display)
+  (let ((Xdisplay (display-Xdisplay display)))
+    (%default-screen-number Xdisplay)))
+
+(import-lambda-definition %default-screen-number (Xdisplay)
+  "Display_Default_Screen_Number")
+
+;; ...
+
+(define (check-screen-number display screen-number)
+  (if (or (< screen-number 0)
+	  (>= screen-number (display-screen-count display)))
+      (error "invalid screen number" screen-number)))
+
+(define (display-cells display screen-number)
+  (check-screen-number display screen-number)
+  (%display-cells (display-Xdisplay display) screen-number))
+
+(import-lambda-definition %display-cells (Xdisplay screen-number)
+  "Display_Cells")
+
+;; ...
+
+(define (display-planes display screen-number)
+  (check-screen-number display screen-number)
+  (%display-planes (display-Xdisplay display) screen-number))
+
+(import-lambda-definition %display-planes (Xdisplay screen-number)
+  "Display_Planes")
+
+;; ...
+
+(define (display-string display)
+  (%display-string (display-Xdisplay display)))
+
+(import-lambda-definition %display-string (Xdisplay)
+  "Display_String")
+
+;; Display-Vendor returns a pair, whose car is the vendor identification and 
+;; whose cdr is the release number
+
+(define (display-vendor display)
+  (%display-vendor (display-Xdisplay display)))
+
+(import-lambda-defintion %display-vendor (Xdisplay)
+  "Display_Vendor")
+
+;; Display-protocol-version return a pair of major and minor version numbers of
+;; the X protocol.
+
+(define (display-protocol-version display)
+  (%display-protocol-version (display-Xdisplay display)))
+
+(import-lambda-definition %display-protocol-version (Xdisplay)
+  "Display_Protocol_Version")
+
+;; ...
+
+(define (display-screen-count display)
+  (%display-screen-count (display-Xdisplay display)))
+
+(import-lambda-definition %display-screen-count (Xdisplay)
+  "Display_Screen_Count")
+
+;; display-image-byte-order returns one of the symbols 'lsb-first and 
+;; 'msb-first.
+
+(define (display-image-byte-order display)
+  (%display-image-byte-order (display-Xdisplay display)))
+
+(import-lambda-definition %display-image-byte-order (Xdisplay)
+  "Display_Image_Byte_Order")
+
+;; ...
+
+(define (display-bitmap-unit display)
+  (%display-bitmap-unit (display-Xdisplay display)))
+
+(import-lambda-definition %display-bitmap-unit (Xdisplay)
+  "Display_Bitmap_Unit")
+
+;; ...
+
+(define (display-bitmap-bit-order display)
+  (%display-bitmap-bit-order (display-Xdisplay display)))
+
+(import-lambda-definition %display-bitmap-bit-order (Xdisplay)
+  "Display_Bitmap_Bit_Order")
+
+;; ...
+
+
+(define (display-bitmap-pad display)
+  (%display-bitmap-pad (display-Xdisplay display)))
+
+(import-lambda-definition %display-bitmap-pad (Xdisplay)
+  "Display_Bitmap_Pad")
+
+;; ...
+
+(define (display-width display)
+  (%display-width (display-Xdisplay display)))
+
+(import-lambda-definition %display-width (Xdisplay)
+  "Display_Width")
+
+;; ...
+
+(define (display-height display)
+  (%display-height (display-Xdisplay display)))
+
+(import-lambda-definition %display-height (Xdisplay)
+  "Display_Height")
+
+;; ...
+
+(define (display-width-mm display)
+  (%display-width-mm (display-Xdisplay display)))
+
+(import-lambda-definition %display-width-mm (Xdisplay)
+  "Display_Width_Mm")
+
+;; ...
+
+(define (display-width-mm display)
+  (%display-width-mm (display-Xdisplay display)))
+
+(import-lambda-definition %display-width-mm (Xdisplay)
+  "Display_Width_Mm")
+
+;; ...
+
+(define (display-height-mm display)
+  (%display-height-mm (display-Xdisplay display)))
+
+(import-lambda-definition %display-height-mm (Xdisplay)
+  "Display_Height_Mm")
+
+;; ...
+
+(define (display-motion-buffer-size display)
+  (%display-motion-buffer-size (display-Xdisplay display)))
+
+(import-lambda-definition %display-motion-buffer-size (Xdisplay)
+  "Display_Motion_Buffer_Size")
+
+;; ... the result is unspecific
+
+(define (display-flush-output display)
+  (%display-flush-output (display-Xdisplay display)))
+
+(import-lambda-definiton %display-flush-output (Xdisplay)
+  "Display_Flush_Output")
+
+;; ... the result is unspecific
+
+(define (display-wait-output display discard-events?)
+  (%display-wait-output (display-Xdisplay display)
+			discard-events?))
+
+(import-lambda-definition %display-wait-ouput (Xdisplay discard)
+  "Display_Wait_Output")
+
+;; ... the result is unspecific
+
+(define (display-no-op display)
+  (%no-op (display-Xdisplay display)))
+
+(import-lambda-definition %no-op (Xdisplay)
+  "No_Op")
+
+(define no-op display-no-op)
+
+;; ... returns a vector of integers
+
+(define (display-list-depths display screen-number)
+  (%display-list-depths (display-Xdisplay display)
+			(check-screen-number screen-number)))
+
+(import-lambda-definition %display-list-depths (Xdisplay scr)
+  "List_Depths")
+
+(define list-depths display-list-depths)
+
+;; ... returns a vector of lists with 3 integers (depth, bits per pixel, 
+;; scanline pad)
+
+(define (display-list-pixmap-formats display)
+  (%display-list-pixmap-formats (display-Xdisplay display)))
+
+(import-lambda-definition %display-list-pixmap-formats (Xdisplay)
+  "List_Pixmap_Formats")
+
+;; synchronize just sets the after-function of the display to 
+;; display-wait-output (with #f for discard-events?).
+
+(define (synchronize display)
+  (display-set-after-function! 
+   display 
+   (lambda (display) 
+     (display-wait-output display #f))))
+
diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm
new file mode 100644
index 0000000..e4b9b9f
--- /dev/null
+++ b/scheme/xlib/xlib-interfaces.scm
@@ -0,0 +1,55 @@
+;;; The display structure
+
+(define-interface xlib-display-interface
+  (export display?
+	  open-display
+	  close-display
+	  display-after-function 
+	  after-function ;; compatibility with Elk, same as above
+	  display-set-after-function! 
+	  set-after-function! ;; compatibility with Elk, same as above
+	  display-default-root-window
+	  display-root-window ;; same as above
+	  display-default-colormap
+	  display-colormap ;; same as above
+	  display-default-gcontext
+	  display-default-depth
+	  display-default-screen-number
+	  display-cells
+	  display-planes
+	  display-string
+	  display-vendor
+	  display-protocol-version
+	  display-screen-count
+	  display-image-byte-order
+	  display-bitmap-unit
+	  display-bitmap-bit-order
+	  display-bitmap-pad
+	  display-width
+	  display-height
+	  display-width-mm
+	  display-height-mm
+	  display-motion-buffer-size
+	  display-flush-output
+	  display-wait-output
+	  display-no-op
+	  no-op ;; compatibility with Elk, same as above
+	  display-list-depths
+	  list-depths ;; compatibility with Elk, same as above
+	  display-list-pixmap-formats
+	  list-pixmap-formats ;; compatibility with Elk, same as above
+	  synchronize
+
+	  ))
+
+(define-structure xlib-display xlib-display-interface
+  (open scsh
+	scheme
+	define-record-types
+	weak
+	general-tables
+;	xlib-window
+	primitives)
+  (files "display.scm"))
+
+;;; ...
\ No newline at end of file