;; 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.50 2008-04-21 16:21:07 espen Exp $
(in-package "GDK")
(display-name display) (pointer-address (foreign-location display))))
(call-next-method)))
-(defbinding %display-open () display
+(defbinding %display-open () (or null display)
(display-name (or null string)))
(defvar *display-aliases* ())
(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
;;; Display manager
-(defbinding display-get-default () display)
+(defbinding display-get-default () (or null display))
(defbinding (display-set-default "gdk_display_manager_set_default_display")
(display) nil
(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))
(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))
#+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))
(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
(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)))
~mdw / clg / blobdiff