;; 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.37 2007-05-10 16:58:45 espen Exp $
+;; $Id: gdk.lisp,v 1.43 2007-06-25 21:28:54 espen Exp $
(in-package "GDK")
(defbinding %display-open () display
(display-name (or null string)))
-(defun display-open (&optional 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 display-name)
- (error "Opening display failed: ~A" display-name))))
+ (%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))) int
(display display))
-(defun find-display (name)
- (find name (list-displays) :key #'display-name :test #'string=))
+(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))))
-(defun ensure-display (display)
+;; 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 (list-displays) :key #'display-name :test #'string=)
- (display-open 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
(&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)
;; (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))
(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 (function &optional (priority +priority-default-idle+))
+ (idle-add function priority)))
+
+
~mdw / clg / blobdiff