571 lines
18 KiB
Scheme
571 lines
18 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Evaluation Commands
|
||
;;; Package: (edwin)
|
||
|
||
|
||
|
||
;;;; Variables
|
||
|
||
(define-variable scheme-environment
|
||
"The environment used by the evaluation commands, or 'DEFAULT.
|
||
If 'DEFAULT, use the default (REP loop) environment."
|
||
'DEFAULT
|
||
#f
|
||
(lambda (object)
|
||
(if (or (eq? 'DEFAULT object)
|
||
(list-of-type? object symbol?)
|
||
(procedure-of-arity? object 1))
|
||
object
|
||
(call-with-current-continuation
|
||
(lambda (k)
|
||
(bind-condition-handler (list condition-type:error)
|
||
(lambda (condition)
|
||
condition
|
||
(message "Ignoring bad evaluation environment: " object)
|
||
(k 'DEFAULT))
|
||
(lambda ()
|
||
(->environment object))))))))
|
||
|
||
(define-variable scheme-syntax-table
|
||
"This variable is obsolete and its value is ignored."
|
||
#f)
|
||
|
||
(add-variable-assignment-daemon! (ref-variable-object scheme-environment)
|
||
(lambda (buffer variable)
|
||
variable
|
||
(if buffer (normal-buffer-evaluation-mode buffer))))
|
||
|
||
(define (normal-buffer-evaluation-mode buffer)
|
||
(let ((env (ref-variable-object scheme-environment))
|
||
(inf-repl (ref-variable-object evaluate-in-inferior-repl))
|
||
(run-light (ref-variable-object run-light)))
|
||
(if (not (repl-buffer? buffer))
|
||
(let ((value
|
||
(if (variable-local-value? buffer env)
|
||
(variable-local-value buffer env)
|
||
'DEFAULT)))
|
||
(cond ((eq? 'DEFAULT value)
|
||
(undefine-variable-local-value! buffer inf-repl)
|
||
(undefine-variable-local-value! buffer run-light))
|
||
((procedure? value)
|
||
(define-variable-local-value! buffer inf-repl
|
||
(lambda (buffer) buffer (eq? 'DEFAULT (value 'DEFAULT))))
|
||
;; Force run-light to be set:
|
||
(evaluate-in-inferior-repl? buffer))
|
||
(else
|
||
(define-variable-local-value! buffer inf-repl #f)
|
||
(define-variable-local-value! buffer run-light #f)))))))
|
||
|
||
(define (evaluate-in-inferior-repl? buffer)
|
||
(if buffer
|
||
(let ((buffer (->buffer buffer))
|
||
(var (ref-variable-object evaluate-in-inferior-repl)))
|
||
(let ((value (variable-local-value buffer var)))
|
||
(if (procedure? value)
|
||
(let ((value (value buffer)))
|
||
(let ((run-light (ref-variable-object run-light)))
|
||
(if value
|
||
(undefine-variable-local-value! buffer run-light)
|
||
(define-variable-local-value! buffer run-light #f)))
|
||
(invoke-variable-assignment-daemons! buffer var)
|
||
value)
|
||
value)))
|
||
(let ((value (ref-variable evaluate-in-inferior-repl #f)))
|
||
(if (procedure? value)
|
||
(value #f)
|
||
value))))
|
||
|
||
(define-variable debug-on-evaluation-error
|
||
"True means enter debugger if an evaluation error is signalled.
|
||
False means ignore the error and resume editing.
|
||
The symbol ASK means ask what to do (this is the default value).
|
||
This does not affect editor errors or internal errors."
|
||
'ASK
|
||
(lambda (x) (or (boolean? x) (eq? x 'ASK))))
|
||
|
||
(define-variable evaluation-input-recorder
|
||
"A procedure that receives each input region before evaluation.
|
||
If #F, disables input recording."
|
||
#f)
|
||
|
||
(define-variable evaluation-output-receiver
|
||
"Procedure to call with the value and output from evaluation.
|
||
The value is an object, and the output is a string.
|
||
If #F, the value is printed in the typein window,
|
||
and the output, if non-null, is shown in a pop-up buffer."
|
||
#f)
|
||
|
||
(define-variable enable-transcript-buffer
|
||
"If true, output from evaluation commands is recorded in transcript buffer."
|
||
#f
|
||
boolean?)
|
||
|
||
(define-variable disable-evaluation-commands
|
||
"If true, evaluation commands signal an error."
|
||
#f
|
||
boolean?)
|
||
|
||
(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."
|
||
#t
|
||
(lambda (object) (or (boolean? object) (procedure-of-arity? object 1))))
|
||
|
||
(define-variable transcript-buffer-name
|
||
"Name of evaluation transcript buffer.
|
||
This can also be a buffer object."
|
||
"*transcript*")
|
||
|
||
(define-variable transcript-buffer-mode
|
||
"Mode of evaluation transcript buffer.
|
||
This can be either a mode object or the name of one."
|
||
'scheme)
|
||
|
||
(define-variable transcript-buffer-read-only
|
||
"If true, transcript buffer is initialized to read-only when created."
|
||
#t
|
||
boolean?)
|
||
|
||
(define-variable transcript-output-wrapper
|
||
"A procedure that is called to setup transcript output.
|
||
It is passed a thunk as its only argument.
|
||
If #F, normal transcript output is done."
|
||
#f)
|
||
|
||
(define-variable transcript-list-depth-limit
|
||
"List depth to which evaluation results are printed. #F means no limit."
|
||
#f
|
||
(lambda (object) (or (not object) (exact-nonnegative-integer? object))))
|
||
|
||
(define-variable transcript-list-breadth-limit
|
||
"List breadth to which evaluation results are printed. #F means no limit."
|
||
#f
|
||
(lambda (object) (or (not object) (exact-nonnegative-integer? object))))
|
||
|
||
(define-variable transcript-disable-evaluation
|
||
"If true, evaluation commands are disabled in the transcript buffer."
|
||
#t
|
||
boolean?)
|
||
|
||
;;;; Commands
|
||
|
||
(define-command eval-defun
|
||
"Evaluate defun that point is in or before.
|
||
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."
|
||
()
|
||
(lambda () (evaluate-from-mark (current-point))))
|
||
|
||
(define-command eval-last-sexp
|
||
"Evaluate the expression preceding point.
|
||
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"
|
||
(lambda (region)
|
||
(let ((buffer (mark-buffer (region-start region))))
|
||
(cond ((ref-variable disable-evaluation-commands buffer)
|
||
(editor-error "Evaluation commands disabled in this buffer."))
|
||
((evaluate-in-inferior-repl? buffer)
|
||
(inferior-repl-eval-region (current-repl-buffer buffer) region))
|
||
(else
|
||
(evaluate-region region (evaluation-environment buffer #f)))))))
|
||
|
||
(define-command eval-current-buffer
|
||
"Evaluate the current buffer.
|
||
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."
|
||
"xEvaluate expression"
|
||
(lambda (expression)
|
||
(let ((buffer (current-buffer)))
|
||
(cond ((ref-variable disable-evaluation-commands buffer)
|
||
(editor-error "Evaluation commands disabled in this buffer."))
|
||
((and (evaluate-in-inferior-repl? buffer)
|
||
(current-repl-buffer* buffer))
|
||
=> (lambda (buffer)
|
||
(inferior-repl-eval-expression buffer expression)))
|
||
(else
|
||
(if (ref-variable enable-transcript-buffer buffer)
|
||
(call-with-transcript-buffer
|
||
(lambda (buffer)
|
||
(insert-string
|
||
(parameterize ((param:print-with-maximum-readability? #t))
|
||
(write-to-string expression))
|
||
(buffer-end buffer)))))
|
||
(editor-eval buffer
|
||
expression
|
||
(evaluation-environment buffer #f)))))))
|
||
|
||
(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 ()
|
||
(if (evaluate-in-inferior-repl? (current-buffer))
|
||
((ref-command inferior-cmdl-abort-top-level))
|
||
(editor-error "Nothing to abort."))))
|
||
|
||
(define-command set-environment
|
||
"Make ENVIRONMENT the current evaluation environment."
|
||
"XSet environment"
|
||
(lambda (environment)
|
||
(local-set-variable! scheme-environment environment)))
|
||
|
||
(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)
|
||
environment)))
|
||
|
||
(define-command set-repl-environment
|
||
"Make ENVIRONMENT the environment of the nearest REP loop."
|
||
"XSet REPL environment"
|
||
(lambda (environment)
|
||
(set-repl/environment! (nearest-repl) (->environment environment))))
|
||
|
||
(define-command select-transcript-buffer
|
||
"Select the transcript buffer."
|
||
()
|
||
(lambda ()
|
||
(call-with-transcript-buffer select-buffer)))
|
||
|
||
;;;; Expression Prompts
|
||
|
||
(define (prompt-for-expression-value prompt #!optional default environment
|
||
. options)
|
||
(let ((environment
|
||
(if (default-object? environment)
|
||
(evaluation-environment)
|
||
(begin
|
||
(guarantee environment? environment 'PROMPT-FOR-EXPRESSION-VALUE)
|
||
environment))))
|
||
(eval-with-history (apply prompt-for-expression
|
||
prompt
|
||
(if (or (symbol? default)
|
||
(pair? default)
|
||
(vector? default))
|
||
`',default
|
||
default)
|
||
environment
|
||
options)
|
||
environment)))
|
||
|
||
(define (prompt-for-expression prompt #!optional default environment . options)
|
||
(let ((environment
|
||
(if (default-object? environment)
|
||
(evaluation-environment)
|
||
(begin
|
||
(guarantee environment? environment 'PROMPT-FOR-EXPRESSION)
|
||
environment))))
|
||
(read-from-string
|
||
(apply prompt-for-string
|
||
prompt
|
||
(and (not (default-object? default))
|
||
default)
|
||
'MODE
|
||
(lambda (buffer)
|
||
(set-buffer-major-mode! buffer
|
||
(ref-mode-object prompt-for-expression))
|
||
;; This sets up the correct environment in the typein buffer
|
||
;; so that completion of variables works right.
|
||
(local-set-variable! scheme-environment environment buffer))
|
||
options))))
|
||
|
||
(define (read-from-string string)
|
||
(bind-condition-handler (list condition-type:error) evaluation-error-handler
|
||
(lambda ()
|
||
(read (open-input-string string)))))
|
||
|
||
(define-major-mode prompt-for-expression scheme #f
|
||
(mode-description (ref-mode-object minibuffer-local))
|
||
(lambda (buffer)
|
||
;; This kludge prevents auto-fill from being turned on. Probably
|
||
;; there is a better way to do this, but I can't think of one
|
||
;; right now. -- cph
|
||
(for-each (lambda (mode)
|
||
(disable-buffer-minor-mode! buffer mode))
|
||
(buffer-minor-modes buffer))))
|
||
|
||
(set-car! (mode-comtabs (ref-mode-object prompt-for-expression))
|
||
(car (mode-comtabs (ref-mode-object minibuffer-local))))
|
||
|
||
;;;; Evaluation
|
||
|
||
(define (evaluate-region region environment)
|
||
(let ((buffer (->buffer region)))
|
||
(let ((evaluation-input-recorder
|
||
(ref-variable evaluation-input-recorder buffer)))
|
||
(if evaluation-input-recorder
|
||
(evaluation-input-recorder region)))
|
||
(if (ref-variable enable-transcript-buffer buffer)
|
||
(call-with-transcript-buffer
|
||
(lambda (buffer)
|
||
(insert-region (region-start region)
|
||
(region-end region)
|
||
(buffer-end 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)
|
||
(call-with-input-region region
|
||
(lambda (port)
|
||
(let loop ()
|
||
(let ((expression (read port)))
|
||
(if (eof-object? expression)
|
||
'()
|
||
(cons expression (loop))))))))
|
||
|
||
(define (evaluation-environment #!optional buffer global-ok?)
|
||
(let ((buffer (->buffer buffer)))
|
||
(evaluation-environment-no-repl
|
||
buffer
|
||
(let ((repl-buffer
|
||
(and (evaluate-in-inferior-repl? buffer)
|
||
(current-repl-buffer* buffer))))
|
||
(if (and repl-buffer
|
||
(not (eq? repl-buffer buffer)))
|
||
(evaluation-environment-no-repl repl-buffer)
|
||
#!default))
|
||
global-ok?)))
|
||
|
||
(define (evaluation-environment-no-repl #!optional buffer default global-ok?)
|
||
(let ((buffer (->buffer buffer))
|
||
(default
|
||
(if (default-object? default)
|
||
(nearest-repl/environment)
|
||
default))
|
||
(global-ok? (if (default-object? global-ok?) #t global-ok?)))
|
||
(let ((environment (ref-variable scheme-environment buffer)))
|
||
(cond ((eq? 'DEFAULT environment) default)
|
||
((environment? environment) environment)
|
||
((procedure? environment) (environment default))
|
||
((name->package environment) => package/environment)
|
||
(global-ok? system-global-environment)
|
||
(else (editor-error "Package not loaded: " environment))))))
|
||
|
||
(define-variable run-light
|
||
"Scheme run light. Not intended to be modified by users.
|
||
Set by Scheme evaluation code to update the mode line."
|
||
#f
|
||
(lambda (object) (or (not object) (string? object))))
|
||
|
||
(define-variable enable-run-light?
|
||
"If true, Scheme evaluation commands display a run light in the mode line."
|
||
#t
|
||
boolean?)
|
||
|
||
(define (editor-eval buffer sexp environment)
|
||
(let ((core
|
||
(lambda ()
|
||
(parameterize ((current-input-port dummy-i/o-port))
|
||
(let ((value))
|
||
(let ((output-string
|
||
(call-with-output-string
|
||
(lambda (port)
|
||
(parameterize ((current-output-port port))
|
||
(set! value
|
||
(eval-with-history sexp environment))
|
||
unspecific)))))
|
||
(let ((evaluation-output-receiver
|
||
(ref-variable evaluation-output-receiver buffer)))
|
||
(if evaluation-output-receiver
|
||
(evaluation-output-receiver value output-string)
|
||
(with-output-to-transcript-buffer
|
||
(lambda ()
|
||
(write-string output-string)
|
||
(transcript-write
|
||
value
|
||
(and (ref-variable enable-transcript-buffer
|
||
buffer)
|
||
(transcript-buffer))))))))
|
||
value)))))
|
||
(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! #f))
|
||
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! #f))))
|
||
(core))))
|
||
|
||
(define (eval-with-history expression environment)
|
||
(bind-condition-handler (list condition-type:error)
|
||
evaluation-error-handler
|
||
(lambda ()
|
||
(repl-eval expression environment))))
|
||
|
||
(define (evaluation-error-handler condition)
|
||
(maybe-debug-scheme-error 'EVALUATION condition)
|
||
(standard-error-report 'EVALUATION condition #f)
|
||
(editor-beep)
|
||
(return-to-command-loop condition))
|
||
|
||
;;;; Transcript Buffer
|
||
|
||
(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)
|
||
(call-with-transcript-buffer
|
||
(lambda (buffer)
|
||
(let ((output-port
|
||
(mark->output-port (buffer-end buffer) buffer)))
|
||
(fresh-line output-port)
|
||
(parameterize ((current-output-port output-port))
|
||
(thunk)))))))
|
||
(let ((value))
|
||
(let ((output
|
||
(call-with-output-string
|
||
(lambda (port)
|
||
(parameterize ((current-output-port port))
|
||
(set! value (thunk))
|
||
unspecific)))))
|
||
(if (and (not (string-null? output))
|
||
(not (ref-variable evaluation-output-receiver)))
|
||
(string->temporary-buffer output "*Unsolicited-Output*" '())))
|
||
value)))
|
||
|
||
(define (transcript-write value buffer)
|
||
(let ((value-string
|
||
(string-append
|
||
(transcript-value-prefix-string value #f)
|
||
(transcript-value-string value))))
|
||
(if buffer
|
||
(let ((point (mark-left-inserting-copy (buffer-end buffer))))
|
||
(with-read-only-defeated point
|
||
(lambda ()
|
||
(guarantee-newlines 1 point)
|
||
(insert-string value-string point)
|
||
(insert-newlines 2 point)))
|
||
(mark-temporary! point)))
|
||
(if (or (not buffer) (null? (buffer-windows buffer)))
|
||
(message value-string))))
|
||
|
||
(define (transcript-value-prefix-string value hash-number?)
|
||
(if (undefined-value? value)
|
||
";No value"
|
||
(string-append
|
||
";Value"
|
||
(if (and hash-number?
|
||
(object-pointer? value)
|
||
(not (interned-symbol? value))
|
||
(not (number? value)))
|
||
(string-append
|
||
" "
|
||
(write-to-string (hash-object value)))
|
||
"")
|
||
": ")))
|
||
|
||
(define (transcript-value-string value)
|
||
(if (undefined-value? value)
|
||
""
|
||
(parameterize ((param:printer-list-depth-limit
|
||
(ref-variable transcript-list-depth-limit))
|
||
(param:printer-list-breadth-limit
|
||
(ref-variable transcript-list-breadth-limit)))
|
||
(write-to-string value))))
|
||
|
||
(define (call-with-transcript-buffer procedure)
|
||
(let ((buffer (transcript-buffer)))
|
||
(let ((group (buffer-group buffer))
|
||
(outside)
|
||
(inside #f))
|
||
(dynamic-wind (lambda ()
|
||
(set! outside (group-read-only? group))
|
||
(if inside
|
||
(set-group-read-only! group)
|
||
(set-group-writeable! group)))
|
||
(lambda ()
|
||
(procedure buffer))
|
||
(lambda ()
|
||
(set! inside (group-read-only? group))
|
||
(if outside
|
||
(set-group-read-only! group)
|
||
(set-group-writeable! group)))))))
|
||
|
||
(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)))
|
||
(if (ref-variable transcript-buffer-read-only)
|
||
(set-buffer-read-only! buffer))
|
||
(if (ref-variable transcript-disable-evaluation)
|
||
(local-set-variable! disable-evaluation-commands #t buffer)
|
||
(if (eq? (buffer-major-mode buffer)
|
||
(ref-mode-object scheme))
|
||
(begin
|
||
(local-set-variable! evaluate-in-inferior-repl #f
|
||
buffer)
|
||
(local-set-variable! run-light #f buffer))))
|
||
buffer)))))
|