;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.1 1989/08/08 22:00:00 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.2 1989/08/09 13:17:06 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(hook/prompt-for-expression
(lambda (cmdl prompt)
cmdl ;ignore
- (prompt-for-expression prompt false))) (hook/debugger-failure
+ (prompt-for-expression prompt)))
+ (hook/debugger-failure
(lambda (string)
(message string)
(editor-beep)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.44 1989/08/03 23:33:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.45 1989/08/09 13:16:41 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(temporary-message "Loading file \"" (pathname->string pathname) "\"")
(let ((scode (fasload pathname true)))
(if (or (default-object? purify?) purify?) (purify scode))
- (scode-eval scode (->environment package)))) (append-message " -- done"))
+ (scode-eval-with-history scode (->environment package))))
+ (append-message " -- done"))
(define-command load-file
"Load an Edwin binary file.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.82 1989/04/28 22:47:10 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.83 1989/08/09 13:16:45 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(if buffer
(search-loop 2)
name))))
+
+(define (string->temporary-buffer string name)
+ (let ((buffer (temporary-buffer name)))
+ (insert-string string (buffer-point buffer))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (buffer-not-modified! buffer)
+ (pop-up-buffer buffer false)))
+
(define (with-output-to-temporary-buffer name thunk)
(let ((buffer (temporary-buffer name)))
(with-output-to-mark (buffer-point buffer) thunk)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.131 1989/08/08 10:05:22 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.132 1989/08/09 13:16:48 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
thunk
(lambda ()
(if read-only? (set-group-read-only! group))))))
-\f
-;;;; Buffer Display Name
-
-(define (buffer-display-name buffer)
- (let ((name (buffer-name buffer))
- (pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
- (let ((display-string
- (lambda (name)
- (if (pathname-version pathname)
- (let ((version
- (pathname-version
- (or (buffer-truename buffer) pathname))))
- (if (integer? version)
- (string-append name " (" (number->string version) ")")
- name))
- name))))
- (if (not pathname)
- name
- (let ((name* (pathname->buffer-name pathname)))
- (if (or (string-ci=? name name*)
- (let ((i (string-match-forward-ci name name*)))
- (and i
- (= i (string-length name*))
- (char=? (string-ref name i) #\<))))
- (display-string name)
- (string-append name " [" (display-string name*) "]")))))))
+
+(define (add-buffer-initialization! buffer thunk)
+ (without-interrupts (lambda () (%add-buffer-initialization! buffer thunk))))
+
+(define (%add-buffer-initialization! buffer thunk)
+ (if (current-buffer? buffer)
+ (thunk)
+ (vector-set! buffer
+ buffer-index:initializations
+ (append! (buffer-initializations buffer) (list thunk)))))
+
+(define (perform-buffer-initializations! buffer)
+ ;; Assumes that interrupts are disabled and BUFFER is selected.
+ (let loop ((thunks (buffer-initializations buffer)))
+ (if (not (null? thunks))
+ (begin
+ ((car thunks))
+ (loop)))) (vector-set! buffer buffer-index:initializations '())
+ unspecific)
\f
;;;; Local Bindings
unspecific)))
(define (undo-local-bindings!)
- (without-interrupts
- (lambda ()
- (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 '()))
- unspecific)))
-
+ (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 '()))
+ unspecific)
(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 invoke-variable-assignment-daemons! variables))))
\f
(define (variable-local-value buffer variable)
- (let ((buffer* (current-buffer))
- (in-cell
+ (let ((in-cell
(lambda ()
(variable-value variable))))
- (if (eq? buffer buffer*)
+ (if (current-buffer? buffer)
(in-cell)
(let ((binding (assq variable (buffer-local-bindings buffer))))
(cond (binding
(cdr binding))
- ((variable-buffer-local? variable)
+ ((and (variable-buffer-local? variable)
+ (within-editor?))
(let ((binding
- (assq variable (buffer-local-bindings buffer*))))
+ (assq variable
+ (buffer-local-bindings (current-buffer)))))
(if binding
(cdr binding)
(in-cell))))
(in-cell)))))))
(define (set-variable-local-value! buffer variable value)
- (if (eq? buffer (current-buffer))
+ (if (current-buffer? buffer)
(set-variable-value! variable value)
(let ((binding (assq variable (buffer-local-bindings buffer))))
(if binding
unspecific)
(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)))
+ unspecific))))))
+
(define (variable-local-value? buffer variable)
(assq variable (buffer-local-bindings buffer)))
(set-cdr! modes '()))
(set-buffer-comtabs! buffer (mode-comtabs mode))
(vector-set! buffer buffer-index:alist '())
- (buffer-modeline-event! buffer 'BUFFER-MODES)
(vector-set! buffer buffer-index:initializations '())
- (add-buffer-initialization! buffer undo-local-bindings!)
- (add-buffer-initialization! buffer (mode-initialization mode)))))
+ (buffer-modeline-event! buffer 'BUFFER-MODES)
+ (%add-buffer-initialization! buffer undo-local-bindings!)
+ (%add-buffer-initialization! buffer (mode-initialization mode)))))
+
+(define-integrable (buffer-minor-modes buffer)
+ (cdr (buffer-modes buffer)))
(define (buffer-minor-mode? buffer mode)
(if (mode-major? mode) (error "Not a minor mode" mode))
- (memq mode (buffer-modes buffer)))
+ (memq mode (buffer-minor-modes buffer)))
(define (enable-buffer-minor-mode! buffer mode)
(if (mode-major? mode) (error "Not a minor mode" mode))
(set-buffer-comtabs! buffer
(cons (mode-comtab mode)
(buffer-comtabs buffer)))
- (buffer-modeline-event! buffer 'BUFFER-MODES)
- (add-buffer-initialization! buffer
- (mode-initialization mode))))))))
+ (%add-buffer-initialization! buffer (mode-initialization mode))
+ (buffer-modeline-event! buffer 'BUFFER-MODES)))))))
(define (disable-buffer-minor-mode! buffer mode)
(if (mode-major? mode) (error "Not a minor mode" mode))
(set-buffer-comtabs! buffer
(delq! (mode-comtab mode)
(buffer-comtabs buffer)))
- (buffer-modeline-event! buffer 'BUFFER-MODES)))))))
-
-(define (add-buffer-initialization! buffer thunk)
- (if (eq? buffer (current-buffer))
- (thunk)
- (vector-set! buffer
- buffer-index:initializations
- (append! (buffer-initializations buffer) (list thunk)))))
-
-(define (perform-buffer-initializations! buffer)
- ;; Assumes that BUFFER is selected.
- (let loop ()
- (let ((thunks (buffer-initializations buffer)))
- (if (not (null? thunks))
- (begin
- (vector-set! buffer buffer-index:initializations (cdr thunks))
- ((car thunks))
- (loop))))))
\ No newline at end of file
+ (buffer-modeline-event! buffer 'BUFFER-MODES)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufout.scm,v 1.2 1989/04/28 22:47:40 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufout.scm,v 1.3 1989/08/09 13:16:53 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;;
;;;; Buffer Output Ports
+;;; Package: (edwin buffer-output-port)
(declare (usual-integrations))
\f
(with-output-to-port (mark->output-port mark)
thunk))
-(define (mark->output-port mark)
- (output-port/copy mark-output-port-template (mark-left-inserting mark)))
+(define (mark->output-port mark #!optional buffer)
+ (output-port/copy mark-output-port-template
+ (cons (mark-left-inserting mark)
+ (if (default-object? buffer)
+ false
+ buffer))))
-(define (operation/write-char port char)
- (region-insert-char! (output-port/state port) char))
+(define (fresh-line #!optional port)
+ (let ((port (if (default-object? port) (current-output-port) port)))
+ (let ((operation (output-port/custom-operation port 'fresh-line)))
+ (if operation
+ (operation port)
+ (output-port/write-char port #\newline))
+ (output-port/flush-output port))))
-(define (operation/write-string port string)
- (region-insert-string! (output-port/state port) string))
+(define (fresh-lines n #!optional port)
+ (let ((port (if (default-object? port) (current-output-port) port)))
+ (let ((operation (output-port/custom-operation port 'fresh-lines)))
+ (if operation
+ (operation port n)
+ (let loop ((n n))
+ (if (positive? n)
+ (begin
+ (output-port/write-char port #\newline)
+ (loop (-1+ n))))))
+ (output-port/flush-output port))))
+
+(define-integrable (output-port/mark port)
+ (car (output-port/state port)))
+
+(define-integrable (output-port/buffer port)
+ (cdr (output-port/state port)))
+
+(define (operation/flush-output port)
+ (let ((mark (output-port/mark port))
+ (buffer (output-port/buffer port)))
+ (if buffer
+ (for-each (if (mark= mark (buffer-point buffer))
+ (lambda (window)
+ (set-window-point! window mark)
+ (window-direct-update! window false))
+ (lambda (window)
+ (window-direct-update! window false)))
+ (buffer-windows buffer)))))
+
+(define (operation/fresh-line port)
+ (guarantee-newline (output-port/mark port)))
+
+(define (operation/fresh-lines port n)
+ (guarantee-newlines n (output-port/mark port)))
(define (operation/print-self state port)
(unparse-string state "to buffer at ")
- (unparse-object state (output-port/state port)))
+ (unparse-object state (output-port/mark port)))
+
+(define (operation/write-char port char)
+ (region-insert-char! (output-port/mark port) char))
+
+(define (operation/write-string port string)
+ (region-insert-string! (output-port/mark port) string))
(define mark-output-port-template
- (make-output-port `((PRINT-SELF ,operation/print-self) (WRITE-CHAR ,operation/write-char)
+ (make-output-port `((FLUSH-OUTPUT ,operation/flush-output)
+ (FRESH-LINE ,operation/fresh-line)
+ (FRESH-LINES ,operation/fresh-lines)
+ (PRINT-SELF ,operation/print-self)
+ (WRITE-CHAR ,operation/write-char)
(WRITE-STRING ,operation/write-string))
false))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.59 1989/08/08 10:05:43 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.60 1989/08/09 13:16:56 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(vector-set! command command-index:procedure procedure)
command))
-(define editor-commands
- (make-string-table 500))
+(define editor-commands (make-string-table 500))
(define (name->command name)
(let ((name (canonicalize-name name)))
(editor-error "Undefined command: "
(command-name-string command))))))
command))))
+
+(define (->command object)
+ (if (command? object) object (name->command object)))
\f
(define-named-structure "Variable"
name
(for-each (lambda (daemon) (daemon variable))
(variable-assignment-daemons variable)))
-(define editor-variables
- (make-string-table 50))
+(define editor-variables (make-string-table 50))
(define (name->variable name)
(let ((name (canonicalize-name name)))
(or (string-table-get editor-variables (symbol->string name))
(make-variable name "" false))))
+
+(define (->variable object)
+ (if (variable? object) object (name->variable object)))
+
(define (set-variable-value! variable value)
(if (variable-buffer-local? variable)
(make-local-binding! variable value)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.77 1989/08/08 10:05:47 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.78 1989/08/09 13:16:59 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
((#\v)
(prompting (variable-name (prompt-for-variable prompt))))
((#\x)
- (prompting (prompt-for-expression prompt false)))
+ (prompting (prompt-for-expression prompt)))
((#\X)
- (prompting (prompt-for-expression-value prompt false))) (else
+ (prompting (prompt-for-expression-value prompt)))
+ (else
(editor-error "Invalid control letter "
char
" in interactive calling string")))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.84 1989/08/08 10:05:50 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.85 1989/08/09 13:17:02 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-integrable (buffer-names)
(bufferset-names (current-bufferset)))
+(define-integrable (current-buffer? buffer)
+ (eq? buffer (current-buffer)))
+
(define-integrable (current-buffer)
(window-buffer (current-window)))
\f
;;;; Modes and Comtabs
-(define-integrable (current-modes)
- (buffer-modes (current-buffer)))
-
(define-integrable (current-major-mode)
(buffer-major-mode (current-buffer)))
+
+(define-integrable (current-minor-modes)
+ (buffer-minor-modes (current-buffer)))
+
(define-integrable (current-comtabs)
(buffer-comtabs (current-buffer)))
"midas"
"modefs"
"modes"
+ "modlin"
"motcom"
"pasmod"
"prompt"
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.5 1989/08/07 08:44:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.6 1989/08/09 13:17:13 cph Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(load "simple" environment)
(load "debuge" environment)
(load "calias" environment)
+ (load "modlin" (->environment '(EDWIN MODELINE-STRING)))
(load "input" (->environment '(EDWIN KEYBOARD)))
(load "prompt" (->environment '(EDWIN PROMPT)))
(load "comred" (->environment '(EDWIN COMMAND-READER)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.8 1989/08/08 10:06:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.9 1989/08/09 13:17:16 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
initialize-buttons!
make-display
make-editor-frame
- modeline-mode-string
- modeline-modified-string
- modeline-percentage-string
set-window-point!
set-window-start-mark!
update-screen!
combination-leaf-window
window0))
+(define-package (edwin modeline-string)
+ (files "modlin")
+ (parent (edwin))
+ (export (edwin)
+ edwin-variable$global-mode-string
+ edwin-variable$mode-line-buffer-identification
+ edwin-variable$mode-line-format
+ edwin-variable$mode-line-modified
+ edwin-variable$mode-line-procedure
+ edwin-variable$mode-line-process
+ modeline-string))
+
(define-package (edwin command-reader)
(files "comred")
(parent (edwin))
(files "bufout")
(parent (edwin))
(export (edwin)
+ fresh-line
+ fresh-lines
+ mark->output-port
with-output-to-mark))
(define-package (edwin buffer-output-port-truncating)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.15 1989/08/07 08:44:48 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.16 1989/08/09 13:17:23 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;;
;;;; Evaluation Commands
+;;; Package: (edwin)
(declare (usual-integrations))
\f
+;;;; Variables
+
(define-variable scheme-environment
"The environment used by the evaluation commands, or 'DEFAULT.
If 'DEFAULT, use the default (REP loop) environment."
'DEFAULT)
(define-variable scheme-syntax-table
- "The syntax table used by the evaluation commands, or false.
-If false, use the default (REP loop) syntax-table."
- false)
-
-(define-variable previous-evaluation-expression
- "The last expression evaluated in the typein window."
+ "The syntax table used by the evaluation commands, or #F
+If #F, use the default (REP loop) syntax-table."
false)
(define-variable debug-on-evaluation-error
This does not affect editor errors."
true)
+(define-variable enable-transcript-buffer
+ "If true, output from evaluation commands is recorded in transcript buffer."
+ true)
+
+(define-variable transcript-buffer-name
+ "Name of evaluation transcript buffer.
+This can also be a buffer object."
+ "*scratch*")
+
+(define-variable transcript-buffer-mode
+ "Mode of evaluation transcript buffer.
+This can be either a mode object or the name of one."
+ 'scheme-interaction)
+
+(define-variable transcript-input-recorder
+ "A procedure which receives each input region before evaluation.
+If #F, disables input recording."
+ false)
+
+(define-variable transcript-output-wrapper
+ "A procedure which is called to setup transcript output.
+It is passed a thunk as its only argument.
+If #F, normal transcript output is done."
+ false)
+
+(define-variable transcript-value-truncate
+ "True means evaluation results are printed with depth and breadth limits."
+ true)
+\f
+;;;; Commands
+
(define-command eval-definition
"Evaluate the definition at point.
Prints the result in the typein window.
-With an argument, prompts for the evaluation environment.
-Output goes to the transcript buffer."
+With an argument, prompts for the evaluation environment."
"P"
(lambda (argument)
- (evaluate-from-mark (current-definition-start)
- (evaluation-environment argument))))
+ (evaluate-from-mark (current-definition-start) argument)))
(define-command eval-next-sexp
"Evaluate the expression following point.
Prints the result in the typein window.
-With an argument, prompts for the evaluation environment.
-Output goes to the transcript buffer."
+With an argument, prompts for the evaluation environment."
"P"
(lambda (argument)
- (evaluate-from-mark (current-point)
- (evaluation-environment argument))))
+ (evaluate-from-mark (current-point) argument)))
(define-command eval-previous-sexp
"Evaluate the expression preceding point.
Prints the result in the typein window.
-With an argument, prompts for the evaluation environment.
-Output goes to the transcript buffer."
+With an argument, prompts for the evaluation environment."
"P"
(lambda (argument)
- (evaluate-from-mark (backward-one-sexp (current-point))
- (evaluation-environment argument))))
+ (evaluate-from-mark (backward-sexp (current-point) 1 'ERROR) argument)))
(define-command eval-region
"Evaluate the region, printing the results in the typein window.
-With an argument, prompts for the evaluation environment.
-Output goes to the transcript buffer."
+With an argument, prompts for the evaluation environment."
"r\nP"
(lambda (region argument)
- (evaluate-region region (evaluation-environment argument))))
+ (evaluate-region region argument)))
-(define-command eval-current-buffer
+(define-command eval-buffer
"Evaluate the buffer.
The values are printed in the typein window.
-With an argument, prompts for the evaluation environment.
-Output goes to the transcript buffer."
- "P"
- (lambda (argument)
- (evaluate-region (buffer-region (current-buffer))
- (evaluation-environment argument))))
-\f
-(define-command eval-previous-sexp-into-buffer
- "Evaluate the expression preceding point.
-With an argument, prompts for the evaluation environment.
-Output is inserted into the buffer at point."
+With an argument, prompts for the evaluation environment."
"P"
(lambda (argument)
- (let ((start (backward-sexp (current-point) 1 false)))
- (if (not start) (editor-error "No previous expression"))
- (let ((environment (evaluation-environment argument)))
- (with-output-to-current-point
- (lambda ()
- (write-line
- (eval-with-history (read-from-mark start) environment))))))))
+ (evaluate-region (buffer-region (current-buffer)) argument)))
(define-command eval-expression
"Read an evaluate an expression in the typein window.
(lambda (environment)
(set-repl/environment! (nearest-repl) (->environment environment))))
-(define (evaluation-environment argument)
- (cond (argument
- (->environment
- (prompt-for-expression-value "Evaluate in environment" false)))
- ((eq? 'DEFAULT (ref-variable scheme-environment))
- (nearest-repl/environment))
- (else
- (->environment (ref-variable scheme-environment)))))
-
(define-command set-syntactic-environment
"Sets the current syntactic environment."
"XSet syntactic environment"
(lambda (syntactic-environment)
(set-repl/syntax-table! (nearest-repl) syntactic-environment)))
+(define-command select-transcript-buffer
+ "Select the transcript buffer."
+ ()
+ (lambda ()
+ (select-buffer (transcript-buffer))))
+\f
+;;;; Expression Prompts
+
+(define (prompt-for-expression-value prompt #!optional default)
+ (eval-with-history (if (default-object? default)
+ (prompt-for-expression prompt)
+ (prompt-for-expression prompt default))
+ (evaluation-environment false)))
+
+(define (prompt-for-expression prompt #!optional default-object default-type)
+ (read-from-string
+ (prompt-for-string prompt
+ (and (not (default-object? default-object))
+ (write-to-string default-object))
+ (if (default-object? default-type)
+ 'VISIBLE-DEFAULT
+ default-type)
+ (ref-mode-object prompt-for-expression))))
+(define-major-mode prompt-for-expression scheme #f
+ "Major mode for editing solicited input expressions.
+Depending on what is being solicited, either defaulting or completion
+may be available. The following commands are special to this mode:
+
+\\[exit-minibuffer] terminates the input.
+\\[minibuffer-yank-default] yanks the default string, if there is one.")
+
+(define-key 'prompt-for-expression #\return 'exit-minibuffer)
+(define-key 'prompt-for-expression #\c-m-y 'minibuffer-yank-default)
+\f
+;;;; Evaluation
+
+(define (evaluate-from-mark input-mark argument)
+ (evaluate-region (make-region input-mark (forward-sexp input-mark 1 'ERROR))
+ argument))
+
+(define (evaluate-region region argument)
+ (let ((transcript-input-recorder (ref-variable transcript-input-recorder)))
+ (if transcript-input-recorder
+ (transcript-input-recorder region)))
+ (let ((environment (evaluation-environment argument)))
+ (with-input-from-region region
+ (lambda ()
+ (let loop ((sexp (read)))
+ (if (not (eof-object? sexp))
+ (begin
+ (editor-eval sexp environment)
+ (loop (read)))))))))
+
+(define (evaluation-environment argument)
+ (if argument
+ (if (environment? argument)
+ argument
+ (->environment
+ (prompt-for-expression-value "Evaluate in environment")))
+ (let ((environment (ref-variable scheme-environment)))
+ (if (eq? 'DEFAULT environment)
+ (nearest-repl/environment)
+ (->environment environment)))))
+
(define (evaluation-syntax-table)
(or (ref-variable scheme-syntax-table)
(nearest-repl/syntax-table)))
-\f
-(define (evaluate-from-mark input-mark environment)
- (editor-eval (read-from-mark input-mark) environment))
-
-(define (read-from-mark input-mark)
- (with-input-from-mark input-mark read))
(define (editor-eval sexp environment)
(with-output-to-transcript-buffer
(transcript-write value)
value))))
-(define (evaluate-region region environment)
- (with-output-to-transcript-buffer
- (lambda ()
- (with-input-from-region region
- (lambda ()
- (let loop ((object (read)))
- (if (not (eof-object? object))
- (begin
- (transcript-write (eval-with-history object environment))
- (loop (read))))))))))
-
(define (eval-with-history expression environment)
- (let ((scode (syntax expression (evaluation-syntax-table))))
- (bind-condition-handler '()
- (lambda (condition)
- (and (not (condition/internal? condition))
- (error? condition)
+ (scode-eval-with-history (syntax expression (evaluation-syntax-table))
+ environment))
+
+(define (scode-eval-with-history scode environment)
+ (bind-condition-handler '()
+ (lambda (condition)
+ (and (not (condition/internal? condition))
+ (error? condition)
+ (begin
(if (ref-variable debug-on-evaluation-error)
(debug-scheme-error condition)
(let ((string
(< (string-column-length string 18) 80))
(message "Evaluation error: " string)
(begin
- (with-output-to-temporary-buffer "*error*" string)
+ (string->temporary-buffer string "*Error*")
(message "Evaluation error")))))
- (%editor-error)))
- (lambda ()
- (with-new-history
- (lambda () (extended-scode-eval scode environment)))))))
-
-(define (prompt-for-expression-value prompt default)
- (eval-with-history (prompt-for-expression prompt default)
- (evaluation-environment false)))
-
-(define (prompt-for-expression prompt default-object #!optional default-type)
- (read-from-string
- (prompt-for-string prompt
- (and default-object
- (write-to-string default-object))
- (if (default-object? default-type)
- 'VISIBLE-DEFAULT
- default-type)
- (ref-mode-object prompt-for-expression))))
-
-(define-major-mode prompt-for-expression scheme #f
- "Major mode for editing solicited input expressions.
-Depending on what is being solicited, either defaulting or completion
-may be available. The following commands are special to this mode:
-
-\\[exit-minibuffer] terminates the input.
-\\[minibuffer-yank-default] yanks the default string, if there is one.")
-
-(define-key 'prompt-for-expression #\return 'exit-minibuffer)
-(define-key 'prompt-for-expression #\c-m-y 'minibuffer-yank-default)
+ (%editor-error))))
+ (lambda ()
+ (with-new-history
+ (lambda ()
+ (extended-scode-eval scode environment))))))
\f
;;;; Transcript Buffer
-(define-variable transcript-buffer-name
- "Name of buffer to which evaluation commands record their output."
- "*Transcript*")
-
-(define-variable enable-transcript-buffer
- "If true, I/O from evaluation commands is recorded in transcript buffer.
-Recording is done only for commands that write their output to the
-message area, not commands that write to a specific buffer."
- false)
-
-(define (transcript-buffer)
- (find-or-create-buffer (ref-variable transcript-buffer-name)))
+(define (with-output-to-transcript-buffer thunk)
+ (if (ref-variable enable-transcript-buffer)
+ (let ((output-wrapper (ref-variable transcript-output-wrapper)))
+ (if output-wrapper
+ (output-wrapper thunk)
+ (with-output-to-port
+ (let ((buffer (transcript-buffer)))
+ (mark->output-port (buffer-end buffer) buffer))
+ (lambda ()
+ (fresh-lines 1)
+ (thunk)))))
+ (let ((value))
+ (let ((output
+ (with-output-to-string
+ (lambda ()
+ (set! value (thunk))
+ unspecific))))
+ (if (not (string-null? output))
+ (string->temporary-buffer output "*Unsolicited-Output*")))
+ value)))
(define (transcript-write value)
- (if (ref-variable enable-transcript-buffer)
- (write-line value))
- (if (or (not (ref-variable enable-transcript-buffer))
- (null? (buffer-windows (transcript-buffer))))
- (message (write-to-string value))))
+ (let ((value-string
+ (with-output-to-string
+ (lambda ()
+ (write-value value (ref-variable transcript-value-truncate))))))
+ (let ((value-message (lambda () (message value-string))))
+ (if (ref-variable enable-transcript-buffer)
+ (begin
+ (fresh-lines 1) (write-string value-string)
+ (fresh-lines 2)
+ (if (null? (buffer-windows (transcript-buffer)))
+ (value-message)))
+ (value-message)))))
-(define (with-output-to-transcript-buffer thunk)
- (if (ref-variable enable-transcript-buffer)
- (with-interactive-output-port (transcript-output-port) thunk)
- (thunk)))
-
-(define (transcript-output-port)
- (output-port/copy transcript-output-port-template (transcript-buffer)))
-
-(define (operation/write-char port char)
- (region-insert-char! (buffer-end (output-port/state port)) char))
-
-(define (operation/write-string port string)
- (region-insert-string! (buffer-end (output-port/state port)) string))
-
-(define (operation/flush-output port)
- (let ((buffer (output-port/state port)))
- (let ((end (buffer-end buffer)))
- (for-each (lambda (window)
- (set-window-point! window end)
- (window-direct-update! window false))
- (buffer-windows buffer)))))
-
-(define (operation/print-self state port)
- (unparse-string state "to transcript buffer ")
- (unparse-object state (output-port/state port)))
-
-(define transcript-output-port-template
- (make-output-port `((FLUSH-OUTPUT ,operation/flush-output)
- (PRINT-SELF ,operation/print-self)
- (WRITE-CHAR ,operation/write-char)
- (WRITE-STRING ,operation/write-string))
- false))
\ No newline at end of file
+(define (transcript-buffer)
+ (let ((name (ref-variable transcript-buffer-name)))
+ (if (buffer? name)
+ name
+ (or (find-buffer name)
+ (let ((buffer (create-buffer name)))
+ (set-buffer-major-mode!
+ buffer
+ (->mode (ref-variable transcript-buffer-mode)))
+ buffer)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.123 1989/04/28 22:50:11 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.124 1989/08/09 13:17:27 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; *** One important note: the image abstraction will not "correctly"
;;; display strings that contain newlines. Currently, a newline in
-;;; such a string will be represented by the string "^N" (or perhaps
+;;; such a string will be represented by the string "^J" (or perhaps
;;; "^M"). This is so because images are intended to be used on a
;;; per-line basis; that is, the string should be for a single line.
(define-structure (image (type vector) (constructor false))
(string false read-only true)
+ (start-index false read-only true)
+ (start-column false read-only true)
(parse false read-only true)
(column-size false read-only true))
(define (make-null-image)
- (vector "" '() 0))
+ (vector "" 0 0 '() 0))
-(define (make-image string)
- (parse-string-for-image string
+(define-integrable (string->image string start-column)
+ (string-head->image string 0 start-column))
+
+(define (string-head->image string start start-column)
+ (parse-substring-for-image string start (string-length string) start-column
(lambda (parse column-size)
- (vector string parse column-size))))
+ (vector string start start-column parse column-size))))
-(define-integrable (image-index-size image)
- (string-length (image-string image)))
+(define (image-index-size image)
+ (- (string-length (image-string image)) (image-start-index image)))
(define (image-direct-output-insert-char! image char)
(vector-set! image 0 (string-append-char (vector-ref image 0) char))
- (vector-set! image 2 (1+ (vector-ref image 2)))
+ (vector-set! image 4 (1+ (vector-ref image 4)))
unspecific)
(define (image-direct-output-insert-substring! image string start end)
(vector-set! image 0
(string-append-substring (vector-ref image 0)
string start end))
- (vector-set! image 2 (+ (vector-ref image 2) (- end start)))
+ (vector-set! image 4 (+ (vector-ref image 4) (- end start)))
unspecific)
\f
(define (image-representation image)
(let ((string (image-string image))
- (result-end (image-column-size image)))
- (let ((string-end (string-length string))
- (result (string-allocate result-end)))
- (let loop ((parse (image-parse image)) (string-start 0) (result-start 0))
+ (result (string-allocate (image-column-size image))))
+ (let ((string-end (string-length string)))
+ (let loop
+ ((parse (image-parse image))
+ (string-start (image-start-index image))
+ (result-start 0))
(cond ((null? parse)
(substring-move-right! string string-start string-end
result result-start))
result)))
(define (image-index->column image index)
- (let loop ((parse (image-parse image)) (start 0) (column 0))
+ (let loop
+ ((parse (image-parse image))
+ (start (image-start-index image))
+ (column (image-start-column image)))
(cond ((null? parse)
(+ column (- index start)))
((string? (car parse))
(error "Bad parse element" (car parse))))))
(define (image-column->index image column)
- (let loop ((parse (image-parse image)) (start 0) (c 0))
+ (let loop
+ ((parse (image-parse image))
+ (start (image-start-index image))
+ (c (image-start-column image)))
(cond ((null? parse)
(+ start (- column c)))
((string? (car parse))
(else
(error "Bad parse element" (car parse))))))
\f
-;;;; Parsing
+;;;; String Operations
-(define (parse-string-for-image string receiver)
- (parse-substring-for-image string 0 (string-length string) receiver))
+(define (string-representation string start-column)
+ (substring-representation string 0 (string-length string) start-column))
+
+(define (substring-representation string start end start-column)
+ (let ((result
+ (string-allocate
+ (- (substring-column-length string start end start-column)
+ start-column))))
+ (let loop ((start start) (column start-column) (rindex 0))
+ (let* ((index
+ (substring-find-next-char-in-set string start end
+ char-set:not-graphic))
+ (copy-representation!
+ (lambda (column rindex)
+ (let* ((representation
+ (char-representation (string-ref string index) column))
+ (size (string-length representation)))
+ (substring-move-right! representation 0 size result rindex)
+ (loop (1+ index) (+ column size) (+ rindex size))))))
+ (cond ((not index)
+ (substring-move-right! string start end result rindex)
+ result)
+ ((= start index)
+ (copy-representation! column rindex))
+ (else
+ (substring-move-right! string start index result rindex)
+ (let ((size (- index start)))
+ (copy-representation! (+ column size) (+ rindex size)))))))))
(define (string-column-length string start-column)
(substring-column-length string 0 (string-length string) start-column))
(define (string-index->column string start-column index)
(+ start-column (substring-column-length string 0 index start-column)))
+(define (substring-column-length string start end start-column)
+ (let loop ((i start) (c start-column))
+ (let ((index
+ (substring-find-next-char-in-set string i end
+ char-set:not-graphic)))
+ (if (not index)
+ (+ c (- end i))
+ (loop (1+ index)
+ (let ((c (+ c (- index i))))
+ (+ c (char-column-length (string-ref string index) c))))))))
+
(define (string-column->index string start-column column if-lose)
(substring-column->index string 0 (string-length string) start-column
column if-lose))
-(define (char-column-length char start-column)
- (string-length (char-representation char start-column)))
-
-(define parse-substring-for-image)
-(define substring-column-length)
-(define substring-column->index)
-(define char-representation)
-(let ()
+(define (substring-column->index string start end start-column column
+ #!optional if-lose)
+ (if (zero? column)
+ start
+ (let loop ((i start) (c start-column) (left (- column start-column)))
+ (let ((index
+ (substring-find-next-char-in-set string i end
+ char-set:not-graphic)))
+ (if (not index)
+ (let ((n (- end i)))
+ (cond ((<= left n) (+ i left))
+ ((default-object? if-lose) end)
+ (else (if-lose (+ c n)))))
+ (let ((n (- index i)))
+ (if (<= left n)
+ (+ i left)
+ (let ((c (+ c n))
+ (left (- left n)))
+ (let ((n
+ (char-column-length (string-ref string index) c)))
+ (cond ((< left n) index)
+ ((= left n) (1+ index))
+ (else
+ (loop (1+ index) (+ c n) (- left n)))))))))))))
+\f
+;;;; Parsing
-(set! parse-substring-for-image
-(named-lambda (parse-substring-for-image string start end receiver)
- (define (loop start column receiver)
- (let ((index (substring-find-next-char-in-set string start end
- char-set:not-graphic)))
+(define (parse-substring-for-image string start end start-column receiver)
+ (let loop ((start start) (column start-column) (receiver receiver))
+ (let ((index
+ (substring-find-next-char-in-set string start end
+ char-set:not-graphic)))
(if (not index)
(receiver '() (+ column (- end start)))
(let ((column (+ column (- index start))))
- (let ((representation (char-rep string index column)))
+ (let ((representation
+ (char-representation (string-ref string index) column)))
(loop (1+ index)
(+ column (string-length representation))
(lambda (parse column-size)
(receiver (if (= index start) (cons representation parse)
(cons index (cons representation parse)))
- column-size))))))))
- (loop start 0 receiver)))
+ column-size)))))))))
-(set! substring-column-length
-(named-lambda (substring-column-length string start end start-column)
- (define (loop i c)
- (let ((index (substring-find-next-char-in-set string i end
- char-set:not-graphic)))
- (if (not index)
- (+ c (- end i))
- (let ((c (+ c (- index i))))
- (loop (1+ index)
- (+ c (string-length (char-rep string index c))))))))
- (loop start start-column)))
-
-(set! substring-column->index
-(named-lambda (substring-column->index string start end start-column
- column #!optional if-lose)
- (define (loop i c left)
- (let ((index (substring-find-next-char-in-set string i end
- char-set:not-graphic)))
- (if (not index)
- (let ((n (- end i)))
- (cond ((<= left n) (+ i left))
- ((default-object? if-lose) end)
- (else (if-lose (+ c n)))))
- (let ((n (- index i)))
- (if (<= left n)
- (+ i left)
- (let ((c (+ c n)) (left (- left n)))
- (let ((n (string-length (char-rep string index c))))
- (cond ((< left n) index)
- ((= left n) (1+ index))
- (else (loop (1+ index) (+ c n) (- left n)))))))))))
- (if (zero? column)
- start
- (loop start start-column (- column start-column)))))
-\f
-(define-integrable (char-rep string index column)
- (char-representation (string-ref string index) column))
-
-(set! char-representation
-(named-lambda (char-representation char column)
- (if (char=? char #\Tab)
- (vector-ref tab-display-images (remainder column 8))
- (vector-ref display-images (char->ascii char)))))
-
-(define tab-display-images
- #(" " " " " " " " " " " " " " " "))
-
-(define display-images
- #("^@" "^A" "^B" "^C" "^D" "^E" "^F" "^G"
- "^H" "^I" "^J" "^K" "^L" "^M" "^N" "^O"
- "^P" "^Q" "^R" "^S" "^T" "^U" "^V" "^W"
- "^X" "^Y" "^Z" "^[" "^\\" "^]" "^^" "^_"
- " " "!" "\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/"
- "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?"
- "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O"
- "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\" "]" "^" "_"
- "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o"
- "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "^?"
- "\200" "\201" "\202" "\203" "\204" "\205" "\206" "\207"
- "\210" "\211" "\212" "\213" "\214" "\215" "\216" "\217"
- "\220" "\221" "\222" "\223" "\224" "\225" "\226" "\227"
- "\230" "\231" "\232" "\233" "\234" "\235" "\236" "\237"
- "\240" "\241" "\242" "\243" "\244" "\245" "\246" "\247"
- "\250" "\251" "\252" "\253" "\254" "\255" "\256" "\257"
- "\260" "\261" "\262" "\263" "\264" "\265" "\266" "\267"
- "\270" "\271" "\272" "\273" "\274" "\275" "\276" "\277"
- "\300" "\301" "\302" "\303" "\304" "\305" "\306" "\307"
- "\310" "\311" "\312" "\313" "\314" "\315" "\316" "\317"
- "\320" "\321" "\322" "\323" "\324" "\325" "\326" "\327"
- "\330" "\331" "\332" "\333" "\334" "\335" "\336" "\337"
- "\340" "\341" "\342" "\343" "\344" "\345" "\346" "\347"
- "\350" "\351" "\352" "\353" "\354" "\355" "\356" "\357"
- "\360" "\361" "\362" "\363" "\364" "\365" "\366" "\367"
- "\370" "\371" "\372" "\373" "\374" "\375" "\376" "\377"))
-
-)
\ No newline at end of file
+(define char-column-length)
+(define char-representation)
+(let ((tab-display-images
+ #(" " " " " " " " " " " " " " " "))
+ (display-images
+ #("^@" "^A" "^B" "^C" "^D" "^E" "^F" "^G"
+ "^H" "^I" "^J" "^K" "^L" "^M" "^N" "^O"
+ "^P" "^Q" "^R" "^S" "^T" "^U" "^V" "^W"
+ "^X" "^Y" "^Z" "^[" "^\\" "^]" "^^" "^_"
+ " " "!" "\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/"
+ "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?"
+ "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O"
+ "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\" "]" "^" "_"
+ "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o"
+ "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "^?"
+ "\200" "\201" "\202" "\203" "\204" "\205" "\206" "\207"
+ "\210" "\211" "\212" "\213" "\214" "\215" "\216" "\217"
+ "\220" "\221" "\222" "\223" "\224" "\225" "\226" "\227"
+ "\230" "\231" "\232" "\233" "\234" "\235" "\236" "\237"
+ "\240" "\241" "\242" "\243" "\244" "\245" "\246" "\247"
+ "\250" "\251" "\252" "\253" "\254" "\255" "\256" "\257"
+ "\260" "\261" "\262" "\263" "\264" "\265" "\266" "\267"
+ "\270" "\271" "\272" "\273" "\274" "\275" "\276" "\277"
+ "\300" "\301" "\302" "\303" "\304" "\305" "\306" "\307"
+ "\310" "\311" "\312" "\313" "\314" "\315" "\316" "\317"
+ "\320" "\321" "\322" "\323" "\324" "\325" "\326" "\327"
+ "\330" "\331" "\332" "\333" "\334" "\335" "\336" "\337"
+ "\340" "\341" "\342" "\343" "\344" "\345" "\346" "\347"
+ "\350" "\351" "\352" "\353" "\354" "\355" "\356" "\357"
+ "\360" "\361" "\362" "\363" "\364" "\365" "\366" "\367"
+ "\370" "\371" "\372" "\373" "\374" "\375" "\376" "\377")))
+ (set! char-representation
+ (lambda (char column)
+ (if (char=? char #\Tab)
+ (vector-ref tab-display-images (remainder column 8))
+ (vector-ref display-images (char->ascii char)))))
+ (let ((tab-display-lengths (vector-map tab-display-images string-length))
+ (display-lengths (vector-map display-images string-length)))
+ (set! char-column-length
+ (lambda (char column)
+ (if (char=? char #\Tab)
+ (vector-ref tab-display-lengths (remainder column 8))
+ (vector-ref display-lengths (char->ascii char)))))
+ unspecific))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.92 1989/08/03 23:32:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.93 1989/08/09 13:17:32 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(local-set-variable! info-current-node false)
(local-set-variable! info-tag-table-start false)
(local-set-variable! info-tag-table-end false)
- (buffer-put! (current-buffer) 'MODELINE-STRING info-modeline-string))
+ (info-set-mode-line!))
\f
-(define (info-modeline-string window)
- (string-append "--"
- (modeline-modified-string window)
- "-Info: ("
- (let ((pathname (ref-variable info-current-file)))
- (if pathname
- (pathname-name-string pathname)
- ""))
- ")"
- (or (ref-variable info-current-node) "")
- " "
- (modeline-mode-string window)
- "--"
- (modeline-percentage-string window)))
+(define (info-set-mode-line!)
+ (local-set-variable! mode-line-buffer-identification
+ (string-append
+ "Info: ("
+ (let ((pathname (ref-variable info-current-file)))
+ (if pathname
+ (pathname-name-string pathname)
+ ""))
+ ")"
+ (or (ref-variable info-current-node) ""))))
(define-key 'info #\space 'scroll-up)
(define-key 'info #\. 'beginning-of-buffer)
(if (string=? nodename "*")
(begin
(set-variable! info-current-subfile false)
- (set-variable! info-current-node nodename))
+ (set-variable! info-current-node nodename)
+ (info-set-mode-line!))
(select-node
(let ((end (buffer-end buffer)))
(let loop ((start (node-search-start nodename)))
(define (select-node point)
(let ((node (node-start point (group-start point))))
- (set-variable! info-current-node (extract-node-name node)) ;; **** need to add active node hacking here ****
+ (set-variable! info-current-node (extract-node-name node))
+ (info-set-mode-line!)
+ ;; **** need to add active node hacking here ****
(region-clip! (node-region node))
(set-current-point! point)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.35 1989/04/28 22:50:26 cph Rel $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;;
;;;; Interaction Mode
+;;; Package: (edwin)
(declare (usual-integrations))
\f
"Major mode for evaluating Scheme expressions interactively.
Same as Scheme mode, except for
-\\[scheme-interaction-eval-previous-sexp] evaluates the current expression.
-\\[scheme-interaction-eval-definition] evaluates the current definition.
-\\[scheme-interaction-eval-region] evaluates the region.
\\[scheme-interaction-yank] yanks the most recently evaluated expression.
\\[scheme-interaction-yank-pop] yanks an earlier expression, replacing a yank."
- (local-set-variable! scheme-interaction-kill-ring (make-ring 32))
- (local-set-variable! scheme-environment (ref-variable scheme-environment))
- (local-set-variable! scheme-syntax-table (ref-variable scheme-syntax-table)))
+ (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)))
+
+(define (scheme-interaction-input-recorder region)
+ (ring-push! (ref-variable scheme-interaction-kill-ring)
+ (region->string region)))
+
+(define (scheme-interaction-output-wrapper thunk)
+ (set-current-point! (buffer-end (current-buffer)))
+ (with-output-to-current-point
+ (lambda ()
+ (intercept-^G-interrupts
+ (lambda ()
+ (fresh-line)
+ (write-string ";Abort!")
+ (fresh-lines 2)
+ (^G-signal))
+ thunk))))
-(define-prefix-key 'scheme-interaction #\C-x 'prefix-char)
(define-prefix-key 'scheme-interaction #\C-c 'prefix-char)
-(define-key 'scheme-interaction '(#\C-x #\C-e)
- 'scheme-interaction-eval-previous-sexp)
-(define-key 'scheme-interaction #\M-return
- 'scheme-interaction-eval-previous-sexp)
-(define-key 'scheme-interaction #\M-z 'scheme-interaction-eval-definition)
-(define-key 'scheme-interaction #\C-M-z 'scheme-interaction-eval-region)
(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-eval-region region argument)
- (set-current-point! (region-end region))
- (let ((string (region->string region)))
- (ring-push! (ref-variable scheme-interaction-kill-ring) string)
- (let ((expression (with-input-from-string string read)))
- (let ((value
- (with-output-to-current-point
- (lambda ()
- (intercept-^G-interrupts
- (lambda ()
- (guarantee-newline)
- (insert-string "Abort!")
- (insert-newlines 2)
- (^G-signal))
- (lambda ()
- (eval-with-history expression
- (evaluation-environment argument))))))))
- (guarantee-newline)
- (if (undefined-value? value)
- (insert-string ";No value")
- (begin
- (insert-string ";Value: ")
- (insert-string (scheme-interaction-object->string value))))
- (guarantee-newlines 2)))))
-
-(define (scheme-interaction-object->string object)
- (fluid-let ((*unparser-list-depth-limit* 5)
- (*unparser-list-breadth-limit* 10))
- (write-to-string object)))
-\f
-(define-command scheme-interaction-eval-previous-sexp
- "Evaluate the expression to the left of point."
- "P"
- (lambda (argument)
- (let ((point (current-point)))
- (scheme-interaction-eval-region
- (make-region (backward-one-sexp point) point)
- argument))))
-
-(define-command scheme-interaction-eval-definition
- "Evaluate the definition at point.
-Moves point to the definition's end.
-Output and the result are written at that point.
-With an argument, prompts for the evaluation environment."
- "P"
- (lambda (argument)
- (scheme-interaction-eval-region
- (let ((start (current-definition-start)))
- (make-region start (forward-one-definition-end start)))
- argument)))
-
-(define-command scheme-interaction-eval-region
- "Evaluate the definition at point.
-Moves point to the definition's end.
-Output and the result are written at that point.
-With an argument, prompts for the evaluation environment."
- "r\nP"
- scheme-interaction-eval-region)
-
-(define scheme-interaction-mode:yank-command-message
- "Yank")
+(define scheme-interaction-mode:yank-command-message "Yank")
(define-command scheme-interaction-yank
- "Yank the last input expression."
+ "Re-insert the last input expression.
+Puts point after it and the mark before it."
()
(lambda ()
- (push-current-mark! (mark-right-inserting (current-point)))
- (insert-string (ring-ref (ref-variable scheme-interaction-kill-ring) 0))
- (set-command-message! scheme-interaction-mode:yank-command-message)))
+ (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
- "Yank the last input expression."
+ "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 ()
- (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! (ref-variable scheme-interaction-kill-ring))
- (insert-string
- (ring-ref (ref-variable scheme-interaction-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
+ (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
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.6 1989/04/28 22:50:31 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.7 1989/08/09 13:17:41 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
"I-search"
(if (search-state-forward? state) "" " backward")
": "
- (image-representation (make-image (search-state-text state))) (if invalid-regexp (string-append " [" invalid-regexp "]") ""))))
+ (string-representation (search-state-text state) 0)
+ (if invalid-regexp (string-append " [" invalid-regexp "]") ""))))
(string-set! m 0 (char-upcase (string-ref m 0)))
m)))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.13 1989/08/08 10:06:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.14 1989/08/09 13:17:47 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 13 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 14 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.119 1989/08/08 10:06:25 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.120 1989/08/09 13:17:51 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(ref-mode-object fundamental))
(define initial-buffer-name
- "*scratch*")
+ (ref-variable transcript-buffer-name))
(define initial-buffer-mode
- (ref-mode-object scheme-interaction))
+ (->mode (ref-variable transcript-buffer-mode)))
(define-variable file-type-to-major-mode
"Specifies the major mode for new buffers based on file type.
This is an alist, the cars of which are pathname types,
and the cdrs of which are major modes."
- `(("ASM" . midas)
- ("C" . c)
- ("PAS" . pascal)
- ("S" . scheme)
- ("SCM" . scheme)
- ("TXI" . texinfo)
- ("TXT" . text)))
+ (os/file-type-to-major-mode))
(define-default-key 'fundamental '^r-bad-command)
(define-key 'fundamental #\c-m-v 'scroll-other-window)
(define-key 'fundamental #\c-m-w 'append-next-kill)
(define-key 'fundamental #\c-m-rubout 'backward-kill-sexp)
-\f(define-key 'fundamental '(#\c-h #\a) 'command-apropos)(define-key 'fundamental '(#\c-h #\c) 'describe-key-briefly)
+\f
+(define-key 'fundamental '(#\c-c #\c-s) 'select-transcript-buffer)
+
+(define-key 'fundamental '(#\c-h #\a) 'command-apropos)(define-key 'fundamental '(#\c-h #\c) 'describe-key-briefly)
(define-key 'fundamental '(#\c-h #\d) 'describe-command)(define-key 'fundamental '(#\c-h #\i) 'info)
(define-key 'fundamental '(#\c-h #\k) 'describe-key)
(define-key 'fundamental '(#\c-h #\l) 'view-lossage)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.23 1989/04/28 22:51:33 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.24 1989/08/09 13:17:56 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-integrable (mode-comtab mode)
(car (mode-comtabs mode)))
-(define editor-modes
- (make-string-table))
+(define editor-modes (make-string-table))
(define (name->mode name)
(let ((name (canonicalize-name name)))
(symbol->string name)
'()
""
- (lambda () (error "Undefined mode" name))))))
\ No newline at end of file
+ (lambda () (error "Undefined mode" name))))))
+
+(define (->mode object)
+ (if (mode? object) object (name->mode object)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.29 1989/04/28 22:51:38 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.30 1989/08/09 13:17:59 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
xl xu yl yu display-style)
display-style ;ignore
(if (< yl yu)
- (with-inverse-video! screen (ref-variable mode-line-inverse-video)
- (lambda ()
- (screen-write-substring!
- screen x-start y-start
- (string-pad-right (modeline-string superior) x-size #\-)
- xl xu))))
- true)
+ (let ((thunk
+ (lambda ()
+ (screen-write-substring!
+ screen x-start y-start
+ (string-pad-right (modeline-string superior) x-size #\-)
+ xl xu))))
+ (if (and (variable-local-value
+ (window-buffer superior)
+ (ref-variable-object mode-line-inverse-video))
+ (let ((x-size (screen-x-size screen)))
+ (or (= x-size (window-x-size superior))
+ (= x-size (window-x-size (window-superior superior)))))) (with-inverse-video! screen thunk)
+ (thunk)))) true)
-(define (with-inverse-video! screen flag? thunk)
- (if flag?
- (let ((old-inverse? (screen-inverse-video! screen false))
- (new-inverse? true))
- (screen-inverse-video! screen old-inverse?)
- (dynamic-wind (lambda ()
- (set! old-inverse?
- (screen-inverse-video! screen new-inverse?)))
- thunk
- (lambda ()
- (set! new-inverse?
- (screen-inverse-video! screen old-inverse?)))))
- (thunk)))
+(define (with-inverse-video! screen thunk)
+ (let ((old-inverse? (screen-inverse-video! screen false))
+ (new-inverse? true))
+ (screen-inverse-video! screen old-inverse?)
+ (dynamic-wind (lambda ()
+ (set! old-inverse?
+ (screen-inverse-video! screen new-inverse?)))
+ thunk
+ (lambda ()
+ (set! new-inverse?
+ (screen-inverse-video! screen old-inverse?))))))
(define-method modeline-window (:event! window type)
(case type
unspecific)
(else
(setup-redisplay-flags! redisplay-flags)))
- unspecific)
-\f
-(define (modeline-string window)
- ((or (buffer-get (window-buffer window) 'MODELINE-STRING)
- standard-modeline-string)
- window))
-
-(define (standard-modeline-string window)
- (string-append "--"
- (modeline-modified-string window)
- "-Edwin: "
- (string-pad-right (buffer-display-name (window-buffer window))
- 30)
- " "
- (modeline-mode-string window)
- "--"
- (modeline-percentage-string window)))
-
-(define (modeline-modified-string window)
- (let ((buffer (window-buffer window)))
- (cond ((not (buffer-writeable? buffer)) "%%")
- ((buffer-modified? buffer) "**")
- (else "--"))))
-
-(define (modeline-mode-string window)
- (let ((buffer (window-buffer window)))
- (string-append
- (make-string recursive-edit-level #\[)
- "("
- (let loop ((modes (buffer-modes buffer)))
- (if (null? (cdr modes))
- (string-append (mode-display-name (car modes))
- (if *defining-keyboard-macro?* " Def" "")
- (if (group-clipped? (buffer-group buffer))
- " Narrow" ""))
- (string-append (mode-display-name (car modes))
- " "
- (loop (cdr modes)))))
- ")"
- (make-string recursive-edit-level #\]))))
-
-(define (modeline-percentage-string window)
- (let ((buffer (window-buffer window)))
- (if (window-mark-visible? window (buffer-start buffer))
- (if (window-mark-visible? window (buffer-end buffer))
- "All" "Top")
- (if (window-mark-visible? window (buffer-end buffer))
- "Bot"
- (string-append
- (string-pad-left
- (number->string
- (round
- (* 100
- (let ((start-index (mark-index (buffer-start buffer))))
- (/ (- (mark-index (window-start-mark window)) start-index)
- (- (mark-index (buffer-end buffer)) start-index))))))
- 2)
- "%")))))
\ No newline at end of file
+ unspecific)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.134 1989/04/28 22:52:09 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.135 1989/08/09 13:18:02 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;;
;;;; User Prompting
+;;; Package: (edwin prompt)
(declare (usual-integrations))
\f
(prompt-for-typein (string-append prompt ": ") false
(lambda ()
(let ((char (keyboard-read-char)))
- (set-typein-string! (char-name char))
+ (set-typein-string! (char-name char) true)
char))))))
(define (prompt-for-key prompt #!optional comtab)
(let outer-loop ((prefix '()))
(let inner-loop ((char (keyboard-read-char)))
(let ((chars (append! prefix (list char))))
- (set-typein-string! (xchar->name chars))
+ (set-typein-string! (xchar->name chars) true)
(if (prefix-char-list? comtab chars)
(outer-loop chars)
(let ((command (comtab-entry comtab chars)))
(let ((char (char-upcase (keyboard-read-char))))
(cond ((or (char=? char #\Y)
(char=? char #\Space))
- (set-typein-string! "Yes")
+ (set-typein-string! "yes" true)
true)
((or (char=? char #\N)
(char=? char #\Rubout))
- (set-typein-string! "No")
+ (set-typein-string! "no" true)
false)
(else
(editor-failure)
(typein-editor-thunk (ref-mode-object minibuffer-local-yes-or-no)))))
(define-major-mode minibuffer-local-yes-or-no fundamental #f
- "Enter either \"Yes\" or \"No\".")
+ "Enter either \"yes\" or \"no\".")
(define-key 'minibuffer-local-yes-or-no #\return 'exit-minibuffer-yes-or-no)
(define-command exit-minibuffer-yes-or-no
- "Like \\[exit-minibuffer], but insists on \"Yes\" or \"No\" as an answer."
+ "Like \\[exit-minibuffer], but insists on \"yes\" or \"no\" as an answer."
()
(lambda ()
(let ((string (typein-string)))
(if (or (string-ci=? "yes" string)
(string-ci=? "no" string))
(exit-typein-edit)
- (editor-error "Please enter \"Yes\" or \"No\"")))))
+ (begin
+ (set-typein-string! "" false)
+ (editor-error "Please enter \"yes\" or \"no\""))))))
\f
;;;; Command History Prompt
(execute-command-history-entry
(read-from-string
(prompt-for-string "Redo"
- (write-to-string
+ (command-history-entry->string
(list-ref *command-history* (-1+ argument)))
'INSERTED-DEFAULT
(ref-mode-object repeat-complex-command)))))))
(define *command-history*)
(define *command-history-index*)
+(define (command-history-entry->string command)
+ (fluid-let ((*unparse-with-maximum-readability?* true))
+ (write-to-string command)))
+
(define-major-mode repeat-complex-command minibuffer-local #f
"Major mode for editing command history.")
"No preceeding item in command history")))
(set! *command-history-index* index)
(set-typein-string!
- (write-to-string (list-ref *command-history* (-1+ index)))) (set-current-point! (buffer-start (current-buffer))))))
+ (command-history-entry->string (list-ref *command-history* (-1+ index)))
+ true)
+ (set-current-point! (buffer-start (current-buffer))))))
(define-command previous-complex-command
"Inserts the next element of `command-history' into the minibuffer."
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.12 1989/08/07 08:45:12 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.13 1989/08/09 13:18:07 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\\[lisp-indent-line] indents the current line for Scheme.
\\[indent-sexp] indents the next s-expression.
-\\[eval-previous-sexp-into-buffer] evaluates the expression preceding point.
- All output is inserted into the buffer at point.
-\\[eval-expression] reads and evaluates an expression in the typein window.
-
-The following evaluation commands keep a transcript of all output in
-the buffer *Transcript*:
+The following commands evaluate Scheme expressions;
+normally they record the associated output in a transcript buffer:
+\\[eval-expression] reads and evaluates an expression in minibuffer.
+\\[eval-previous-sexp] evaluates the expression preceding point.
\\[eval-definition] evaluates the current definition.
\\[eval-buffer] evaluates the buffer.
-\\[eval-next-sexp] evaluates the expression following point.
-\\[eval-previous-sexp] evaluates the expression preceding point.
\\[eval-region] evaluates the current region."
(local-set-variable! syntax-table scheme-mode:syntax-table)
(define-key 'scheme #\) 'lisp-insert-paren)
(define-key 'scheme #\m-o 'eval-buffer)
(define-key 'scheme #\m-z 'eval-definition)
-(define-key 'scheme #\c-m-= 'eval-previous-sexp-into-buffer)
(define-key 'scheme #\c-m-q 'indent-sexp)
-(define-key 'scheme #\c-m-x 'eval-expression)
(define-key 'scheme #\c-m-z 'eval-region)
\f
;;;; Read Syntax
(define scheme-mode:syntax-table (make-syntax-table))
-(modify-syntax-entries! scheme-mode:syntax-table #\NUL #\/ "_")
+(modify-syntax-entries! scheme-mode:syntax-table #\nul #\/ "_")
(modify-syntax-entries! scheme-mode:syntax-table #\: #\@ "_")
(modify-syntax-entries! scheme-mode:syntax-table #\[ #\` "_")
-(modify-syntax-entries! scheme-mode:syntax-table #\{ #\Rubout "_")
+(modify-syntax-entries! scheme-mode:syntax-table #\{ #\rubout "_")
-(modify-syntax-entry! scheme-mode:syntax-table #\Space " ")
-(modify-syntax-entry! scheme-mode:syntax-table #\Tab " ")
-(modify-syntax-entry! scheme-mode:syntax-table #\Page " ")(modify-syntax-entry! scheme-mode:syntax-table #\[ " ")
+(modify-syntax-entry! scheme-mode:syntax-table #\space " ")
+(modify-syntax-entry! scheme-mode:syntax-table #\tab " ")
+(modify-syntax-entry! scheme-mode:syntax-table #\page " ")
+(modify-syntax-entry! scheme-mode:syntax-table #\[ " ")
(modify-syntax-entry! scheme-mode:syntax-table #\] " ")
(modify-syntax-entry! scheme-mode:syntax-table #\{ " ")
(modify-syntax-entry! scheme-mode:syntax-table #\} " ")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.8 1989/08/07 08:45:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.9 1989/08/09 13:18:11 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(list-copy
'(".o" ".elc" "~" ".bin" ".lbin" ".fasl"
".dvi" ".toc" ".log" ".aux"
- ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot")))
\ No newline at end of file
+ ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot")))
+
+(define (os/file-type-to-major-mode)
+ (alist-copy
+ `(("article" . text)
+ ("asm" . midas)
+ ("bib" . text)
+ ("c" . c)
+ ("cc" . c)
+ ("h" . c)
+ ("pas" . pascal)
+ ("s" . scheme)
+ ("scm" . scheme)
+ ("text" . text)
+ ("txi" . texinfo)
+ ("txt" . text)
+ ("y" . c))))
+
+(define (os/truncate-filename-for-modeline filename width)
+ (let ((length (string-length filename)))
+ (if (< 0 width length)
+ (let ((result
+ (substring
+ filename
+ (let ((index (- length width)))
+ (or (and (not (char=? #\/ (string-ref filename index)))
+ (substring-find-next-char filename index length
+ #\/))
+ (1+ index)))
+ length)))
+ (string-set! result 0 #\$)
+ result)
+ filename)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.15 1989/04/28 22:54:22 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.16 1989/08/09 13:18:15 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(lambda (condition)
condition
(continuation (if-error)))
- thunk))))
\ No newline at end of file
+ thunk))))
+
+(define (write-value value truncate?)
+ (if (undefined-value? value)
+ (write-string ";No value")
+ (begin
+ (write-string ";Value: ") (if truncate?
+ (fluid-let ((*unparser-list-depth-limit* 5)
+ (*unparser-list-breadth-limit* 10))
+ (write value))
+ (write value)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.3 1989/04/28 22:54:48 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.4 1989/08/09 13:18:18 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;;
;;;; Buffer I/O Ports
+;;; package: (edwin window-output-port)
(declare (usual-integrations))
\f
(define (window-output-port window)
(output-port/copy window-output-port-template window))
+(define (operation/fresh-line port)
+ (if (not (line-start? (window-point (output-port/state port))))
+ (operation/write-char port #\newline)))
+
+(define (operation/fresh-lines port n)
+ (let loop
+ ((n
+ (if (line-start? (window-point (output-port/state port))) (-1+ n) n)))
+ (if (positive? n)
+ (begin
+ (operation/write-char port #\newline)
+ (loop (-1+ n))))))
+
(define (operation/write-char port char)
(let ((window (output-port/state port)))
(let ((buffer (window-buffer window))
(unparse-object state (output-port/state port)))
(define window-output-port-template
- (make-output-port `((FLUSH-OUTPUT ,operation/flush-output) (PRINT-SELF ,operation/print-self)
+ (make-output-port `((FLUSH-OUTPUT ,operation/flush-output)
+ (FRESH-LINE ,operation/fresh-line)
+ (FRESH-LINES ,operation/fresh-lines)
+ (PRINT-SELF ,operation/print-self)
(WRITE-CHAR ,operation/write-char)
(WRITE-STRING ,operation/write-string))
false))
\ No newline at end of file
projects / mit-scheme.git / commitdiff