;; 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.33 2007-01-14 23:24:11 espen Exp $
+;; $Id: gdk.lisp,v 1.50 2008-04-21 16:21:07 espen Exp $
(in-package "GDK")
;;; Display
-(defbinding %display-open () display
+#-debug-ref-counting
+(defmethod print-object ((display display) stream)
+ (if (and (proxy-valid-p display) (slot-boundp display 'name))
+ (print-unreadable-object (display stream :type t :identity nil)
+ (format stream "~S at 0x~X"
+ (display-name display) (pointer-address (foreign-location display))))
+ (call-next-method)))
+
+(defbinding %display-open () (or null display)
(display-name (or null string)))
-(defun display-open (&optional display-name)
- (let ((display (%display-open display-name)))
+(defvar *display-aliases* ())
+
+(defun display-add-alias (display alias)
+ (unless (rassoc display *display-aliases*)
+ (signal-connect display 'closed
+ #'(lambda (is-error-p)
+ (declare (ignore is-error-p))
+ (setq *display-aliases*
+ (delete-if #'(lambda (mapping)
+ (eq (cdr mapping) display))
+ *display-aliases*))))
+ (push (cons alias display) *display-aliases*)))
+
+
+(defun display-open (&optional name)
+ (let ((display (or
+ (%display-open name)
+ (error "Opening display failed: ~A" name))))
(unless (display-get-default)
(display-set-default display))
+ (when (and (stringp name) (not (string= name (display-name display))))
+ (display-add-alias display name))
display))
(defbinding %display-get-n-screens () int
(display display))
(defbinding display-close (&optional (display (display-get-default))) nil
- (display display))
+ ((ensure-display display t) display))
+
+(defbinding flush () nil)
(defbinding display-get-event
- (&optional (display (display-get-default))) event
+ (&optional (display (display-get-default))) (or null event)
(display display))
(defbinding display-peek-event
- (&optional (display (display-get-default))) event
+ (&optional (display (display-get-default))) (or null event)
(display display))
(defbinding display-put-event
(&optional (display (display-get-default))) int
(display display))
+(defun find-display (name &optional (error-p t))
+ (or
+ (find name (list-displays) :key #'display-name :test #'string=)
+ (cdr (assoc name *display-aliases* :test #'string=))
+ (when error-p
+ (error "No such display: ~A" name))))
+
+;; This will not detect connections to the same server that use
+;; different hostnames
+(defun %find-similar-display (display)
+ (find (display-name display) (delete display (list-displays))
+ :key #'display-name :test #'string=))
+
+(defun ensure-display (display &optional existing-only-p)
+ (etypecase display
+ (null (display-get-default))
+ (display display)
+ (string (or
+ (find-display display existing-only-p)
+ (let* ((new (display-open display))
+ (existing (%find-similar-display new)))
+ (if existing
+ (progn
+ (display-add-alias existing display)
+ (display-close new)
+ existing)
+ new))))))
;;; Display manager
-(defbinding display-get-default () display)
-
-(defbinding (display-manager "gdk_display_manager_get") () display-manager)
+(defbinding display-get-default () (or null display))
(defbinding (display-set-default "gdk_display_manager_set_default_display")
(display) nil
((display-manager) display-manager)
(display display))
+(defbinding (list-displays "gdk_display_manager_list_displays") ()
+ (gslist (static display))
+ ((display-manager) display-manager))
+
+;; The only purpose of exporting this is to make it possible for
+;; applications to connect to the display-opened signal
+(defbinding (display-manager "gdk_display_manager_get") () display-manager)
+
+(defbinding display-get-core-pointer
+ (&optional (display (display-get-default))) device
+ (display display))
+
+(defmacro with-default-display ((display) &body body)
+ (let ((saved-display (make-symbol "SAVED-DISPLAY"))
+ (current-display (make-symbol "CURRENT-DISPLAY")))
+ `(let* ((,current-display ,display)
+ (,saved-display (when ,current-display
+ (prog1
+ (display-get-default)
+ (display-set-default (ensure-display ,current-display))))))
+ (unwind-protect
+ (progn ,@body)
+ (when ,saved-display
+ (display-set-default ,saved-display))))))
+
;;; Primitive graphics structures (points, rectangles and regions)
(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))
(defbinding (events-pending-p "gdk_events_pending") () boolean)
-(defbinding event-get () event)
+(defbinding event-get () (or null event))
-(defbinding event-peek () event)
+(defbinding event-peek () (or null event))
(defbinding event-get-graphics-expose () event
(window window))
-(defbinding event-put () event
+(defbinding event-put () nil
(event event))
;(defbinding event-handler-set () ...)
(defbinding window-destroy () nil
(window window))
-(defbinding window-at-pointer () window
+(defbinding (window-at-pointer "gdk_display_get_window_at_pointer")
+ (&optional (display (display-get-default))) (or null window)
+ display
(x int :out)
(y int :out))
(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))
(x int :out)
(y int :out))
-(defbinding window-get-pointer () window
+(defbinding window-get-pointer () (or null window)
(window window)
(x int :out)
(y int :out)
(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")
(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
;;; Key values
-(defbinding keyval-name () string
+(defbinding keyval-name () (static string)
(keyval unsigned-int))
(defbinding %keyval-from-name () unsigned-int
(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")
(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))
)
;;; 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)
+ (defvar *recursion-count* 0)
+
+ (defun %global-lock-p ()
+ (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*))
+
+ (defun threads-enter ()
+ (when *global-lock*
+ (if (%global-lock-p)
+ (incf *recursion-count*)
+ (sb-thread:get-mutex *global-lock*))))
+
+ (defun threads-leave (&optional flush-p)
+ (when *global-lock*
+ (assert (%global-lock-p))
(cond
- ((zerop recursive-level)
+ ((zerop *recursion-count*)
(when flush-p
- (display-flush))
+ (flush))
(sb-thread:release-mutex *global-lock*))
- (t (decf recursive-level)))))
+ (t (decf *recursion-count*)))))
(define-callback %enter-fn nil ()
(threads-enter))
(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 ()
+ (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
+ (%threads-set-lock-functions))
+
(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 (function &optional (priority +priority-default-idle+))
+ (idle-add function priority)))
+
+
~mdw / clg / blobdiff