X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/b77536094bb40f40245c30ddff7e65ce0a581d2a..8bdd4dc621033ad58371ebd623f7efb1f963ad2f:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index b00c1ab..f193114 100644 --- a/gtk/gtk.lisp +++ b/gtk/gtk.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: gtk.lisp,v 1.93 2008-04-14 19:10:41 espen Exp $ +;; $Id: gtk.lisp,v 1.98 2008-11-25 22:11:08 espen Exp $ (in-package "GTK") @@ -110,19 +110,21 @@ (defun %init-async-event-handling (display) (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) style))) (error "When running clg in Slime, the communication style ~S must be used in combination with asynchronous event handling on this platform. See the README file and for more information." style))) + #+(or cmu sbcl) + (signal-connect (gdk:display-manager) 'display-opened + #'(lambda (display) + (let ((fd (gdk:display-connection-number display))) + (unless (< fd 0) + (let ((handler (add-fd-handler + (gdk:display-connection-number display) + :input #'main-iterate-all))) + (signal-connect display 'closed + #'(lambda (is-error-p) + (declare (ignore is-error-p)) + (remove-fd-handler handler)))))))) + #?(or (featurep :cmu) (sbcl< 1 0 6) (sbcl>= 1 0 15 6)) (progn - (signal-connect (gdk:display-manager) 'display-opened - #'(lambda (display) - (let ((fd (gdk:display-connection-number display))) - (unless (< fd 0) - (let ((handler (add-fd-handler - (gdk:display-connection-number display) - :input #'main-iterate-all))) - (signal-connect display 'closed - #'(lambda (is-error-p) - (declare (ignore is-error-p)) - (remove-fd-handler handler)))))))) (setq *periodic-polling-function* #'main-iterate-all) #?(or (featurep :cmu) (sbcl< 1 0 6)) (multiple-value-setq (*max-event-to-sec* *max-event-to-usec*) @@ -130,30 +132,42 @@ (defun %init-async-event-handling (display) #?(sbcl>= 1 0 15 6) (setq *periodic-polling-period* *event-polling-interval*)) - #+(and clisp readline) - ;; Readline will call the event hook at most ten times per second - (setf readline:event-hook #'main-iterate-all) - #?(or (featurep :clisp) (and (sbcl>= 1 0 6) (sbcl< 1 0 15 6))) - ;; When running in Slime we need to hook into the Swank server - ;; to handle events asynchronously. - (unless (and - (find-package "SWANK") - (let ((connection (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK")))) - (when connection - (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))) - (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") connection))) - (multiple-value-bind (sec usec) - (decompose-time *event-polling-interval*) - (setf - (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")) - #'(lambda () - (loop - (case (socket-status (cons stream :input) sec usec) - ((:input :eof) (return (funcall read-from-emacs))) - (otherwise (main-iterate-all))))))))))) - #-(and clisp readline) - (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started.")) + ;; When running in CLISP or certain versions of SBCL in Slime we need + ;; to hook into the Swank server to handle events asynchronously. + (cond + ((and (find-package "SWANK") (find-symbol "CHECK-SLIME-INTERRUPTS" "SWANK")) + (let ((check-slime-interrupts + (symbol-function (find-symbol "CHECK-SLIME-INTERRUPTS" "SWANK")))) + (setf + (symbol-function (find-symbol "CHECK-SLIME-INTERRUPTS" "SWANK")) + #'(lambda () + (main-iterate-all) + (funcall check-slime-interrupts))))) + ((and (find-package "SWANK") + (find-symbol "READ-FROM-EMACS" "SWANK") + (find-symbol "*EMACS-CONNECTION*" "SWANK") + (find-symbol "CONNECTION.SOCKET-IO" "SWANK")) + (let ((connection (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK")))) + (when connection + (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))) + (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") connection))) + (multiple-value-bind (sec usec) + (decompose-time *event-polling-interval*) + (setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")) + #'(lambda () + (loop + (case (socket-status (cons stream :input) sec usec) + ((:input :eof) (return (funcall read-from-emacs))) + (otherwise (main-iterate-all))))))))))) + ((flet ((warn-main-loop () + (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started."))) + #+(and clisp readline) + (if (find-package "SWANK") + (warn-main-loop) ; assuming we're running in SLIME + ;; Readline will call the event hook at most ten times per second + (setf readline:event-hook #'main-iterate-all)) + #-(and clisp readline)(warn-main-loop)))) (gdk:display-open display)) @@ -602,8 +616,8 @@ (defun (setf bin-child) (child bin) (defmethod compute-signal-function ((bin bin) signal function object args) (declare (ignore signal)) (if (eq object :child) - #'(lambda (&rest emission-args) - (apply function (bin-child bin) (nconc (rest emission-args) args))) + #'(lambda (bin &rest emission-args) + (apply function (bin-child bin) (nconc emission-args args))) (call-next-method))) @@ -774,7 +788,7 @@ (defbinding combo-box-prepend-text () nil (text string)) #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") -(defbinding combo-box-get-active-text () string +(defbinding combo-box-get-active-text () (or null string) (combo-box combo-box)) (defbinding combo-box-popup () nil @@ -851,15 +865,17 @@ (defmethod compute-signal-function ((dialog dialog) signal function object args) (funcall callback dialog (dialog-find-response dialog response)))) (callback)))) -(defbinding dialog-run () nil +(defbinding %dialog-run () int (dialog dialog)) +(defun dialog-run (dialog) + (dialog-find-response dialog (%dialog-run dialog))) (defbinding dialog-response (dialog response) nil (dialog dialog) ((dialog-response-id dialog response nil t) int)) -(defbinding %dialog-add-button () button +(defbinding %dialog-add-button () bin (dialog dialog) (text string) (response-id int)) @@ -2531,36 +2547,40 @@ (defbinding (stock-set-translate-function "gtk_stock_set_translate_func") ;;; Tooltip -;; #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0") -;; (progn -;; (defbinding %tooltip-set-markup () nil -;; tooltip -;; (markup string)) - -;; (defbinding %tooltip-set-text () nil -;; tooltip -;; (text string)) - -;; (defbinding %tooltip-set-icon () nil -;; tooltip -;; (icon gdk:pixbuf)) - -;; (defbinding %tooltip-set-from-stock-icon () nil -;; tooltip -;; (stock-id string) -;; icon-size) - -;; (defbinding %tooltip-set-custom () nil -;; tooltip -;; widget) - -;; (defun tooltip-set (tooltip value &key (markup t) (icon-size :button)) -;; (etypecase value -;; (string (if markup -;; (tooltip-set-markup tooltip value) -;; (tooltip-set-text tooltip value))) -;; (pixbuf (tooltip-set-icon tooltip value)) -;; (keyword (tooltip-set-icon-from-stock tooltip value icon-size)) +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0") +(progn + (defbinding tooltip-set-markup () nil + tooltip + (markup string)) + + (defbinding tooltip-set-text () nil + tooltip + (text string)) + + (defbinding %tooltip-set-icon () nil + tooltip + (icon gdk:pixbuf)) + + (defbinding %tooltip-set-icon-from-stock () nil + tooltip + (stock-id string) + icon-size) + + (defun tooltip-set-icon (tooltip icon &key (size :button)) + (etypecase icon + (gdk:pixbuf (%tooltip-set-icon tooltip icon)) + (string (%tooltip-set-icon-from-stock tooltip icon size)))) + + (defbinding tooltip-set-custom () nil + tooltip + widget) + + (defbinding tooltip-trigger-tooltip-query (&optional (display (gdk:display-get-default))) nil + (display gdk:display)) + + (defbinding tooltip-set-tip-area () nil + tooltip + gdk:rectangle))