;; 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.34 2007-04-06 14:19:08 espen Exp $
+;; $Id: gdk.lisp,v 1.39 2007-06-18 12:23:05 espen Exp $
(in-package "GDK")
(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))
(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
(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"))
(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)
"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
(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))
(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)
(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))
(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))
;; (defbinding cairo-region () nil
;; (cr cairo:context)
;; (region region))
+
+ (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)
- (cond
- ((zerop recursive-level)
- (when flush-p
- (display-flush))
- (sb-thread:release-mutex *global-lock*))
- (t (decf recursive-level)))))
+
+ (defun %global-lock-p ()
+ (eq (car (sb-thread:mutex-value *global-lock*)) sb-thread:*current-thread*))
+
+ (defun threads-enter ()
+ (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)
+ (assert (%global-lock-p))
+ (cond
+ ((zerop (cdr (sb-thread:mutex-value *global-lock*)))
+ (when flush-p
+ (flush))
+ (sb-thread:release-mutex *global-lock*))
+ (t (decf (cdr (sb-thread:mutex-value *global-lock*))))))
(define-callback %enter-fn nil ()
(threads-enter))
`(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 (funcation &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)))
+
+
~mdw / clg / blobdiff