From 3f2c40ca0400796fb9efa191e9d43f48ac41e9f8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 16 Mar 1991 00:03:18 +0000 Subject: [PATCH] This version of Edwin requires microcode version 11.69 and runtime version 14.113. * Implement Emacs-style subprocesses, RCS support, and Shell mode. * Add code to M-x save-buffers-kill-edwin to request confirmation when there are modified buffers or active processes. * Change default handling of Scheme errors that occur while Edwin is running (i.e. errors in the Edwin implementation): such errors are now caught, causing a message to be written to the minibuffer, and aborting the current command. This behavior may be overridden by the Scheme variable `debug-internal-errors?' or the Edwin variable `debug-on-internal-error'. * Change M-x find-alternate-file not to signal an error if the current buffer is not visiting a file. * Change Scheme Interaction mode to have input history with same commands as Shell mode; both are based on Olin Shivers' comint mode. * Change buffer to have default-directory field that is separate from the pathname and truename fields. All buffers have a default directory, even if they aren't visiting files. Change the `cd' command to change a buffer's default directory. New command `pwd' shows you the default directory of the current buffer. * Fix bug in `variable-local-value'. Rewrite implementation of local variable bindings to improve performance. * Change filename prompting and completion procedures to make them more flexible and modular. --- v7/src/edwin/autosv.scm | 37 ++--- v7/src/edwin/basic.scm | 28 +++- v7/src/edwin/buffer.scm | 262 ++++++++++++++++-------------- v7/src/edwin/bufset.scm | 11 +- v7/src/edwin/comred.scm | 13 +- v7/src/edwin/curren.scm | 25 ++- v7/src/edwin/decls.scm | 12 +- v7/src/edwin/ed-ffi.scm | 8 + v7/src/edwin/editor.scm | 44 ++--- v7/src/edwin/edtstr.scm | 11 +- v7/src/edwin/edwin.ldr | 14 +- v7/src/edwin/edwin.pkg | 95 ++++++++++- v7/src/edwin/filcom.scm | 347 +++++++++++++++++++++------------------- v7/src/edwin/input.scm | 97 ++++++----- v7/src/edwin/intmod.scm | 63 ++------ v7/src/edwin/kmacro.scm | 7 +- v7/src/edwin/make.scm | 4 +- v7/src/edwin/modlin.scm | 9 +- v7/src/edwin/screen.scm | 33 ++-- v7/src/edwin/simple.scm | 9 +- v7/src/edwin/tterm.scm | 45 +++--- v7/src/edwin/window.scm | 6 +- v7/src/edwin/xterm.scm | 130 ++++++++------- 23 files changed, 743 insertions(+), 567 deletions(-) diff --git a/v7/src/edwin/autosv.scm b/v7/src/edwin/autosv.scm index e21f9f76b..4772a4c7c 100644 --- a/v7/src/edwin/autosv.scm +++ b/v7/src/edwin/autosv.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.21 1989/04/28 22:47:00 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.22 1991/03/16 00:01:10 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -47,23 +47,27 @@ (declare (usual-integrations)) (define-variable auto-save-visited-file-name - "*True says auto-save a buffer in the file it is visiting, when practical. + "True says auto-save a buffer in the file it is visiting, when practical. Normally auto-save files are written under other names." - false) + false + boolean?) (define-variable auto-save-default - "*True says by default do auto-saving of every file-visiting buffer." - true) + "True says by default do auto-saving of every file-visiting buffer." + true + boolean?) (define-variable auto-save-interval - "*Number of keyboard input characters between auto-saves. + "Number of keyboard input characters between auto-saves. Zero means disable autosaving." - 300) + 300 + exact-nonnegative-integer?) (define-variable delete-auto-save-files - "*True means delete a buffer's auto-save file + "True means delete a buffer's auto-save file when the buffer is saved for real." - true) + true + boolean?) (define-command auto-save-mode "Toggle auto-saving of contents of current buffer. @@ -90,16 +94,13 @@ With arg, turn auto-saving on if arg is positive, else off." (set-buffer-auto-save-pathname! buffer (let ((pathname (buffer-pathname buffer))) - (if (and pathname - (ref-variable auto-save-visited-file-name)) + (if (and pathname (ref-variable auto-save-visited-file-name)) pathname (os/auto-save-pathname pathname (buffer-name buffer)))))) (define (disable-buffer-auto-save! buffer) (set-buffer-auto-save-pathname! buffer false)) -(define *auto-save-keystroke-count*) - (define (do-auto-save) (let ((buffers (list-transform-positive (buffer-list) @@ -109,10 +110,10 @@ With arg, turn auto-saving on if arg is positive, else off." (<= (* 10 (buffer-save-length buffer)) (* 13 (buffer-length buffer)))))))) (if (not (null? buffers)) - (begin (temporary-message "Auto saving...") - (for-each auto-save-buffer buffers) - (clear-message)))) - (set! *auto-save-keystroke-count* 0)) + (begin + (temporary-message "Auto saving...") + (for-each auto-save-buffer buffers) + (append-message "done"))))) (define (auto-save-buffer buffer) (region->file (buffer-unclipped-region buffer) diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index c174fd3d2..bf46032c6 100644 --- a/v7/src/edwin/basic.scm +++ b/v7/src/edwin/basic.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.106 1991/02/15 18:12:24 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.107 1991/03/16 00:01:14 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -281,11 +281,27 @@ With prefix arg, silently save all file-visiting buffers, then kill." "P" (lambda (no-confirmation?) (save-some-buffers no-confirmation?) - (set! edwin-finalization - (lambda () - (set! edwin-finalization false) - (reset-editor))) - ((ref-command suspend-edwin)))) + (if (and (or (not (there-exists? (buffer-list) + (lambda (buffer) + (and (buffer-modified? buffer) + (buffer-pathname buffer))))) + (prompt-for-yes-or-no? + "Modified buffers exist; exit anyway")) + (or (not (there-exists? (process-list) + (lambda (process) + (and (not (process-kill-without-query process)) + (process-runnable? process))))) + (and (prompt-for-yes-or-no? + "Active processes exist; kill them and exit anyway") + (begin + (for-each delete-process (process-list)) + true)))) + (begin + (set! edwin-finalization + (lambda () + (set! edwin-finalization false) + (reset-editor))) + ((ref-command suspend-edwin)))))) ;;;; Comment Commands diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index 822c8a0d8..ce268e5c2 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.138 1990/11/02 03:22:26 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.139 1991/03/16 00:01:19 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -54,6 +54,7 @@ comtabs windows display-start + default-directory pathname truename alist @@ -78,43 +79,40 @@ The new buffer is passed as its argument. The buffer is guaranteed to be deselected at that time." (make-event-distributor)) -(define (make-buffer name #!optional mode) - (let ((mode - (if (default-object? mode) - (ref-variable editor-default-mode) - mode))) - (let ((group (region-group (string->region "")))) - (let ((buffer (%make-buffer))) - (vector-set! buffer buffer-index:name name) - (vector-set! buffer buffer-index:group group) - (let ((daemon (buffer-modification-daemon buffer))) - (add-group-insert-daemon! group daemon) - (add-group-delete-daemon! group daemon)) - (add-group-clip-daemon! group (buffer-clip-daemon buffer)) - (if (not (minibuffer? buffer)) - (enable-group-undo! group)) - (vector-set! buffer - buffer-index:mark-ring - (make-ring (ref-variable mark-ring-maximum))) - (ring-push! (buffer-mark-ring buffer) (group-start-mark group)) - (vector-set! buffer buffer-index:modes (list mode)) - (vector-set! buffer buffer-index:comtabs (mode-comtabs mode)) - (vector-set! buffer buffer-index:windows '()) - (vector-set! buffer buffer-index:display-start false) - (vector-set! buffer buffer-index:pathname false) - (vector-set! buffer buffer-index:truename false) - (vector-set! buffer buffer-index:alist '()) - (vector-set! buffer buffer-index:local-bindings '()) - (vector-set! buffer - buffer-index:initializations - (list (mode-initialization mode))) - (vector-set! buffer buffer-index:auto-save-pathname false) - (vector-set! buffer buffer-index:auto-save-modified? false) - (vector-set! buffer buffer-index:save-length 0) - (vector-set! buffer buffer-index:backed-up? false) - (vector-set! buffer buffer-index:modification-time false) - (event-distributor/invoke! (ref-variable buffer-creation-hook) buffer) - buffer)))) +(define (make-buffer name mode directory) + (let ((group (region-group (string->region "")))) + (let ((buffer (%make-buffer))) + (vector-set! buffer buffer-index:name name) + (vector-set! buffer buffer-index:group group) + (let ((daemon (buffer-modification-daemon buffer))) + (add-group-insert-daemon! group daemon) + (add-group-delete-daemon! group daemon)) + (add-group-clip-daemon! group (buffer-clip-daemon buffer)) + (if (not (minibuffer? buffer)) + (enable-group-undo! group)) + (vector-set! buffer + buffer-index:mark-ring + (make-ring (ref-variable mark-ring-maximum))) + (ring-push! (buffer-mark-ring buffer) (group-start-mark group)) + (vector-set! buffer buffer-index:modes (list mode)) + (vector-set! buffer buffer-index:comtabs (mode-comtabs mode)) + (vector-set! buffer buffer-index:windows '()) + (vector-set! buffer buffer-index:display-start false) + (vector-set! buffer buffer-index:default-directory directory) + (vector-set! buffer buffer-index:pathname false) + (vector-set! buffer buffer-index:truename false) + (vector-set! buffer buffer-index:alist '()) + (vector-set! buffer buffer-index:local-bindings '()) + (vector-set! buffer + buffer-index:initializations + (list (mode-initialization mode))) + (vector-set! buffer buffer-index:auto-save-pathname false) + (vector-set! buffer buffer-index:auto-save-modified? false) + (vector-set! buffer buffer-index:save-length 0) + (vector-set! buffer buffer-index:backed-up? false) + (vector-set! buffer buffer-index:modification-time false) + (event-distributor/invoke! (ref-variable buffer-creation-hook) buffer) + buffer))) (define (buffer-modeline-event! buffer type) (let loop ((windows (buffer-windows buffer))) @@ -145,8 +143,12 @@ The buffer is guaranteed to be deselected at that time." (vector-set! buffer buffer-index:name name) (buffer-modeline-event! buffer 'BUFFER-NAME)) +(define (set-buffer-default-directory! buffer directory) + (vector-set! buffer buffer-index:default-directory directory)) + (define (set-buffer-pathname! buffer pathname) (vector-set! buffer buffer-index:pathname pathname) + (set-buffer-default-directory! buffer (pathname-directory-path pathname)) (buffer-modeline-event! buffer 'BUFFER-PATHNAME)) (define (set-buffer-truename! buffer truename) @@ -322,17 +324,17 @@ The buffer is guaranteed to be deselected at that time." (define (make-local-binding! variable new-value) (without-interrupts (lambda () - (let ((buffer (current-buffer)) - (old-value (variable-value variable))) - (check-variable-value-validity! variable new-value) - (%set-variable-value! variable new-value) - (invoke-variable-assignment-daemons! variable) + (let ((buffer (current-buffer))) (let ((bindings (buffer-local-bindings buffer))) (let ((binding (assq variable bindings))) (if (not binding) (vector-set! buffer buffer-index:local-bindings - (cons (cons variable old-value) bindings))))))))) + (cons (cons variable (variable-value variable)) + bindings)))))) + (check-variable-value-validity! variable new-value) + (%set-variable-value! variable new-value) + (invoke-variable-assignment-daemons! variable)))) (define (unmake-local-binding! variable) (without-interrupts @@ -343,111 +345,105 @@ The buffer is guaranteed to be deselected at that time." (if binding (begin (%set-variable-value! variable (cdr binding)) - (invoke-variable-assignment-daemons! variable) (vector-set! buffer buffer-index:local-bindings - (delq! binding bindings)))))))))) + (delq! binding bindings)) + (invoke-variable-assignment-daemons! variable))))))))) (define (undo-local-bindings!) + ;; Caller guarantees that interrupts are disabled. (let ((buffer (current-buffer))) - (for-each (lambda (binding) - (let ((variable (car binding))) - (%set-variable-value! variable (cdr binding)) - (invoke-variable-assignment-daemons! variable))) - (buffer-local-bindings buffer)) - (vector-set! buffer buffer-index:local-bindings '()))) + (let ((bindings (buffer-local-bindings buffer))) + (do ((bindings bindings (cdr bindings))) + ((null? bindings)) + (%set-variable-value! (caar bindings) (cdar bindings))) + (vector-set! buffer buffer-index:local-bindings '()) + (do ((bindings bindings (cdr bindings))) + ((null? bindings)) + (invoke-variable-assignment-daemons! (caar bindings)))))) (define (with-current-local-bindings! thunk) (let ((wind-bindings (lambda (buffer) - (for-each (lambda (binding) - (let ((variable (car binding))) - (let ((old-value (variable-value variable))) - (%set-variable-value! variable (cdr binding)) - (set-cdr! binding old-value)))) - (buffer-local-bindings buffer))))) - (dynamic-wind - (lambda () - (let ((buffer (current-buffer))) - (wind-bindings buffer) - (perform-buffer-initializations! buffer))) - thunk - (lambda () - (wind-bindings (current-buffer)))))) + (do ((bindings (buffer-local-bindings buffer) (cdr bindings))) + ((null? bindings)) + (let ((old-value (variable-value (caar bindings)))) + (%set-variable-value! (caar bindings) (cdar bindings)) + (set-cdr! (car bindings) old-value)))))) + (dynamic-wind (lambda () + (let ((buffer (current-buffer))) + (wind-bindings buffer) + (perform-buffer-initializations! buffer))) + thunk + (lambda () + (wind-bindings (current-buffer)))))) (define (change-local-bindings! old-buffer new-buffer select-buffer!) ;; Assumes that interrupts are disabled and that OLD-BUFFER is selected. (let ((variables '())) - (for-each (lambda (binding) - (let ((variable (car binding))) - (let ((old-value (variable-value variable))) - (%set-variable-value! variable (cdr binding)) - (set-cdr! binding old-value)) - (if (not (null? (variable-assignment-daemons variable))) - (begin - (set! variables (cons variable variables)) - unspecific)))) - (buffer-local-bindings old-buffer)) + (do ((bindings (buffer-local-bindings old-buffer) (cdr bindings))) + ((null? bindings)) + (let ((old-value (variable-value (caar bindings)))) + (%set-variable-value! (caar bindings) (cdar bindings)) + (set-cdr! (car bindings) old-value)) + (if (not (null? (variable-assignment-daemons (caar bindings)))) + (set! variables (cons (caar bindings) variables)))) (select-buffer!) - (for-each (lambda (binding) - (let ((variable (car binding))) - (let ((old-value (variable-value variable))) - (%set-variable-value! variable (cdr binding)) - (set-cdr! binding old-value)) - (if (and (not (null? (variable-assignment-daemons variable))) - (not (memq variable variables))) - (begin - (set! variables (cons variable variables)) - unspecific)))) - (buffer-local-bindings new-buffer)) + (do ((bindings (buffer-local-bindings new-buffer) (cdr bindings))) + ((null? bindings)) + (let ((old-value (variable-value (caar bindings)))) + (%set-variable-value! (caar bindings) (cdar bindings)) + (set-cdr! (car bindings) old-value)) + (if (and (not (null? (variable-assignment-daemons (caar bindings)))) + (not (let loop ((variables variables)) + (and (not (null? variables)) + (or (eq? (caar bindings) (car variables)) + (loop (cdr variables))))))) + (set! variables (cons (caar bindings) variables)))) (perform-buffer-initializations! new-buffer) (if (not (null? variables)) - (for-each invoke-variable-assignment-daemons! variables)))) + (do ((variables variables (cdr variables))) + ((null? variables)) + (invoke-variable-assignment-daemons! (car variables)))))) -(define (variable-local-value buffer variable) - (let ((binding - (and (within-editor?) - (not (current-buffer? buffer)) - (or (assq variable (buffer-local-bindings buffer)) - (and (variable-buffer-local? variable) - (assq variable - (buffer-local-bindings (current-buffer)))))))) - (if binding - (cdr binding) - (variable-value variable)))) - -(define (set-variable-local-value! buffer variable value) - (let ((binding - (and (not (current-buffer? buffer)) - (assq variable (buffer-local-bindings buffer))))) - (if binding - (set-cdr! binding value) - (set-variable-value! variable value)))) - (define (define-variable-local-value! buffer variable value) (if (current-buffer? buffer) (make-local-binding! variable value) (without-interrupts (lambda () - (let ((bindings (buffer-local-bindings buffer))) - (let ((binding (assq variable bindings))) - (if binding - (set-cdr! binding value) - (vector-set! buffer - buffer-index:local-bindings - (cons (cons variable value) bindings))))))))) + (let ((binding (search-local-bindings buffer variable))) + (if binding + (set-cdr! binding value) + (vector-set! buffer + buffer-index:local-bindings + (cons (cons variable value) + (buffer-local-bindings buffer))))))))) -(define (variable-local-value? buffer variable) - (assq variable (buffer-local-bindings buffer))) +(define (variable-local-value buffer variable) + (if (or (not (within-editor?)) + (current-buffer? buffer)) + (variable-value variable) + (let ((binding (search-local-bindings buffer variable))) + (if binding + (cdr binding) + (variable-default-value variable))))) + +(define (set-variable-local-value! buffer variable value) + (if (current-buffer? buffer) + (set-variable-value! variable value) + (let ((binding (search-local-bindings buffer variable))) + (if binding + (set-cdr! binding value) + (set-variable-default-value! variable value))))) (define (variable-default-value variable) - (let ((binding (assq variable (buffer-local-bindings (current-buffer))))) + (let ((binding (search-local-bindings (current-buffer) variable))) (if binding (cdr binding) (variable-value variable)))) (define (set-variable-default-value! variable value) - (let ((binding (assq variable (buffer-local-bindings (current-buffer))))) + (let ((binding (search-local-bindings (current-buffer) variable))) (if binding (set-cdr! binding value) (without-interrupts @@ -455,6 +451,19 @@ The buffer is guaranteed to be deselected at that time." (check-variable-value-validity! variable value) (%set-variable-value! variable value) (invoke-variable-assignment-daemons! variable)))))) + +(define (variable-local-value? buffer variable) + (let loop ((bindings (buffer-local-bindings buffer))) + (and (not (null? bindings)) + (or (eq? (caar bindings) variable) + (loop (cdr bindings)))))) + +(define-integrable (search-local-bindings buffer variable) + (let loop ((bindings (buffer-local-bindings buffer))) + (and (not (null? bindings)) + (if (eq? (caar bindings) variable) + (car bindings) + (loop (cdr bindings)))))) ;;;; Modes @@ -462,7 +471,8 @@ The buffer is guaranteed to be deselected at that time." (car (buffer-modes buffer))) (define (set-buffer-major-mode! buffer mode) - (if (not (mode-major? mode)) (error "Not a major mode" mode)) + (if (not (and (mode? mode) (mode-major? mode))) + (error:wrong-type-argument mode "major mode" 'SET-BUFFER-MAJOR-MODE!)) (without-interrupts (lambda () (let ((modes (buffer-modes buffer))) @@ -479,11 +489,13 @@ The buffer is guaranteed to be deselected at that time." (cdr (buffer-modes buffer))) (define (buffer-minor-mode? buffer mode) - (if (mode-major? mode) (error "Not a minor mode" mode)) + (if (not (and (mode? mode) (not (mode-major? mode)))) + (error:wrong-type-argument mode "minor mode" 'BUFFER-MINOR-MODE?)) (memq mode (buffer-minor-modes buffer))) (define (enable-buffer-minor-mode! buffer mode) - (if (mode-major? mode) (error "Not a minor mode" mode)) + (if (not (and (mode? mode) (not (mode-major? mode)))) + (error:wrong-type-argument mode "minor mode" 'ENABLE-BUFFER-MINOR-MODE!)) (without-interrupts (lambda () (let ((modes (buffer-modes buffer))) @@ -497,7 +509,9 @@ The buffer is guaranteed to be deselected at that time." (buffer-modeline-event! buffer 'BUFFER-MODES))))))) (define (disable-buffer-minor-mode! buffer mode) - (if (mode-major? mode) (error "Not a minor mode" mode)) + (if (not (and (mode? mode) (not (mode-major? mode)))) + (error:wrong-type-argument mode "minor mode" + 'DISABLE-BUFFER-MINOR-MODE!)) (without-interrupts (lambda () (let ((modes (buffer-modes buffer))) diff --git a/v7/src/edwin/bufset.scm b/v7/src/edwin/bufset.scm index 93855cf8e..4c79a7987 100644 --- a/v7/src/edwin/bufset.scm +++ b/v7/src/edwin/bufset.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufset.scm,v 1.7 1989/04/28 22:47:45 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufset.scm,v 1.8 1991/03/16 00:01:24 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -92,7 +92,12 @@ (define (bufferset-create-buffer bufferset name) (if (bufferset-find-buffer bufferset name) (error "Attempt to re-create buffer" name)) - (let ((buffer (make-buffer name))) + (let ((buffer + (make-buffer name + (ref-variable editor-default-mode) + (if (within-editor?) + (buffer-default-directory (current-buffer)) + (working-directory-pathname))))) (string-table-put! (bufferset-names bufferset) name buffer) (vector-set! bufferset bufferset-index:buffer-list diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index 2c2f34fe4..53965b3d5 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.84 1991/02/15 18:12:46 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.85 1991/03/16 00:01:28 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -354,16 +354,11 @@ (varies (current-point) '(CURRENT-POINT))) ((#\D) (prompting - (pathname->string - (prompt-for-directory prompt (current-default-pathname))))) + (pathname->string (prompt-for-directory prompt false false)))) ((#\f) - (prompting - (pathname->string - (prompt-for-input-truename prompt (current-default-pathname))))) + (prompting (pathname->string (prompt-for-input-truename prompt false)))) ((#\F) - (prompting - (pathname->string - (prompt-for-pathname prompt (current-default-pathname))))) + (prompting (pathname->string (prompt-for-pathname prompt false false)))) ((#\k) (prompting (prompt-for-key prompt (current-comtabs)))) ((#\m) diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm index 9132c624c..9f0fbe86d 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.90 1990/10/09 16:23:40 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.91 1991/03/16 00:01:33 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -307,6 +307,10 @@ (error "Buffer to be killed has no replacement" buffer)))) (set-window-buffer! (car windows) new-buffer false) (loop (cdr windows) new-buffer)))) + (for-each (lambda (process) + (hangup-process process true) + (set-process-buffer! process false)) + (buffer-processes buffer)) (bufferset-kill-buffer! (current-bufferset) buffer)) (define-integrable (select-buffer buffer) @@ -357,6 +361,12 @@ The buffer is guaranteed to be selected at that time." (set-window-buffer! window old-buffer true))) (set! old-buffer) unspecific)))) + +(define (current-process) + (let ((process (get-buffer-process (current-buffer)))) + (if (not process) + (editor-error "Current buffer has no process")) + process)) ;;;; Point @@ -367,11 +377,12 @@ The buffer is guaranteed to be selected at that time." (set-window-point! (current-window) mark)) (define (set-buffer-point! buffer mark) - (if (buffer-visible? buffer) - (for-each (lambda (window) - (set-window-point! window mark)) - (buffer-windows buffer)) - (%set-buffer-point! buffer mark))) + (let ((windows (buffer-windows buffer))) + (if (null? windows) + (%set-buffer-point! buffer mark) + (for-each (lambda (window) + (set-window-point! window mark)) + windows)))) (define (with-current-point point thunk) (let ((old-point)) diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 88009e0f6..fa888cbfc 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.15 1990/11/02 03:23:33 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.16 1991/03/16 00:01:38 cph Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -111,15 +111,14 @@ MIT in each case. |# "autosv" "basic" "bufcom" - "buffer" "bufmnu" "bufset" "c-mode" "calias" "cinden" + "comint" "comman" "comred" - "curren" "debug" "debuge" "dired" @@ -148,7 +147,9 @@ MIT in each case. |# "modlin" "motcom" "pasmod" + "process" "prompt" + "rcs" "reccom" "regcom" "regexp" @@ -157,6 +158,7 @@ MIT in each case. |# "scrcom" "screen" "sercom" + "shell" "struct" "syntax" "tags" @@ -175,6 +177,8 @@ MIT in each case. |# (sf-edwin "grpops" "struct") (sf-edwin "regops" "struct") (sf-edwin "motion" "struct") + (sf-edwin "buffer" "comman" "modes") + (sf-edwin "curren" "buffer") (sf-class "window" "class") (sf-class "utlwin" "window" "class") (sf-class "bufwin" "window" "class" "buffer" "struct") diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index 5d5f4cd7b..87ac60c4e 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -45,6 +45,8 @@ syntax-table/system-internal) ("comman" (edwin) edwin-syntax-table) + ("comint" (edwin) + edwin-syntax-table) ("comred" (edwin command-reader) edwin-syntax-table) ("comtab" (edwin comtab) @@ -129,8 +131,12 @@ edwin-syntax-table) ("paths" (edwin) syntax-table/system-internal) + ("process" (edwin process) + edwin-syntax-table) ("prompt" (edwin prompt) edwin-syntax-table) + ("rcs" (edwin rcs) + edwin-syntax-table) ("reccom" (edwin rectangle) edwin-syntax-table) ("regcom" (edwin register-command) @@ -157,6 +163,8 @@ syntax-table/system-internal) ("sercom" (edwin) edwin-syntax-table) + ("shell" (edwin) + edwin-syntax-table) ("simple" (edwin) syntax-table/system-internal) ("strpad" (edwin) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index cd4084563..40e6e9f52 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.200 1991/02/15 18:13:08 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.201 1991/03/16 00:01:46 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -47,12 +47,10 @@ (declare (usual-integrations)) (define (edit) - (if (not edwin-editor) - (create-editor)) + (if (not edwin-editor) (create-editor)) (call-with-current-continuation (lambda (continuation) (fluid-let ((editor-abort continuation) - (*auto-save-keystroke-count* 0) (current-editor edwin-editor) (recursive-edit-continuation false) (recursive-edit-level 0)) @@ -73,9 +71,6 @@ (if edwin-finalization (edwin-finalization)) unspecific) -(define (edwin) - (edit)) - (define (editor-grab-display editor receiver) (display-type/with-display-grabbed (editor-display-type editor) (lambda (with-display-ungrabbed) @@ -113,8 +108,8 @@ message spawn-child))))) -(define (within-editor?) - (not (unassigned? current-editor))) +(define (edwin) (edit)) +(define (within-editor?) (not (unassigned? current-editor))) (define editor-abort) (define edwin-editor false) @@ -145,6 +140,7 @@ (initialize-typeout!) (initialize-syntax-table!) (initialize-command-reader!) + (initialize-processes!) (set! edwin-editor (make-editor "Edwin" (let ((name (car args))) @@ -261,22 +257,26 @@ with the contents of the startup message." (define recursive-edit-level) (define (internal-error-handler condition) - (cond ((ref-variable debug-on-internal-error) + (cond (debug-internal-errors? + (exit-editor-and-signal-error condition)) + ((ref-variable debug-on-internal-error) (debug-scheme-error condition) (message "Scheme error") (%editor-error)) - (debug-internal-errors? - (error condition)) (else - (exit-editor-and-signal-error condition)))) + (message + "Internal error: " + (with-string-output-port + (lambda (port) + (write-condition-report condition port)))) + (%editor-error)))) (define-variable debug-on-internal-error "True means enter debugger if error is signalled while the editor is running. This does not affect editor errors or evaluation errors." false) -(define debug-internal-errors? - false) +(define debug-internal-errors? false) (define (exit-editor-and-signal-error condition) (within-continuation editor-abort @@ -287,9 +287,8 @@ This does not affect editor errors or evaluation errors." (make-condition-type 'EDITOR-ERROR condition-type:error '(STRINGS) (lambda (condition port) (write-string "Editor error: " port) - (write-string - (message-args->string (access-condition condition 'STRINGS)) - port)))) + (write-string (message-args->string (editor-error-strings condition)) + port)))) (define editor-error (let ((signaller @@ -299,12 +298,15 @@ This does not affect editor errors or evaluation errors." (lambda strings (signaller strings)))) +(define editor-error-strings + (condition-accessor condition-type:editor-error 'STRINGS)) + (define (editor-error-handler condition) (if (ref-variable debug-on-editor-error) (debug-scheme-error condition) - (let ((strings (access-condition condition 'STRINGS))) + (let ((strings (editor-error-strings condition))) (if (not (null? strings)) - (apply temporary-message strings)))) + (apply message strings)))) (%editor-error)) (define-variable debug-on-editor-error @@ -314,7 +316,7 @@ This does not affect editor errors or evaluation errors." (define (%editor-error) (editor-beep) (abort-current-command)) - + (define (^G-signal) (let ((continuations *^G-interrupt-continuations*)) (if (not (pair? continuations)) diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm index 6a7770710..f33e981c9 100644 --- a/v7/src/edwin/edtstr.scm +++ b/v7/src/edwin/edtstr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.13 1991/03/11 01:14:10 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.14 1991/03/16 00:01:51 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -54,6 +54,7 @@ (bufferset false read-only true) (kill-ring false read-only true) (char-history false read-only true) + (halt-update? false read-only true) (char-ready? false read-only true) (peek-char false read-only true) (read-char false read-only true) @@ -61,13 +62,16 @@ (select-time 1)) (define (make-editor name display-type make-screen-args) - (let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode))) + (let ((initial-buffer + (make-buffer initial-buffer-name + initial-buffer-mode + (working-directory-pathname)))) (let ((bufferset (make-bufferset initial-buffer)) (screen (display-type/make-screen display-type make-screen-args))) (initialize-screen-root-window! screen bufferset initial-buffer) (with-values (lambda () (display-type/get-input-operations display-type screen)) - (lambda (char-ready? peek-char read-char) + (lambda (halt-update? char-ready? peek-char read-char) (%make-editor name display-type (list screen) @@ -75,6 +79,7 @@ bufferset (make-ring 10) (make-ring 100) + halt-update? char-ready? peek-char read-char diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index 78e961dd4..293447d96 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.11 1990/11/02 03:24:04 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.12 1991/03/16 00:01:57 cph Exp $ ;;; program to load package contents ;;; **** This program (unlike most .ldr files) is not generated by a program. @@ -75,28 +75,40 @@ (load "linden" (->environment '(EDWIN LISP-INDENTATION))) (load "unix" environment) (load "fileio" environment) + (load-option 'SUBPROCESS) + (load "process" (->environment '(EDWIN PROCESS))) (load "argred" (->environment '(EDWIN COMMAND-ARGUMENT))) (load "autold" environment) (load "autosv" environment) (load "basic" environment) (load "bufcom" environment) (load "bufmnu" (->environment '(EDWIN BUFFER-MENU))) + (load "c-mode" environment) + (load "cinden" (->environment '(EDWIN C-INDENTATION))) + (load "comint" environment) (load "debug" (->environment '(EDWIN DEBUGGER))) + (load "dired" (->environment '(EDWIN DIRED))) (load "evlcom" environment) (load "filcom" environment) (load "fill" environment) (load "hlpcom" environment) + (load "info" (->environment '(EDWIN INFO))) (load "intmod" environment) + (load "keymap" (->environment '(EDWIN COMMAND-SUMMARY))) (load "kilcom" environment) (load "kmacro" environment) (load "lincom" environment) (load "lspcom" environment) (load "motcom" environment) + (load "rcs" (->environment '(EDWIN RCS))) + (load "reccom" (->environment '(EDWIN RECTANGLE))) (load "regcom" (->environment '(EDWIN REGISTER-COMMAND))) (load "replaz" environment) (load "schmod" environment) (load "sercom" environment) (load "iserch" (->environment '(EDWIN INCREMENTAL-SEARCH))) + (load "shell" environment) + (load "tags" (->environment '(EDWIN TAGS))) (load "texcom" environment) (load "wincom" environment) (load "scrcom" environment) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 43b00b9cb..534e2f2f9 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.24 1991/03/11 01:14:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.25 1991/03/16 00:02:03 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -72,6 +72,7 @@ MIT in each case. |# "autosv" ; auto save "basic" ; basic commands "bufcom" ; buffer commands + "comint" ; command interpreter process stuff "evlcom" ; evaluation commands "filcom" ; file commands "fill" ; text fill commands @@ -86,6 +87,7 @@ MIT in each case. |# "schmod" ; scheme mode "scrcom" ; screen commands "sercom" ; search commands + "shell" ; shell subprocess commands "texcom" ; text commands "wincom" ; window commands @@ -452,7 +454,8 @@ MIT in each case. |# prompt-for-yes-or-no? typein-edit-other-window within-typein-edit - within-typein-edit?) + within-typein-edit? + write-completions-list) (export (edwin screen) make-typein-buffer-name)) @@ -498,11 +501,21 @@ MIT in each case. |# match-backward match-forward re-match-end + re-match-end-index re-match-forward re-match-start + re-match-start-index + re-match-string-forward + re-match-string-forward-ci + re-match-substring-forward + re-match-substring-forward-ci re-quote-string re-search-backward re-search-forward + re-search-string-forward + re-search-string-forward-ci + re-search-substring-forward + re-search-substring-forward-ci search-backward search-forward skip-chars-backward @@ -570,7 +583,13 @@ MIT in each case. |# (export (edwin) c-indent-expression c-indent-line:indentation - c-inside-parens?)) + c-inside-parens? + edwin-variable$c-argdecl-indent + edwin-variable$c-brace-imaginary-offset + edwin-variable$c-brace-offset + edwin-variable$c-continued-statement-offset + edwin-variable$c-indent-level + edwin-variable$c-label-offset)) (define-package (edwin incremental-search) (files "iserch") @@ -620,11 +639,23 @@ MIT in each case. |# (files "dired") (parent (edwin)) (export (edwin) + edwin-variable$list-directory-unpacked make-dired-buffer)) (define-package (edwin info) (files "info") - (parent (edwin))) + (parent (edwin)) + (export (edwin) + edwin-variable$info-current-file + edwin-variable$info-current-node + edwin-variable$info-current-subfile + edwin-variable$info-directory + edwin-variable$info-enable-active-nodes + edwin-variable$info-enable-edit + edwin-variable$info-history + edwin-variable$info-previous-search + edwin-variable$info-tag-table-start + edwin-variable$info-tag-table-end)) (define-package (edwin rectangle) (files "reccom") @@ -632,4 +663,58 @@ MIT in each case. |# (define-package (edwin tags) (files "tags") - (parent (edwin))) \ No newline at end of file + (parent (edwin)) + (export (edwin) + edwin-variable$tags-table-pathname)) + +(define-package (edwin rcs) + (files "rcs") + (parent (edwin))) + +(define-package (edwin process) + (files "process") + (parent (edwin)) + (export (edwin) + accept-process-output + buffer-default-directory + buffer-processes + continue-process + delete-process + edwin-command$list-processes + edwin-variable$exec-path + edwin-variable$process-connection-type + find-program + get-buffer-process + get-process-by-name + hangup-process + initialize-processes! + interrupt-process + kill-process + notify-process-status-changes + process-arguments + process-arguments->string + process-buffer + process-environment-bind + process-exit-reason + process-filter + process-kill-without-query + process-list + process-mark + process-name + process-runnable? + process-send-char + process-send-eof + process-send-string + process-send-substring + process-sentinel + process-status + process-status-message + quit-process + set-process-buffer! + set-process-filter! + set-process-kill-without-query! + set-process-sentinel! + shell-command + shell-command-region + start-process + stop-process)) \ No newline at end of file diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 66dcb1eda..d6c6fdfe4 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.144 1991/02/15 18:13:29 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.145 1991/03/16 00:02:10 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -94,13 +94,12 @@ May create a window, or reuse one." find-file-other-window) (define-command find-alternate-file - "Find a file in its own buffer, killing the current buffer. -Like \\[kill-buffer] followed by \\[find-file]." + "Find file FILENAME, select its buffer, kill previous buffer. +If the current buffer now contains an empty file that you just visited +\(presumably by mistake), use this command to visit the file you really want." "FFind alternate file" (lambda (filename) (let ((buffer (current-buffer))) - (if (not (buffer-pathname buffer)) - (editor-error "Buffer not visiting any file")) (let ((do-it (lambda () (kill-buffer-interactive buffer) @@ -228,12 +227,11 @@ Argument means don't offer to use auto-save file." (let ((exponent (command-argument-multiplier-only?))) (if (buffer-pathname buffer) (save-buffer-prepare-version buffer) - (set-visited-pathname buffer - (prompt-for-pathname - (string-append "Write buffer " - (buffer-name buffer) - " to file") - false))) + (set-visited-pathname + buffer + (prompt-for-pathname + (string-append "Write buffer " (buffer-name buffer) " to file") + false false))) (if (memv exponent '(2 3)) (set-buffer-backed-up?! buffer false)) (write-buffer-interactive buffer) (if (memv exponent '(1 3)) (set-buffer-backed-up?! buffer false))) @@ -259,9 +257,11 @@ Argument means don't offer to use auto-save file." buffers)))) (define (save-buffer-prepare-version buffer) - (let ((pathname (buffer-pathname buffer))) - (if (and pathname (integer? (pathname-version pathname))) - (set-buffer-pathname! buffer (newest-pathname pathname))))) + (if pathname-newest + (let ((pathname (buffer-pathname buffer))) + (if (and pathname (integer? (pathname-version pathname))) + (set-buffer-pathname! buffer + (pathname-new-version pathname 'NEWEST)))))) (define-command save-buffer "Save current buffer in visited file if modified. Versions described below. @@ -309,7 +309,7 @@ if you wish to make buffer not be visiting any file." (lambda (filename) (set-visited-pathname (current-buffer) (and (not (string-null? filename)) - (prompt-string->pathname filename))))) + (string->pathname filename))))) (define (set-visited-pathname buffer pathname) (set-buffer-pathname! buffer pathname) @@ -346,13 +346,42 @@ Leaves point at the beginning, mark at the end." "FInsert file" (lambda (filename) (set-current-region! (insert-file (current-point) filename)))) + +(define (pathname->buffer-name pathname) + (let ((name (pathname-name pathname))) + (if name + (pathname->string + (make-pathname false false false + name (pathname-type pathname) false)) + (let ((name + (let ((directory (pathname-directory pathname))) + (and (pair? directory) + (car (last-pair directory)))))) + (if (string? name) name "*random*"))))) + +(define (pathname->buffer pathname) + (or (list-search-positive (buffer-list) + (lambda (buffer) + (let ((pathname* (buffer-pathname buffer))) + (and pathname* + (pathname=? pathname pathname*))))) + (let ((truename (pathname->input-truename pathname))) + (and truename + (list-search-positive (buffer-list) + (lambda (buffer) + (let ((pathname* (buffer-pathname buffer))) + (and pathname* + (or (pathname=? pathname pathname*) + (pathname=? truename pathname*) + (let ((truename* (buffer-truename buffer))) + (and truename* + (pathname=? truename truename*)))))))))))) (define-command copy-file "Copy a file; the old and new names are read in the typein window. If a file with the new name already exists, confirmation is requested first." (lambda () - (let ((old - (prompt-for-input-truename "Copy file" (current-default-pathname)))) + (let ((old (prompt-for-input-truename "Copy file" false))) (list old (prompt-for-output-truename "Copy to" old)))) (lambda (old new) (if (or (not (file-exists? new)) @@ -368,9 +397,7 @@ If a file with the new name already exists, confirmation is requested first." "Rename a file; the old and new names are read in the typein window. If a file with the new name already exists, confirmation is requested first." (lambda () - (let ((old - (prompt-for-input-truename "Rename file" - (current-default-pathname)))) + (let ((old (prompt-for-input-truename "Rename file" false))) (list old (prompt-for-output-truename "Rename to" old)))) (lambda (old new) (let ((do-it @@ -391,10 +418,33 @@ If a file with the new name already exists, confirmation is requested first." "fDelete File" delete-file) +(define-command pwd + "Show the current default directory." + () + (lambda () + (message "Directory " + (pathname->string (buffer-default-directory (current-buffer)))))) + (define-command cd - "Make DIR become Scheme's default directory." + "Make DIR become the current buffer's default directory." "DChange default directory" - cd) + (lambda (directory) + (set-default-directory directory) + ((ref-command pwd)))) + +(define (set-default-directory directory) + (let ((buffer (current-buffer))) + (let ((directory + (pathname-as-directory + (merge-pathnames (->pathname directory) + (buffer-default-directory buffer))))) + (if (not (file-directory? directory)) + (editor-error (pathname->string directory) " is not a directory")) + (if (not (unix/file-access directory 1)) + (editor-error "Cannot cd to " + (pathname->string directory) + ": Permission denied")) + (set-buffer-default-directory! buffer directory)))) ;;;; Printer Support @@ -444,84 +494,111 @@ If a file with the new name already exists, confirmation is requested first." ;;;; Prompting -(define (prompt-for-filename prompt default require-match?) - (let ((default - (if default - (pathname-directory-path default) - (working-directory-pathname)))) - (prompt-for-completed-string - prompt - (os/pathname->display-string default) - 'INSERTED-DEFAULT - (lambda (string if-unique if-not-unique if-not-found) - (define (loop directory filenames) - (let ((unique-case - (lambda (filenames) - (let ((filename - (os/make-filename directory (car filenames)))) - (if (os/file-directory? filename) - (let ((directory (os/filename-as-directory filename))) - (let ((filenames (os/directory-list directory))) - (if (null? filenames) - (if-unique directory) - (loop directory filenames)))) - (if-unique filename))))) - (non-unique-case - (lambda (filenames*) - (let ((string (string-greatest-common-prefix filenames*))) - (if-not-unique - (os/make-filename directory string) - (lambda () - (canonicalize-filename-completions - directory - (list-transform-positive filenames - (lambda (filename) - (string-prefix? string filename)))))))))) - (if (null? (cdr filenames)) - (unique-case filenames) - (let ((filtered-filenames - (list-transform-negative filenames - (lambda (filename) - (completion-ignore-filename? - (os/make-filename directory filename)))))) - (cond ((null? filtered-filenames) - (non-unique-case filenames)) - ((null? (cdr filtered-filenames)) - (unique-case filtered-filenames)) - (else - (non-unique-case filtered-filenames))))))) - (let ((pathname - (merge-pathnames (prompt-string->pathname string) default))) - (let ((directory (pathname-directory-string pathname)) - (prefix (pathname-name-string pathname))) - (cond ((not (os/file-directory? directory)) - (if-not-found)) - ((string-null? prefix) - ;; This optimization assumes that all directories - ;; contain at least one file. - (if-not-unique directory - (lambda () - (canonicalize-filename-completions - directory - (os/directory-list directory))))) - (else - (let ((filenames - (os/directory-list-completions directory prefix))) - (if (null? filenames) - (if-not-found) - (loop directory filenames)))))))) - (lambda (string) - (let ((pathname - (merge-pathnames (prompt-string->pathname string) default))) - (let ((directory (pathname-directory-string pathname))) - (canonicalize-filename-completions - directory - (os/directory-list-completions - directory - (pathname-name-string pathname)))))) - file-exists? - require-match?))) +(define (prompt-for-input-truename prompt default) + (pathname->input-truename (prompt-for-pathname prompt default true))) + +(define (prompt-for-output-truename prompt default) + (pathname->output-truename (prompt-for-pathname prompt default false))) + +(define (prompt-for-directory prompt default require-match?) + (let ((directory + (prompt-for-pathname* prompt default file-directory? require-match?))) + (if (file-directory? directory) + (pathname-as-directory directory) + directory))) + +(define-integrable (prompt-for-pathname prompt default require-match?) + (prompt-for-pathname* prompt default file-exists? require-match?)) + +(define (prompt-for-pathname* prompt directory + verify-final-value? require-match?) + (let ((directory + (if directory + (pathname-directory-path directory) + (buffer-default-directory (current-buffer))))) + (prompt-string->pathname + (prompt-for-completed-string + prompt + (os/pathname->display-string directory) + 'INSERTED-DEFAULT + (lambda (string if-unique if-not-unique if-not-found) + (filename-complete-string (prompt-string->pathname string directory) + if-unique if-not-unique if-not-found)) + (lambda (string) + (filename-completions-list + (prompt-string->pathname string directory))) + verify-final-value? + require-match?) + directory))) +;;;; Filename Completion + +(define (filename-complete-string pathname + if-unique if-not-unique if-not-found) + (define (loop directory filenames) + (let ((unique-case + (lambda (filenames) + (let ((filename (os/make-filename directory (car filenames)))) + (if (os/file-directory? filename) + (let ((directory (os/filename-as-directory filename))) + (let ((filenames (os/directory-list directory))) + (if (null? filenames) + (if-unique directory) + (loop directory filenames)))) + (if-unique filename))))) + (non-unique-case + (lambda (filenames*) + (let ((string (string-greatest-common-prefix filenames*))) + (if-not-unique (os/make-filename directory string) + (lambda () + (canonicalize-filename-completions + directory + (list-transform-positive filenames + (lambda (filename) + (string-prefix? string filename)))))))))) + (if (null? (cdr filenames)) + (unique-case filenames) + (let ((filtered-filenames + (list-transform-negative filenames + (lambda (filename) + (completion-ignore-filename? + (os/make-filename directory filename)))))) + (cond ((null? filtered-filenames) + (non-unique-case filenames)) + ((null? (cdr filtered-filenames)) + (unique-case filtered-filenames)) + (else + (non-unique-case filtered-filenames))))))) + (let ((directory (pathname-directory-string pathname)) + (prefix (pathname-name-string pathname))) + (cond ((not (os/file-directory? directory)) + (if-not-found)) + ((string-null? prefix) + ;; This optimization assumes that all directories + ;; contain at least one file. + (if-not-unique directory + (lambda () + (canonicalize-filename-completions + directory + (os/directory-list directory))))) + (else + (let ((filenames + (os/directory-list-completions directory prefix))) + (if (null? filenames) + (if-not-found) + (loop directory filenames))))))) + +(define (filename-completions-list pathname) + (let ((directory (pathname-directory-string pathname))) + (canonicalize-filename-completions + directory + (os/directory-list-completions directory + (pathname-name-string pathname))))) + +(define-integrable (prompt-string->pathname string directory) + (merge-pathnames (string->pathname (os/trim-pathname-string string)) + directory)) + (define (canonicalize-filename-completions directory filenames) (map (lambda (filename) (if (os/file-directory? (os/make-filename directory filename)) @@ -533,68 +610,14 @@ If a file with the new name already exists, confirmation is requested first." (and (not (os/file-directory? filename)) (there-exists? (ref-variable completion-ignored-extensions) (lambda (extension) - (and (string? extension) - (string-suffix? extension filename)))))) + (string-suffix? extension filename))))) (define-variable completion-ignored-extensions - "*Completion ignores filenames ending in any string in this list." - (os/completion-ignored-extensions)) - -(define (prompt-for-input-truename prompt default) - (pathname->input-truename - (prompt-string->pathname (prompt-for-filename prompt default true)))) - -(define (prompt-for-output-truename prompt default) - (pathname->output-truename (prompt-for-pathname prompt default))) - -(define (prompt-for-pathname prompt default) - (prompt-string->pathname (prompt-for-filename prompt default false))) - -(define (prompt-for-directory prompt default-pathname) - (let ((pathname (prompt-for-pathname prompt default-pathname))) - (if (file-directory? pathname) - (pathname-as-directory pathname) - pathname))) - -(define (current-default-pathname) - (newest-pathname - (let ((buffer (current-buffer))) - (or (buffer-pathname buffer) - (buffer-truename buffer))))) - -(define (newest-pathname pathname) - (pathname-new-version (or pathname (working-directory-pathname)) - (and pathname-newest 'NEWEST))) - -(define-integrable (prompt-string->pathname string) - (string->pathname (os/trim-pathname-string string))) - -(define (pathname->buffer-name pathname) - (let ((name (pathname-name pathname))) - (if name - (pathname->string - (make-pathname false false false - name (pathname-type pathname) false)) - (let ((name - (let ((directory (pathname-directory pathname))) - (and (pair? directory) - (car (last-pair directory)))))) - (if (string? name) name "*random*"))))) - -(define (pathname->buffer pathname) - (or (list-search-positive (buffer-list) - (lambda (buffer) - (let ((pathname* (buffer-pathname buffer))) - (and pathname* - (pathname=? pathname pathname*))))) - (let ((truename (pathname->input-truename pathname))) - (and truename - (list-search-positive (buffer-list) - (lambda (buffer) - (let ((pathname* (buffer-pathname buffer))) - (and pathname* - (or (pathname=? pathname pathname*) - (pathname=? truename pathname*) - (let ((truename* (buffer-truename buffer))) - (and truename* - (pathname=? truename truename*)))))))))))) \ No newline at end of file + "Completion ignores filenames ending in any string in this list." + (os/completion-ignored-extensions) + (lambda (extensions) + (and (list? extensions) + (for-all? extensions + (lambda (extension) + (and (string? extension) + (not (string-null? extension)))))))) \ No newline at end of file diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm index acf29d5b8..44ca03c51 100644 --- a/v7/src/edwin/input.scm +++ b/v7/src/edwin/input.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.87 1991/03/11 01:14:20 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.88 1991/03/16 00:02:18 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -104,12 +104,14 @@ B 3BAB8C (define command-prompt-displayed?) (define message-string) (define message-should-be-erased?) +(define auto-save-keystroke-count) (define (initialize-typeout!) (set! command-prompt-string false) (set! command-prompt-displayed? false) (set! message-string false) (set! message-should-be-erased? false) + (set! auto-save-keystroke-count 0) unspecific) (define (reset-command-prompt!) @@ -121,7 +123,8 @@ B 3BAB8C ;; timeout instead of right away. (begin (set! command-prompt-displayed? false) - (set! message-should-be-erased? true)))) + (set! message-should-be-erased? true))) + unspecific) (define-integrable (command-prompt) (or command-prompt-string "")) @@ -182,7 +185,7 @@ B 3BAB8C (if *executing-keyboard-macro?* (keyboard-macro-read-char) (let ((char (keyboard-read-char-1 (editor-read-char current-editor)))) - (set! *auto-save-keystroke-count* (1+ *auto-save-keystroke-count*)) + (set! auto-save-keystroke-count (1+ auto-save-keystroke-count)) (ring-push! (current-char-history) char) (if *defining-keyboard-macro?* (keyboard-macro-write-char char)) char))) @@ -191,44 +194,52 @@ B 3BAB8C (define read-char-timeout/slow 2000) (define (keyboard-read-char-1 read-char) - (let ((char-ready? (editor-char-ready? current-editor))) - ;; Perform redisplay if needed. - (if (not (char-ready?)) - (begin - (update-screens! false) - (if (let ((interval (ref-variable auto-save-interval)) - (count *auto-save-keystroke-count*)) - (and (positive? interval) - (> count interval) - (> count 20))) - (begin - (do-auto-save) - (set! *auto-save-keystroke-count* 0))))) - ;; Perform the appropriate juggling of the minibuffer message. - (cond ((within-typein-edit?) - (if message-string - (begin - (let ((t (+ (real-time-clock) read-char-timeout/slow))) - (let loop () - (if (and (not (char-ready?)) - (< (real-time-clock) t)) - (loop)))) - (set! message-string false) - (set! message-should-be-erased? false) - (clear-current-message!)))) - ((and (or message-should-be-erased? - (and command-prompt-string - (not command-prompt-displayed?))) - (let ((t (+ (real-time-clock) read-char-timeout/fast))) - (let loop () - (cond ((char-ready?) false) - ((< (real-time-clock) t) (loop)) - (else true))))) - (set! message-string false) - (set! message-should-be-erased? false) - (if command-prompt-string + (remap-alias-char + (let ((char-ready? (editor-char-ready? current-editor)) + (halt-update? (editor-halt-update? 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))) (begin - (set! command-prompt-displayed? true) - (set-current-message! command-prompt-string)) - (clear-current-message!))))) - (remap-alias-char (read-char))) \ No newline at end of file + (do-auto-save) + (set! auto-save-keystroke-count 0))))) + (let ((wait + (lambda (timeout) + (let ((t (+ (real-time-clock) timeout))) + (let loop () + (cond ((char-ready?) false) + ((>= (real-time-clock) t) true) + (else (loop)))))))) + ;; Perform the appropriate juggling of the minibuffer message. + (cond ((within-typein-edit?) + (if message-string + (begin + (wait read-char-timeout/slow) + (set! message-string false) + (set! message-should-be-erased? false) + (clear-current-message!)))) + ((and (or message-should-be-erased? + (and command-prompt-string + (not command-prompt-displayed?))) + (wait read-char-timeout/fast)) + (set! message-string false) + (set! message-should-be-erased? false) + (if command-prompt-string + (begin + (set! command-prompt-displayed? true) + (set-current-message! command-prompt-string)) + (clear-current-message!))))) + (let loop () + (or (read-char) + (begin + (accept-process-output) + (notify-process-status-changes) + (update-screens! false) + (loop))))))) \ No newline at end of file diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 327f40d2e..6dc1fbfff 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.36 1989/08/09 13:17:37 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.37 1991/03/16 00:02:24 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -55,20 +55,24 @@ (define-major-mode scheme-interaction scheme "Scheme Interaction" "Major mode for evaluating Scheme expressions interactively. -Same as Scheme mode, except for +Like Scheme mode, except that a history of evaluated expressions is saved. +The history may be accessed with the following commands: -\\[scheme-interaction-yank] yanks the most recently evaluated expression. -\\[scheme-interaction-yank-pop] yanks an earlier expression, replacing a yank." +\\[comint-previous-input] cycles backwards through the input history; +\\[comint-next-input] cycles forwards; +\\[comint-history-search-backward] searches backwards for a matching string; +\\[comint-history-search-forward] searchs forwards." (local-set-variable! enable-transcript-buffer true) (local-set-variable! transcript-buffer-name (current-buffer)) (local-set-variable! transcript-input-recorder scheme-interaction-input-recorder) (local-set-variable! transcript-output-wrapper scheme-interaction-output-wrapper) - (local-set-variable! scheme-interaction-kill-ring (make-ring 32))) + (local-set-variable! comint-input-ring + (make-ring (ref-variable comint-input-ring-size)))) (define (scheme-interaction-input-recorder region) - (ring-push! (ref-variable scheme-interaction-kill-ring) + (ring-push! (ref-variable comint-input-ring) (region->string region))) (define (scheme-interaction-output-wrapper thunk) @@ -83,44 +87,9 @@ Same as Scheme mode, except for (^G-signal)) thunk)))) -(define-prefix-key 'scheme-interaction #\C-c 'prefix-char) -(define-key 'scheme-interaction '(#\C-c #\C-y) 'scheme-interaction-yank) -(define-key 'scheme-interaction '(#\C-c #\C-r) 'scheme-interaction-yank-pop) - -(define-variable scheme-interaction-kill-ring - "Kill ring used by Interaction mode evaluation commands.") - -(define scheme-interaction-mode:yank-command-message "Yank") +(define-key 'scheme-interaction #\M-p 'comint-previous-input) +(define-key 'scheme-interaction #\M-n 'comint-next-input) -(define-command scheme-interaction-yank - "Re-insert the last input expression. -Puts point after it and the mark before it." - () - (lambda () - (let ((kill-ring (ref-variable scheme-interaction-kill-ring))) - (if (ring-empty? kill-ring) - (editor-error "Nothing to yank")) - (push-current-mark! (mark-right-inserting (current-point))) - (insert-string (ring-ref kill-ring 0)) - (set-command-message! scheme-interaction-mode:yank-command-message)))) - -(define-command scheme-interaction-yank-pop - "Correct after \\[scheme-interaction-yank] to use an earlier expression. -Requires that the region contain the most recent expression, -as it does immediately after using \\[scheme-interaction-yank]. -It is deleted and replaced with the previous expression, -which is rotated to the front of the expression ring." - () - (lambda () - (let ((kill-ring (ref-variable scheme-interaction-kill-ring))) - (if (ring-empty? kill-ring) - (editor-error "Nothing to yank")) - (command-message-receive scheme-interaction-mode:yank-command-message - (lambda () - (delete-string (pop-current-mark!) (current-point)) - (push-current-mark! (mark-right-inserting (current-point))) - (ring-pop! kill-ring) - (insert-string (ring-ref kill-ring 0)) - (set-command-message! scheme-interaction-mode:yank-command-message)) - (lambda () - (editor-error "No previous yank to replace")))))) \ No newline at end of file +(define-prefix-key 'scheme-interaction #\C-c 'prefix-char) +(define-key 'scheme-interaction '(#\C-c #\C-r) 'comint-history-search-backward) +(define-key 'scheme-interaction '(#\C-c #\C-s) 'comint-history-search-forward) \ No newline at end of file diff --git a/v7/src/edwin/kmacro.scm b/v7/src/edwin/kmacro.scm index dec8da957..22a8cf469 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.32 1990/11/02 03:09:52 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.33 1991/03/16 00:02:29 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -214,7 +214,8 @@ With argument, also record the keys it is bound to." (prompt-for-pathname (string-append "Write keyboard macro " name " to file") - (current-default-pathname))) + false + false)) (buffer (temporary-buffer "*Write-Keyboard-Macro-temp*"))) (with-output-to-mark (buffer-point buffer) (lambda () diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 791bfd884..2ba21d54c 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.26 1991/03/11 01:14:32 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.27 1991/03/16 00:02:36 cph Exp $ Copyright (c) 1989-91 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 26 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 27 '())) \ No newline at end of file diff --git a/v7/src/edwin/modlin.scm b/v7/src/edwin/modlin.scm index f665d00cd..65ea6f2f0 100644 --- a/v7/src/edwin/modlin.scm +++ b/v7/src/edwin/modlin.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.5 1990/11/02 03:24:31 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.6 1991/03/16 00:02:41 cph Exp $ ;;; -;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -264,7 +264,10 @@ If #F, the normal method is used." ((buffer-modified? buffer) "*") (else "-"))) ((#\s) - "no processes") + (let ((process (get-buffer-process buffer))) + (if process + (symbol->string (process-status process)) + "no process"))) ((#\p) (if (let ((end (buffer-end buffer))) (or (window-mark-visible? window end) diff --git a/v7/src/edwin/screen.scm b/v7/src/edwin/screen.scm index 454684697..2d78be098 100644 --- a/v7/src/edwin/screen.scm +++ b/v7/src/edwin/screen.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.87 1991/03/11 01:14:38 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.88 1991/03/16 00:02:48 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -507,23 +507,18 @@ (define (with-screen-in-update screen display-style thunk) (without-interrupts (lambda () - (call-with-current-continuation - (lambda (continuation) - (let ((old-flag)) - (dynamic-wind (lambda () - (set! old-flag (screen-in-update? screen)) - (set-screen-in-update?! screen - (or old-flag continuation))) + (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 () - ((screen-operation/wrap-update! screen) - screen - (lambda () - (and (thunk) - (screen-update screen display-style))))) - (lambda () - (set-screen-in-update?! screen old-flag) - (set! old-flag) - unspecific)))))))) + (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'. @@ -534,7 +529,7 @@ (let ((current-matrix (screen-current-matrix screen)) (new-matrix (screen-new-matrix screen)) (y-size (screen-y-size screen)) - (char-ready? (editor-char-ready? current-editor))) + (halt-update? (editor-halt-update? current-editor))) (let ((enable (matrix-enable new-matrix))) (let loop ((y 0)) (cond ((fix:= y y-size) @@ -549,7 +544,7 @@ ;; `terminal-preempt-update?' has side-effects, ;; and it must be run regardless of `force?'. (not force?) - (or (char-ready?) + (or (halt-update?) (eq? (screen-debug-preemption-y screen) y))) (terminal-move-cursor screen (matrix-cursor-x current-matrix) diff --git a/v7/src/edwin/simple.scm b/v7/src/edwin/simple.scm index 2b13c31d9..24cc602a5 100644 --- a/v7/src/edwin/simple.scm +++ b/v7/src/edwin/simple.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.30 1991/03/11 01:14:43 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.31 1991/03/16 00:02:56 cph Exp $ ;;; ;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology ;;; @@ -190,9 +190,10 @@ (cond (*executing-keyboard-macro?* unspecific) ((not mark) (editor-beep)) ((window-mark-visible? (current-window) mark) - (with-current-point mark - (lambda () - (sit-for 500)))) + (if (not ((editor-char-ready? current-editor))) + (with-current-point mark + (lambda () + (sit-for 500))))) (else (temporary-message (let ((start (line-start mark 0)) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index be64ff021..ca29c1615 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.4 1991/03/11 01:14:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.5 1991/03/16 00:03:03 cph Exp $ Copyright (c) 1990-91 Massachusetts Institute of Technology @@ -141,30 +141,37 @@ MIT in each case. |# (if block? (channel-blocking channel) (channel-nonblocking channel)) - (let ((n (channel-read channel string 0 input-buffer-size))) - (cond (n - (if (fix:= n 0) (eof)) - (set! start 0) - (set! end n) - (if transcript-port - (write-string (substring string 0 n) - transcript-port))) - (block? (error "Blocking read returned #F."))) - n))))) + (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))))))) (values - (lambda () ;char-ready? + (lambda () ;halt-update? (if (fix:< start end) true (fill-buffer false))) + (lambda () ;char-ready? + (if (fix:< start end) + true + (eq? 'CHAR (fill-buffer false)))) (lambda () ;peek-char - (if (not (fix:< start end)) (fill-buffer true)) - (string-ref string start)) + (and (or (fix:< start end) (eq? 'CHAR (fill-buffer true))) + (string-ref string start))) (lambda () ;read-char - (if (not (fix:< start end)) (fill-buffer true)) - (let ((char (string-ref string start))) - (set! start (fix:+ start 1)) - char)))))) - + (and (or (fix:< start end) (eq? 'CHAR (fill-buffer true))) + (let ((char (string-ref string start))) + (set! start (fix:+ start 1)) + char))))))) + (define (signal-interrupt! interrupt-enables) interrupt-enables ; ignored ;; (editor-beep) ; kbd beeps by itself diff --git a/v7/src/edwin/window.scm b/v7/src/edwin/window.scm index 8e7571cd6..2df27ae54 100644 --- a/v7/src/edwin/window.scm +++ b/v7/src/edwin/window.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.153 1991/03/11 01:14:53 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.154 1991/03/16 00:03:11 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -209,9 +209,9 @@ display-style) (update-inferiors! (window-inferiors window) screen x-start y-start xl xu yl yu display-style - (let ((char-ready? (editor-char-ready? current-editor))) + (let ((halt-update? (editor-halt-update? current-editor))) (lambda (window screen x-start y-start xl xu yl yu display-style) - (and (or display-style (not (char-ready?))) + (and (or display-style (not (halt-update?))) (=> window :update-display! screen x-start y-start xl xu yl yu display-style)))))) diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index 828b5f704..663afa9a8 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.14 1991/03/11 01:15:02 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.15 1991/03/16 00:03:18 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -230,66 +230,74 @@ (start 0) (end 0) (pending-event false)) - (let ((process-events! - (lambda (limit) - (letrec - ((loop - (lambda () - (let ((event (x-display-process-events display limit))) - (cond ((not event) - (if (not limit) - (error "Blocking read returned #F.")) - false) - ((eq? event true) - ;; Handle subprocess output here. - (loop)) - ((= (vector-ref event 0) event-type:key-press) - (set! string (vector-ref event 2)) - (set! start 0) - (set! end (string-length string)) - (if signal-interrupts? - (let ((^g-index - (string-find-previous-char string - #\BEL))) - (if ^g-index - (begin - (set! start (fix:+ ^g-index 1)) - (signal-interrupt!))))) - true) - (else - (process-special-event event)))))) - (process-special-event - (lambda (event) - (let ((handler - (vector-ref event-handlers (vector-ref event 0))) - (screen (xterm->screen (vector-ref event 1)))) - (if (and handler screen) - (begin - (let ((continuation (screen-in-update? screen))) - (if continuation - (begin - (set! pending-event event) - (continuation false)))) - (handler screen event)))) - (loop)))) - (if (not pending-event) - (loop) - (let ((event pending-event)) - (set! pending-event false) - (process-special-event event))))))) - (values - (lambda () ;char-ready? - (if (fix:< start end) - true - (process-events! 0))) - (lambda () ;peek-char - (if (not (fix:< start end)) (process-events! false)) - (string-ref string start)) - (lambda () ;read-char - (if (not (fix:< start end)) (process-events! false)) - (let ((char (string-ref string start))) - (set! start (fix:+ start 1)) - char)))))) + (let ((get-next-event + (lambda (time-limit) + (if pending-event + (let ((event pending-event)) + (set! pending-event false) + event) + (x-display-process-events display time-limit)))) + (process-key-press-event + (lambda (event) + (set! string (vector-ref event 2)) + (set! start 0) + (set! end (string-length string)) + (if signal-interrupts? + (let ((i (string-find-previous-char string #\BEL))) + (if i + (begin + (set! start (fix:+ i 1)) + (signal-interrupt!))))))) + (process-special-event + (lambda (event) + (let ((handler (vector-ref event-handlers (vector-ref event 0))) + (screen (xterm->screen (vector-ref event 1)))) + (if (and handler screen) + (handler screen event)))))) + (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) + ((eq? event-type:key-press (vector-ref event 0)) + (process-key-press-event event) + (if (fix:< start end) true (loop))) + (else + (process-special-event event) + (loop)))))))) + (values + (lambda () ;halt-update? + (if (or (fix:< start end) pending-event) + true + (let ((event (get-next-event 0))) + (and event + (begin + (set! pending-event event) + true))))) + (lambda () ;char-ready? + (if (fix:< start end) + true + (let loop () + (let ((event (get-next-event 0))) + (cond ((or (not event) (eq? true event)) + false) + ((eq? event-type:key-press (vector-ref event 0)) + (process-key-press-event event) + (if (fix:< start end) true (loop))) + (else + (process-special-event event) + (loop))))))) + (lambda () ;peek-char + (and (or (fix:< start end) (guarantee-input)) + (string-ref string start))) + (lambda () ;read-char + (and (or (fix:< start end) (guarantee-input)) + (let ((char (string-ref string start))) + (set! start (fix:+ start 1)) + char)))))))) ;;; The values of these flags must be equal to the corresponding event ;;; types in "microcode/x11base.c" -- 2.25.1