Added function INPUT-ADD

[clg] / gdk / gdk.lisp

diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp
index 18ef42924362f40bb3a58bb18173a6ce849a8276..d3cdc721b766efeec36711db298f90e64f6d0caf 100644 (file)
--- 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.42 2007-06-20 10:16:19 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))))
+
+;; 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)
+(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)))