;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.16 1992/01/09 17:55:24 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.17 1992/02/04 04:02:16 cph Exp $
;;;
;;; Copyright (c) 1989-92 Massachusetts Institute of Technology
;;;
(define (debug-scheme-error condition error-type-name)
(if in-debugger?
- (exit-editor-and-signal-error condition)
+ (quit-editor-and-signal-error condition)
(begin
(editor-beep)
(if (and (if in-debugger-evaluation?
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.117 1992/01/06 21:50:40 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.118 1992/02/04 04:01:10 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(if (prompt-for-yes-or-no? "Suspend Scheme")
(begin
(if argument (save-buffer (current-buffer) false))
- (set! edwin-finalization
- (lambda ()
- (set! edwin-finalization false)
- (quit)
- (edit)))
- (abort-edwin)))))
+ (quit)))))
(define-command suspend-edwin
"Stop Edwin and return to Scheme."
()
(lambda ()
(if (prompt-for-yes-or-no? "Suspend Edwin")
- (abort-edwin))))
-
-(define (abort-edwin)
- (editor-abort *the-non-printing-object*))
+ (quit-editor))))
(define-command save-buffers-kill-scheme
"Offer to save each buffer, then kill Scheme.
(lambda (no-confirmation?)
(save-some-buffers no-confirmation? true)
(if (prompt-for-yes-or-no? "Kill Scheme")
- (begin
- (set! edwin-finalization
- (lambda ()
- (set! edwin-finalization false)
- (%exit)))
- (abort-edwin)))))
+ (%exit))))
(define-command save-buffers-kill-edwin
"Offer to save each buffer, then kill Edwin, returning to Scheme.
(begin
(for-each delete-process (process-list))
true))))
- (begin
- (set! edwin-finalization
- (lambda ()
- (set! edwin-finalization false)
- (reset-editor)))
- (abort-edwin)))))
+ (exit-editor))))
\f
;;;; Comment Commands
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.90 1992/01/13 19:14:33 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.91 1992/02/04 04:01:20 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define (call-with-temporary-buffer name procedure)
(let ((buffer))
- (dynamic-wind (lambda ()
- unspecific)
- (lambda ()
- (set! buffer (temporary-buffer name))
- (procedure buffer))
- (lambda ()
- (kill-buffer buffer)
- (set! buffer)
- unspecific))))
+ (unwind-protect (lambda ()
+ (set! buffer (temporary-buffer name)))
+ (lambda ()
+ (procedure buffer))
+ (lambda ()
+ (kill-buffer buffer)
+ (set! buffer)
+ unspecific))))
(define (temporary-buffer name)
(let ((buffer (find-or-create-buffer name)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.150 1992/01/09 17:45:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.151 1992/02/04 04:01:29 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define (with-read-only-defeated mark thunk)
(let ((group (mark-group mark))
(read-only?))
- (dynamic-wind (lambda ()
- (set! read-only? (group-read-only? group))
- (if read-only? (set-group-writeable! group)))
- thunk
- (lambda ()
- (if read-only? (set-group-read-only! group))))))
+ (unwind-protect (lambda ()
+ (set! read-only? (group-read-only? group))
+ (set-group-writeable! group))
+ thunk
+ (lambda ()
+ (if read-only? (set-group-read-only! group))))))
\f
;;;; Local Bindings
(vector-set! buffer
buffer-index:local-bindings-installed?
installed?))))
- (dynamic-wind
+ (unwind-protect
(lambda ()
(let ((buffer (current-buffer)))
(wind-bindings buffer true)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.67 1991/04/23 06:37:57 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.68 1992/02/04 04:01:39 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define (with-variable-value! variable new-value thunk)
(let ((old-value))
- (dynamic-wind (lambda ()
- (set! old-value (variable-value variable))
- (set-variable-value! variable new-value)
- (set! new-value)
- unspecific)
- thunk
- (lambda ()
- (set! new-value (variable-value variable))
- (set-variable-value! variable old-value)
- (set! old-value)
- unspecific))))
\ No newline at end of file
+ (unwind-protect (lambda ()
+ (set! old-value (variable-value variable))
+ (set-variable-value! variable new-value)
+ (set! new-value)
+ unspecific)
+ thunk
+ (lambda ()
+ (set-variable-value! variable old-value)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.90 1991/11/14 22:49:16 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.91 1992/02/04 04:01:50 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define command-history-limit 30)
(define command-reader-reset-thunk)
(define command-reader-reset-continuation)
+(define command-reader-override-queue)
(define (initialize-command-reader!)
(set! keyboard-keys-read 0)
(set! command-history (make-circular-list command-history-limit false))
(set! command-reader-reset-thunk false)
+ (set! command-reader-override-queue (make-queue))
unspecific)
(define (top-level-command-reader initialization)
(let loop ((initialization initialization))
(with-keyboard-macro-disabled
(lambda ()
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(fluid-let ((command-reader-reset-continuation continuation))
- (dynamic-wind
- (lambda () unspecific)
+ (unwind-protect
+ false
(lambda ()
(intercept-^G-interrupts (lambda () unspecific)
(lambda ()
(define (command-reader/reset-and-execute thunk)
(set! command-reader-reset-thunk thunk)
(command-reader-reset-continuation false))
+
+(define (override-next-command! override)
+ (enqueue! command-reader-override-queue override))
\f
(define (command-reader #!optional initialization)
(define (command-reader-loop)
(command-reader-loop))
(define (with-command-variables start-next-command)
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(fluid-let ((*command-continuation* continuation)
(*command-key* false)
(define (start-next-command)
(reset-command-state!)
- (let ((key (with-editor-interrupts-disabled keyboard-read)))
- (set! *command-key* key)
- (clear-message)
- (set-command-prompt!
- (if (not (command-argument))
- (key-name key)
- (string-append-separated (command-argument-prompt)
- (key-name key))))
- (let ((window (current-window)))
- (%dispatch-on-command window
- (comtab-entry (buffer-comtabs
- (window-buffer window))
- key)
- false)))
+ (if (queue-empty? command-reader-override-queue)
+ (let ((key (with-editor-interrupts-disabled keyboard-read)))
+ (set! *command-key* key)
+ (clear-message)
+ (set-command-prompt!
+ (if (not (command-argument))
+ (key-name key)
+ (string-append-separated (command-argument-prompt)
+ (key-name key))))
+ (let ((window (current-window)))
+ (%dispatch-on-command window
+ (comtab-entry (buffer-comtabs
+ (window-buffer window))
+ key)
+ false)))
+ ((dequeue! command-reader-override-queue)))
(start-next-command))
(fluid-let ((*last-command* false)
(%dispatch-on-command (current-window)
command
(if (default-object? record?) false record?)))
-
+\f
(define (%dispatch-on-command window command record?)
(set! *command* command)
(guarantee-command-loaded command)
(and (eq? command (ref-command-object auto-fill-space))
(not (auto-fill-break? point)))
(command-argument-self-insert? command)))
- (if (or (= *non-undo-count* 0)
- (>= *non-undo-count* 20))
- (begin
- (set! *non-undo-count* 0)
- (undo-boundary! point)))
- (set! *non-undo-count* (+ *non-undo-count* 1))
(let ((key *command-key*))
(if (let ((buffer (window-buffer window)))
(and (buffer-auto-save-modified? buffer)
(null? (cdr (buffer-windows buffer)))
(line-end? point)
(char-graphic? key)
- (< point-x (- (window-x-size window) 1))))
- (window-direct-output-insert-char! window key)
- (region-insert-char! point key))))
+ (fix:< point-x (fix:- (window-x-size window) 1))))
+ (begin
+ (if (fix:< *non-undo-count* 20)
+ (set! *non-undo-count* (fix:+ *non-undo-count* 1))
+ (begin
+ (set! *non-undo-count* 1)
+ (undo-boundary! point)))
+ (window-direct-output-insert-char! window key))
+ (begin
+ (set! *non-undo-count* 0)
+ (undo-boundary! point)
+ (region-insert-char! point key)))))
((eq? command (ref-command-object forward-char))
(if (and (not (group-end? point))
(char-graphic? (mark-right-char point))
- (< point-x (- (window-x-size window) 2))
- (null? (group-move-point-daemons
- (mark-group point))))
+ (fix:< point-x (fix:- (window-x-size window) 2))
+ (null? (group-move-point-daemons (mark-group point))))
(window-direct-output-forward-char! window)
(normal)))
((eq? command (ref-command-object backward-char))
(if (and (not (group-start? point))
(char-graphic? (mark-left-char point))
- (< 0 point-x (- (window-x-size window) 1))
- (null? (group-move-point-daemons
- (mark-group point))))
+ (fix:< 0 point-x)
+ (fix:< point-x (fix:- (window-x-size window) 1))
+ (null? (group-move-point-daemons (mark-group point))))
(window-direct-output-backward-char! window)
(normal)))
(else
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.93 1991/10/25 00:02:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.94 1992/02/04 04:02:06 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(let ((message (current-message)))
(clear-current-message!)
(screen-exit! (selected-screen))
- (change-selected-buffer
- (window-buffer (screen-selected-window screen))
- true
- (lambda ()
- (set-editor-selected-screen! current-editor screen)))
+ (let ((window (screen-selected-window screen)))
+ (undo-leave-window! window)
+ (change-selected-buffer (window-buffer window) true
+ (lambda ()
+ (set-editor-selected-screen! current-editor screen))))
(set-current-message! message)
(screen-enter! screen)))))
\f
(define (select-window window)
(without-interrupts
(lambda ()
+ (undo-leave-window! window)
(let ((screen (window-screen window)))
(if (selected-screen? screen)
(change-selected-buffer (window-buffer window) true
(hangup-process process true)
(set-process-buffer! process false))
(buffer-processes buffer))
+ (kill-buffer-inferior-repl buffer)
(bufferset-kill-buffer! (current-bufferset) buffer))
\f
(define (select-buffer buffer)
(define (set-window-buffer! window buffer record?)
(without-interrupts
(lambda ()
+ (undo-leave-window! window)
(if (current-window? window)
(change-selected-buffer buffer record?
(lambda ()
(define (with-selected-buffer buffer thunk)
(let ((old-buffer))
- (dynamic-wind (lambda ()
- (let ((window (current-window)))
- (set! old-buffer (window-buffer window))
- (if (buffer-alive? buffer)
- (set-window-buffer! window buffer true)))
- (set! buffer)
- unspecific)
- thunk
- (lambda ()
- (let ((window (current-window)))
- (set! buffer (window-buffer window))
+ (unwind-protect (lambda ()
+ (let ((window (current-window)))
+ (set! old-buffer (window-buffer window))
+ (if (buffer-alive? buffer)
+ (set-window-buffer! window buffer true)))
+ (set! buffer)
+ unspecific)
+ thunk
+ (lambda ()
(if (buffer-alive? old-buffer)
- (set-window-buffer! window old-buffer true)))
- (set! old-buffer)
- unspecific))))
+ (set-window-buffer! (current-window)
+ old-buffer
+ true))))))
(define (current-process)
(let ((process (get-buffer-process (current-buffer))))
(define (with-current-point point thunk)
(let ((old-point))
- (dynamic-wind (lambda ()
- (let ((window (current-window)))
- (set! old-point (window-point window))
- (set-window-point! window point))
- (set! point)
- unspecific)
- thunk
- (lambda ()
- (let ((window (current-window)))
- (set! point (window-point window))
- (set-window-point! window old-point))
- (set! old-point)
- unspecific))))
+ (unwind-protect (lambda ()
+ (let ((window (current-window)))
+ (set! old-point (window-point window))
+ (set-window-point! window point))
+ (set! point)
+ unspecific)
+ thunk
+ (lambda ()
+ (set-window-point! (current-window) old-point)))))
(define (current-column)
(mark-column (current-point)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.29 1992/01/10 18:52:50 bal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.30 1992/02/04 04:02:26 cph Exp $
-Copyright (c) 1989-91 Massachusetts Institute of Technology
+Copyright (c) 1989-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
"strpad"
"strtab"
"termcap"
+ "thread"
"utils"
"winren"
"xform"
edwin-syntax-table)
("things" (edwin)
edwin-syntax-table)
+ ("thread" (edwin thread)
+ syntax-table/system-internal)
("tparse" (edwin)
edwin-syntax-table)
("tterm" (edwin console-screen)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.210 1992/01/10 22:26:54 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.211 1992/02/04 04:02:36 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
((not edwin-editor)
(apply create-editor args))
((not (null? args))
- (error "edwin: Arguments ignored when re-entering editor" args)))
+ (error "edwin: Arguments ignored when re-entering editor" args))
+ (edwin-continuation
+ => (lambda (continuation)
+ (set! edwin-continuation false)
+ (continuation unspecific))))
(call-with-current-continuation
(lambda (continuation)
(fluid-let ((editor-abort continuation)
(current-editor edwin-editor)
+ (editor-thread)
+ (editor-initial-threads '())
+ (unwind-protect-cleanups '())
+ (inferior-thread-changes? false)
(recursive-edit-continuation false)
(recursive-edit-level 0))
- (editor-grab-display edwin-editor
- (lambda (with-editor-ungrabbed operations)
- (let ((message (cmdl-message/null)))
- (cmdl/start
- (push-cmdl
- (lambda (cmdl)
- cmdl ;ignore
- (bind-condition-handler (list condition-type:error)
- internal-error-handler
- (lambda ()
- (top-level-command-reader edwin-initialization)))
- message)
- false
- `((START-CHILD ,(editor-start-child-cmdl with-editor-ungrabbed))
- ,@operations))
- message)))))))
- (if edwin-finalization (edwin-finalization))
- unspecific)
+ (within-thread-environment
+ (lambda ()
+ (set! editor-thread (create-initial-thread))
+ (editor-grab-display edwin-editor
+ (lambda (with-editor-ungrabbed operations)
+ (let ((message (cmdl-message/null)))
+ (cmdl/start
+ (push-cmdl
+ (lambda (cmdl)
+ cmdl ;ignore
+ (bind-condition-handler (list condition-type:error)
+ internal-error-handler
+ (lambda ()
+ (call-with-current-continuation
+ (lambda (root-continuation)
+ (set-thread-root-continuation! root-continuation)
+ (do ((thunks (let ((thunks editor-initial-threads))
+ (set! editor-initial-threads '())
+ thunks)
+ (cdr thunks)))
+ ((null? thunks))
+ (create-thread (car thunks)))
+ (top-level-command-reader edwin-initialization)))))
+ message)
+ false
+ `((START-CHILD
+ ,(editor-start-child-cmdl with-editor-ungrabbed))
+ ,@operations))
+ message))))))))))
(define (edwin . args) (apply edit args))
(define (within-editor?) (not (unassigned? current-editor)))
(define editor-abort)
(define edwin-editor false)
(define current-editor)
+(define editor-thread)
+(define editor-initial-threads)
+(define edwin-continuation)
;; Set this before entering the editor to get something done after the
;; editor's dynamic environment is initialized, but before the command
;; loop is started.
(define edwin-initialization false)
-;; Set this while in the editor to get something done after leaving
-;; the editor's dynamic environment; for example, this can be used to
-;; reset and then reenter the editor.
-(define edwin-finalization false)
+(define (queue-initial-thread thunk)
+ (set! editor-initial-threads (cons thunk editor-initial-threads))
+ unspecific)
\f
(define create-editor-args
(list false))
(initialize-typeout!)
(initialize-command-reader!)
(initialize-processes!)
+ (initialize-inferior-repls!)
(set! edwin-editor
(make-editor "Edwin"
(let ((name (car args)))
(lambda ()
(set! edwin-initialization false)
(standard-editor-initialization)))
+ (set! edwin-continuation false)
unspecific))
(define (standard-editor-initialization)
(lambda ()
(if edwin-editor
(begin
+ ;; Restore the default bindings of all of the local
+ ;; variables in the current buffer.
+ (let ((buffer
+ (window-buffer
+ (screen-selected-window
+ (editor-selected-screen edwin-editor)))))
+ (for-each (lambda (binding)
+ (%%set-variable-value! (car binding)
+ (cdr binding)))
+ (buffer-local-bindings buffer))
+ (vector-set! buffer buffer-index:local-bindings '()))
(for-each (lambda (screen)
(screen-discard! screen))
(editor-screens edwin-editor))
(set! edwin-editor false)
+ (set! edwin-continuation)
(set! init-file-loaded? false)
(set! *previous-popped-up-buffer* (object-hash false))
(set! *previous-popped-up-window* (object-hash false))
(define (enter-recursive-edit)
(let ((value
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(fluid-let ((recursive-edit-continuation continuation)
(recursive-edit-level (1+ recursive-edit-level)))
(window-modeline-event! window
'RECURSIVE-EDIT))
(window-list)))))
- (dynamic-wind recursive-edit-event!
- command-reader
- recursive-edit-event!)))))))
+ (unwind-protect
+ false
+ (lambda ()
+ (recursive-edit-event!)
+ (command-reader))
+ recursive-edit-event!)))))))
(if (eq? value 'ABORT)
(abort-current-command)
(begin
\f
(define (internal-error-handler condition)
(cond (debug-internal-errors?
- (exit-editor-and-signal-error condition))
+ (error condition))
((ref-variable debug-on-internal-error)
(debug-scheme-error condition "internal"))
(else
(define debug-internal-errors? false)
-(define (exit-editor-and-signal-error condition)
- (within-continuation editor-abort
- (lambda ()
- (error condition))))
-
(define condition-type:editor-error
(make-condition-type 'EDITOR-ERROR condition-type:error '(STRINGS)
(lambda (condition port)
(define (%editor-error)
(editor-beep)
(abort-current-command))
-\f
-(define *^G-interrupt-handler*)
+(define (quit-editor-and-signal-error condition)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (within-continuation editor-abort
+ (lambda ()
+ (set! edwin-continuation continuation)
+ (error condition))))))
+
+(define (quit-editor)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (within-continuation editor-abort
+ (lambda ()
+ (set! edwin-continuation continuation)
+ *the-non-printing-object*)))))
+
+(define (exit-editor)
+ (within-continuation editor-abort reset-editor))
+\f
(define (^G-signal)
- (*^G-interrupt-handler*))
+ (let ((handler *^G-interrupt-handler*))
+ (if handler
+ (handler))))
(define (intercept-^G-interrupts interceptor thunk)
(let ((signal-tag "signal-tag"))
(let ((value
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(fluid-let ((*^G-interrupt-handler*
(lambda () (continuation signal-tag))))
(interceptor)
value))))
+(define (call-with-protected-continuation receiver)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((cleanups unwind-protect-cleanups))
+ (receiver
+ (lambda (value)
+ (let ((blocked? (block-thread-events)))
+ (do () ((eq? cleanups unwind-protect-cleanups))
+ (if (null? unwind-protect-cleanups)
+ (error "unwind-protect stack slipped!"))
+ (let ((cleanup (car unwind-protect-cleanups)))
+ (set! unwind-protect-cleanups (cdr unwind-protect-cleanups))
+ (cleanup)))
+ (if (not blocked?) (unblock-thread-events)))
+ (continuation value)))))))
+
+(define (unwind-protect setup body cleanup)
+ (let ((blocked? (block-thread-events)))
+ (if setup (setup))
+ (let ((cleanups (cons cleanup unwind-protect-cleanups)))
+ (set! unwind-protect-cleanups cleanups)
+ (if (not blocked?) (unblock-thread-events))
+ (let ((value (body)))
+ (block-thread-events)
+ (if (not (eq? unwind-protect-cleanups cleanups))
+ (error "unwind-protect stack slipped!"))
+ (set! unwind-protect-cleanups (cdr cleanups))
+ (cleanup)
+ (if (not blocked?) (unblock-thread-events))
+ value))))
+
+(define *^G-interrupt-handler* false)
+(define unwind-protect-cleanups)
+\f
(define (editor-grab-display editor receiver)
(display-type/with-display-grabbed (editor-display-type editor)
(lambda (with-display-ungrabbed operations)
(lambda ()
(let ((enter
(lambda ()
+ (start-timer-interrupt)
(let ((screen (selected-screen)))
(screen-enter! screen)
(update-screen! screen true))))
(exit
(lambda ()
- (screen-exit! (selected-screen)))))
+ (screen-exit! (selected-screen))
+ (stop-timer-interrupt))))
(dynamic-wind enter
(lambda ()
(receiver
(define (editor-start-child-cmdl with-editor-ungrabbed)
(lambda (cmdl thunk)
cmdl
- (with-editor-ungrabbed thunk)))
\ No newline at end of file
+ (with-editor-ungrabbed thunk)))
+
+(define (start-timer-interrupt)
+ (if timer-interval
+ ((ucode-primitive real-timer-set) timer-interval timer-interval)
+ (stop-timer-interrupt)))
+
+(define (stop-timer-interrupt)
+ ((ucode-primitive real-timer-clear))
+ ((ucode-primitive clear-interrupts!) interrupt-bit/timer))
+
+(define (set-thread-timer-interval! interval)
+ (if (not (or (false? interval)
+ (and (exact-integer? interval)
+ (positive? interval))))
+ (error:wrong-type-argument interval false 'SET-THREAD-TIMER-INTERVAL!))
+ (set! timer-interval interval)
+ (start-timer-interrupt))
+
+(define (thread-timer-interval)
+ timer-interval)
+
+(define timer-interval 100)
+(define inferior-thread-changes?)
+
+(define (accept-thread-output)
+ (without-interrupts
+ (lambda ()
+ (and inferior-thread-changes?
+ (begin
+ (set! inferior-thread-changes? false)
+ (accept-inferior-repl-output/unsafe))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.18 1991/11/26 08:02:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.19 1992/02/04 04:02:41 cph Exp $
;;;
-;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define (with-current-button-event button-event thunk)
(let ((old-button-event))
- (dynamic-wind
+ (unwind-protect
(lambda ()
(set! old-button-event (editor-button-event current-editor))
(set-editor-button-event! current-editor button-event)
unspecific)
thunk
(lambda ()
- (set! button-event (editor-button-event current-editor))
- (set-editor-button-event! current-editor old-button-event)
- (set! old-button-event false)
- unspecific))))
+ (set-editor-button-event! current-editor old-button-event)))))
(define button-record-type
(make-record-type 'BUTTON '(NUMBER DOWN?)))
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.21 1991/11/26 22:23:53 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.22 1992/02/04 04:02:46 cph Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(load "tterm" env)
((access initialize-package! env)))
(load "edtstr" environment)
+ (load "thread" (->environment '(EDWIN THREAD)))
(load "editor" environment)
(load "curren" environment)
(load "simple" environment)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.73 1992/01/24 23:02:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.74 1992/02/04 04:02:51 cph Exp $
Copyright (c) 1989-92 Massachusetts Institute of Technology
enable-group-undo!
undo-boundary!
undo-done!
+ undo-leave-window!
undo-record-deletion!
undo-record-insertion!
with-group-undo-disabled))
(files "xterm")
(parent (edwin))
(export (edwin)
- set-x-timer-interval!
- x-display-type
- x-timer-interval)
+ x-display-type)
(export (edwin x-commands)
screen-xterm)
(initialization (initialize-package!)))
keyboard-keys-read
last-command
last-command-key
+ override-next-command!
read-and-dispatch-on-key
set-command-argument!
set-command-message!
find-program
get-buffer-process
get-process-by-name
+ handle-process-status-changes
hangup-process
initialize-processes!
interrupt-process
kill-process
- notify-process-status-changes
process-arguments
process-arguments->string
process-buffer
(files "intmod")
(parent (edwin))
(export (edwin)
+ accept-inferior-repl-output/unsafe
edwin-command$inferior-debugger-self-insert
edwin-command$inferior-repl-abort-nearest
edwin-command$inferior-repl-abort-previous
edwin-command$repl
edwin-mode$inferior-debugger
edwin-mode$inferior-repl
+ initialize-inferior-repls!
+ kill-buffer-inferior-repl
start-inferior-repl!))
(define-package (edwin bochser)
edwin-variable$bindings-window-fraction)
(import (runtime debugger-utilities)
show-environment-bindings)
- (initialization (initialize-bochser-mode!)))
\ No newline at end of file
+ (initialization (initialize-bochser-mode!)))
+
+(define-package (edwin thread)
+ (files "thread")
+ (parent (edwin))
+ (export (edwin)
+ allow-preempt-current-thread
+ block-thread-events
+ condition-type:thread-deadlock
+ condition-type:thread-detached
+ condition-type:thread-error
+ create-initial-thread
+ create-thread
+ current-thread
+ detach-thread
+ disallow-preempt-current-thread
+ exit-current-thread
+ join-thread
+ lock-thread-mutex
+ make-thread-mutex
+ other-running-threads?
+ set-thread-root-continuation!
+ signal-thread-event
+ sleep-current-thread
+ suspend-current-thread
+ thread-continuation
+ thread-dead?
+ thread-mutex?
+ thread?
+ try-lock-thread-mutex
+ unblock-thread-events
+ unlock-thread-mutex
+ within-thread-environment
+ yield-current-thread))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.33 1992/01/09 17:55:35 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.34 1992/02/04 04:02:56 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(transcript-buffer))))))))
value))))))
(if (ref-variable enable-run-light?)
- (dynamic-wind
+ (unwind-protect
(lambda ()
(set-variable! run-light "eval")
(for-each (lambda (window)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.105 1992/01/13 19:17:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.106 1992/02/04 04:03:02 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
set-buffer-major-mode!
enable-buffer-minor-mode!)
buffer mode)))
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(bind-condition-handler
(list condition-type:error)
(rename-file pathname old)
(set! modes (file-modes old))
true))))
- (dynamic-wind
- (lambda () unspecific)
+ (unwind-protect
+ false
(lambda ()
(clear-visited-file-modification-time! buffer)
(write-buffer buffer)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.90 1991/08/06 15:38:30 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.91 1992/02/04 04:03:08 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(if *executing-keyboard-macro?*
(keyboard-macro-read-key)
(let ((key (keyboard-read-1 (editor-read-char current-editor))))
- (set! auto-save-keystroke-count (1+ auto-save-keystroke-count))
+ (set! auto-save-keystroke-count (fix:+ auto-save-keystroke-count 1))
(ring-push! (current-char-history) key)
(if *defining-keyboard-macro?* (keyboard-macro-write-key key))
key)))
(let ((char-ready? (editor-char-ready? current-editor)))
(if (not (char-ready?))
(begin
- (accept-process-output)
- (notify-process-status-changes)
(update-screens! false)
(if (let ((interval (ref-variable auto-save-interval))
(count auto-save-keystroke-count))
- (and (positive? interval)
- (> count interval)
- (> count 20)))
+ (and (fix:> count 20)
+ (> interval 0)
+ (> count interval)))
(begin
(do-auto-save)
(set! auto-save-keystroke-count 0)))))
(set! command-prompt-displayed? true)
(set-current-message! command-prompt-string))
(clear-current-message!)))))
- (let loop ()
- (or (read-key)
- (begin
- (accept-process-output)
- (notify-process-status-changes)
- (update-screens! false)
- (loop)))))))
\ No newline at end of file
+ (read-key))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.40 1991/11/26 08:03:18 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.41 1992/02/04 04:03:13 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(select-buffer
(or (find-buffer initial-buffer-name)
(let ((environment (evaluation-environment argument)))
- (start-inferior-repl! (create-buffer initial-buffer-name)
- environment
- (evaluation-syntax-table environment)
- false))))))
+ (let ((buffer (create-buffer initial-buffer-name)))
+ (start-inferior-repl! buffer
+ environment
+ (evaluation-syntax-table environment)
+ false)
+ buffer))))))
(define (start-inferior-repl! buffer environment syntax-table message)
(set-buffer-major-mode! buffer (ref-mode-object inferior-repl))
- (let ((port (make-interface-port buffer)))
- (attach-buffer-interface-port! buffer port)
- (set-port/inferior-continuation! port command-reader-reset-continuation)
- (add-buffer-initialization!
- buffer
- (lambda ()
- (set-buffer-default-directory! buffer (working-directory-pathname))
- (within-inferior port
- (lambda ()
- (fluid-let ((*^G-interrupt-handler* cmdl-interrupt/abort-nearest))
- (with-input-from-port port
- (lambda ()
- (with-output-to-port port
- (lambda ()
- (repl/start (make-repl false
- port
- environment
- syntax-table
- false
- '()
- user-initial-prompt)
- message))))))))))
- buffer))
-
-(define (within-inferior port thunk)
- (without-interrupts
+ (set-buffer-default-directory! buffer (working-directory-pathname))
+ (add-buffer-initialization!
+ buffer
(lambda ()
- (set-run-light! port true)
- (update-screens! false)
- (call-with-current-continuation
- (lambda (continuation)
- (set-port/editor-continuation! port continuation)
- (let ((continuation (port/inferior-continuation port)))
- (set-port/inferior-continuation! port false)
- (within-continuation continuation thunk)))))))
-
-(define (within-editor port thunk)
- (call-with-current-continuation
- (lambda (continuation)
- (without-interrupts
+ (create-thread
(lambda ()
- (set-port/inferior-continuation! port continuation)
- (let ((continuation (port/editor-continuation port)))
- (set-port/editor-continuation! port false)
- (within-continuation continuation
- (lambda ()
- (set-run-light! port false)
- (thunk)))))))))
+ (let ((thread (current-thread)))
+ (detach-thread thread)
+ (let ((port (make-interface-port buffer thread)))
+ (register-interface-port! port)
+ (attach-buffer-interface-port! buffer port)
+ (with-input-from-port port
+ (lambda ()
+ (with-output-to-port port
+ (lambda ()
+ (repl/start (make-repl false
+ port
+ environment
+ syntax-table
+ false
+ '()
+ user-initial-prompt)
+ message))))))))))))
+
+(define (initialize-inferior-repls!)
+ (set! interface-ports '())
+ unspecific)
+
+(define (register-interface-port! port)
+ (set! interface-ports
+ (system-pair-cons (ucode-type weak-cons) port interface-ports))
+ unspecific)
+
+(define (accept-inferior-repl-output/unsafe)
+ (let loop ((ports interface-ports) (prev false) (output? false))
+ (if (null? ports)
+ output?
+ (let ((port (system-pair-car ports))
+ (next (system-pair-cdr ports)))
+ (cond ((not port)
+ (if prev
+ (system-pair-set-cdr! prev next)
+ (set! interface-ports next))
+ (loop next prev output?))
+ ((or (not (null? (port/output-strings port)))
+ (not (queue-empty? (port/output-queue port))))
+ (process-output-queue port)
+ (loop next ports true))
+ (else
+ (loop next ports output?)))))))
+
+(define interface-ports)
\f
-(define (invoke-inferior port result)
- (within-inferior port (lambda () result)))
-
-(define (within-editor-temporarily port thunk)
- (within-editor port
- (lambda ()
- (invoke-inferior port (thunk)))))
-
-(define (return-to-editor port level mode)
- (within-editor port
+(define (wait-for-input port level mode)
+ (enqueue-output-operation! port
+ (lambda (mark)
+ (if (not (group-start? mark))
+ (guarantee-newlines 2 mark))
+ (undo-boundary! mark)))
+ (signal-thread-event editor-thread
(lambda ()
- (process-output-queue port)
(maybe-switch-modes! port mode)
- (add-buffer-initialization! (port/buffer port)
- (lambda ()
- (local-set-variable! mode-line-process
- (list (string-append ": " (or level "???") " ")
- 'RUN-LIGHT))))
- (let ((mark (port/mark port)))
- (if (not (group-start? mark))
- (guarantee-newlines 2 mark))))))
+ (let ((buffer (port/buffer port)))
+ (define-variable-local-value! buffer
+ (ref-variable-object mode-line-process)
+ (list (string-append ": " (or level "???") " ") 'RUN-LIGHT))
+ (set-run-light! buffer false))))
+ (suspend-current-thread))
+
+(define (end-input-wait port)
+ (set-run-light! (port/buffer port) true)
+ (signal-thread-event (port/thread port) false))
(define (maybe-switch-modes! port mode)
(let ((buffer (port/buffer port)))
(define (attach-buffer-interface-port! buffer port)
(buffer-put! buffer 'INTERFACE-PORT port)
- (add-buffer-initialization! buffer
- (lambda ()
- (local-set-variable! comint-input-ring (port/input-ring port))
- (set-run-light! port false))))
+ (define-variable-local-value! buffer
+ (ref-variable-object comint-input-ring)
+ (port/input-ring port))
+ (set-run-light! buffer false))
+
+(define (set-run-light! buffer run?)
+ (define-variable-local-value! buffer (ref-variable-object run-light)
+ (if run? "run" "listen"))
+ (buffer-modeline-event! buffer 'RUN-LIGHT))
(define-integrable (buffer-interface-port buffer)
(buffer-get buffer 'INTERFACE-PORT))
-(define (set-run-light! port run?)
- (let ((buffer (port/buffer port)))
- (define-variable-local-value! buffer (ref-variable-object run-light)
- (if run? "run" "listen"))
- (buffer-modeline-event! buffer 'RUN-LIGHT)))
+(define (kill-buffer-inferior-repl buffer)
+ (let ((port (buffer-interface-port buffer)))
+ (if port
+ (begin
+ (signal-thread-event (port/thread port)
+ (lambda ()
+ (exit-current-thread unspecific)))
+ (buffer-remove! buffer 'INTERFACE-PORT)))))
\f
;;;; Modes
(define (interrupt-command interrupt)
(lambda ()
- (within-inferior (buffer-interface-port (current-buffer)) interrupt)))
+ (signal-thread-event (port/thread (buffer-interface-port (current-buffer)))
+ interrupt)))
(define-command inferior-repl-breakpoint
"Force the inferior REPL into a breakpoint."
(or (let ((cmdl (port/inferior-cmdl port)))
(and (repl? cmdl)
(repl/condition cmdl)))
- (port/inferior-continuation port)))))
+ (thread-continuation (port/thread port))))))
(buffer-put! browser 'INVOKE-CONTINUATION
(lambda (continuation arguments)
(if (not (buffer-alive? buffer))
(editor-error
"Can't continue; REPL buffer no longer exists!"))
- (select-buffer buffer)
- (within-continuation *command-continuation*
+ (signal-thread-event (port/thread port)
(lambda ()
- (within-inferior port
- (lambda ()
- (apply continuation arguments)))
- 'ABORT))))
+ ;; This call to UNBLOCK-THREAD-EVENTS is a kludge.
+ ;; The continuation should be able to decide whether
+ ;; or not to unblock, but that isn't so right now.
+ ;; As a default, having them unblocked is better
+ ;; than having them blocked.
+ (unblock-thread-events)
+ (apply continuation arguments)))))
(select-buffer browser))))))
(define (port/inferior-cmdl port)
- (call-with-current-continuation
- (lambda (continuation)
- (within-continuation (port/inferior-continuation port)
- (lambda ()
- (continuation (nearest-cmdl)))))))
+ (let ((thread (current-thread))
+ (cmdl false))
+ (signal-thread-event (port/thread port)
+ (lambda ()
+ (set! cmdl (nearest-cmdl))
+ (signal-thread-event thread false)))
+ (do () (cmdl)
+ (suspend-current-thread))
+ cmdl))
(define-command inferior-debugger-self-insert
"Send this character to the inferior debugger process."
()
(lambda ()
- (invoke-inferior (buffer-interface-port (current-buffer))
- (last-command-key))))
-\f
-;;;; Evaluation
+ (let ((port (buffer-interface-port (current-buffer))))
+ (set-port/command-char! port (last-command-key))
+ (end-input-wait port))))
(define (inferior-repl-eval-from-mark mark)
(inferior-repl-eval-region mark (forward-sexp mark 1 'ERROR)))
(begin
(enqueue! queue sexp)
(loop))))))))
- (let ((empty (cons '() '())))
- (let ((expression (dequeue! queue empty)))
- (if (not (eq? expression empty))
- (invoke-inferior port expression))))))))
+ (if (not (queue-empty? queue))
+ (end-input-wait port))))))
+\f
+;;;; Queue
+
+(define-integrable (make-queue)
+ (cons '() '()))
+
+(define-integrable (queue-empty? queue)
+ (null? (car queue)))
+
+(declare (integrate-operator enqueue!/unsafe dequeue!/unsafe))
+
+(define (enqueue!/unsafe queue object)
+ (let ((next (cons object '())))
+ (if (null? (cdr queue))
+ (set-car! queue next)
+ (set-cdr! (cdr queue) next))
+ (set-cdr! queue next)))
+
+(define (dequeue!/unsafe queue empty)
+ (let ((this (car queue)))
+ (if (null? this)
+ empty
+ (begin
+ (set-car! queue (cdr this))
+ (if (null? (cdr this))
+ (set-cdr! queue '()))
+ (car this)))))
+
+(define (enqueue! queue object)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (enqueue!/unsafe queue object)
+ (set-interrupt-enables! interrupt-mask)))
(define (dequeue! queue empty)
- (without-interrupts
- (lambda ()
- (if (queue-empty? queue)
- empty
- (dequeue!/unsafe queue)))))
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((value (dequeue!/unsafe queue empty)))
+ (set-interrupt-enables! interrupt-mask)
+ value)))
\f
;;;; Interface Port
-(define (make-interface-port buffer)
+(define (make-interface-port buffer thread)
(port/copy interface-port-template
(make-interface-port-state
+ thread
(mark-left-inserting-copy (buffer-end buffer))
(make-ring (ref-variable comint-input-ring-size))
(make-queue)
- (make-queue)
- '()
false
- false)))
+ (make-queue)
+ '())))
(define-structure (interface-port-state (conc-name interface-port-state/))
+ (thread false read-only true)
(mark false read-only true)
(input-ring false read-only true)
(expression-queue false read-only true)
+ command-char
(output-queue false read-only true)
- output-strings
- editor-continuation
- inferior-continuation)
+ output-strings)
+
+(define-integrable (port/thread port)
+ (interface-port-state/thread (port/state port)))
(define-integrable (port/mark port)
(interface-port-state/mark (port/state port)))
(define-integrable (port/expression-queue port)
(interface-port-state/expression-queue (port/state port)))
+(define-integrable (port/command-char port)
+ (interface-port-state/command-char (port/state port)))
+
+(define-integrable (set-port/command-char! port command-char)
+ (set-interface-port-state/command-char! (port/state port) command-char))
+
(define-integrable (port/output-queue port)
(interface-port-state/output-queue (port/state port)))
(define-integrable (set-port/output-strings! port strings)
(set-interface-port-state/output-strings! (port/state port) strings))
-
-(define-integrable (port/editor-continuation port)
- (interface-port-state/editor-continuation (port/state port)))
-
-(define-integrable (set-port/editor-continuation! port continuation)
- (set-interface-port-state/editor-continuation! (port/state port)
- continuation))
-
-(define-integrable (port/inferior-continuation port)
- (interface-port-state/inferior-continuation (port/state port)))
-
-(define-integrable (set-port/inferior-continuation! port continuation)
- (set-interface-port-state/inferior-continuation! (port/state port)
- continuation))
\f
;;; Output operations
(define (operation/write-char port char)
- (set-port/output-strings! port
- (cons (string char)
- (port/output-strings port))))
+ (enqueue-output-string! port (string char)))
(define (operation/write-substring port string start end)
- (set-port/output-strings! port
- (cons (substring string start end)
- (port/output-strings port))))
-
-(define (process-output-queue port)
- (synchronize-output port)
- (let ((queue (port/output-queue port))
- (mark (port/mark port)))
- (let loop ()
- (let ((operation (dequeue! queue false)))
- (if operation
- (begin
- (operation mark)
- (loop)))))))
+ (enqueue-output-string! port (substring string start end)))
(define (operation/fresh-line port)
(enqueue-output-operation! port guarantee-newline))
-(define (enqueue-output-operation! port operator)
- (synchronize-output port)
- (enqueue! (port/output-queue port) operator))
-
-(define (synchronize-output port)
- (without-interrupts
- (lambda ()
- (let ((strings (port/output-strings port)))
- (set-port/output-strings! port '())
- (if (not (null? strings))
- (enqueue! (port/output-queue port)
- (let ((string (apply string-append (reverse! strings))))
- (lambda (mark)
- (region-insert-string! mark string)))))))))
-
(define (operation/x-size port)
(let ((buffer (port/buffer port)))
(and buffer
(and (not (null? windows))
(apply min (map window-x-size windows)))))))
+(define (enqueue-output-string! port string)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (set-port/output-strings! port (cons string (port/output-strings port)))
+ (set! inferior-thread-changes? true)
+ (set-interrupt-enables! interrupt-mask)))
+
+(define (enqueue-output-operation! port operator)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((strings (port/output-strings port)))
+ (if (not (null? strings))
+ (begin
+ (set-port/output-strings! port '())
+ (enqueue!/unsafe
+ (port/output-queue port)
+ (let ((string (apply string-append (reverse! strings))))
+ (lambda (mark)
+ (region-insert-string! mark string)))))))
+ (enqueue!/unsafe (port/output-queue port) operator)
+ (set! inferior-thread-changes? true)
+ (set-interrupt-enables! interrupt-mask)))
+
+(define (process-output-queue port)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))
+ (mark (port/mark port)))
+ (let loop ()
+ (let ((operation (dequeue!/unsafe (port/output-queue port) false)))
+ (if operation
+ (begin
+ (operation mark)
+ (loop)))))
+ (let ((strings (port/output-strings port)))
+ (if (not (null? strings))
+ (begin
+ (set-port/output-strings! port '())
+ (do ((strings (reverse! strings) (cdr strings)))
+ ((null? strings))
+ (region-insert-string! mark (car strings))))))
+ (set-interrupt-enables! interrupt-mask)))
+
;;; Input operations
(define (operation/peek-char port)
parser-table
(read-expression port (number->string (nearest-cmdl/level))))
-(define (read-expression port level)
+(define read-expression
(let ((empty (cons '() '())))
- (let ((expression (dequeue! (port/expression-queue port) empty)))
- (if (eq? expression empty)
- (return-to-editor port level (ref-mode-object inferior-repl))
- expression))))
+ (lambda (port level)
+ (let loop ()
+ (let ((expression (dequeue! (port/expression-queue port) empty)))
+ (if (eq? expression empty)
+ (begin
+ (wait-for-input port level (ref-mode-object inferior-repl))
+ (loop))
+ expression))))))
\f
;;; Debugger
;;; Prompting
(define (operation/prompt-for-expression port prompt)
- (within-editor-temporarily port
- (lambda ()
- (process-output-queue port)
- (prompt-for-expression prompt))))
+ (unsolicited-prompt port prompt-for-expression prompt))
(define (operation/prompt-for-confirmation port prompt)
- (within-editor-temporarily port
- (lambda ()
- (process-output-queue port)
- (prompt-for-confirmation prompt))))
+ (unsolicited-prompt port prompt-for-confirmation prompt))
+
+(define unsolicited-prompt
+ (let ((unique (list false)))
+ (lambda (port procedure prompt)
+ (let ((value unique))
+ (signal-thread-event editor-thread
+ (lambda ()
+ ;; This is unlikely to work. We've got to get a better
+ ;; mechanism to handle this kind of stuff.
+ (override-next-command!
+ (lambda ()
+ (set! value
+ (cleanup-pop-up-buffers
+ (lambda ()
+ (let ((buffer (port/buffer port)))
+ (if (not (buffer-visible? buffer))
+ (pop-up-buffer buffer false)))
+ (procedure prompt))))
+ (signal-thread-event (port/thread port) false)))))
+ (do () ((not (eq? value unique)))
+ (suspend-current-thread))
+ value))))
(define (operation/prompt-for-command-expression port prompt)
(read-expression port (parse-command-prompt prompt)))
(define (operation/prompt-for-command-char port prompt)
- (return-to-editor port
- (parse-command-prompt prompt)
- (ref-mode-object inferior-debugger)))
+ (set-port/command-char! port false)
+ (let ((level (parse-command-prompt prompt))
+ (mode (ref-mode-object inferior-debugger)))
+ (let loop ()
+ (wait-for-input port level mode)
+ (or (port/command-char port)
+ (loop)))))
(define (parse-command-prompt prompt)
(and (re-match-string-forward (re-compile-pattern "\\([0-9]+\\) " false)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.15 1991/08/06 15:54:48 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.16 1992/02/04 04:03:19 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(let ((point (window-point window))
(y-point (window-point-y window)))
(let ((result
- (dynamic-wind
- (lambda () unspecific)
+ (unwind-protect
+ false
(lambda ()
(with-editor-interrupts-disabled
(lambda ()
initial-point))))))
(define (perform-search forward? regexp? text start)
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:re-compile-pattern)
(lambda (condition)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.35 1991/11/22 06:58:36 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.36 1992/02/04 04:03:23 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define named-keyboard-macros (make-string-table))
(define (with-keyboard-macro-disabled thunk)
- (define old-executing)
- (define old-defining)
- (define new-executing false)
- (define new-defining false)
- (dynamic-wind (lambda ()
- (set! old-executing
- (set! *executing-keyboard-macro?*
- (set! new-executing)))
- (set! old-defining
- (set! *defining-keyboard-macro?*
- (set! new-defining)))
- (if (not (eq? old-defining *defining-keyboard-macro?*))
- (keyboard-macro-event)))
- thunk
- (lambda ()
- (set! new-executing
- (set! *executing-keyboard-macro?*
- (set! old-executing)))
- (set! new-defining
- (set! *defining-keyboard-macro?*
- (set! old-defining)))
- (if (not (eq? new-defining *defining-keyboard-macro?*))
- (keyboard-macro-event)))))
+ (fluid-let ((*executing-keyboard-macro?* false)
+ (*defining-keyboard-macro?* false))
+ (unwind-protect keyboard-macro-event
+ thunk
+ keyboard-macro-event)))
(define (keyboard-macro-disable)
(set! *defining-keyboard-macro?* false)
(define (keyboard-macro-event)
(window-modeline-event! (current-window) 'KEYBOARD-MACRO-EVENT))
-\f
+
(define (keyboard-macro-read-key)
(let ((key (keyboard-macro-peek-key)))
(set! *keyboard-macro-position* (cdr *keyboard-macro-position*))
(*keyboard-macro-continuation*))
(define (loop n)
(set! *keyboard-macro-position* *macro)
- (if (call-with-current-continuation
+ (if (call-with-protected-continuation
(lambda (c)
(set! *keyboard-macro-continuation* c)
(command-reader)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.64 1992/01/09 17:55:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.65 1992/02/04 04:03:28 cph Exp $
Copyright (c) 1989-92 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 64 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 65 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.17 1992/01/27 11:04:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.18 1992/02/04 04:03:32 cph Exp $
;;;
;;; Copyright (c) 1991-92 Massachusetts Institute of Technology
;;;
(let ((channel (process-input-channel process))
(buffer (make-string 512)))
(and (channel-open? channel)
- (let ((n (channel-read channel buffer 0 512)))
- (and n
- (if (positive? n)
- (output-substring process buffer n)
- (begin
- (channel-close channel)
- false)))))))
-
-(define (notify-process-status-changes)
+ (let loop ((output? false))
+ (let ((n (channel-read channel buffer 0 512)))
+ (cond ((not n)
+ output?)
+ ((> n 0)
+ (loop (or (output-substring process buffer n) output?)))
+ (else
+ (channel-close channel)
+ output?)))))))
+
+(define (handle-process-status-changes)
(without-interrupts
(lambda ()
(let ((tick (subprocess-global-status-tick)))
\f
(define (synchronous-process-wait process input-region output-mark)
(if input-region
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:system-call-error)
(lambda (condition)
(channel (subprocess-output-channel process))
(buffer (make-string 512)))
(channel-nonblocking channel)
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:system-call-error)
(lambda (condition)
(mark (current-mark)))
(let ((swap? (mark< point mark))
(temp))
- (dynamic-wind
- (lambda () unspecific)
+ (unwind-protect
(lambda ()
(set! temp (temporary-buffer " *shell-output*"))
+ unspecific)
+ (lambda ()
(shell-command (make-region point mark)
(buffer-start temp)
directory
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.151 1992/01/19 04:47:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.152 1992/02/04 04:03:38 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(define (within-typein-edit thunk)
(let ((value
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(fluid-let ((typein-edit-continuation continuation)
(typein-edit-depth (1+ typein-edit-depth))
(typein-saved-windows
(cons (current-window)
typein-saved-windows)))
- (dynamic-wind
+ (unwind-protect
+ false
(lambda ()
(let ((window (typein-window)))
(select-window window)
(make-typein-buffer-name typein-edit-depth)))
(buffer-reset! (current-buffer))
(reset-command-prompt!)
- (window-clear-override-message! window)))
- thunk
+ (window-clear-override-message! window))
+ (thunk))
(lambda ()
(let ((window (typein-window)))
(select-window window)
(define (temporary-typein-message string)
(let ((point) (start) (end))
- (dynamic-wind (lambda ()
- (set! point (current-point))
- (set! end (buffer-end (current-buffer)))
- (set! start (mark-right-inserting end))
- (insert-string string start)
- (set-current-point! start))
- (lambda ()
- (sit-for 2000))
- (lambda ()
- (delete-string start end)
- (set-current-point! point)
- (set! point)
- (set! start)
- (set! end)
- unspecific))))
+ (unwind-protect (lambda ()
+ (set! point (current-point))
+ (set! end (buffer-end (current-buffer)))
+ (set! start (mark-right-inserting end))
+ unspecific)
+ (lambda ()
+ (insert-string string start)
+ (set-current-point! start)
+ (sit-for 2000))
+ (lambda ()
+ (delete-string start end)
+ (set-current-point! point)))))
\f
;;;; Character Prompts
(fluid-let ((execute-extended-keys? false))
(dispatch-on-command command)))
chars))))))))))))
-
+\f
;;;; Confirmation Prompts
(define (prompt-for-confirmation? prompt)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.60 1991/10/25 00:03:06 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.61 1992/02/04 04:03:48 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define (preserving-match-data thunk)
(let ((group unspecific)
(marks unspecific))
- (dynamic-wind
+ (unwind-protect
(lambda ()
(set! group (object-unhash match-group))
(set! marks
(mark-temporary! mark)
index))))
marks))
- (set! group unspecific)
- (set! marks unspecific)
unspecific))))
(define-integrable (syntax-table-argument syntax-table)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regops.scm,v 1.84 1991/08/16 20:29:22 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regops.scm,v 1.85 1992/02/04 04:03:52 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define (with-region-clipped! new-region thunk)
(let ((group (region-group new-region))
(old-region))
- (dynamic-wind (lambda ()
- (set! old-region (group-region group))
- (region-clip! new-region)
- (set! new-region)
- unspecific)
- thunk
- (lambda ()
- (set! new-region (group-region group))
- (region-clip! old-region)
- (set! old-region)
- unspecific))))
+ (unwind-protect (lambda ()
+ (set! old-region (group-region group))
+ (region-clip! new-region)
+ (set! new-region)
+ unspecific)
+ thunk
+ (lambda ()
+ (region-clip! old-region)))))
(define (without-group-clipped! group thunk)
(let ((old-region))
- (dynamic-wind (lambda ()
- (set! old-region (group-region group))
- (group-widen! group))
- thunk
- (lambda ()
- (region-clip! old-region)
- (set! old-region)
- unspecific))))
+ (unwind-protect (lambda ()
+ (set! old-region (group-region group))
+ (group-widen! group))
+ thunk
+ (lambda ()
+ (region-clip! old-region)))))
(define (group-clipped? group)
(not (and (zero? (group-start-index group))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.13 1992/01/23 22:02:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.14 1992/02/04 04:03:57 cph Exp $
;;;
;;; Copyright (c) 1991-92 Massachusetts Institute of Technology
;;;
(outside-end)
(inside-start (mark-permanent! (group-absolute-start group)))
(inside-end (mark-permanent! (group-absolute-end group))))
- (dynamic-wind (lambda ()
- (set! outside-ro (group-read-only? group))
- (set! outside-start (group-start-mark group))
- (set! outside-end (group-end-mark group))
- (vector-set! group group-index:read-only? inside-ro)
- (vector-set! group group-index:start-mark inside-start)
- (vector-set! group group-index:end-mark inside-end))
- thunk
- (lambda ()
- (set! inside-ro (group-read-only? group))
- (set! inside-start (group-start-mark group))
- (set! inside-end (group-end-mark group))
- (vector-set! group group-index:read-only? outside-ro)
- (vector-set! group group-index:start-mark outside-start)
- (vector-set! group group-index:end-mark outside-end)))))
+ (unwind-protect (lambda ()
+ (set! outside-ro (group-read-only? group))
+ (set! outside-start (group-start-mark group))
+ (set! outside-end (group-end-mark group))
+ (vector-set! group group-index:read-only? inside-ro)
+ (vector-set! group group-index:start-mark inside-start)
+ (vector-set! group group-index:end-mark inside-end))
+ thunk
+ (lambda ()
+ (set! inside-ro (group-read-only? group))
+ (set! inside-start (group-start-mark group))
+ (set! inside-end (group-end-mark group))
+ (vector-set! group group-index:read-only? outside-ro)
+ (vector-set! group group-index:start-mark outside-start)
+ (vector-set! group group-index:end-mark outside-end)))))
\f
;;;; Constants
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.94 1991/07/09 22:52:18 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.95 1992/02/04 04:04:04 cph Exp $
;;;
-;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(without-interrupts
(lambda ()
(let ((old-flag))
- (dynamic-wind (lambda ()
- (set! old-flag (screen-in-update? screen))
- (set-screen-in-update?! screen true))
- (lambda ()
- ((screen-operation/wrap-update! screen)
- screen
- (lambda ()
- (and (thunk)
- (screen-update screen display-style)))))
- (lambda ()
- (set-screen-in-update?! screen old-flag)))))))
+ (unwind-protect (lambda ()
+ (set! old-flag (screen-in-update? screen))
+ (set-screen-in-update?! screen true))
+ (lambda ()
+ ((screen-operation/wrap-update! screen)
+ screen
+ (lambda ()
+ (and (thunk)
+ (screen-update screen display-style)))))
+ (lambda ()
+ (set-screen-in-update?! screen old-flag)))))))
(define (screen-update screen force?)
;; Update the actual terminal screen based on the data in `new-matrix'.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.8 1991/11/04 20:52:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.9 1992/02/04 04:04:10 cph Exp $
-Copyright (c) 1991 Massachusetts Institute of Technology
+Copyright (c) 1991-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(string->number string)))
\f
(define (shell-process-cd filename)
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:editor-error)
(lambda (condition)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.79 1991/11/04 21:55:39 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.80 1992/02/04 04:04:15 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(old-text-end)
(new-text-start (make-permanent-mark group start false))
(new-text-end (make-permanent-mark group end true)))
- (dynamic-wind (lambda ()
- (set! old-text-start (group-start-mark group))
- (set! old-text-end (group-end-mark group))
- (vector-set! group group-index:start-mark new-text-start)
- (vector-set! group group-index:end-mark new-text-end))
- thunk
- (lambda ()
- (set! new-text-start (group-start-mark group))
- (set! new-text-end (group-end-mark group))
- (vector-set! group group-index:start-mark old-text-start)
- (vector-set! group group-index:end-mark old-text-end)))))
+ (unwind-protect (lambda ()
+ (set! old-text-start (group-start-mark group))
+ (set! old-text-end (group-end-mark group))
+ (vector-set! group group-index:start-mark new-text-start)
+ (vector-set! group group-index:end-mark new-text-end))
+ thunk
+ (lambda ()
+ (set! new-text-start (group-start-mark group))
+ (set! new-text-end (group-end-mark group))
+ (vector-set! group group-index:start-mark old-text-start)
+ (vector-set! group group-index:end-mark old-text-end)))))
(define (group-text-clip group start end)
(let ((start (make-permanent-mark group start false))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.9 1991/11/26 08:03:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.10 1992/02/04 04:04:21 cph Exp $
-Copyright (c) 1990-91 Massachusetts Institute of Technology
+Copyright (c) 1990-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(tf-teleray description)
(tf-underscore description))))
\f
-(define-integrable input-buffer-size 16)
-
-(define (get-console-input-operations screen)
- screen ;ignored
+(define (get-console-input-operations)
(let ((channel (input-port/channel console-input-port))
(string (make-string input-buffer-size))
(start input-buffer-size)
- (end input-buffer-size))
+ (end input-buffer-size)
+ (pending-event false))
(let ((fill-buffer
- (lambda (block?)
- (let ((eof (lambda () "Reached EOF in keyboard input.")))
- (if (fix:= end 0) (eof))
- (if block?
+ (lambda (type)
+ (let loop ()
+ (if (eq? type 'BLOCKING)
(channel-blocking channel)
(channel-nonblocking channel))
(let ((n
- (channel-select-then-read channel
- string 0 input-buffer-size)))
- (if (or (not n) (eq? true n))
- n
- (begin
- (if (fix:= n 0) (eof))
- (set! start 0)
- (set! end n)
- (if transcript-port
- (write-string (substring string 0 n)
- transcript-port))
- 'CHAR)))))))
+ (channel-select-then-read
+ channel string 0 input-buffer-size))
+ (maybe-process-changes
+ (lambda (event)
+ (if (eq? type 'NO-PROCESSING)
+ (begin
+ (set! pending-event event)
+ true)
+ (begin
+ (process-change-event event)
+ (loop))))))
+ (cond ((not n)
+ (if (eq? type 'BLOCKING)
+ (error "#F returned from blocking read"))
+ false)
+ ((fix:> n 0)
+ (set! start 0)
+ (set! end n)
+ (if transcript-port
+ (output-port/write-substring
+ transcript-port string 0 n))
+ true)
+ ((or (fix:= n event:process-output)
+ (fix:= n event:process-status))
+ (maybe-process-changes n))
+ ((fix:= n event:interrupt)
+ (if inferior-thread-changes?
+ (maybe-process-changes n)
+ (loop)))
+ ((fix:= n 0)
+ (error "Reached EOF in keyboard input."))
+ (else
+ (error "Illegal return value:" n)))))))
+ (process-pending-event
+ (lambda ()
+ (let ((event pending-event))
+ (set! pending-event false)
+ (process-change-event event)))))
(values
(lambda () ;halt-update?
- (if (fix:< start end)
- true
- (fill-buffer false)))
+ (or pending-event
+ (fix:< start end)
+ (fill-buffer 'NO-PROCESSING)))
(lambda () ;char-ready?
- (if (fix:< start end)
- true
- (eq? 'CHAR (fill-buffer false))))
+ (if pending-event (process-pending-event))
+ (or (fix:< start end)
+ (fill-buffer 'NONBLOCKING)))
(lambda () ;peek-char
- (and (or (fix:< start end) (eq? 'CHAR (fill-buffer true)))
- (string-ref string start)))
+ (if pending-event (process-pending-event))
+ (if (not (fix:< start end)) (fill-buffer 'BLOCKING))
+ (string-ref string start))
(lambda () ;read-char
- (and (or (fix:< start end) (eq? 'CHAR (fill-buffer true)))
- (let ((char (string-ref string start)))
- (set! start (fix:+ start 1))
- char)))))))
+ (if pending-event (process-pending-event))
+ (if (not (fix:< start end)) (fill-buffer 'BLOCKING))
+ (let ((char (string-ref string start)))
+ (set! start (fix:+ start 1))
+ char))))))
\f
+(define-integrable input-buffer-size 16)
+(define-integrable event:process-output -2)
+(define-integrable event:process-status -3)
+(define-integrable event:interrupt -4)
+
+(define (process-change-event event)
+ (if (cond ((fix:= event event:process-output)
+ (accept-process-output))
+ ((fix:= event event:process-status)
+ (handle-process-status-changes))
+ ((fix:= event event:interrupt)
+ (accept-thread-output))
+ (else
+ (error "Illegal change event:" event)))
+ (update-screens! false)))
+
(define (signal-interrupt!)
- ;; (editor-beep) ; kbd beeps by itself
- (temporary-message "Quit")
- (^G-signal))
+ (signal-thread-event editor-thread
+ (lambda ()
+ ;; (editor-beep) ; kbd beeps by itself
+ (temporary-message "Quit")
+ (^G-signal))))
(define (with-console-interrupts-enabled thunk)
(with-console-interrupt-state 2 thunk))
(with-console-interrupt-state 0 thunk))
(define (with-console-interrupt-state state thunk)
- (let ((outside)
- (inside state))
- (dynamic-wind (lambda ()
- (set! outside (tty-get-interrupt-enables))
- (tty-set-interrupt-enables inside))
- thunk
- (lambda ()
- (set! inside (tty-get-interrupt-enables))
- (tty-set-interrupt-enables outside)))))
+ (let ((outside))
+ (unwind-protect (lambda ()
+ (set! outside (tty-get-interrupt-enables))
+ (tty-set-interrupt-enables state))
+ thunk
+ (lambda ()
+ (tty-set-interrupt-enables outside)))))
(define console-display-type)
(define console-description)
false
console-available?
make-console-screen
- get-console-input-operations
+ (lambda (screen)
+ screen
+ (get-console-input-operations))
with-console-grabbed
with-console-interrupts-enabled
with-console-interrupts-disabled))
`((INTERRUPT/ABORT-TOP-LEVEL ,signal-interrupt!))))))
(define (bind-console-state state receiver)
- (let ((outside-state)
- (inside-state state))
- (dynamic-wind (lambda ()
- (set! outside-state (console-state))
- (if inside-state
- (set-console-state! inside-state))
- (set! inside-state false)
- unspecific)
- (lambda ()
- (receiver (lambda () outside-state)))
- (lambda ()
- (set! inside-state (console-state))
- (set-console-state! outside-state)
- (set! outside-state false)
- unspecific))))
+ (let ((outside-state))
+ (unwind-protect (lambda ()
+ (set! outside-state (console-state))
+ (if state
+ (set-console-state! state)))
+ (lambda ()
+ (receiver (lambda () outside-state)))
+ (lambda ()
+ (set-console-state! outside-state)))))
(define (console-state)
(vector (channel-state (input-port/channel console-input-port))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.48 1991/05/02 01:14:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.49 1992/02/04 04:04:28 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
next-record ; position in vector
chars ; string of characters
next-char ; position in string
+ last-undo-record
+ last-undone-record
+ last-undone-char
+
+ ;; This counts the total number of records that have been undone,
+ ;; so that it can be compared to the total number of records, to
+ ;; determine if we have run out of records.
+ number-records-undone
+
+ ;; This says how many chars of undo are left. It is initialized by
+ ;; the Undo command to the length of the chars string, and used,
+ ;; like NUMBER-RECORDS-UNDONE, to determine if we have run out of
+ ;; undo data. This, however, is kept up to date by NEW-UNDO
+ ;; because there is no NOT-UNDOABLE boundary in the chars array to
+ ;; tell us where the chars end.
+ number-chars-left
)
(define-structure (undo-record
(vector-set! records index new-record)
new-record)))
-(define last-undo-group false)
-(define last-undo-record false)
-
(define (enable-group-undo! group)
(without-interrupts
(lambda ()
records)
0
(string-allocate initial-undo-chars)
+ 0
+ false
+ false
+ false
+ 0
0)))))
(define (disable-group-undo! group)
(set-group-undo-data! group false))
(define (with-group-undo-disabled group thunk)
- (dynamic-wind (lambda () (disable-group-undo! group))
- thunk
- (if (group-undo-data group)
- (lambda () (enable-group-undo! group))
- (lambda () unspecific))))
+ (unwind-protect (lambda () (disable-group-undo! group))
+ thunk
+ (if (group-undo-data group)
+ (lambda () (enable-group-undo! group))
+ (lambda () unspecific))))
\f
(define (new-undo! undo-data type group start length)
+ group
(let ((records (undo-data-records undo-data))
(index (undo-data-next-record undo-data)))
(let ((undo-record (undo-records-ref records index)))
(set-undo-record-type! undo-record type)
(set-undo-record-start! undo-record start)
(set-undo-record-length! undo-record length)
- (set! last-undo-record undo-record))
+ (set-undo-data-last-undo-record! undo-data undo-record))
(let ((next (+ index 1)))
(cond ((< next (vector-length records))
(mark-not-undoable! (undo-records-ref records next))
(vector-set! new-records (- maximum-undo-records 1) max-record)
(set-undo-data-records! undo-data new-records)
(set-undo-data-next-record! undo-data next))))))
- (set! last-undo-group group)
(if (not (eq? 'BOUNDARY type))
- (set! last-undone-record -1)))
+ (set-undo-data-last-undone-record! undo-data -1)))
(define-integrable (mark-not-undoable! record)
(set-undo-record-type! record 'NOT-UNDOABLE))
(cond ((> room needed)
(substring-move-right! string start end chars i)
(set-undo-data-next-char! undo-data (+ i needed))
- (set! number-chars-left (- number-chars-left needed)))
+ (set-undo-data-number-chars-left!
+ undo-data
+ (- (undo-data-number-chars-left undo-data) needed)))
((= room needed)
(substring-move-right! string start end chars i)
(set-undo-data-next-char! undo-data 0)
- (set! number-chars-left (- number-chars-left needed)))
+ (set-undo-data-number-chars-left!
+ undo-data
+ (- (undo-data-number-chars-left undo-data) needed)))
((< (string-length chars) maximum-undo-chars)
(let ((new-chars (string-allocate maximum-undo-chars)))
(substring-move-right! chars 0 i new-chars 0)
(set-undo-data-chars! undo-data new-chars))
- (set! number-chars-left
+ (set-undo-data-number-chars-left!
+ undo-data
(+ (- maximum-undo-chars (string-length chars))
- number-chars-left))
+ (undo-data-number-chars-left undo-data)))
(loop start))
(else
(let ((new-start (+ start room)))
(substring-move-right! string start new-start chars i)
(set-undo-data-next-char! undo-data 0)
- (set! number-chars-left (- number-chars-left room))
- (loop new-start))))))))
+ (set-undo-data-number-chars-left!
+ undo-data
+ (- (undo-data-number-chars-left undo-data) room))
+ (loop new-start)))))))
+ unspecific)
\f
;;;; External Recording Hooks
(let ((undo-data (group-undo-data group)))
(if undo-data
(begin
- (if (not (eq? group last-undo-group))
- (begin
- (undo-mark-previous! undo-data
- 'BOUNDARY
- group
- (mark-index (group-point group)))
- (set! last-undo-record false)))
(undo-mark-modified! group start undo-data)
- (let ((last last-undo-record)
+ (let ((last (undo-data-last-undo-record undo-data))
(length (- end start)))
(if (and last
(eq? 'DELETE (undo-record-type last))
(let ((undo-data (group-undo-data group)))
(if undo-data
(begin
- (if (not (eq? group last-undo-group))
- (begin
- (undo-mark-previous! undo-data
- 'BOUNDARY
- group
- (mark-index (group-point group)))
- (set! last-undo-record false)))
(undo-mark-modified! group start undo-data)
- (let ((last last-undo-record)
+ (let ((last (undo-data-last-undo-record undo-data))
(length (- end start)))
(if (and last
(eq? 'INSERT (undo-record-type last))
group
(mark-index point))))))))
+(define (undo-leave-window! window)
+ ;; Assumes that interrupts are disabled.
+ (let ((point (window-point window)))
+ (let ((group (mark-group point)))
+ (let ((undo-data (group-undo-data group)))
+ (if undo-data
+ (begin
+ (undo-mark-previous! undo-data
+ 'BOUNDARY
+ group
+ (mark-index point))
+ (set-undo-data-last-undone-record! undo-data -1)))))))
+
(define (undo-done! point)
(without-interrupts
(lambda ()
\f
;;;; Undo Command
-;;; These keep track of the state of the Undo command, so that
-;;; subsequent invocations know where to start from.
-(define last-undone-record)
-(define last-undone-char)
-
-;;; This counts the total number of records that have been undone, so
-;;; that it can be compared to the total number of records, to
-;;; determine if we have run out of records.
-(define number-records-undone)
-
-;;; This says how many chars of undo are left. It is initialized by
-;;; the Undo command to the length of the chars string, and used, like
-;;; NUMBER-RECORDS-UNDONE, to determine if we have run out of undo
-;;; data. This, however, is kept up to date by NEW-UNDO because there
-;;; is no NOT-UNDOABLE boundary in the chars array to tell us where
-;;; the chars end.
-(define number-chars-left 0)
-
;;; Some error messages:
(define cant-undo-more
(lambda ()
(command-message-receive undo-command-tag
(lambda ()
- (if (= -1 last-undone-record)
+ (if (= -1 (undo-data-last-undone-record undo-data))
(editor-error cant-undo-more)))
(lambda ()
- (set! number-records-undone 0)
- (set! number-chars-left
- (string-length (undo-data-chars undo-data)))
- (set! last-undone-record
- (undo-data-next-record undo-data))
- (set! last-undone-char (undo-data-next-char undo-data))
+ (set-undo-data-number-records-undone! undo-data 0)
+ (set-undo-data-number-chars-left!
+ undo-data
+ (string-length (undo-data-chars undo-data)))
+ (set-undo-data-last-undone-record!
+ undo-data
+ (undo-data-next-record undo-data))
+ (set-undo-data-last-undone-char!
+ undo-data
+ (undo-data-next-char undo-data))
;; This accounts for the boundary that is inserted
;; just before this command is called.
(set! argument (+ argument 1))
\f
(define (count-records-to-undo undo-data argument)
(let ((records (undo-data-records undo-data)))
- (let find-nth-boundary ((argument argument) (i last-undone-record) (n 0))
+ (let find-nth-boundary
+ ((argument argument)
+ (i (undo-data-last-undone-record undo-data))
+ (n 0))
(let find-boundary ((i i) (n n) (any-records? false))
(let ((i (- (if (= i 0) (vector-length records) i) 1))
- (n (+ n 1)))
- (set! number-records-undone (+ number-records-undone 1))
- (if (> number-records-undone (vector-length records))
- (editor-error no-more-undo))
+ (n (+ n 1))
+ (n-undone (+ (undo-data-number-records-undone undo-data) 1)))
+ (set-undo-data-number-records-undone! undo-data n-undone)
+ (if (> n-undone (vector-length records)) (editor-error no-more-undo))
(case (undo-record-type (vector-ref records i))
((BOUNDARY)
(if (= argument 1)
;; Treat this as if it were a BOUNDARY record.
n)
((INSERT)
- (set! number-chars-left
- (- number-chars-left
- (undo-record-length (vector-ref records i))))
- (if (< number-chars-left 0)
- (editor-error no-more-undo))
- (find-boundary i n true))
+ (let ((n-left
+ (- (undo-data-number-chars-left undo-data)
+ (undo-record-length (vector-ref records i)))))
+ (set-undo-data-number-chars-left! undo-data n-left)
+ (if (< n-left 0)
+ (editor-error no-more-undo))
+ (find-boundary i n true)))
(else
(find-boundary i n true))))))))
(do ((n n (- n 1)))
((= n 0))
(let ((ir
- (- (if (= last-undone-record 0)
- (vector-length records)
- last-undone-record)
+ (- (let ((record (undo-data-last-undone-record undo-data)))
+ (if (= record 0) (vector-length records) record))
1)))
(let ((record (vector-ref records ir)))
(let ((start (undo-record-start record)))
(set-current-point! (make-mark group start)))
((INSERT)
(set-current-point! (make-mark group start))
- (let ((ic (- last-undone-char (undo-record-length record))))
+ (let* ((last-undone-char (undo-data-last-undone-char undo-data))
+ (ic (- last-undone-char (undo-record-length record))))
(if (>= ic 0)
(begin
(group-insert-substring! group start
chars ic last-undone-char)
- (set! last-undone-char ic))
+ (set-undo-data-last-undone-char! undo-data ic))
(let ((l (string-length chars)))
(let ((ic* (+ l ic)))
(group-insert-substring! group start chars ic* l)
(group-insert-substring! group (- start ic)
chars 0 last-undone-char)
- (set! last-undone-char ic*))))))
+ (set-undo-data-last-undone-char! undo-data ic*))))))
((UNMODIFY)
(if (eqv? (undo-record-length record)
(buffer-modification-time buffer))
unspecific)
(else
(error "Losing undo record type" (undo-record-type record))))))
- (set! last-undone-record ir)))))
\ No newline at end of file
+ (set-undo-data-last-undone-record! undo-data ir)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.26 1991/11/04 20:52:22 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.27 1992/02/04 04:04:34 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(make-char (char-code char) 0))
(define (catch-file-errors if-error thunk)
- (call-with-current-continuation
+ (call-with-protected-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:file-error
condition-type:port-error)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.108 1991/10/11 03:33:27 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.109 1992/02/04 04:04:41 cph Exp $
;;;
-;;; Copyright (c) 1987, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1987, 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(fluid-let ((*previous-popped-up-window* (object-hash false))
(*previous-popped-up-buffer* (object-hash false))
(*minibuffer-scroll-window* (object-hash false)))
- (dynamic-wind (lambda () unspecific)
- thunk
- (lambda () (kill-pop-up-buffer false)))))
+ (unwind-protect false
+ thunk
+ (lambda () (kill-pop-up-buffer false)))))
(define (kill-pop-up-buffer error-if-none?)
(let ((window (object-unhash *previous-popped-up-window*)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.24 1991/11/26 08:03:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.25 1992/02/04 04:04:50 cph Exp $
;;;
-;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1989-92 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(declare (usual-integrations))
\f
(define-primitives
- (clear-interrupts! 1)
- (real-timer-clear 0)
- (real-timer-set 2)
(x-open-display 1)
(x-close-all-displays 0)
(x-close-display 1)
(xterm-write-substring! 7)
(xterm-x-size 1)
(xterm-y-size 1))
+
+;; These constants must match "microcode/x11base.c"
+(define-integrable event:process-output -2)
+(define-integrable event:process-status -3)
+(define-integrable event:interrupt -4)
+(define-integrable event-type:button-down 0)
+(define-integrable event-type:button-up 1)
+(define-integrable event-type:configure 2)
+(define-integrable event-type:enter 3)
+(define-integrable event-type:focus-in 4)
+(define-integrable event-type:focus-out 5)
+(define-integrable event-type:key-press 6)
+(define-integrable event-type:leave 7)
+(define-integrable event-type:motion 8)
+(define-integrable event-type:expose 9)
+(define-integrable number-of-event-types 10)
+
+;; This mask contains button-down, button-up, configure, focus-in,
+;; key-press, and expose.
+(define-integrable event-mask #x257)
\f
(define-structure (xterm-screen-state
(constructor make-xterm-screen-state (xterm display))
(loop (cdr screens))))))
\f
(define (xterm-screen/wrap-update! screen thunk)
- (dynamic-wind
+ (unwind-protect
(lambda ()
(xterm-enable-cursor (screen-xterm screen) false))
thunk
\f
;;;; Event Handling
-(define-integrable control-bucky-bit 2)
-
(define (get-xterm-input-operations)
(let ((display x-display-data)
(queue x-display-events)
- (bucky-bits 0)
- (keysym false)
- (special-key? false)
+ (pending-key false)
(string false)
(start 0)
(end 0)
(pending-event false))
- (let ((process-key-press-event
+ (let ((get-next-event
+ (lambda (time-limit)
+ (if pending-event
+ (let ((event pending-event))
+ (set! pending-event false)
+ event)
+ (read-event queue display time-limit))))
+ (process-key-press-event
(lambda (event)
(set! string (vector-ref event 2))
- (set! bucky-bits (vector-ref event 3))
- (set! keysym (vector-ref event 4))
- (set! start 0)
(set! end (string-length string))
- (set! special-key? (zero? end))
- (if (and signal-interrupts?
- (not special-key?))
- (let ((i (string-find-previous-char string #\BEL)))
- (if i
- (begin
- (set! start (fix:+ i 1))
- (signal-interrupt!))))))))
- (let ((get-next-event
- (lambda (time-limit)
- (if pending-event
- (let ((event pending-event))
- (set! pending-event false)
- event)
- (read-event queue display time-limit)))))
- (let ((guarantee-input
- (lambda ()
- (let loop ()
- (let ((event (get-next-event false)))
- (cond ((not event)
- (error "#F returned from blocking read"))
- ((eq? true event)
- false)
- ((fix:= event-type:key-press
- (vector-ref event 0))
- (process-key-press-event event)
- (if (or special-key? (fix:< start end))
- true
- (loop)))
- (else
- (process-special-event event)
- (loop)))))))
- (apply-bucky-bits
- (lambda (character)
- (if (and (zero? start)
- (= end 1))
- (make-char (char-code character)
- (fix:andc bucky-bits
- control-bucky-bit))
- character))))
- (values
- (lambda () ;halt-update?
- (if (or special-key? (fix:< start end) pending-event)
- true
- (let ((event (get-next-event 0)))
- (and event
- (begin
- (set! pending-event event)
- true)))))
- (lambda () ;char-ready?
- (if (or special-key? (fix:< start end))
- true
- (let loop ()
- (let ((event (get-next-event 0)))
- (cond ((or (not event) (eq? true event))
+ (set! start end)
+ (cond ((fix:= end 0)
+ (set! pending-key
+ (x-make-special-key (vector-ref event 4)
+ (vector-ref event 3)))
+ true)
+ ((fix:= end 1)
+ (let ((char
+ (if (or (fix:= (vector-ref event 3) 0)
+ (fix:= (vector-ref event 3) 2))
+ (string-ref string 0)
+ (make-char (char-code (string-ref string 0))
+ (fix:andc (vector-ref event 3) 2)))))
+ (if (and signal-interrupts? (char=? char #\BEL))
+ (begin
+ (set! pending-key false)
+ (signal-interrupt!)
false)
- ((fix:= event-type:key-press (vector-ref event 0))
- (process-key-press-event event)
- (if (or special-key? (fix:< start end))
- true
- (loop)))
+ (begin
+ (set! pending-key char)
+ true))))
+ (else
+ (set! start 0)
+ (set! pending-key false)
+ (if signal-interrupts?
+ (let ((i (string-find-previous-char string #\BEL)))
+ (if i
+ (begin
+ (set! start (fix:+ i 1))
+ (signal-interrupt!)
+ (fix:< start end))
+ true))
+ true))))))
+ (let ((read-until-key
+ (lambda (time-limit)
+ (let loop ()
+ (let ((event (get-next-event time-limit)))
+ (cond ((not event)
+ (if (not time-limit)
+ (error "#F returned from blocking read"))
+ false)
+ ((not (vector? event))
+ (process-change-event event)
+ (loop))
+ ((fix:= event-type:key-press (vector-ref event 0))
+ (or (process-key-press-event event) (loop)))
+ (else
+ (process-special-event event)
+ (loop))))))))
+ (values
+ (lambda () ;halt-update?
+ (or pending-key
+ (fix:< start end)
+ pending-event
+ (let ((event (get-next-event 0)))
+ (if event (set! pending-event event))
+ event)))
+ (lambda () ;char-ready?
+ (or pending-key
+ (fix:< start end)
+ (read-until-key 0)))
+ (letrec ((peek-char
+ (lambda ()
+ (or pending-key
+ (if (fix:< start end)
+ (string-ref string start)
+ (begin
+ (read-until-key false)
+ (peek-char)))))))
+ peek-char)
+ (letrec ((read-char
+ (lambda ()
+ (cond (pending-key
+ => (lambda (key)
+ (set! pending-key false)
+ key))
+ ((fix:< start end)
+ (let ((char (string-ref string start)))
+ (set! start (fix:+ start 1))
+ char))
(else
- (process-special-event event)
- (loop)))))))
- (lambda () ;peek-char
- (and (or special-key? (fix:< start end) (guarantee-input))
- (if special-key?
- (x-make-special-key keysym bucky-bits)
- (apply-bucky-bits (string-ref string start)))))
- (lambda () ;read-char
- (and (or special-key? (fix:< start end) (guarantee-input))
- (if special-key?
- (begin (set! special-key? false)
- (x-make-special-key keysym bucky-bits))
- (let ((char
- (apply-bucky-bits
- (string-ref string start))))
- (set! start (fix:+ start 1))
- char))))))))))
+ (read-until-key false)
+ (read-char))))))
+ read-char))))))
\f
(define (read-event queue display time-limit)
- ;; If no time-limit, we're reading from the keyboard. In that case,
- ;; make sure that asynchronous input is reenabled afterwards.
- (let ((reenable? (if time-limit allow-asynchronous-input? true)))
- (set! allow-asynchronous-input? false)
+ (unwind-protect
+ (lambda ()
+ (lock-thread-mutex event-stream-mutex))
+ (lambda ()
+ (let loop ()
+ (let ((event
+ (if (queue-empty? queue)
+ (if (and (not time-limit)
+ (other-running-threads?))
+ ;; Don't block process if any other threads
+ ;; want to run. Mutex will stop previewer.
+ (or (x-display-process-events display 0)
+ (begin
+ (yield-current-thread)
+ event:interrupt))
+ (x-display-process-events display time-limit))
+ (dequeue!/unsafe queue))))
+ (cond ((eq? event event:interrupt)
+ (if inferior-thread-changes? event (loop)))
+ ((and (vector? event)
+ (fix:= (vector-ref event 0) event-type:expose))
+ (process-expose-event event)
+ (loop))
+ (else event)))))
+ (lambda ()
+ (unlock-thread-mutex event-stream-mutex))))
+
+(define (preview-event-stream)
+ (detach-thread (current-thread))
+ (do () (false)
+ (lock-thread-mutex event-stream-mutex)
(let loop ()
- (let ((event
- (if (queue-empty? queue)
- (x-display-process-events display time-limit)
- (dequeue!/unsafe queue))))
- (if (and (vector? event)
- (fix:= event-type:expose (vector-ref event 0)))
- (begin
- (process-expose-event event)
- (loop))
- (begin
- (set! allow-asynchronous-input? reenable?)
- event))))))
-
-(define (timer-interrupt-handler)
- (if (and allow-asynchronous-input?
- (buffer-events x-display-events x-display-data signal-interrupts?))
- (begin
- ;; Don't allow further asynchronous input until the command
- ;; loop has restarted (actually, until next attempt to read
- ;; from the keyboard).
- (set! allow-asynchronous-input? false)
- (signal-interrupt!))))
-
-(define allow-asynchronous-input?)
-
-(define (buffer-events queue display allow-interrupts?)
- (let loop ()
- (let ((event (x-display-process-events display 0)))
- (cond ((not event)
- false)
- ((eq? true event)
- (accept-process-output)
- (notify-process-status-changes)
- (loop))
- ((and allow-interrupts?
- (fix:= event-type:key-press (vector-ref event 0))
- (string-find-next-char (vector-ref event 2) #\BEL))
- ;; Flush keyboard and mouse events from the input
- ;; queue. Other events are harmless and must be
- ;; processed regardless.
- (do ((events
- (let loop ()
- (if (queue-empty? queue)
- '()
- (let ((event (dequeue!/unsafe queue)))
- (if (let ((type (vector-ref event 0)))
- (or (fix:= type event-type:button-down)
- (fix:= type event-type:button-up)
- (fix:= type event-type:key-press)
- (fix:= type event-type:motion)))
- (loop)
- (cons event (loop))))))
- (cdr events)))
- ((null? events))
- (enqueue!/unsafe queue (car events)))
- true)
- (else
- (enqueue!/unsafe queue event)
- (loop))))))
+ (let ((event (x-display-process-events x-display-data 0)))
+ (cond ((not (vector? event))
+ (if (and event
+ (or (not (eq? event:interrupt event))
+ inferior-thread-changes?)
+ (not (queued?/unsafe x-display-events event)))
+ (enqueue!/unsafe x-display-events event)))
+ ((and signal-interrupts?
+ (fix:= event-type:key-press (vector-ref event 0))
+ (string-find-next-char (vector-ref event 2) #\BEL))
+ (clean-event-queue x-display-events)
+ (signal-thread-event editor-thread signal-interrupt!))
+ (else
+ (enqueue!/unsafe x-display-events event)
+ (loop)))))
+ (unlock-thread-mutex event-stream-mutex)
+ (sleep-current-thread previewer-interval)))
+
+(define (clean-event-queue queue)
+ ;; Flush keyboard and mouse events from the input queue. Other
+ ;; events are harmless and must be processed regardless.
+ (do ((events (let loop ()
+ (if (queue-empty? queue)
+ '()
+ (let ((event (dequeue!/unsafe queue)))
+ (if (and (vector? event)
+ (let ((type (vector-ref event 0)))
+ (or (fix:= type event-type:button-down)
+ (fix:= type event-type:button-up)
+ (fix:= type event-type:key-press)
+ (fix:= type event-type:motion))))
+ (loop)
+ (cons event (loop))))))
+ (cdr events)))
+ ((null? events))
+ (enqueue!/unsafe queue (car events))))
\f
-;;; The values of these flags must be equal to the corresponding event
-;;; types in "microcode/x11base.c"
-
-(define-integrable event-type:button-down 0)
-(define-integrable event-type:button-up 1)
-(define-integrable event-type:configure 2)
-(define-integrable event-type:enter 3)
-(define-integrable event-type:focus-in 4)
-(define-integrable event-type:focus-out 5)
-(define-integrable event-type:key-press 6)
-(define-integrable event-type:leave 7)
-(define-integrable event-type:motion 8)
-(define-integrable event-type:expose 9)
-(define-integrable number-of-event-types 10)
-
-;; This mask contains button-down, button-up, configure, focus-in,
-;; key-press, and expose.
-(define-integrable event-mask #x257)
-
-(define event-handlers
- (make-vector number-of-event-types false))
+(define (process-change-event event)
+ (if (cond ((fix:= event event:process-output)
+ (accept-process-output))
+ ((fix:= event event:process-status)
+ (handle-process-status-changes))
+ ((fix:= event event:interrupt)
+ (accept-thread-output))
+ (else
+ (error "Illegal change event:" event)))
+ (update-screens! false)))
-(define-integrable (define-event-handler event-type handler)
- (vector-set! event-handlers event-type handler))
+(define (process-expose-event event)
+ (xterm-dump-rectangle (vector-ref event 1)
+ (vector-ref event 2)
+ (vector-ref event 3)
+ (vector-ref event 4)
+ (vector-ref event 5)))
(define (process-special-event event)
(let ((handler (vector-ref event-handlers (vector-ref event 0)))
(if (and handler screen)
(handler screen event))))
-(define (process-expose-event event)
- (xterm-dump-rectangle (vector-ref event 1)
- (vector-ref event 2)
- (vector-ref event 3)
- (vector-ref event 4)
- (vector-ref event 5)))
+(define event-handlers
+ (make-vector number-of-event-types false))
+
+(define-integrable (define-event-handler event-type handler)
+ (vector-set! event-handlers event-type handler))
(define-event-handler event-type:configure
(lambda (screen event)
(select-screen screen))))))
\f
(define signal-interrupts?)
-(define timer-interval 1000)
-
-(define (signal-interrupt!)
- (editor-beep)
- (temporary-message "Quit")
- (^G-signal))
+(define event-stream-mutex)
+(define previewer-interval 1000)
(define (with-editor-interrupts-from-x receiver)
(fluid-let ((signal-interrupts? true)
- (timer-interrupt timer-interrupt-handler))
- (dynamic-wind start-timer-interrupt
- (lambda ()
- (receiver
- (lambda (thunk)
- (dynamic-wind stop-timer-interrupt
- thunk
- start-timer-interrupt))
- '()))
- stop-timer-interrupt)))
-
-(define (set-x-timer-interval! interval)
- (if (not (or (false? interval)
- (and (exact-integer? interval)
- (positive? interval))))
- (error:wrong-type-argument interval false 'SET-X-TIMER-INTERVAL!))
- (set! timer-interval interval)
- (start-timer-interrupt))
-
-(define (x-timer-interval)
- timer-interval)
-
-(define (start-timer-interrupt)
- (if timer-interval
- (real-timer-set timer-interval timer-interval)
- (stop-timer-interrupt)))
-
-(define (stop-timer-interrupt)
- (real-timer-clear)
- (clear-interrupts! interrupt-bit/timer))
+ (event-stream-mutex (make-thread-mutex)))
+ (queue-initial-thread preview-event-stream)
+ (receiver (lambda (thunk) (thunk)) '())))
(define (with-x-interrupts-enabled thunk)
- (fluid-let ((signal-interrupts? true)) (thunk)))
+ (with-signal-interrupts true thunk))
(define (with-x-interrupts-disabled thunk)
- (fluid-let ((signal-interrupts? false)) (thunk)))
-\f
+ (with-signal-interrupts false thunk))
+
+(define (with-signal-interrupts enabled? thunk)
+ (let ((old))
+ (unwind-protect (lambda ()
+ (set! old signal-interrupts?)
+ (set! signal-interrupts? enabled?)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! signal-interrupts? old)
+ unspecific))))
+
+(define (signal-interrupt!)
+ (editor-beep)
+ (temporary-message "Quit")
+ (^G-signal))
+
(define x-display-type)
(define x-display-data)
(define x-display-events)
(let ((display (x-open-display x-display-name)))
(set! x-display-data display)
(set! x-display-events (make-queue))
- (set! allow-asynchronous-input? true)
display)))
(define (initialize-package!)
projects / mit-scheme.git / commitdiff