X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e99a089d8043b561235529dbc613fac386bd9bf4..73b0140015fced01ece088f4419b6fa7dbd45052:/gdk/gdk.lisp diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index 18ef429..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.39 2007-06-18 12:23:05 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,7 @@ (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) @@ -102,16 +118,33 @@ (defbinding (display-connection-number "clg_gdk_connection_number") (&optional (display (display-get-default))) int (display display)) -(defun find-display (name) - (if (not name) - (display-get-default) - (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 display) (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 @@ -135,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) @@ -1068,24 +1114,26 @@ (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () w #+sb-thread (progn - (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock")) + (defvar *global-lock* nil) (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)))) + (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) - (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*)))))) + (when *global-lock* + (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)) @@ -1093,10 +1141,14 @@ (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) @@ -1110,7 +1162,7 @@ (defun timeout-add-with-lock (interval function &optional (priority +priority- (with-global-lock (funcall 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 #'(lambda () (with-global-lock (funcall function))) @@ -1125,7 +1177,7 @@ (defmacro with-global-lock (&body 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+)) + (defun idle-add-with-lock (function &optional (priority +priority-default-idle+)) (idle-add function priority)))