X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e4143920ea3bffef43cd27f671a1f498107d758a..73b0140015fced01ece088f4419b6fa7dbd45052:/gdk/gdk.lisp diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index 7a5f641..fa5932e 100644 --- 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.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") @@ -47,12 +47,28 @@ (defmethod print-object ((display display) stream) (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 @@ -81,7 +97,9 @@ (defbinding display-flush (&optional (display (display-get-default))) nil (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 @@ -100,17 +118,33 @@ (defbinding (display-connection-number "clg_gdk_connection_number") (&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 @@ -134,6 +168,19 @@ (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) @@ -1057,31 +1104,36 @@ (defbinding cairo-rectangle () nil ;; (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)) @@ -1089,13 +1141,43 @@ (define-callback %enter-fn nil () (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))) + +