From 68ded3c4424d6c6bbfc3185d50cd0b96d86b7f48 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Mon, 30 Jul 2001 14:45:24 +0000
Subject: [PATCH] added support for the cursor functions.

---
 scheme/xlib/cursor-type.scm | 56 +++++++++++++++++++++++++++++++++++++
 scheme/xlib/cursor.scm      | 51 +++++++++++++++++++++++++++++++++
 2 files changed, 107 insertions(+)
 create mode 100644 scheme/xlib/cursor-type.scm
 create mode 100644 scheme/xlib/cursor.scm

diff --git a/scheme/xlib/cursor-type.scm b/scheme/xlib/cursor-type.scm
new file mode 100644
index 0000000..4369248
--- /dev/null
+++ b/scheme/xlib/cursor-type.scm
@@ -0,0 +1,56 @@
+(define-record-type cursor :cursor
+  (really-make-cursor tag Xcursor display) 
+  cursor? 
+  (tag cursor-tag cursor-set-tag!)
+  (Xcursor real-cursor-Xcursor cursor-set-Xcursor!)
+  (display cursor-display cursor-set-display!))
+
+(define (cursor-Xcursor cursor)
+  (if (none-resource? cursor)
+      0
+      (real-cursor-Xcursor cursor)))
+
+(define (make-cursor Xcursor display finalize?)
+  (if (= 0 Xcursor)
+      none-resource
+      (let ((maybe-cursor (cursor-list-find Xcursor)))
+	(if maybe-cursor
+	    maybe-cursor
+	    (let ((cursor (really-make-cursor #f Xcursor display)))
+	      (add-finalizer! cursor cursor-list-delete!)
+	      (if finalize?
+		  (add-finalizer! cursor free-cursor))
+	      (cursor-list-set! Xcursor cursor)
+	      cursor)))))
+
+;; ...
+
+(define (free-cursor cursor)
+  (let ((Xdisplay (display-Xdisplay (cursor-display cursor)))
+	(Xcursor (cursor-Xcursor cursor)))
+    (if (integer? Xcursor)
+	(begin
+	  (%free-cursor Xdisplay Xcursor)
+	  (cursor-set-Xcursor! cursor 'already-destroyed)))))
+
+(import-lambda-definition %free-cursor (Xdisplay Xcursor)
+  "Free_Cursor")
+
+;; All cursor records need to be saved in a weak-list, to have only one record
+;; for the same Xlib cursor-structure in the heap.
+
+(define *weak-cursor-list* (make-integer-table))
+
+(define (cursor-list-find Xcursor)
+  (let ((r (table-ref *weak-cursor-list* Xcursor)))
+    (if r 
+	(weak-pointer-ref r)
+	r)))
+
+(define (cursor-list-set! Xcursor cursor)
+  (let ((p (make-weak-pointer cursor)))
+    (table-set! *weak-cursor-list* Xcursor p)))
+
+(define (cursor-list-delete! cursor)
+  (table-set! *weak-cursor-list* 
+	      (cursor-Xcursor cursor) #f))
\ No newline at end of file
diff --git a/scheme/xlib/cursor.scm b/scheme/xlib/cursor.scm
new file mode 100644
index 0000000..25716b4
--- /dev/null
+++ b/scheme/xlib/cursor.scm
@@ -0,0 +1,51 @@
+(define (create-pixmap-cursor src mask x y foreground background)
+  (let ((display (pixmap-display src)))
+    (make-cursor (%create-pixmap-cursor (display-Xdisplay display)
+					(pixmap-Xpixmap src)
+					(pixmap-Xpixmap mask)
+					x y
+					(color-Xcolor foreground)
+					(color-Xcolor background))
+		 display
+		 #t)))
+
+(define create-cursor create-pixmap-cursor) ;; for compatibility with elk
+
+(import-lambda-definition %create-pixmap-cursor (Xdisplay src mask x y f b)
+  "scx_Create_Pixmap_Cursor")
+
+(define (create-glyph-cursor src src-char mask mask-char foreground background)
+  (let ((display (pixmap-display src)))
+    (make-cursor (%create-glyph-cursor (display-Xdisplay display)
+				       (pixmap-Xpixmap src)
+				       src-char
+				       (pixmap-Xpixmap mask)
+				       mask-char
+				       (color-Xcolor foreground)
+				       (color-Xcolor background))
+		 display
+		 #t)))
+
+(import-lambda-definition %create-glyph-cursor 
+			  (Xdisplay src srcc mask maskc f b)
+  "scx_Create_Glyph_Cursor")
+
+(define (create-font-cursor display src-char)
+  (let ((font (load-font display "cursor")))
+    (create-glyph-cursor font src-char
+			 font (+ 1 src-char)
+			 (make-color 0 0 0)
+			 (make-color 1 1 1))
+    ;; elk protects that with unwind-protect, and calls unload-font to free 
+    ;; the font, but we free it anyway on garbage-collection...(??)
+    ;;(unload-font font)
+    ))
+
+(define (recolor-cursor cursor foreground background)
+  (%recolor-cursor (display-Xdisplay (cursor-display cursor))
+		   (cursor-Xcursor cursor)
+		   foreground background))
+
+(import-lambda-definition %recolor-cursor (Xdisplay Xcursor f b)
+  "scx_Recolor_Cursor")
+