From: Matt Birkholz Date: Tue, 15 Dec 2015 08:00:46 +0000 (-0700) Subject: gtk-screen: Update input operations. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a72c39c86f793d6aabb82c0bc4131df1084ef2f1;p=mit-scheme.git gtk-screen: Update input operations. Edwin no longer uses permanently-register-io-thread-event. --- diff --git a/src/gtk-screen/Makefile b/src/gtk-screen/Makefile index 73abff161..b802a9a80 100644 --- a/src/gtk-screen/Makefile +++ b/src/gtk-screen/Makefile @@ -33,7 +33,7 @@ install: | $(exe) -- *.com *.bci *.pkd make.scm clean distclean maintainer-clean: - rm -f *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd + rm -f TAGS *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd tags: etags *.scm diff --git a/src/gtk-screen/gtk-screen-check.scm b/src/gtk-screen/gtk-screen-check.scm index 2b4b52d69..28e60c8b4 100644 --- a/src/gtk-screen/gtk-screen-check.scm +++ b/src/gtk-screen/gtk-screen-check.scm @@ -61,18 +61,6 @@ USA. (for-each (lambda (o) (display o port)) args)) #f)) - (define (spawn-edit) - (call-with-current-continuation - (lambda (continue) - (detach-thread - (create-thread continue - (lambda () - (let ((self (current-thread))) - (note* "Edwin thread: "self) - (edit) - (note* "Edwin thread "self" finished.") - (stop-current-thread)))))))) - (run-test 'gtk-screens (lambda () (with-gc-notification! #t await-closed-windows) diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index bf043c183..3d9c8bb2a 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -35,8 +35,7 @@ USA. (files "gtk-screen" "gtk-faces") (parent (edwin screen)) (export () - spawn-edit - set-gtk-screen-hooks!) + spawn-edit) (export (edwin) ;; edwin-variable$x-cut-to-clipboard ;; edwin-variable$x-paste-from-clipboard @@ -54,10 +53,8 @@ USA. ;; xterm-screen/set-icon-name ;; xterm-screen/set-name ) - (import (runtime thread) - register-subprocess-status-change-event) (import (edwin process) - hook/inferior-process-output) + register-process-output-events) (import (edwin window) editor-frame-root-window window-inferiors find-inferior window-next diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 111ee165c..254261305 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -25,16 +25,20 @@ USA. ;;; Package: (edwin screen gtk-screen) (define-class ( - (constructor %make-gtk-screen (toplevel editor-thread) no-init)) + (constructor %make-gtk-screen + (toplevel editor-thread event-queue) no-init)) () ;; TODO: could also be a , replacing toplevel! ;; The toplevel . The top widget. (toplevel define accessor) - ;; The Edwin thread, used by event handlers (callbacks) running in - ;; the gtk-thread, where editor-thread is unassigned. + ;; The thread to interrupt when ^G is seen by an event handler (i.e. a + ;; callback in the glib-thread). (editor-thread define accessor) + ;; The editor-thread's event queue. + (event-queue define accessor) + ;; An alist of Edwin buffers and their drawings, to be shared among ;; the text-widgets, and updated during screen update. (drawings define standard initial-value '()) @@ -64,7 +68,7 @@ USA. (define (make-gtk-screen #!optional geometry) (%trace "; make-gtk-screen "geometry"\n") (let* ((toplevel (gtk-window-new 'toplevel)) - (screen (%make-gtk-screen toplevel (current-thread))) + (screen (%make-gtk-screen toplevel (current-thread) (make-queue))) (geometry* (if (default-object? geometry) "80x24" (begin @@ -521,61 +525,152 @@ USA. ;;; Event Handling -(define event-queue) -(define change-event-registration) - -(define (get-gtk-input-operations) - (values - (named-lambda (gtk-screen-halt-update?) - ;; Large buffers will generate large runs of these traces... - ;;(%trace2 ";halt-update?") - (let ((halt? (not (thread-queue/empty? event-queue)))) - ;;(%trace2 " => "halt?"\n") - halt?)) - (named-lambda (gtk-screen-peek-no-hang msec) - (%trace2 ";peek-no-hang "msec"\n") - (let ((event (thread-queue/peek-no-hang event-queue msec))) - (%trace2 ";peek-no-hang "msec" => "event"\n") - event)) - (named-lambda (gtk-screen-peek) - (%trace2 ";peek\n") - (let ((event (thread-queue/peek event-queue))) - (%trace2 ";peek => "event"\n") - event)) - (named-lambda (gtk-screen-read) - (%trace2 ";read\n") - (let ((event (thread-queue/dequeue! event-queue))) - (%trace2 ";read => "event"\n") - event)))) - -(define (gtk-screen-inferior-thread-output) - ;; Invoked via hook/signal-inferior-thread-output!. - (thread-queue/queue-no-hang! - event-queue (make-input-event 'UPDATE gtk-screen-accept-thread-output))) - -(define (gtk-screen-accept-thread-output) - (if (accept-thread-output) - (update-screens! #f))) - -(define (gtk-screen-inferior-process-output) - ;; Invoked via hook/inferior-process-output. - (thread-queue/queue-no-hang! - event-queue (make-input-event 'UPDATE gtk-screen-accept-process-output))) - -(define (gtk-screen-accept-process-output) - (if (accept-process-output) - (update-screens! #f))) - -(define (gtk-screen-process-status-change) - ;; Invoked by a thread-event (asynchronously) whenever ANY - ;; subprocess status changes. - (thread-queue/queue-no-hang! - event-queue - (make-input-event 'UPDATE gtk-screen-accept-process-status-change))) - -(define (gtk-screen-accept-process-status-change) - (if (handle-process-status-changes) - (update-screens! #f))) +(define (queue-input-event screen input-event) + (%trace2 ";queue-input-event "screen" "input-event"\n") + (let ((queue (gtk-screen-event-queue screen))) + (signal-thread-event (gtk-screen-editor-thread screen) + (named-lambda (gtk-screen-enqueue) + (%trace2 ";queue-input event "screen" "input-event"\n") + (enqueue!/unsafe queue input-event))))) + +(define (block-for-event-until event-queue time) + (%trace2 ";block-for-event-until\n") + (let ((output-available? #f) + (timeout? #f) + (registrations)) + (if (and time (not (zero? time))) + (begin + (%trace2 ";block-for-event-until setting timer\n") + (register-timer-event (- time (real-time-clock)) + (lambda () + (%trace2 ";block-for-event-until timer expired\n") + (set! timeout? #t))))) + (dynamic-wind + (lambda () + (%trace2 ";block-for-event-until registering IO events\n") + (let ((thread (current-thread))) + (set! registrations + (register-process-output-events + thread (lambda (mode) + mode + (set! output-available? #t)))))) + (lambda () + (let loop () + (%trace2 ";block-for-event-until blocking\n") + (with-thread-events-blocked + (lambda () + (if (and (queue-empty? event-queue) + (not (process-status-changes?)) + (not inferior-thread-changes?) + (not output-available?) + (not timeout?)) + (suspend-current-thread)))) + (cond ((not (queue-empty? event-queue)) + (%trace2 ";block-for-event-until input-event\n") + 'INPUT-EVENT) + (output-available? + (%trace2 ";block-for-event-until process-output\n") + 'PROCESS-OUTPUT) + (inferior-thread-changes? + (%trace2 ";block-for-event-until inferior-thread-output\n") + 'INFERIOR-THREAD-OUTPUT) + ((process-status-changes?) + (%trace2 ";block-for-event-until process-status\n") + 'PROCESS-STATUS) + (timeout? + 'TIMEOUT) + (else + (loop))))) + (lambda () + (%trace2 ";block-for-event-until deregistering\n") + (for-each deregister-io-thread-event registrations) + (set! registrations))))) + +(define (probe-for-event event-queue) + (%trace2 ";probe-for-event\n") + (cond ((not (queue-empty? event-queue)) + (%trace2 ";probe-for-event input-event\n") + 'INPUT-EVENT) + ((process-output-available?) + (%trace2 ";probe-for-event process-output\n") + 'PROCESS-OUTPUT) + (inferior-thread-changes? + (%trace2 ";probe-for-event inferior-thread-output\n") + 'INFERIOR-THREAD-OUTPUT) + ((process-status-changes?) + (%trace2 ";probe-for-event process-status\n") + 'PROCESS-STATUS) + (else + (%trace2 ";probe-for-event none\n") + 'TIMEOUT))) + +(define (block-for-input-event event-queue msec) + (let ((time (and msec (not (zero? msec)) + (queue-empty? event-queue) + (+ (real-time-clock) + (internal-time/seconds->ticks + (/ msec 1000)))))) + (let loop () + (or (not (queue-empty? event-queue)) + (case (if (and msec (zero? msec)) + (probe-for-event event-queue) + (block-for-event-until event-queue time)) + ((INPUT-EVENT) + #t) + ((PROCESS-STATUS) + (if (handle-process-status-changes) + (update-screens! #f)) + (loop)) + ((PROCESS-OUTPUT) + (if (accept-process-output) + (update-screens! #f)) + (loop)) + ((INFERIOR-THREAD-OUTPUT) + (if (accept-thread-output) + (update-screens! #f)) + (loop)) + ((TIMEOUT) + #f) + (else (error "Unexpected value."))))))) + +(define-integrable (queue/peek queue) + (let ((objects (cadr queue))) + (and (pair? objects) + (car objects)))) + +(define-integrable (queue/push! queue object) + (let ((next (cons object (cadr queue)))) + (set-car! (cdr queue) next) + (if (not (pair? (cddr queue))) + (set-cdr! (cdr queue) next)))) + +(define (get-gtk-input-operations screen) + (let ((event-queue (gtk-screen-event-queue screen))) + (values + (named-lambda (gtk-screen-halt-update?) + ;; Large buffers will generate large runs of these traces... + ;;(%trace2 ";halt-update?") + (let ((halt? (not (queue-empty? event-queue)))) + ;;(%trace2 " => "halt?"\n") + halt?)) + (named-lambda (gtk-screen-peek-no-hang msec) + (%trace2 ";peek-no-hang "msec"\n") + (let ((event (and (block-for-input-event event-queue msec) + (queue/peek event-queue)))) + (%trace2 ";peek-no-hang "msec" => "event"\n") + event)) + (named-lambda (gtk-screen-peek) + (%trace2 ";peek\n") + (let ((event (and (block-for-input-event event-queue #f) + (queue/peek event-queue)))) + (%trace2 ";peek => "event"\n") + event)) + (named-lambda (gtk-screen-read) + (%trace2 ";read\n") + (let ((event (and (block-for-input-event event-queue #f) + (dequeue!/unsafe event-queue)))) + (%trace2 ";read => "event"\n") + event))))) (define interrupts?) @@ -639,36 +734,37 @@ USA. (define (key-press-handler widget key char-bits) (%trace "; Key-press: "key" "char-bits" "widget"\n") - (let ((queue! (lambda (x) - (thread-queue/queue-no-hang! event-queue x) - (%trace "; queued "x"\n") - #t)) - (k (case key - ((#\backspace) #\rubout) - ((#\rubout) #\c-d) - ((#\return) #\c-m) - ((#\linefeed) #\c-j) - ((#\tab) #\c-i) - ((|Shift_L| |Shift_R| |Control_L| |Control_R| - |Caps_Lock| |Shift_Lock| - |Meta_L| |Meta_R| |Alt_L| |Alt_R| - |Super_L| |Super_R| |Hyper_L| |Hyper_R|) - #f) - (else (if (symbol? key) - (intern (symbol-name key)) - key))))) + (let* ((screen (edwin-widget-screen widget)) + (queue! (lambda (x) + (queue-input-event screen x) + (%trace "; queued "x"\n") + #t)) + (k (case key + ((#\backspace) #\rubout) + ((#\rubout) #\c-d) + ((#\return) #\c-m) + ((#\linefeed) #\c-j) + ((#\tab) #\c-i) + ((|Shift_L| |Shift_R| |Control_L| |Control_R| + |Caps_Lock| |Shift_Lock| + |Meta_L| |Meta_R| |Alt_L| |Alt_R| + |Super_L| |Super_R| |Hyper_L| |Hyper_R|) + #f) + (else (if (symbol? key) + (intern (symbol-name key)) + key))))) (if (char? k) (if (char=? k #\BEL) (let* ((screen (edwin-widget-screen widget)) (thread (gtk-screen-editor-thread screen))) (%trace "; pushing ^G in "(current-thread)"...\n") - (thread-queue/push! event-queue #\BEL) + (queue/push! (gtk-screen-event-queue screen) #\BEL) (%trace "; signaling "thread"\n") (signal-thread-event - thread - (lambda () - (%trace ";interrupt! in editor "(current-thread)"\n") - (interrupt!))) + thread + (lambda () + (%trace ";interrupt! in editor "(current-thread)"\n") + (interrupt!))) (%trace "; pushed ^G in "(current-thread)".\n") #t) (queue! (merge-bucky-bits k char-bits))) @@ -680,26 +776,14 @@ USA. (define gtk-display-type) -(define (set-gtk-screen-hooks!) - (set! hook/signal-inferior-thread-output! gtk-screen-inferior-thread-output) - (set! hook/inferior-process-output gtk-screen-inferior-process-output)) - (define (initialize-package!) (set! screen-list '()) - (set! event-queue (make-thread-queue 128)) - (set! change-event-registration ;deregister when??? - (register-subprocess-status-change-event - (lambda (mode) - (declare (ignore mode)) - (gtk-screen-process-status-change)))) (set! gtk-display-type (make-display-type 'GTK #t gtk-initialized? make-gtk-screen - (lambda (screen) - screen ;ignore - (get-gtk-input-operations)) + get-gtk-input-operations with-editor-interrupts-from-gtk with-gtk-interrupts-enabled with-gtk-interrupts-disabled)) @@ -1104,25 +1188,25 @@ USA. (define-method fix-widget-new-geometry-callback ((widget )) (%trace "; (fix-widget-new-geometry-callback ) "widget"\n") (call-next-method widget) - (thread-queue/queue-no-hang! - event-queue - (make-input-event - 'SET-WINDOW-SIZE - (lambda (widget) - (%trace "; input event: set-window-size "widget"\n") - (let ((geometry (fix-widget-geometry widget)) - (screen (edwin-widget-screen widget)) - (window (text-widget-buffer-frame widget))) - (let ((widget-x-size (width->x-size screen (fix-rect-width geometry))) - (widget-y-size (height->y-size screen (fix-rect-height geometry))) - (window-x-size (%text-x-size window)) - (window-y-size (%text-y-size window))) - (%trace "; "widget": "geometry"\n") - (%trace "; "window": "window-x-size"x"window-y-size"\n") - (if (not (and (fix:= widget-x-size window-x-size) - (fix:= widget-y-size window-y-size))) - (update-sizes screen))))) - widget))) + (let ((screen (edwin-widget-screen widget))) + (queue-input-event + screen + (make-input-event + 'SET-WINDOW-SIZE + (lambda (widget) + (%trace "; input event: set-window-size "widget"\n") + (let ((geometry (fix-widget-geometry widget)) + (window (text-widget-buffer-frame widget))) + (let ((widget-x-size (width->x-size screen (fix-rect-width geometry))) + (widget-y-size (height->y-size screen (fix-rect-height geometry))) + (window-x-size (%text-x-size window)) + (window-y-size (%text-y-size window))) + (%trace "; "widget": "geometry"\n") + (%trace "; "window": "window-x-size"x"window-y-size"\n") + (if (not (and (fix:= widget-x-size window-x-size) + (fix:= widget-y-size window-y-size))) + (update-sizes screen))))) + widget)))) (define (update-sizes screen) ;; The underhanded way to adjust window sizes. This procedure does diff --git a/src/gtk-screen/make.scm b/src/gtk-screen/make.scm index aeb2dca4a..c45ff302f 100644 --- a/src/gtk-screen/make.scm +++ b/src/gtk-screen/make.scm @@ -7,5 +7,4 @@ Load the Gtk-Screen option. |# (with-loader-base-uri (system-library-uri "gtk-screen/") (lambda () (load-package-set "gtk-screen"))) -(set-gtk-screen-hooks!) (add-subsystem-identification! "Gtk-Screen" '(0 1)) \ No newline at end of file