From 5dd328ff6f454bf520aa9dbc5f4461eaaf4a4c1b Mon Sep 17 00:00:00 2001 Message-Id: <5dd328ff6f454bf520aa9dbc5f4461eaaf4a4c1b.1714371496.git.mdw@distorted.org.uk> From: Mark Wooding Date: Fri, 29 Feb 2008 18:34:19 +0000 Subject: [PATCH] Reintroduced SERVE-EVENT based asynchronous event handling for SBCL 1.0.15.6 Organization: Straylight/Edgeware From: espen --- gtk/defpackage.lisp | 6 ++++-- gtk/gtk.lisp | 42 ++++++++++++++++++++++++++---------------- 2 files changed, 30 insertions(+), 18 deletions(-) diff --git a/gtk/defpackage.lisp b/gtk/defpackage.lisp index a348ac9..58367a8 100644 --- a/gtk/defpackage.lisp +++ b/gtk/defpackage.lisp @@ -13,8 +13,10 @@ (defpackage "GTK" (pkg-config:featurep :cmu) (and (pkg-config:sbcl< 1 0 6) (not (pkg-config:featurep :win32)))) (:import-from #+cmu"LISP" #+sbcl"SB-IMPL" - "*PERIODIC-POLLING-FUNCTION*" "*MAX-EVENT-TO-SEC*" - "*MAX-EVENT-TO-USEC*") + "*PERIODIC-POLLING-FUNCTION*" "*MAX-EVENT-TO-SEC*" "*MAX-EVENT-TO-USEC*") + #?(and (pkg-config:sbcl>= 1 0 15 6) (not (pkg-config:featurep :win32))) + (:import-from "SB-IMPL" + "*PERIODIC-POLLING-FUNCTION*" "*PERIODIC-POLLING-PERIOD*") #+clisp (:import-from "SOCKET" "SOCKET-STATUS") (:export "EVENTS-PENDING-P" "GET-CURRENT-EVENT" "MAIN-DO-EVENT" "MAIN" diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 11afe7e..c613886 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.89 2008-01-11 14:44:28 espen Exp $ +;; $Id: gtk.lisp,v 1.90 2008-02-29 18:34:19 espen Exp $ (in-package "GTK") @@ -50,8 +50,12 @@ (defun clg-version () ;;;; 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 ~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,14 +124,17 @@ (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. (unless (and @@ -135,13 +143,15 @@ (defun %init-async-event-handling (display) (when connection (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))) (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") connection))) - (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)))))))))) + (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.")) -- [mdw]