;;; Package: (edwin screen gtk-screen)
(define-class (<gtk-screen>
- (constructor %make-gtk-screen (toplevel editor-thread) no-init))
+ (constructor %make-gtk-screen
+ (toplevel editor-thread event-queue) no-init))
(<screen>) ;; TODO: could also be a <gtk-window>, replacing toplevel!
;; The toplevel <gtk-window>. 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 '())
(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
\f
;;; 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?)
(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)))
(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))
(define-method fix-widget-new-geometry-callback ((widget <text-widget>))
(%trace "; (fix-widget-new-geometry-callback <text-widget>) "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
projects / mit-scheme.git / commitdiff