X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/aadaf8fb0d034374e4d4ad253bc37608c13c96e3..7c14f6abb37972445ffc0be122d743da59ea9063:/gdk/gdk.lisp

diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp
index 5e18e2e..49f26fb 100644
--- a/gdk/gdk.lisp
+++ b/gdk/gdk.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: gdk.lisp,v 1.35 2007-04-06 14:25:20 espen Exp $
+;; $Id: gdk.lisp,v 1.41 2007-06-18 14:27:02 espen Exp $
 
 
 (in-package "GDK")
@@ -83,6 +83,8 @@ (defbinding display-flush (&optional (display (display-get-default))) nil
 (defbinding display-close (&optional (display (display-get-default))) nil
   (display display))
 
+(defbinding flush () nil)
+
 (defbinding display-get-event
     (&optional (display (display-get-default))) event
   (display display))
@@ -101,16 +103,15 @@ (defbinding (display-connection-number "clg_gdk_connection_number")
   (display display))
 
 (defun find-display (name)
-  (find name (list-displays) :key #'display-name :test #'string=))
+  (if (not name)
+      (display-get-default)
+    (find name (list-displays) :key #'display-name :test #'string=)))
 
 (defun ensure-display (display)
   (etypecase display
     (null (display-get-default))
     (display display)
-    (string 
-     (or
-      (find display (list-displays) :key #'display-name :test #'string=)
-      (display-open display)))))
+    (string (or (find-display display) (display-open display)))))
 
 
 ;;; Display manager
@@ -178,7 +179,6 @@ (defbinding %region-destroy () nil
   (location pointer))
 
 (defmethod allocate-foreign ((region region) &key rectangle polygon fill-rule)
-  (declare (ignore initargs))
   (cond
    ((and rectangle polygon) 
     (error "Only one of the keyword arguments :RECTANGLE and :POLYGON can be specified"))
@@ -190,7 +190,9 @@ (defun ensure-region (region)
   (etypecase region 
     (region region)
     ((or rectangle vector) 
-     (make-instance 'region :rectangle (ensure-rectangle region)))))
+     (make-instance 'region :rectangle (ensure-rectangle region)))
+    (list
+     (make-instance 'region :polygon region))))
 
 (defbinding region-get-clipbox (region &optional (rectangle (make-instance 'rectangle))) nil
   (region region)
@@ -205,7 +207,7 @@ (defun region-get-rectangles (region)
   "Obtains the area covered by the region as a list of rectangles."
   (multiple-value-bind (location length) (%region-get-rectangles region)
     (prog1
-	(map-c-vector 'list #'identity location 'point length :get)
+	(map-c-vector 'list #'identity location '(inlined rectangle) length :get)
       (deallocate-memory location))))
 
 (defbinding region-empty-p () boolean
@@ -235,19 +237,19 @@ (defbinding region-shrink () nil
   (dy int))
 
 (defbinding region-intersect (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 (defbinding region-union (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 (defbinding region-subtract (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 (defbinding region-xor (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 
@@ -443,6 +445,13 @@ (defbinding window-scroll () nil
   (dx int)
   (dy int))
 
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
+(defbinding window-move-region (window region dx dy) nil
+  (window window)
+  ((ensure-region region) region)
+  (dx int)
+  (dy int))
+
 (defbinding window-reparent () nil
   (window window)
   (new-parent window)
@@ -577,9 +586,9 @@ (defbinding %window-shape-combine-region () nil
 
 (defun window-shape-combine (window shape offset-x offset-y)
   (etypecase shape
-    (nil (%window-shape-combine-region window nil 0 0)
+    (null (%window-shape-combine-region window nil 0 0))
     (region (%window-shape-combine-region window shape offset-x offset-y))
-    (bitmask (window-shape-combine-mask window shape offset-x offset-y)))))
+    (bitmap (window-shape-combine-mask window shape offset-x offset-y))))
 
 (defbinding window-set-child-shapes () nil
   (window window))
@@ -603,9 +612,9 @@   (defbinding %window-input-shape-combine-region () nil
   
   (defun window-input-shape-combine (window shape x y)
     (etypecase shape
-      (nil (%window-input-shape-combine-region window nil 0 0)
-	   (region (%window-input-shape-combine-region window shape x y))
-	   (bitmask (%window-input-shape-combine-mask window shape x y)))))
+      (null (%window-input-shape-combine-region window nil 0 0))
+      (region (%window-input-shape-combine-region window shape x y))
+      (bitmap (%window-input-shape-combine-mask window shape x y))))
 
   (defbinding window-set-child-input-shapes () nil
     (window window))
@@ -1049,31 +1058,36 @@   (defbinding cairo-rectangle () nil
 ;;     (cr cairo:context)
 ;;     (region region))
 
-  (defbinding (cairo-xlib-surface-get-window 
-	       "clg_gdk_cairo_xlib_surface_get_window") () window
-  (surface cairo:xlib-surface))
+  (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window
+    (surface cairo:surface))
 )
 
 
 
 ;;; Multi-threading support
 
-#+sbcl
+#+sb-thread
 (progn
-  (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
-  (let ((recursive-level 0))
-    (defun threads-enter ()
-      (if (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)
-	  (incf recursive-level)
- 	(sb-thread:get-mutex *global-lock*)))
-
-    (defun threads-leave (&optional flush-p)
+  (defvar *global-lock* nil)
+
+  (defun %global-lock-p ()
+    (eq (car (sb-thread:mutex-value *global-lock*)) sb-thread:*current-thread*))
+
+  (defun threads-enter ()
+    (when *global-lock*
+      (if (%global-lock-p)
+	  (incf (cdr (sb-thread:mutex-value *global-lock*)))
+	(sb-thread:get-mutex *global-lock* (cons sb-thread:*current-thread* 0)))))
+    
+  (defun threads-leave (&optional flush-p)
+    (when *global-lock*
+      (assert (%global-lock-p))
       (cond
-       ((zerop recursive-level)	  
+       ((zerop (cdr (sb-thread:mutex-value *global-lock*)))
 	(when flush-p
-	  (display-flush))
+	  (flush))
 	(sb-thread:release-mutex *global-lock*))
-       (t (decf recursive-level)))))
+       (t (decf (cdr (sb-thread:mutex-value *global-lock*)))))))
 
   (define-callback %enter-fn nil ()
     (threads-enter))
@@ -1081,13 +1095,43 @@   (define-callback %enter-fn nil ()
   (define-callback %leave-fn nil ()
     (threads-leave))
   
-  (defbinding threads-set-lock-functions (&optional) nil
+  (defbinding %threads-set-lock-functions (&optional) nil
     (%enter-fn callback)
     (%leave-fn callback))
 
+  (defun threads-init ()
+    (%threads-set-lock-functions)
+    (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock")))
+
   (defmacro with-global-lock (&body body)
     `(progn
        (threads-enter)
        (unwind-protect
-	   ,@body
-	 (threads-leave t)))))
+	   (progn ,@body)
+	 (threads-leave t))))
+
+  (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
+    (timeout-add interval
+     #'(lambda () 
+	 (with-global-lock (funcall function)))
+     priority))
+
+  (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
+    (idle-add 
+     #'(lambda () 
+	 (with-global-lock (funcall function)))
+     priority)))
+
+
+#-sb-thread
+(progn
+  (defmacro with-global-lock (&body body)
+    `(progn ,@body))
+
+  (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
+    (timeout-add interval function priority))
+
+  (defun idle-add-with-lock (funcation &optional (priority +priority-default-idle+))
+    (idle-add function priority)))
+
+