set-local-repl-buffer!
start-inferior-repl!)
(import (runtime user-interface)
- default/write-result))
+ default/write-values))
(define-package (edwin dired)
(files "dired")
(and (not (null? windows))
(apply min (map window-x-size windows)))))))
-(define (operation/write-result port expression value hash-number)
+(define (operation/write-values port expression vals)
(let ((buffer (port/buffer port))
(other-buffer?
(memq (operation/current-expression-context port expression)
- '(OTHER-BUFFER EXPRESSION))))
+ '(other-buffer expression))))
(if (and other-buffer?
(not (ref-variable inferior-repl-write-results buffer)))
- (transcript-write value
- (and (ref-variable enable-transcript-buffer buffer)
- (transcript-buffer)))
+ (let ((tbuffer
+ (and (ref-variable enable-transcript-buffer buffer)
+ (transcript-buffer))))
+ (for-each (lambda (object)
+ (transcript-write object tbuffer))
+ vals))
(begin
- (default/write-result port expression value hash-number)
+ (default/write-values port expression vals)
(if (and other-buffer? (not (mark-visible? (port/mark port))))
- (transcript-write value #f))))))
+ (for-each (lambda (val)
+ (transcript-write val #f))
+ vals))))))
(define (mark-visible? mark)
(any (lambda (window)
(READ-CHAR ,operation/read-char)
(READ ,operation/read)
(CURRENT-EXPRESSION-CONTEXT ,operation/current-expression-context)
- (WRITE-RESULT ,operation/write-result))
+ (WRITE-VALUES ,operation/write-values))
#f))
\ No newline at end of file
\f
;;;; Miscellaneous Hooks
-(define (emacs/write-result port expression object hash-number)
- expression
- (cond ((undefined-value? object)
- (transmit-signal-with-argument port #\v ""))
- (hash-number
- ;; The #\P command used to do something useful, but now
- ;; it just sets the Emacs variable `xscheme-prompt' to
- ;; its string argument. We use this to advantage here.
- (transmit-signal-with-argument port #\P (write-to-string object))
- (emacs-eval
- port
- "(xscheme-write-message-1 xscheme-prompt (format \";Value "
- (number->string hash-number)
- ": %s\" xscheme-prompt))"))
- (else
- (transmit-signal-with-argument
- port #\v
- (call-with-output-string
- (lambda (port)
- (write object port)))))))
+(define (emacs/write-values port expression vals)
+ (declare (ignore expression))
+
+ (define (write-one val)
+ (let ((hash-number (repl-get-hash-number val)))
+ (if hash-number
+ (begin
+ ;; The #\P command used to do something useful, but now it just sets
+ ;; the Emacs variable `xscheme-prompt' to its string argument. We
+ ;; use this to advantage here so that we can pass a string in
+ ;; Scheme's syntax to Emac's eval.
+ (transmit-signal-with-argument port #\P
+ (call-with-output-string
+ (lambda (port)
+ (write val port))))
+ (emacs-eval
+ port
+ "(xscheme-write-message-1 xscheme-prompt (format \";Value "
+ (number->string hash-number)
+ ": %s\" xscheme-prompt))"))
+ (transmit-signal-with-argument port #\v
+ (call-with-output-string
+ (lambda (port)
+ (write val port)))))))
+
+ (case (length vals)
+ ((0)
+ (emacs-eval port
+ "(xscheme-write-message-1 \"(no values)\" \";No values\")"))
+ ((1)
+ (if (undefined-value? (car vals))
+ (transmit-signal-with-argument port #\v "")
+ (write-one (car vals))))
+ (else
+ (for-each write-one vals))))
(define (emacs/error-decision repl condition)
condition
(debugger-failure ,emacs/debugger-failure)
(debugger-message ,emacs/debugger-message)
(debugger-presentation ,emacs/debugger-presentation)
- (write-result ,emacs/write-result)
+ (write-values ,emacs/write-values)
(set-default-directory ,emacs/set-default-directory)
(read-start ,emacs/read-start)
(read-finish ,emacs/read-finish)
(define (%repl-eval s-expression environment repl)
(repl-history/record! (repl/reader-history repl) s-expression)
- (let ((value (hook/repl-eval s-expression environment repl)))
- (repl-history/record! (repl/printer-history repl) value)
- value))
+ (receive vals (hook/repl-eval s-expression environment repl)
+ (for-each (let ((history (repl/printer-history repl)))
+ (lambda (val)
+ (repl-history/record! history val)))
+ vals)
+ (apply values vals)))
(define hook/repl-eval)
(define (default/repl-eval s-expression environment repl)
+
+ (define (do-eval expr env)
+ (%repl-scode-eval (syntax expr env) env repl))
+
(if (and (pair? s-expression)
(eq? 'unquote (car s-expression))
(pair? (cdr s-expression))
(null? (cddr s-expression)))
- (let ((env (->environment '(user))))
- (%repl-scode-eval (syntax (cadr s-expression) env) env repl))
- (%repl-scode-eval (syntax s-expression environment) environment repl)))
+ (do-eval (cadr s-expression) (->environment '(user)))
+ (do-eval s-expression environment)))
(define (repl-scode-eval scode #!optional environment repl)
(receive (environment repl) (optional-er environment repl 'repl-scode-eval)
with-repl-eval-boundary
repl))
-(define (repl-write value s-expression #!optional repl)
- (hook/repl-write value
+(define (repl-write vals s-expression #!optional repl)
+ (hook/repl-write vals
s-expression
(if (default-object? repl)
(nearest-repl)
repl))))
(define hook/repl-write)
-(define (default/repl-write object s-expression repl)
- (port/write-result (cmdl/port repl)
- s-expression
- object
- (and repl:write-result-hash-numbers?
- (object-pointer? object)
- (not (interned-symbol? object))
- (not (number? object))
- (hash-object object))))
+(define (default/repl-write vals s-expression repl)
+ (port/write-values (cmdl/port repl) s-expression vals))
+
+(define (repl-get-hash-number object)
+ (and repl:write-result-hash-numbers?
+ (object-pointer? object)
+ (not (interned-symbol? object))
+ (not (number? object))
+ (hash-object object)))
(define (repl-eval/write s-expression #!optional environment repl)
(receive (environment repl) (optional-er environment repl 'repl-eval/write)
(%repl-eval/write s-expression environment repl)))
(define (%repl-eval/write s-expression environment repl)
- (hook/repl-write (%repl-eval s-expression environment repl)
- s-expression
- repl))
+ (receive vals (%repl-eval s-expression environment repl)
+ (hook/repl-write vals s-expression repl)))
(define (optional-er environment repl caller)
(let ((repl
standard-print-method-parts
standard-print-method?)
(export (runtime rep)
- finished-booting!)
+ finished-booting!
+ multi-values-list
+ multi-values?)
(export (runtime tagged-dispatch)
set-predicate-tag!))
cmdl?
condition-type:breakpoint
condition/breakpoint?
+ default/repl-eval
+ default/repl-read
+ default/repl-write
ge
hook/repl-eval
hook/repl-read
repl-read
repl-reader-history-size
repl-scode-eval
+ repl-get-hash-number
repl-write
repl/base
repl/condition
with-notification)
(export (runtime rep)
port/set-default-environment
- port/write-result)
+ port/write-values)
(export (runtime rep)
port/set-default-directory)
(export (runtime debugger-command-loop)
port/read-finish
port/read-start)
(export (runtime swank)
- port/write-result)
+ port/write-values)
(initialization (initialize-package!)))
(define-package (runtime thread)
'nil)
(define (interactive-eval sexp socket nl?)
- (let ((value (repl-eval sexp socket)))
+ (receive vals (repl-eval sexp socket)
(call-with-output-string
(lambda (port)
- (port/write-result port sexp value (hash-object value))
+ (port/write-values port sexp vals)
(if nl? (newline port))))))
(define (for-each-sexp procedure string)
\f
;;;; Miscellaneous Hooks
-(define (port/write-result port expression value hash-number)
- (let ((operation (textual-port-operation port 'write-result)))
+(define (port/write-values port expression vals)
+ (let ((operation (textual-port-operation port 'write-values)))
(if operation
- (operation port expression value hash-number)
- (default/write-result port expression value hash-number))))
+ (operation port expression vals)
+ (default/write-values port expression vals))))
-(define (default/write-result port expression object hash-number)
- expression
+(define (default/write-values port expression vals)
+ (declare (ignore expression))
(if (not (nearest-cmdl/batch-mode?))
(with-output-port-terminal-mode port 'cooked
(lambda ()
- (fresh-line port)
- (write-string ";" port)
- (if (and write-result:undefined-value-is-special?
- (undefined-value? object))
- (write-string "Unspecified return value" port)
- (begin
- (write-string "Value" port)
- (if hash-number
- (begin
- (write-string " " port)
- (write hash-number port)))
- (write-string ": " port)
- (write object port)))))))
+
+ (define (write-one val)
+ (fresh-line port)
+ (write-string ";Value" port)
+ (let ((hash-number (repl-get-hash-number val)))
+ (if hash-number
+ (begin
+ (write-string " " port)
+ (write hash-number port))))
+ (write-string ": " port)
+ (write val port))
+
+ (case (length vals)
+ ((0)
+ (fresh-line port)
+ (write-string ";No values" port))
+ ((1)
+ (if (and write-result:undefined-value-is-special?
+ (undefined-value? (car vals)))
+ (begin
+ (fresh-line port)
+ (write-string ";Unspecified return value" port))
+ (write-one (car vals))))
+ (else
+ (for-each write-one vals)))))))
(define write-result:undefined-value-is-special? true)
projects / mit-scheme.git / commitdiff