X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/7defde44ca5d1db8d76ccc73a6714e1c5ef85e1e..06364bdbf32faa557bc9bc85049dcc15a42a9383:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 0f2d37e..5d1e3cb 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.85 2007-11-01 15:05:00 espen Exp $ +;; $Id: gtk.lisp,v 1.92 2008-04-10 20:38:49 espen Exp $ (in-package "GTK") @@ -45,13 +45,17 @@ (defun gtk-version () (format nil "Gtk+ v~A.~A.~A" major minor micro)))) (defun clg-version () - "clg 0.93") + "clg 0.94") ;;;; Initalization and display handling -(defparameter *event-poll-interval* 10000) ; in microseconds +(defparameter *event-polling-interval* 0.01) +#?(or (featurep :clisp) (featurep :cmu) (and (sbcl>= 1 0 6) (sbcl< 1 0 15 6))) +(defun decompose-time (time) + (multiple-value-bind (sec subsec) (truncate *event-polling-interval*) + (values sec (truncate (* subsec 1e6))))) (defbinding (gtk-init "gtk_parse_args") () boolean "Initializes the library without opening the display." @@ -80,7 +84,7 @@ (defun clg-init-with-threading (&optional display) (clg-init display t)) -#?(sbcl>= 1 0 6) +#?(and (sbcl>= 1 0 6) (sbcl< 1 0 15 6)) ;; A very minimal implementation of CLISP's socket-status (defun socket-status (socket seconds microseconds) (sb-alien:with-alien ((read-fds (sb-alien:struct sb-unix:fd-set))) @@ -98,14 +102,15 @@ (defun socket-status (socket seconds microseconds) :eof)))))) (defun %init-async-event-handling (display) - (let ((style #?(or (featurep :cmu) (sbcl< 1 0 6)) :fd-handler - #?-(or (featurep :cmu) (sbcl< 1 0 6)) nil)) + (let ((style + #?(or (featurep :cmu) (sbcl< 1 0 6) (sbcl>= 1 0 15 6)) :fd-handler + #?-(or (featurep :cmu) (sbcl< 1 0 6) (sbcl>= 1 0 15 6)) nil)) (when (and (find-package "SWANK") (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) style))) - (error "When running clg in Slime, the communication style ~A must be used in combination with asynchronous event handling on this platform. See the README file and for more information." 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 (featurep :cmu) (sbcl< 1 0 6)) + #?(or (featurep :cmu) (sbcl< 1 0 6) (sbcl>= 1 0 15 6)) (progn (signal-connect (gdk:display-manager) 'display-opened #'(lambda (display) @@ -119,25 +124,34 @@ (defun %init-async-event-handling (display) (declare (ignore is-error-p)) (remove-fd-handler handler)))))))) (setq *periodic-polling-function* #'main-iterate-all) - (setq *max-event-to-sec* 0) - (setq *max-event-to-usec* *event-poll-interval*)) + #?(or (featurep :cmu) (sbcl< 1 0 6)) + (multiple-value-setq (*max-event-to-sec* *max-event-to-usec*) + (decompose-time *event-polling-interval*)) + #?(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 :cmu) (sbcl< 1 0 6)) + #?(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. - (if (find-package "SWANK") - (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))) - (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK"))))) - (setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")) - #'(lambda () - (loop - (case (socket-status (cons stream :input) 0 *event-poll-interval*) - ((:input :eof) (return (funcall read-from-emacs))) - (otherwise (main-iterate-all))))))) + (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.")) @@ -205,9 +219,12 @@ (defun %init-multi-threaded-event-handling (display) ;; We need to hook into the Swank server to protect calls to GDK properly. ;; This will *only* protect code entered directly in the REPL. (when (find-package "SWANK") - (push #'(lambda (form) - (within-main-loop (eval form))) - (symbol-value (find-symbol "*SLIME-REPL-EVAL-HOOKS*" "SWANK")))))) + (let ((repl-eval-hook (find-symbol "*SLIME-REPL-EVAL-HOOKS*" "SWANK"))) + (if repl-eval-hook + (push #'(lambda (form) + (within-main-loop (eval form))) + (symbol-value (find-symbol "*SLIME-REPL-EVAL-HOOKS*" "SWANK"))) + (warn "Your version of Slime does not have *SLIME-REPL-EVAL-HOOKS* so all calls to Gtk+ functions have to be explicit protected by wrapping them in a WITHIN-MAIN-LOOP form")))))) #-sb-thread (defmacro within-main-loop (&body body) @@ -703,10 +720,13 @@ (defbinding check-menu-item-toggled () nil ;;; Color selection -(defbinding (color-selection-is-adjusting-p - "gtk_color_selection_is_adjusting") () boolean +(defbinding color-selection-is-adjusting-p () boolean (colorsel color-selection)) +(defbinding (color-selection-previous-color + "gtk_color_selection_get_previous_color") () nil + (colorsel color-selection) + ((make-instance 'gdk:color) gdk:color :in/return)) ;;; Color selection dialog -- no functions @@ -969,6 +989,10 @@ (defbinding entry-completion-set-match-func (completion function) nil (defbinding entry-completion-complete () nil (completion entry-completion)) +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0") +(defbinding entry-completion-get-completion-prefix () string + (completion entry-completion)) + #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") (defbinding entry-completion-insert-prefix () nil (completion entry-completion)) @@ -2372,7 +2396,7 @@ (defbinding %spin-button-spin () nil (defun spin-button-spin (spin-button value) (etypecase value - (real (%spin-button-spin spin-button :spin-user-defined value)) + (real (%spin-button-spin spin-button :user-defined value)) (spin-type (%spin-button-spin spin-button value 0))))