From a1501802f02d0a3b4b1c60153567274dff4fe4d2 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Mon, 9 Jul 2001 13:45:36 +0000
Subject: [PATCH] moved out of subdirecotry; some changes.

---
 scheme/xlib/color-type.scm    | 71 +++++++++++++++++++++++++++++++++
 scheme/xlib/colormap-type.scm | 63 +++++++++++++++++++++++++++++
 scheme/xlib/display-type.scm  | 74 +++++++++++++++++++++++++++++++++++
 scheme/xlib/drawable-type.scm | 15 +++++++
 scheme/xlib/event-type.scm    |  8 ++++
 scheme/xlib/gcontext-type.scm | 63 +++++++++++++++++++++++++++++
 scheme/xlib/pixel-type.scm    | 41 +++++++++++++++++++
 scheme/xlib/pixmap-type.scm   | 64 ++++++++++++++++++++++++++++++
 scheme/xlib/window-type.scm   | 67 +++++++++++++++++++++++++++++++
 9 files changed, 466 insertions(+)
 create mode 100644 scheme/xlib/color-type.scm
 create mode 100644 scheme/xlib/colormap-type.scm
 create mode 100644 scheme/xlib/display-type.scm
 create mode 100644 scheme/xlib/drawable-type.scm
 create mode 100644 scheme/xlib/event-type.scm
 create mode 100644 scheme/xlib/gcontext-type.scm
 create mode 100644 scheme/xlib/pixel-type.scm
 create mode 100644 scheme/xlib/pixmap-type.scm
 create mode 100644 scheme/xlib/window-type.scm

diff --git a/scheme/xlib/color-type.scm b/scheme/xlib/color-type.scm
new file mode 100644
index 0000000..ea7dea0
--- /dev/null
+++ b/scheme/xlib/color-type.scm
@@ -0,0 +1,71 @@
+;; 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 (create-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")
+
+;; returns a list of r,g,b as integers
+(define (extract-rgb-values color)
+  (%extract-rgb-values (color-Xcolor color)))
+
+(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))
diff --git a/scheme/xlib/colormap-type.scm b/scheme/xlib/colormap-type.scm
new file mode 100644
index 0000000..4075f4c
--- /dev/null
+++ b/scheme/xlib/colormap-type.scm
@@ -0,0 +1,63 @@
+;; the colormap-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type colormap :colormap
+  (really-make-colormap tag Xcolormap display) 
+  colormap? 
+  (tag colormap-tag colormap-set-tag!)
+  (Xcolormap real-colormap-Xcolormap colormap-set-Xcolormap!)
+  (display colormap-display colormap-set-display!))
+
+(define (colormap-Xcolormap colormap)
+  (if (none-resource? colormap)
+      none-resource
+      (real-colormap-Xcolormap colormap)))
+
+(define (make-colormap Xcolormap display)
+  (if (none-resource? Xcolormap)
+      'none
+      (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)))))
+
+;; 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-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))
+
diff --git a/scheme/xlib/display-type.scm b/scheme/xlib/display-type.scm
new file mode 100644
index 0000000..d99d969
--- /dev/null
+++ b/scheme/xlib/display-type.scm
@@ -0,0 +1,74 @@
+;; 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))))
+
+;; 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))
+
+;; The message port is used to efficiently check for pending messages, which
+;; are then read normally with XNextEvent.
+
+(define message-port #f)
+
+(define (display-message-inport display)
+  (if message-port
+      message-port
+      (let* ((fd (%display-message-fd (display-Xdisplay display)))
+	     (p	(fdes->inport fd)))
+	(set! message-port p)
+	p)))
+
+(import-lambda-definition %display-message-fd (Xdisplay)
+  "Display_Message_fd")
\ No newline at end of file
diff --git a/scheme/xlib/drawable-type.scm b/scheme/xlib/drawable-type.scm
new file mode 100644
index 0000000..76f395c
--- /dev/null
+++ b/scheme/xlib/drawable-type.scm
@@ -0,0 +1,15 @@
+;; abstractions for a "drawable" which is a window or a pixmap.
+
+(define (drawable? object)
+  (or (window? object)
+      (pixmap? object)))
+
+(define (drawable-abstraction pixmap-fun window-fun)
+  (lambda (drawable)
+    (cond
+     ((pixmap? drawable) (pixmap-fun drawable))
+     ((window? drawable) (window-fun drawable))
+     (else (error "expected a drawable object" drawable)))))
+
+(define drawable-display (drawable-abstraction pixmap-display window-display))
+(define drawable-Xobject (drawable-abstraction pixmap-Xpixmap window-Xwindow))
\ No newline at end of file
diff --git a/scheme/xlib/event-type.scm b/scheme/xlib/event-type.scm
new file mode 100644
index 0000000..484f329
--- /dev/null
+++ b/scheme/xlib/event-type.scm
@@ -0,0 +1,8 @@
+(define-record-type event-type :event
+  (make-event type args)
+  event?
+  (type event-type event-set-type!) ;a symbol
+  (args event-args event-set-args!)) ;a vector
+
+
+	 
diff --git a/scheme/xlib/gcontext-type.scm b/scheme/xlib/gcontext-type.scm
new file mode 100644
index 0000000..a1c2d74
--- /dev/null
+++ b/scheme/xlib/gcontext-type.scm
@@ -0,0 +1,63 @@
+(define-record-type gcontext :gcontext
+  (really-make-gcontext tag Xgcontext display) 
+  gcontext?
+  (tag gcontext-tag gcontext-set-tag!)
+  (Xgcontext real-gcontext-Xgcontext gcontext-set-Xgcontext!)
+  (display gcontext-display gcontext-set-display!))
+
+(define (gcontext-Xgcontext gcontext)
+  (if (none-resource? gcontext)
+      0
+      (real-gcontext-Xgcontext gcontext)))
+
+(define (make-gcontext Xgcontext display)
+  (if (= 0 Xgcontext)
+      none-resource
+      (let ((maybe-gcontext (gcontext-list-find Xgcontext)))
+	(if maybe-gcontext
+	    maybe-gcontext
+	    (let ((gcontext (really-make-gcontext #f Xgcontext display)))
+	      (add-finalizer! gcontext finalize-gcontext)
+	      (gcontext-list-set! Xgcontext gcontext)
+	      gcontext)))))
+
+;; finalize-gcontext is called, when the garbage collector removes the last
+;; reference to the gcontext from the heap. Then we can savely close the 
+;; gcontext and remove the weak-pointer from our list.
+
+(define (finalize-gcontext gcontext)
+  (let ((Xgcontext (gcontext-Xgcontext gcontext)))
+    (gcontext-set-Xgcontext! gcontext 'already-freed)
+    (gcontext-list-delete! Xgcontext)))
+
+;; to free the gcontext X-lib ressources call free-gcontext. if gcontext is 
+;; already freed, the function does nothing.
+
+(define (free-gcontext gcontext)
+  (let ((Xgcontext (gcontext-Xgcontext gcontext)))
+    (if (integer? Xgcontext)
+	(begin
+	  (%free-gcontext Xgcontext 
+			  (display-Xdisplay (gcontext-display gcontext)))
+	  (gcontext-set-Xgcontext! gcontext 'already-freed)))))
+
+(import-lambda-definition %free-gcontext (Xgcontext Xdisplay)
+  "Free_Gc")
+
+;; All gcontext records need to be saved in a weak-list, to have only one record
+;; for the same XLib gcontext
+
+(define *weak-gcontext-list* (make-integer-table))
+
+(define (gcontext-list-find Xgcontext)
+  (let ((r (table-ref *weak-gcontext-list* Xgcontext)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (gcontext-list-set! Xgcontext gcontext)
+  (let ((p (make-weak-pointer gcontext)))
+    (table-set! *weak-gcontext-list* Xgcontext p)))
+
+(define (gcontext-list-delete! Xgcontext)
+  (table-set! *weak-gcontext-list* Xgcontext #f))
\ No newline at end of file
diff --git a/scheme/xlib/pixel-type.scm b/scheme/xlib/pixel-type.scm
new file mode 100644
index 0000000..abf74cd
--- /dev/null
+++ b/scheme/xlib/pixel-type.scm
@@ -0,0 +1,41 @@
+(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)
+  (let ((maybe-pixel (pixel-list-find Xpixel)))
+    (if maybe-pixel
+	maybe-pixel
+	(let ((pixel (really-make-pixel #f Xpixel)))
+	  (add-finalizer! pixel finalize-pixel)
+	  (pixel-list-set! Xpixel pixel)
+	  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))
\ No newline at end of file
diff --git a/scheme/xlib/pixmap-type.scm b/scheme/xlib/pixmap-type.scm
new file mode 100644
index 0000000..e5ebcf2
--- /dev/null
+++ b/scheme/xlib/pixmap-type.scm
@@ -0,0 +1,64 @@
+;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type pixmap :pixmap
+  (really-make-pixmap tag Xpixmap display) 
+  pixmap? 
+  (tag pixmap-tag pixmap-set-tag!)
+  (Xpixmap real-pixmap-Xpixmap pixmap-set-Xpixmap!)
+  (display pixmap-display pixmap-set-display!))
+
+(define (pixmap-Xpixmap pixmap)
+  (if (none-resource? pixmap)
+      0
+      (real-pixmap-Xpixmap pixmap)))
+
+(define (make-pixmap Xpixmap display)
+  (if (= 0 Xpixmap)
+      none-resource
+      (let ((maybe-pixmap (pixmap-list-find Xpixmap)))
+	(if maybe-pixmap
+	    maybe-pixmap
+	    (let ((pixmap (really-make-pixmap #f Xpixmap display)))
+	      (add-finalizer! pixmap finalize-pixmap)
+	      (pixmap-list-set! Xpixmap pixmap)
+	      pixmap)))))
+
+;; finalize-pixmap is called, when the garbage collector removes the last
+;; reference to the pixmap from the heap. Then we can savely close the pixmap
+;; and remove the weak-pointer from our list.
+
+(define (finalize-pixmap pixmap)
+  (let ((Xpixmap (pixmap-Xpixmap pixmap)))
+    (free-pixmap pixmap)
+    (pixmap-list-delete! Xpixmap)))
+
+;; ...
+
+(define (free-pixmap pixmap)
+  (let ((Xdisplay (display-Xdisplay (pixmap-display pixmap)))
+	(Xpixmap (pixmap-Xpixmap pixmap)))
+    (if (integer? Xpixmap)
+	(begin
+	  (%free-pixmap Xdisplay Xpixmap)
+	  (pixmap-set-Xpixmap! pixmap 'already-destroyed)))))
+
+(import-lambda-definition %free-pixmap (Xdisplay Xpixmap)
+  "Free_Pixmap")
+
+;; All pixmap records need to be saved in a weak-list, to have only one record
+;; for the same Xlib pixmap-structure in the heap.
+
+(define *weak-pixmap-list* (make-integer-table))
+
+(define (pixmap-list-find Xpixmap)
+  (let ((r (table-ref *weak-pixmap-list* Xpixmap)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (pixmap-list-set! Xpixmap pixmap)
+  (let ((p (make-weak-pointer pixmap)))
+    (table-set! *weak-pixmap-list* Xpixmap p)))
+
+(define (pixmap-list-delete! Xpixmap)
+  (table-set! *weak-pixmap-list* Xpixmap #f))
\ No newline at end of file
diff --git a/scheme/xlib/window-type.scm b/scheme/xlib/window-type.scm
new file mode 100644
index 0000000..6d1ec97
--- /dev/null
+++ b/scheme/xlib/window-type.scm
@@ -0,0 +1,67 @@
+;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type window :window
+  (really-make-window tag Xwindow display) 
+  window? 
+  (tag window-tag window-set-tag!)
+  (Xwindow real-window-Xwindow window-set-Xwindow!)
+  (display window-display window-set-display!))
+
+(define (window-Xwindow window)
+  (if (none-resource? window)
+      0
+      (real-window-Xwindow window)))
+
+(define (make-window Xwindow display)
+  (if (= 0 Xwindow)
+      none-resource
+      (let ((maybe-window (window-list-find Xwindow)))
+	(if maybe-window
+	    maybe-window
+	    (let ((window (really-make-window #f Xwindow display)))
+	      (add-finalizer! window finalize-window)
+	      (window-list-set! Xwindow window)
+	      window)))))
+
+
+
+;; 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))
+