Emacs interface.
* Add new variable EVALUATE-IN-INFERIOR-REPL. If true (default is
false), the evaluation commands operate by transmitting expressions
to an inferior REPL. The REPL used is the least-recently-started
inferior REPL (usually the one started when the editor is first
entered). When this variable is true, the RUN-LIGHT in Scheme
buffers is that of the inferior REPL.
* Evaluation commands no longer recognize the prefix argument to have
special meaning.
* The default value of MODE-LINE-PROCESS no longer displays RUN-LIGHT.
This is bound in Scheme mode now.
* The commands M-x set-environment and M-x set-syntax-table now bind
the associated variables locally in the current buffer.
Additionally, they may locally bind the variable
EVALUATE-IN-INFERIOR-REPL to false if the buffer has local
definitions of environment or syntax-table.
* When EVALUATE-IN-INFERIOR-REPL is true, C-c C-c will signal a ^G
interrupt to the inferior REPL when typed in any Scheme mode buffer.
* Add kill-buffer hooks to allow arbitrary actions to be executed when
a buffer is killed. Change inferior REPL support to use this
mechanism to kill the inferior REPL thread when its buffer is
killed.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.92 1992/02/17 22:08:30 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.93 1992/04/08 17:57:38 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(apply (command-procedure (name->command (car entry)))
(map (let ((environment (->environment '(EDWIN))))
(lambda (expression)
- (eval-with-history expression environment)))
+ (eval-with-history (current-buffer) expression environment)))
(cdr entry))))
\f
(define (interactive-argument key prompt)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.101 1992/04/05 02:33:05 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.102 1992/04/08 17:57:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(hangup-process process true)
(set-process-buffer! process false))
(buffer-processes buffer))
- (kill-buffer-inferior-repl buffer)
+ (for-each (lambda (hook) (hook buffer))
+ (buffer-get buffer 'KILL-BUFFER-HOOKS))
(bufferset-kill-buffer! (current-bufferset) buffer))
+
+(define (add-kill-buffer-hook buffer hook)
+ (let ((hooks (or (buffer-get buffer 'KILL-BUFFER-HOOKS) '())))
+ (if (not (memq hook hooks))
+ (buffer-put! buffer 'KILL-BUFFER-HOOKS (cons hook hooks)))))
\f
(define (select-buffer buffer)
(set-window-buffer! (current-window) buffer true))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.84 1992/04/06 20:13:54 bal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.85 1992/04/08 17:57:40 cph Exp $
Copyright (c) 1989-92 Massachusetts Institute of Technology
(files "intmod")
(parent (edwin))
(export (edwin)
+ current-repl-buffer
edwin-command$inferior-cmdl-abort-nearest
edwin-command$inferior-cmdl-abort-previous
edwin-command$inferior-cmdl-abort-top-level
edwin-mode$inferior-repl
edwin-variable$repl-enable-transcript-buffer
edwin-variable$repl-error-decision
+ inferior-repl-eval-expression
+ inferior-repl-eval-region
initialize-inferior-repls!
kill-buffer-inferior-repl
start-inferior-repl!))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.35 1992/02/18 16:00:30 markf Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.36 1992/04/08 17:57:42 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
'DEFAULT)
(define-variable scheme-syntax-table
- "The syntax table used by the evaluation commands, or #F
+ "The syntax table used by the evaluation commands, or #F.
If #F, use the default (REP loop) syntax-table."
false)
"List breadth to which evaluation results are printed. #F means no limit."
false
(lambda (object) (or (not object) (exact-nonnegative-integer? object))))
+
+(define-variable evaluate-in-inferior-repl
+ "If true, evaluation commands evaluate expressions in an inferior REPL.
+Also, the inferior REPL's run light appears in all Scheme mode buffers.
+Otherwise, expressions are evaluated directly by the commands."
+ false
+ boolean?)
\f
;;;; Commands
(define-command eval-defun
"Evaluate defun that point is in or before.
-Print value in minibuffer.
-With argument, prompts for the evaluation environment."
- "P"
- (lambda (argument)
- (evaluate-from-mark (current-definition-start) argument)))
+Print value in minibuffer."
+ ()
+ (lambda () (evaluate-from-mark (current-definition-start))))
(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."
- "P"
- (lambda (argument)
- (evaluate-from-mark (current-point) argument)))
+Prints the result in the typein window."
+ ()
+ (lambda () (evaluate-from-mark (current-point))))
(define-command eval-last-sexp
"Evaluate the expression preceding point.
-Prints the result in the typein window.
-With an argument, prompts for the evaluation environment."
- "P"
- (lambda (argument)
- (evaluate-from-mark (backward-sexp (current-point) 1 'ERROR) argument)))
+Prints the result in the typein window."
+ ()
+ (lambda () (evaluate-from-mark (backward-sexp (current-point) 1 'ERROR))))
+
+(define (evaluate-from-mark input-mark)
+ ((ref-command eval-region)
+ (make-region input-mark
+ (forward-sexp input-mark 1 'ERROR))))
(define-command eval-region
"Evaluate the region, printing the results in the typein window.
With an argument, prompts for the evaluation environment."
- "r\nP"
- (lambda (region argument)
- (evaluate-region region argument)))
+ "r"
+ (lambda (region)
+ (let ((buffer (mark-buffer (region-start region))))
+ (if (ref-variable evaluate-in-inferior-repl buffer)
+ (inferior-repl-eval-region (current-repl-buffer) region)
+ (evaluate-region region (evaluation-environment buffer))))))
(define-command eval-current-buffer
"Evaluate the current buffer.
-The values are printed in the typein window.
-With an argument, prompts for the evaluation environment."
- "P"
- (lambda (argument)
- (evaluate-region (buffer-region (current-buffer)) argument)))
+The values are printed in the typein window."
+ ()
+ (lambda () ((ref-command eval-region) (buffer-region (current-buffer)))))
(define-command eval-expression
- "Read and evaluate an expression in the typein window.
-With an argument, prompts for the evaluation environment."
- "xEvaluate expression\nP"
- (lambda (expression argument)
- (let ((enable-transcript-buffer (ref-variable enable-transcript-buffer)))
- (if enable-transcript-buffer
- (insert-string
- (fluid-let ((*unparse-with-maximum-readability?* true))
- (write-to-string expression))
- (buffer-end (transcript-buffer)))))
- (editor-eval expression (evaluation-environment argument))))
+ "Read and evaluate an expression in the typein window."
+ "xEvaluate expression"
+ (lambda (expression)
+ (let ((buffer (current-buffer)))
+ (if (ref-variable evaluate-in-inferior-repl buffer)
+ (inferior-repl-eval-expression (current-repl-buffer) expression)
+ (begin
+ (if (ref-variable enable-transcript-buffer buffer)
+ (insert-string
+ (fluid-let ((*unparse-with-maximum-readability?* true))
+ (write-to-string expression))
+ (buffer-end (transcript-buffer))))
+ (editor-eval buffer
+ expression
+ (evaluation-environment buffer)))))))
+
+(define-command eval-abort-top-level
+ "Force the evaluation REPL up to top level.
+Has no effect if evaluate-in-inferior-repl is false."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (if (ref-variable evaluate-in-inferior-repl buffer)
+ ((ref-command inferior-cmdl-abort-top-level))
+ (editor-error "Nothing to abort.")))))
\f
(define-command set-environment
"Make ENVIRONMENT the current evaluation environment."
"XSet environment"
(lambda (environment)
- (set-variable! scheme-environment
- (or (and (eq? environment 'DEFAULT) 'DEFAULT)
- (->environment environment)))))
+ (let ((buffer (current-buffer)))
+ (define-variable-local-value! buffer
+ (ref-variable-object scheme-environment)
+ (if (eq? environment 'DEFAULT)
+ 'DEFAULT
+ (->environment environment)))
+ (normal-buffer-evaluation-mode buffer))))
(define-command set-syntax-table
"Make SYNTAX-TABLE the current syntax table."
"XSet syntax table"
(lambda (syntax-table)
- (set-variable! scheme-syntax-table syntax-table)))
+ (let ((buffer (current-buffer)))
+ (define-variable-local-value! buffer
+ (ref-variable-object scheme-syntax-table)
+ syntax-table)
+ (normal-buffer-evaluation-mode buffer))))
+
+(define (normal-buffer-evaluation-mode buffer)
+ (let ((evaluate-in-inferior-repl
+ (ref-variable-object evaluate-in-inferior-repl))
+ (run-light (ref-variable-object run-light)))
+ (if (and (eq? (ref-variable scheme-environment buffer) 'DEFAULT)
+ (memq (ref-variable scheme-syntax-table buffer) '(#F DEFAULT)))
+ (begin
+ (undefine-variable-local-value! buffer evaluate-in-inferior-repl)
+ (undefine-variable-local-value! buffer run-light))
+ (begin
+ (define-variable-local-value! buffer evaluate-in-inferior-repl false)
+ (define-variable-local-value! buffer run-light false)))))
(define-command set-default-environment
"Make ENVIRONMENT the default evaluation environment."
"XSet default environment"
(lambda (environment)
(set-variable-default-value! (ref-variable-object scheme-environment)
- (or (and (eq? environment 'DEFAULT) 'DEFAULT)
+ (if (eq? environment 'DEFAULT)
+ 'DEFAULT
(->environment environment)))))
(define-command set-default-syntax-table
;;;; 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
- (if (or (symbol? default)
- (pair? default)
- (vector? default))
- `',default
- default)))
- (evaluation-environment false)))
+ (let ((buffer (current-buffer)))
+ (eval-with-history
+ buffer
+ (if (default-object? default)
+ (prompt-for-expression prompt)
+ (prompt-for-expression prompt
+ (if (or (symbol? default)
+ (pair? default)
+ (vector? default))
+ `',default
+ default)))
+ (evaluation-environment buffer))))
(define (prompt-for-expression prompt #!optional default-object default-type)
(let ((default-string
\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 ((evaluation-input-recorder (ref-variable evaluation-input-recorder)))
- (if evaluation-input-recorder
- (evaluation-input-recorder region)))
- (let ((enable-transcript-buffer (ref-variable enable-transcript-buffer)))
- (if enable-transcript-buffer
- (insert-region (region-start region)
- (region-end region)
- (buffer-end (transcript-buffer)))))
- (let ((environment (evaluation-environment argument)))
- (with-input-from-region region
+(define (evaluate-region region environment)
+ (let ((buffer (mark-buffer (region-start region))))
+ (let ((evaluation-input-recorder
+ (ref-variable evaluation-input-recorder buffer)))
+ (if evaluation-input-recorder
+ (evaluation-input-recorder region)))
+ (let ((enable-transcript-buffer
+ (ref-variable enable-transcript-buffer buffer)))
+ (if enable-transcript-buffer
+ (insert-region (region-start region)
+ (region-end region)
+ (buffer-end (transcript-buffer)))))
+ (bind-condition-handler (list condition-type:error)
+ evaluation-error-handler
(lambda ()
+ (let loop
+ ((expressions (read-expressions-from-region region))
+ (result unspecific))
+ (if (null? expressions)
+ result
+ (loop (cdr expressions)
+ (editor-eval buffer (car expressions) environment))))))))
+
+(define (read-expressions-from-region region)
+ (with-input-from-region region
+ (lambda ()
+ (let loop ()
+ (let ((expression (read)))
+ (if (eof-object? expression)
+ '()
+ (cons expression (loop))))))))
+
+(define (evaluation-environment buffer)
+ (let ((environment
+ (ref-variable scheme-environment (or buffer (current-buffer)))))
+ (if (eq? 'DEFAULT environment)
+ (nearest-repl/environment)
(bind-condition-handler (list condition-type:error)
- evaluation-error-handler
- (letrec
- ((loop
- (lambda (result)
- (let ((sexp (read)))
- (if (eof-object? sexp)
- result
- (loop (editor-eval sexp environment)))))))
- (lambda ()
- (loop unspecific))))))))
-
-(define (evaluation-environment argument)
- (let ((->environment
- (lambda (object)
- (bind-condition-handler (list condition-type:error)
- (lambda (condition)
- condition
- (editor-error "Illegal environment: " object))
- (lambda ()
- (->environment object))))))
- (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 environment)
- (let ((syntax-table (ref-variable scheme-syntax-table)))
+ (lambda (condition)
+ condition
+ (editor-error "Illegal environment: " environment))
+ (lambda ()
+ (->environment environment))))))
+
+(define (evaluation-syntax-table buffer environment)
+ (let ((syntax-table (ref-variable scheme-syntax-table buffer)))
(cond ((or (not syntax-table) (eq? 'DEFAULT syntax-table))
(nearest-repl/syntax-table))
((scheme-syntax-table? syntax-table)
(access syntax-table? system-global-environment))
\f
(define-variable run-light
- "Scheme run light. Not intended to be modified by users, but needed to
-kludge the mode line."
- false)
+ "Scheme run light. Not intended to be modified by users.
+Set by Scheme evaluation code to update the mode line."
+ false
+ (lambda (object) (or (not object) (string? object))))
(define-variable enable-run-light?
- "Whether to display the Scheme run light."
+ "If true, Scheme evaluation commands display a run light in the mode line."
true
boolean?)
-(define (editor-eval sexp environment)
+(define (editor-eval buffer sexp environment)
(let ((core
(lambda ()
(with-input-from-string ""
(with-output-to-string
(lambda ()
(set! value
- (eval-with-history sexp environment))))))
+ (eval-with-history buffer sexp environment))
+ unspecific))))
(let ((evaluation-output-receiver
- (ref-variable evaluation-output-receiver)))
+ (ref-variable evaluation-output-receiver buffer)))
(if evaluation-output-receiver
(evaluation-output-receiver value output-string)
(with-output-to-transcript-buffer
(write-string output-string)
(transcript-write
value
- (and (ref-variable enable-transcript-buffer)
+ (and (ref-variable enable-transcript-buffer
+ buffer)
(transcript-buffer))))))))
value))))))
- (if (ref-variable enable-run-light?)
- (unwind-protect
- (lambda ()
- (set-variable! run-light "eval")
- (for-each (lambda (window)
- (window-modeline-event! window 'RUN-LIGHT))
- (window-list))
- (update-screens! false))
- core
- (lambda ()
- (set-variable! run-light false)
- (for-each (lambda (window)
- (window-modeline-event! window 'RUN-LIGHT))
- (window-list))
- (update-screens! false)))
+ (if (ref-variable enable-run-light? buffer)
+ (let ((run-light (ref-variable-object run-light))
+ (outside)
+ (inside "eval"))
+ (dynamic-wind
+ (lambda ()
+ (set! outside (variable-local-value buffer run-light))
+ (set-variable-local-value! buffer run-light inside)
+ (set! inside)
+ (global-window-modeline-event!)
+ (update-screens! false))
+ core
+ (lambda ()
+ (set! inside (variable-local-value buffer run-light))
+ (set-variable-local-value! buffer run-light outside)
+ (set! outside)
+ (global-window-modeline-event!)
+ (update-screens! false))))
(core))))
-(define (eval-with-history expression environment)
- (let ((syntax-table (evaluation-syntax-table environment)))
+(define (eval-with-history buffer expression environment)
+ (let ((syntax-table (evaluation-syntax-table buffer environment)))
(bind-condition-handler (list condition-type:error)
evaluation-error-handler
(lambda ()
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.165 1992/02/13 18:25:54 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.166 1992/04/08 17:57:43 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(if entry
(begin
(local-set-variable! scheme-environment (cadr entry))
- (local-set-variable! scheme-syntax-table (caddr entry)))))))
+ (local-set-variable! scheme-syntax-table (caddr entry))
+ (local-set-variable! evaluate-in-inferior-repl false)
+ (local-set-variable! run-light false))))))
\f
(define-command save-buffer
"Save current buffer in visited file if modified. Versions described below.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.45 1992/03/13 10:48:18 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.46 1992/04/08 17:57:45 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
true
boolean?)
+(define (transcript-output-mark buffer)
+ (and (ref-variable repl-enable-transcript-buffer buffer)
+ (ref-variable enable-transcript-buffer buffer)
+ (buffer-end (transcript-buffer))))
+
(define-variable repl-error-decision
"If true, errors in REPL evaluation force the user to choose an option.
Otherwise, they start a nested error REPL."
(define-command repl
"Run an inferior read-eval-print loop (REPL), with I/O through buffer *scheme*.
If buffer exists, just select it; otherwise create it and start REPL.
-REPL uses current evaluation environment,
-but prefix argument means prompt for different environment."
- "P"
- (lambda (argument)
+REPL uses current evaluation environment."
+ ()
+ (lambda ()
(select-buffer
(or (find-buffer initial-buffer-name)
- (let ((environment (evaluation-environment argument)))
- (let ((buffer (create-buffer initial-buffer-name)))
- (start-inferior-repl! buffer
- environment
- (evaluation-syntax-table environment)
- false)
- buffer))))))
+ (let ((current-buffer (current-buffer)))
+ (let ((environment (evaluation-environment current-buffer)))
+ (let ((buffer (create-buffer initial-buffer-name)))
+ (start-inferior-repl! buffer
+ environment
+ (evaluation-syntax-table current-buffer
+ environment)
+ false)
+ buffer)))))))
(define (start-inferior-repl! buffer environment syntax-table message)
(set-buffer-major-mode! buffer (ref-mode-object inferior-repl))
user-initial-prompt)
message))))))))))))
+(define (current-repl-buffer)
+ (let ((buffer (current-buffer)))
+ (if (buffer-interface-port buffer)
+ buffer
+ (let ((buffers repl-buffers))
+ (if (null? buffers)
+ (error "No REPL to evaluate in."))
+ (car buffers)))))
+
+(define repl-buffers)
+
(define (initialize-inferior-repls!)
+ (set! repl-buffers '())
unspecific)
\f
(define (wait-for-input port level mode)
(begin
(set-buffer-major-mode! buffer mode)
(attach-buffer-interface-port! buffer port)))))))
-
+\f
(define (attach-buffer-interface-port! buffer port)
+ (if (not (memq buffer repl-buffers))
+ (set! repl-buffers (append! repl-buffers (list buffer))))
(buffer-put! buffer 'INTERFACE-PORT port)
+ (add-kill-buffer-hook buffer kill-buffer-inferior-repl)
(define-variable-local-value! buffer
(ref-variable-object comint-input-ring)
(port/input-ring port))
(set-run-light! buffer false))
(define (set-run-light! buffer run?)
- (define-variable-local-value! buffer (ref-variable-object run-light)
- (if run? "run" "listen"))
- (buffer-modeline-event! buffer 'RUN-LIGHT))
+ (let ((variable (ref-variable-object run-light))
+ (value (if run? "eval" "listen")))
+ (if (and (ref-variable evaluate-in-inferior-repl buffer)
+ (eq? buffer (current-repl-buffer)))
+ (begin
+ (undefine-variable-local-value! buffer variable)
+ (set-variable-default-value! variable value)
+ (global-window-modeline-event!))
+ (begin
+ (define-variable-local-value! buffer variable value)
+ (buffer-modeline-event! buffer 'RUN-LIGHT)))))
(define-integrable (buffer-interface-port buffer)
(buffer-get buffer 'INTERFACE-PORT))
(signal-thread-event (port/thread port)
(lambda ()
(exit-current-thread unspecific)))
- (buffer-remove! buffer 'INTERFACE-PORT)))))
+ (buffer-remove! buffer 'INTERFACE-PORT)
+ (let ((run-light (ref-variable-object run-light)))
+ (if (and (ref-variable evaluate-in-inferior-repl buffer)
+ (eq? buffer (current-repl-buffer)))
+ (begin
+ (set-variable-default-value! run-light false)
+ (global-window-modeline-event!)))
+ (set! repl-buffers (delq! buffer repl-buffers))
+ (let ((buffer
+ (and (ref-variable evaluate-in-inferior-repl buffer)
+ (current-repl-buffer))))
+ (if buffer
+ (let ((value (variable-local-value buffer run-light)))
+ (undefine-variable-local-value! buffer run-light)
+ (set-variable-default-value! run-light value)
+ (global-window-modeline-event!)))))))))
\f
(define (error-decision repl condition)
(if (ref-variable repl-error-decision)
(define (interrupt-command interrupt)
(lambda ()
- (signal-thread-event (port/thread (buffer-interface-port (current-buffer)))
+ (signal-thread-event
+ (port/thread (buffer-interface-port (current-repl-buffer)))
interrupt)))
(define-command inferior-cmdl-breakpoint
(lambda ()
(inferior-repl-eval-from-mark (backward-sexp (current-point) 1 'ERROR))))
+(define (inferior-repl-eval-from-mark mark)
+ ((ref-command inferior-repl-eval-region)
+ (make-region mark (forward-sexp mark 1 'ERROR))))
+
(define-command inferior-repl-eval-region
"Evaluate the region."
"r"
(lambda (region)
- (inferior-repl-eval-region (region-start region) (region-end region))))
+ (let ((buffer (mark-buffer (region-start region))))
+ (ring-push! (port/input-ring (buffer-interface-port buffer))
+ (region->string region))
+ (inferior-repl-eval-region buffer region))))
\f
(define-command inferior-repl-debug
"Select a debugger buffer to examine the current REPL state.
(let ((port (buffer-interface-port (current-buffer))))
(set-port/command-char! port (last-command-key))
(end-input-wait port))))
-
-(define (inferior-repl-eval-from-mark mark)
- (inferior-repl-eval-region mark (forward-sexp mark 1 'ERROR)))
-
-(define (inferior-repl-eval-region start end)
- (let ((buffer (mark-buffer start)))
- (let ((port (buffer-interface-port buffer)))
+\f
+(define (inferior-repl-eval-region buffer region)
+ (let ((mark (transcript-output-mark buffer)))
+ (if mark
+ (insert-region (region-start region)
+ (region-end region)
+ mark)))
+ (let ((port (buffer-interface-port buffer)))
+ (let ((end
+ (let ((end (buffer-end buffer))
+ (end* (region-end region)))
+ (if (mark~ end end*)
+ end*
+ end))))
(set-buffer-point! buffer end)
- (move-mark-to! (port/mark port) end)
- (let ((string (extract-string start end)))
- (ring-push! (port/input-ring port) string)
- (if (and (ref-variable repl-enable-transcript-buffer)
- (ref-variable enable-transcript-buffer))
- (insert-string string (buffer-end (transcript-buffer)))))
- (let ((queue (port/expression-queue port)))
- (let ((input-port (make-buffer-input-port start end)))
- (bind-condition-handler (list condition-type:error)
- evaluation-error-handler
- (lambda ()
- (let loop ()
- (let ((sexp (read input-port)))
- (if (not (eof-object? sexp))
- (begin
- (enqueue! queue sexp)
- (loop))))))))
- (if (not (queue-empty? queue))
- (end-input-wait port))))))
+ (move-mark-to! (port/mark port) end))
+ (let ((queue (port/expression-queue port)))
+ (bind-condition-handler (list condition-type:error)
+ evaluation-error-handler
+ (lambda ()
+ (for-each (lambda (expression) (enqueue! queue expression))
+ (read-expressions-from-region region))))
+ (if (not (queue-empty? queue))
+ (end-input-wait port)))))
+
+(define (inferior-repl-eval-expression buffer expression)
+ (let ((mark (transcript-output-mark buffer)))
+ (if mark
+ (insert-string (fluid-let ((*unparse-with-maximum-readability?* true))
+ (write-to-string expression))
+ mark)))
+ (let ((port (buffer-interface-port buffer)))
+ (let ((end (buffer-end buffer)))
+ (set-buffer-point! buffer end)
+ (move-mark-to! (port/mark port) end))
+ (enqueue! (port/expression-queue port) expression)
+ (end-input-wait port)))
\f
;;;; Queue
(define (process-output-queue port)
(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))
(mark (port/mark port))
- (transcript-mark
- (and (ref-variable repl-enable-transcript-buffer)
- (ref-variable enable-transcript-buffer)
- (buffer-end (transcript-buffer)))))
+ (transcript-mark (transcript-output-mark (port/buffer port))))
(let loop ()
(let ((operation (dequeue!/unsafe (port/output-queue port) false)))
(if operation
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.13 1992/02/14 22:30:53 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.14 1992/04/08 17:57:46 cph Exp $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
false)
(define-variable-per-buffer mode-line-process
- "Mode-line control for displaying info on process status.
-Normally displays the Scheme run light, if ENABLE-RUN-LIGHT? is true."
- '(run-light (": " run-light) ""))
+ "Mode-line control for displaying info on process status."
+ false)
\f
(define-variable-per-buffer mode-line-procedure
"Procedure used to generate the mode-line.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.25 1992/04/06 05:35:03 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.26 1992/04/08 17:57:48 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
\\[lisp-indent-line] indents the current line for Scheme.
\\[indent-sexp] indents the next s-expression.
-The following commands evaluate Scheme expressions;
-normally they record the associated output in a transcript buffer:
+The following commands evaluate Scheme expressions:
\\[eval-expression] reads and evaluates an expression in minibuffer.
\\[eval-last-sexp] evaluates the expression preceding point.
\\[eval-defun] evaluates the current definition.
\\[eval-current-buffer] evaluates the buffer.
\\[eval-region] evaluates the current region."
-
(local-set-variable! syntax-table scheme-mode:syntax-table)
(local-set-variable! syntax-ignore-comments-backwards false)
(local-set-variable! lisp-indent-hook standard-lisp-indent-hook)
(local-set-variable! paragraph-separate separate))
(local-set-variable! paragraph-ignore-fill-prefix true)
(local-set-variable! indent-line-procedure (ref-command lisp-indent-line))
+ (local-set-variable! mode-line-process '(RUN-LIGHT (": " RUN-LIGHT) ""))
(event-distributor/invoke! (ref-variable scheme-mode-hook)))
(define-variable scheme-mode-hook
(define-key 'scheme #\c-m-q 'indent-sexp)
(define-key 'scheme #\c-m-z 'eval-region)
(define-key 'scheme #\m-tab 'scheme-complete-variable)
+(define-key 'scheme '(#\c-c #\c-c) 'eval-abort-top-level)
\f
;;;; Read Syntax
(define (scheme-mode:indent-let-method state indent-point normal-indent)
(lisp-indent-special-form
- (let ((m (parse-state-containing-sexp state)))
- (let ((start (forward-to-sexp-start (forward-one-sexp (mark1+ m)
- indent-point)
- indent-point)))
- (if (and start
- (not (re-match-forward "\\s(" start)))
- 2
- 1)))
+ (if (let ((start
+ (forward-to-sexp-start
+ (forward-one-sexp (mark1+ (parse-state-containing-sexp state))
+ indent-point)
+ indent-point)))
+ (and start
+ (not (re-match-forward "\\s(" start))))
+ 2
+ 1)
state indent-point normal-indent))
(define scheme-mode:indent-methods (make-string-table))
projects / mit-scheme.git / commitdiff