Made multi threading work on recent versions of SBCL

[clg] / gdk / gdk.lisp

diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp
index d3cdc721b766efeec36711db298f90e64f6d0caf..d44cbfd8d23962c774ec7ee808cc7b4bf2a8d05e 100644 (file)
--- 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.42 2007-06-20 10:16:19 espen Exp $
+;; $Id: gdk.lisp,v 1.48 2008-01-02 15:26:46 espen Exp $
 
 
 (in-package "GDK")
@@ -851,7 +851,7 @@ (defbinding %pixmap-new () pointer
   (depth int))
 
 (defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
-  (%pixmap-new window width height depth))
+  (%pixmap-new window (or width (drawable-width window)) (or height (drawable-height window)) (or depth -1)))
 
 (defun pixmap-new (width height depth &key window)
   (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
@@ -999,22 +999,20 @@ (defbinding draw-arc () nil
 
 (defbinding %draw-layout () nil
   (drawable drawable) (gc gc) 
-  (font pango:font)
   (x int) (y int)
   (layout pango:layout))
 
 (defbinding %draw-layout-with-colors () nil
   (drawable drawable) (gc gc) 
-  (font pango:font)
   (x int) (y int)
   (layout pango:layout)
   (foreground (or null color))
   (background (or null color)))
 
-(defun draw-layout (drawable gc font x y layout &optional foreground background)
+(defun draw-layout (drawable gc x y layout &optional foreground background)
   (if (or foreground background)
-      (%draw-layout-with-colors drawable gc font x y layout foreground background)
-    (%draw-layout drawable gc font x y layout)))
+      (%draw-layout-with-colors drawable gc x y layout foreground background)
+    (%draw-layout drawable gc x y layout)))
 
 (defbinding draw-drawable 
     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
@@ -1049,7 +1047,7 @@ (defbinding drawable-copy-to-image
 
 ;;; Key values
 
-(defbinding keyval-name () string
+(defbinding keyval-name () (static string)
   (keyval unsigned-int))
 
 (defbinding %keyval-from-name () unsigned-int
@@ -1073,6 +1071,7 @@ (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
   (keyval unsigned-int))
 
+
 ;;; Cairo interaction
 
 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
@@ -1090,19 +1089,25 @@   (defbinding cairo-set-source-color () nil
     (cr cairo:context)
     (color color))
 
-  (defbinding cairo-set-source-pixbuf () nil
+  (defbinding cairo-set-source-pixbuf (cr pixbuf &optional (x 0.0) (y 0.0)) nil
     (cr cairo:context)
     (pixbuf pixbuf)
     (x double-float)
     (y double-float))
  
+  (defbinding cairo-set-source-pixmap (cr pixmap &optional (x 0.0) (y 0.0)) nil
+    (cr cairo:context)
+    (pixmap pixmap)
+    (x double-float)
+    (y double-float))
+ 
   (defbinding cairo-rectangle () nil
     (cr cairo:context)
     (rectangle rectangle))
  
-;;   (defbinding cairo-region () nil
-;;     (cr cairo:context)
-;;     (region region))
+  (defbinding cairo-region (cr region) nil
+    (cr cairo:context)
+    ((ensure-region region) region))
 
   (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window
     (surface cairo:surface))
@@ -1115,25 +1120,26 @@   (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () w
 #+sb-thread
 (progn
   (defvar *global-lock* nil)
+  (defvar *recursion-count* 0)
 
   (defun %global-lock-p ()
-    (eq (car (sb-thread:mutex-value *global-lock*)) sb-thread:*current-thread*))
+    (eq (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)))))
+         (incf *recursion-count*)
+        (sb-thread:get-mutex *global-lock*))))
     
   (defun threads-leave (&optional flush-p)
     (when *global-lock*
       (assert (%global-lock-p))
       (cond
-       ((zerop (cdr (sb-thread:mutex-value *global-lock*)))
+       ((zerop *recursion-count*)
        (when flush-p
          (flush))
        (sb-thread:release-mutex *global-lock*))
-       (t (decf (cdr (sb-thread:mutex-value *global-lock*)))))))
+       (t (decf *recursion-count*)))))
 
   (define-callback %enter-fn nil ()
     (threads-enter))
@@ -1141,13 +1147,13 @@   (define-callback %enter-fn nil ()
   (define-callback %leave-fn nil ()
     (threads-leave))
   
-  (defbinding %threads-set-lock-functions (&optional) nil
+  (defbinding %threads-set-lock-functions (nil) 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")))
+    (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
+    (%threads-set-lock-functions))
 
   (defmacro with-global-lock (&body body)
     `(progn
@@ -1177,7 +1183,7 @@   (defmacro with-global-lock (&body 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+))
+  (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
     (idle-add function priority)))