From f8c819f6d83d799ed415015c0a9ad976250486c6 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 4 Feb 1992 04:04:50 +0000 Subject: [PATCH] This release of Edwin requires microcode 11.107 or later. Implement new multi-threading system or Edwin. Inferior REPL buffers now evaluate in parallel with the editor. One widespread effect of this change is that calls to the procedures CALL-WITH-CURRENT-CONTINUATION and DYNAMIC-WIND have been replaced by CALL-WITH-PROTECTED-CONTINUATION and UNWIND-PROTECT, respectively. This is needed because the dynamic state space cannot be used for doing unwind protects -- it is constantly being changed as threads are switched. If someday the multi-thread code is integrated with the runtime system, this will be fixed at a lower level, and these new procedures can become aliases for the old. Other changes: * A subtle bug in the command reader was causing undo boundaries to be inserted too often while text was being entered. This has been fixed, and now undo boundaries are generated every 20 characters or so. * The undo mechanism has been generalized to allow undo tracking to be happening in parallel in several buffers at once. Now undo tracking only interacts with the undo command when they are in the same buffer. Additional undo boundaries have been added at buffer-switch points. * RESET-EDITOR now restores the default bindings of any local variables that are bound when it is called. Previously this was not done, resulting in the default bindings being lost after a reset. * Tuning of the subprocess output code should be noticeable. --- v7/src/edwin/artdebug.scm | 4 +- v7/src/edwin/basic.scm | 30 +-- v7/src/edwin/bufcom.scm | 19 +- v7/src/edwin/buffer.scm | 16 +- v7/src/edwin/comman.scm | 23 +- v7/src/edwin/comred.scm | 81 ++++--- v7/src/edwin/curren.scm | 65 +++--- v7/src/edwin/decls.scm | 5 +- v7/src/edwin/ed-ffi.scm | 2 + v7/src/edwin/editor.scm | 199 +++++++++++++---- v7/src/edwin/edtstr.scm | 11 +- v7/src/edwin/edwin.ldr | 3 +- v7/src/edwin/edwin.pkg | 48 +++- v7/src/edwin/evlcom.scm | 4 +- v7/src/edwin/fileio.scm | 8 +- v7/src/edwin/input.scm | 22 +- v7/src/edwin/intmod.scm | 425 ++++++++++++++++++++--------------- v7/src/edwin/iserch.scm | 10 +- v7/src/edwin/kmacro.scm | 36 +-- v7/src/edwin/make.scm | 4 +- v7/src/edwin/process.scm | 31 +-- v7/src/edwin/prompt.scm | 40 ++-- v7/src/edwin/regexp.scm | 8 +- v7/src/edwin/regops.scm | 37 ++-- v7/src/edwin/rmail.scm | 32 +-- v7/src/edwin/screen.scm | 26 +-- v7/src/edwin/shell.scm | 6 +- v7/src/edwin/struct.scm | 26 +-- v7/src/edwin/tterm.scm | 163 ++++++++------ v7/src/edwin/undo.scm | 171 ++++++++------- v7/src/edwin/utils.scm | 6 +- v7/src/edwin/wincom.scm | 10 +- v7/src/edwin/xterm.scm | 450 +++++++++++++++++++------------------- 33 files changed, 1129 insertions(+), 892 deletions(-) diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index 81c12e912..068cc9878 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -191,7 +191,7 @@ or #F meaning no limit." (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? diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index 8e65e5935..4ae938432 100644 --- a/v7/src/edwin/basic.scm +++ b/v7/src/edwin/basic.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -275,22 +275,14 @@ With argument, saves visited file first." (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. @@ -299,12 +291,7 @@ With prefix arg, silently save all file-visiting buffers, then kill." (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. @@ -327,12 +314,7 @@ With prefix arg, silently save all file-visiting buffers, then kill." (begin (for-each delete-process (process-list)) true)))) - (begin - (set! edwin-finalization - (lambda () - (set! edwin-finalization false) - (reset-editor))) - (abort-edwin))))) + (exit-editor)))) ;;;; Comment Commands diff --git a/v7/src/edwin/bufcom.scm b/v7/src/edwin/bufcom.scm index 5d0a558a7..5927661a4 100644 --- a/v7/src/edwin/bufcom.scm +++ b/v7/src/edwin/bufcom.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -229,15 +229,14 @@ Uses the visited file name, the -*- line, and the local variables spec." (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))) diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index 7eb26d003..20271138c 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -342,12 +342,12 @@ The buffer is guaranteed to be deselected at that time." (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)))))) ;;;; Local Bindings @@ -451,7 +451,7 @@ The buffer is guaranteed to be deselected at that time." (vector-set! buffer buffer-index:local-bindings-installed? installed?)))) - (dynamic-wind + (unwind-protect (lambda () (let ((buffer (current-buffer))) (wind-bindings buffer true) diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm index 621171bfa..2dd6a5fed 100644 --- a/v7/src/edwin/comman.scm +++ b/v7/src/edwin/comman.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -187,14 +187,11 @@ (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 diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index a6ec1321e..cf99bfbcc 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -60,22 +60,24 @@ (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 () @@ -91,6 +93,9 @@ (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)) (define (command-reader #!optional initialization) (define (command-reader-loop) @@ -100,7 +105,7 @@ (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) @@ -113,20 +118,22 @@ (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) @@ -238,7 +245,7 @@ (%dispatch-on-command (current-window) command (if (default-object? record?) false record?))) - + (define (%dispatch-on-command window command record?) (set! *command* command) (guarantee-command-loaded command) @@ -260,35 +267,37 @@ (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 diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm index 74ad98c9e..3a3927d8d 100644 --- a/v7/src/edwin/curren.scm +++ b/v7/src/edwin/curren.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -95,11 +95,11 @@ (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))))) @@ -177,6 +177,7 @@ (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 @@ -311,6 +312,7 @@ (hangup-process process true) (set-process-buffer! process false)) (buffer-processes buffer)) + (kill-buffer-inferior-repl buffer) (bufferset-kill-buffer! (current-bufferset) buffer)) (define (select-buffer buffer) @@ -325,6 +327,7 @@ (define (set-window-buffer! window buffer record?) (without-interrupts (lambda () + (undo-leave-window! window) (if (current-window? window) (change-selected-buffer buffer record? (lambda () @@ -346,21 +349,19 @@ The buffer is guaranteed to be selected at that time." (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)))) @@ -386,19 +387,15 @@ The buffer is guaranteed to be selected at that time." (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))) diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 09d6440bf..fccae5cc4 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -93,6 +93,7 @@ MIT in each case. |# "strpad" "strtab" "termcap" + "thread" "utils" "winren" "xform" diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index bc10f2659..b1b436c90 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -207,6 +207,8 @@ edwin-syntax-table) ("things" (edwin) edwin-syntax-table) + ("thread" (edwin thread) + syntax-table/system-internal) ("tparse" (edwin) edwin-syntax-table) ("tterm" (edwin console-screen) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 3b67f9975..bd5a1923d 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -52,31 +52,50 @@ ((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))) @@ -84,16 +103,18 @@ (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) (define create-editor-args (list false)) @@ -110,6 +131,7 @@ (initialize-typeout!) (initialize-command-reader!) (initialize-processes!) + (initialize-inferior-repls!) (set! edwin-editor (make-editor "Edwin" (let ((name (car args))) @@ -126,6 +148,7 @@ (lambda () (set! edwin-initialization false) (standard-editor-initialization))) + (set! edwin-continuation false) unspecific)) (define (standard-editor-initialization) @@ -171,10 +194,22 @@ with the contents of the startup message." (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)) @@ -193,7 +228,7 @@ with the contents of the startup message." (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))) @@ -203,9 +238,12 @@ with the contents of the startup message." (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 @@ -222,7 +260,7 @@ with the contents of the startup message." (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 @@ -237,11 +275,6 @@ This does not affect editor errors or evaluation errors." (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) @@ -277,16 +310,35 @@ This does not affect editor errors or evaluation errors." (define (%editor-error) (editor-beep) (abort-current-command)) - -(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)) + (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)))) @@ -295,6 +347,40 @@ This does not affect editor errors or evaluation errors." (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) + (define (editor-grab-display editor receiver) (display-type/with-display-grabbed (editor-display-type editor) (lambda (with-display-ungrabbed operations) @@ -302,12 +388,14 @@ This does not affect editor errors or evaluation errors." (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 @@ -322,4 +410,35 @@ This does not affect editor errors or evaluation errors." (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 diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm index 96c587325..b85a75cdc 100644 --- a/v7/src/edwin/edtstr.scm +++ b/v7/src/edwin/edtstr.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -120,7 +120,7 @@ (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) @@ -128,10 +128,7 @@ 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?))) diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index ffef64347..6a68b9b48 100644 --- a/v7/src/edwin/edwin.ldr +++ b/v7/src/edwin/edwin.ldr @@ -1,5 +1,5 @@ ;;; -*-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. @@ -57,6 +57,7 @@ (load "tterm" env) ((access initialize-package! env))) (load "edtstr" environment) + (load "thread" (->environment '(EDWIN THREAD))) (load "editor" environment) (load "curren" environment) (load "simple" environment) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 120d04e76..818b36eef 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -193,6 +193,7 @@ MIT in each case. |# enable-group-undo! undo-boundary! undo-done! + undo-leave-window! undo-record-deletion! undo-record-insertion! with-group-undo-disabled)) @@ -263,9 +264,7 @@ MIT in each case. |# (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!))) @@ -466,6 +465,7 @@ MIT in each case. |# keyboard-keys-read last-command last-command-key + override-next-command! read-and-dispatch-on-key set-command-argument! set-command-message! @@ -821,11 +821,11 @@ MIT in each case. |# 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 @@ -965,6 +965,7 @@ MIT in each case. |# (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 @@ -976,6 +977,8 @@ MIT in each case. |# 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) @@ -1015,4 +1018,37 @@ MIT in each case. |# 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 diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index f5aa5e47b..b7c2cc56c 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -356,7 +356,7 @@ kludge the mode line." (transcript-buffer)))))))) value)))))) (if (ref-variable enable-run-light?) - (dynamic-wind + (unwind-protect (lambda () (set-variable! run-light "eval") (for-each (lambda (window) diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index c62901a72..b17ab6bc1 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -289,7 +289,7 @@ after you find a file. If you explicitly request such a scan with 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) @@ -420,8 +420,8 @@ Otherwise, a message is written both before and after long file writes." (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) diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm index 1abe117e2..1cbc9df37 100644 --- a/v7/src/edwin/input.scm +++ b/v7/src/edwin/input.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -185,7 +185,7 @@ B 3BAB8C (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))) @@ -204,14 +204,12 @@ B 3BAB8C (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))))) @@ -241,10 +239,4 @@ B 3BAB8C (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 diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 6ca52f8d9..eac5bc90c 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -57,83 +57,87 @@ but prefix argument means prompt for different environment." (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) -(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))) @@ -155,19 +159,27 @@ but prefix argument means prompt for different environment." (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))))) ;;;; Modes @@ -242,7 +254,8 @@ Additionally, these commands abort the debugger: (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." @@ -294,36 +307,41 @@ If this is an error, the debugger examines the error condition." (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)))) - -;;;; 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))) @@ -345,39 +363,71 @@ If this is an error, the debugger examines the error condition." (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)))))) + +;;;; 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))) ;;;; 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))) @@ -391,6 +441,12 @@ If this is an error, the debugger examines the error condition." (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))) @@ -399,62 +455,18 @@ If this is an error, the debugger examines the error condition." (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)) ;;; 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 @@ -462,6 +474,45 @@ If this is an error, the debugger examines the error condition." (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) @@ -474,12 +525,16 @@ If this is an error, the debugger examines the error condition." 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)))))) ;;; Debugger @@ -500,24 +555,44 @@ If this is an error, the debugger examines the error condition." ;;; 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) diff --git a/v7/src/edwin/iserch.scm b/v7/src/edwin/iserch.scm index 8d2aba5cf..c04aed390 100644 --- a/v7/src/edwin/iserch.scm +++ b/v7/src/edwin/iserch.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -52,8 +52,8 @@ (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 () @@ -348,7 +348,7 @@ 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) diff --git a/v7/src/edwin/kmacro.scm b/v7/src/edwin/kmacro.scm index 82b193a05..40353fd00 100644 --- a/v7/src/edwin/kmacro.scm +++ b/v7/src/edwin/kmacro.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -56,29 +56,11 @@ (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) @@ -87,7 +69,7 @@ (define (keyboard-macro-event) (window-modeline-event! (current-window) 'KEYBOARD-MACRO-EVENT)) - + (define (keyboard-macro-read-key) (let ((key (keyboard-macro-peek-key))) (set! *keyboard-macro-position* (cdr *keyboard-macro-position*)) @@ -110,7 +92,7 @@ (*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))) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 582d35b89..80c47ccec 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,4 +37,4 @@ MIT in each case. |# (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 diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm index 1c353c40a..c2ab7e0a1 100644 --- a/v7/src/edwin/process.scm +++ b/v7/src/edwin/process.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -245,15 +245,17 @@ False means don't delete them until \\[list-processes] is run." (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))) @@ -512,7 +514,7 @@ after the listing is made.)" (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) @@ -576,7 +578,7 @@ after the listing is made.)" (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) @@ -639,10 +641,11 @@ Prefix arg means replace the region with it." (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 diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm index d6de555e9..e6c6859e5 100644 --- a/v7/src/edwin/prompt.scm +++ b/v7/src/edwin/prompt.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -69,7 +69,7 @@ (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)) @@ -79,7 +79,8 @@ (typein-saved-windows (cons (current-window) typein-saved-windows))) - (dynamic-wind + (unwind-protect + false (lambda () (let ((window (typein-window))) (select-window window) @@ -88,8 +89,8 @@ (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) @@ -607,21 +608,18 @@ a repetition of this command will exit." (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))))) ;;;; Character Prompts @@ -655,7 +653,7 @@ a repetition of this command will exit." (fluid-let ((execute-extended-keys? false)) (dispatch-on-command command))) chars)))))))))))) - + ;;;; Confirmation Prompts (define (prompt-for-confirmation? prompt) diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm index f958e0270..30e2e4b7d 100644 --- a/v7/src/edwin/regexp.scm +++ b/v7/src/edwin/regexp.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -80,7 +80,7 @@ (define (preserving-match-data thunk) (let ((group unspecific) (marks unspecific)) - (dynamic-wind + (unwind-protect (lambda () (set! group (object-unhash match-group)) (set! marks @@ -110,8 +110,6 @@ (mark-temporary! mark) index)))) marks)) - (set! group unspecific) - (set! marks unspecific) unspecific)))) (define-integrable (syntax-table-argument syntax-table) diff --git a/v7/src/edwin/regops.scm b/v7/src/edwin/regops.scm index eca342793..fe00534fb 100644 --- a/v7/src/edwin/regops.scm +++ b/v7/src/edwin/regops.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -149,28 +149,23 @@ (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)) diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 1de65648e..b8be7b834 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -1877,21 +1877,21 @@ Leaves original message, deleted, before the undigestified messages." (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))))) ;;;; Constants diff --git a/v7/src/edwin/screen.scm b/v7/src/edwin/screen.scm index 086b53efd..50cf4f497 100644 --- a/v7/src/edwin/screen.scm +++ b/v7/src/edwin/screen.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -609,17 +609,17 @@ (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'. diff --git a/v7/src/edwin/shell.scm b/v7/src/edwin/shell.scm index f36aa6140..e7cfc89fc 100644 --- a/v7/src/edwin/shell.scm +++ b/v7/src/edwin/shell.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -241,7 +241,7 @@ Otherwise, one argument `-i' is passed to the shell." (string->number string))) (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) diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm index 5c9c05ae3..bc4c53501 100644 --- a/v7/src/edwin/struct.scm +++ b/v7/src/edwin/struct.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -241,17 +241,17 @@ (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)) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index 56a45c07a..7992cd0f8 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -142,56 +142,99 @@ MIT in each case. |# (tf-teleray description) (tf-underscore description)))) -(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)))))) +(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)) @@ -200,15 +243,13 @@ MIT in each case. |# (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) @@ -219,7 +260,9 @@ MIT in each case. |# 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)) @@ -243,21 +286,15 @@ MIT in each case. |# `((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)) diff --git a/v7/src/edwin/undo.scm b/v7/src/edwin/undo.scm index 67a78caa2..52e77e51f 100644 --- a/v7/src/edwin/undo.scm +++ b/v7/src/edwin/undo.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -58,6 +58,22 @@ 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 @@ -73,9 +89,6 @@ (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 () @@ -87,26 +100,32 @@ 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)))) (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)) @@ -126,9 +145,8 @@ (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)) @@ -142,25 +160,33 @@ (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) ;;;; External Recording Hooks @@ -172,15 +198,8 @@ (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)) @@ -195,15 +214,8 @@ (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)) @@ -239,6 +251,19 @@ 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 () @@ -275,24 +300,6 @@ ;;;; 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 @@ -323,15 +330,19 @@ A numeric argument serves as a repeat count." (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)) @@ -347,13 +358,16 @@ A numeric argument serves as a repeat count." (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) @@ -365,12 +379,13 @@ A numeric argument serves as a repeat count." ;; 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)))))))) @@ -381,9 +396,8 @@ A numeric argument serves as a repeat count." (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))) @@ -399,18 +413,19 @@ A numeric argument serves as a repeat count." (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)) @@ -419,4 +434,4 @@ A numeric argument serves as a repeat count." 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 diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 38d1989b3..48613e598 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -159,7 +159,7 @@ (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) diff --git a/v7/src/edwin/wincom.scm b/v7/src/edwin/wincom.scm index e387deb4a..c0daee2ce 100644 --- a/v7/src/edwin/wincom.scm +++ b/v7/src/edwin/wincom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -416,9 +416,9 @@ Also kills any pop up window it may have created." (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*))) diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index d78a216cb..0942ece49 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -48,9 +48,6 @@ (declare (usual-integrations)) (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) @@ -85,6 +82,26 @@ (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) (define-structure (xterm-screen-state (constructor make-xterm-screen-state (xterm display)) @@ -157,7 +174,7 @@ (loop (cdr screens)))))) (define (xterm-screen/wrap-update! screen thunk) - (dynamic-wind + (unwind-protect (lambda () (xterm-enable-cursor (screen-xterm screen) false)) thunk @@ -233,195 +250,197 @@ ;;;; 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)))))) (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)))) -;;; 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))) @@ -429,12 +448,11 @@ (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) @@ -477,52 +495,37 @@ (select-screen screen)))))) (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))) - + (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) @@ -535,7 +538,6 @@ (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!) -- 2.25.1