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.
;;; -*-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
(declare (usual-integrations))
\f
(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.
(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)
(<= (* 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)
;;; -*-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
;;;
"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))))))
\f
;;;; Comment Commands
;;; -*-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
comtabs
windows
display-start
+ default-directory
pathname
truename
alist
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)))
\f
(define (buffer-modeline-event! buffer type)
(let loop ((windows (buffer-windows buffer)))
(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)
(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
(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))))))
\f
(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))))))
\f
-(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
(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))))))
\f
;;;; Modes
(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)))
(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)))
(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)))
;;; -*-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
(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
;;; -*-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
;;;
(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)
;;; -*-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
(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))
\f
(define-integrable (select-buffer buffer)
(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))
\f
;;;; Point
(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))
#| -*-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
"autosv"
"basic"
"bufcom"
- "buffer"
"bufmnu"
"bufset"
"c-mode"
"calias"
"cinden"
+ "comint"
"comman"
"comred"
- "curren"
"debug"
"debuge"
"dired"
"modlin"
"motcom"
"pasmod"
+ "process"
"prompt"
+ "rcs"
"reccom"
"regcom"
"regexp"
"scrcom"
"screen"
"sercom"
+ "shell"
"struct"
"syntax"
"tags"
(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")
syntax-table/system-internal)
("comman" (edwin)
edwin-syntax-table)
+ ("comint" (edwin)
+ edwin-syntax-table)
("comred" (edwin command-reader)
edwin-syntax-table)
("comtab" (edwin comtab)
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)
syntax-table/system-internal)
("sercom" (edwin)
edwin-syntax-table)
+ ("shell" (edwin)
+ edwin-syntax-table)
("simple" (edwin)
syntax-table/system-internal)
("strpad" (edwin)
;;; -*-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
;;;
(declare (usual-integrations))
\f
(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))
(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)
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)
(initialize-typeout!)
(initialize-syntax-table!)
(initialize-command-reader!)
+ (initialize-processes!)
(set! edwin-editor
(make-editor "Edwin"
(let ((name (car args)))
(define recursive-edit-level)
\f
(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
(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
(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
(define (%editor-error)
(editor-beep)
(abort-current-command))
-
+\f
(define (^G-signal)
(let ((continuations *^G-interrupt-continuations*))
(if (not (pair? continuations))
;;; -*-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
;;;
(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)
(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)
bufferset
(make-ring 10)
(make-ring 100)
+ halt-update?
char-ready?
peek-char
read-char
;;; -*-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.
(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)
#| -*-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
"autosv" ; auto save
"basic" ; basic commands
"bufcom" ; buffer commands
+ "comint" ; command interpreter process stuff
"evlcom" ; evaluation commands
"filcom" ; file commands
"fill" ; text fill commands
"schmod" ; scheme mode
"scrcom" ; screen commands
"sercom" ; search commands
+ "shell" ; shell subprocess commands
"texcom" ; text commands
"wincom" ; window commands
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))
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
(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")
(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")
(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
;;; -*-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
;;;
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)
(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)))
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.
(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)
"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*))))))))))))
\f
(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))
"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
"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))))
\f
;;;; Printer Support
\f
;;;; 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)))
\f
+;;;; 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))
(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
;;; -*-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
;;;
(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!)
;; 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 ""))
(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)))
(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
;;; -*-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
(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)
(^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)
-\f
-(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
;;; -*-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
(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 ()
#| -*-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
(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
;;; -*-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
((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)
;;; -*-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
;;;
(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'.
(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)
;; `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)
;;; -*-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
;;;
(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))
#| -*-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
(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)))))))
+\f
(define (signal-interrupt! interrupt-enables)
interrupt-enables ; ignored
;; (editor-beep) ; kbd beeps by itself
;;; -*-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
;;;
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))))))
;;; -*-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
;;;
(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))))))))
\f
;;; The values of these flags must be equal to the corresponding event
;;; types in "microcode/x11base.c"
projects / mit-scheme.git / commitdiff