From: Chris Hanson Date: Thu, 5 Dec 2019 05:20:47 +0000 (-0800) Subject: Change REPL to recognize and print multiple values. X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~4 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3df7fa6bea54ee0cecd2d581108f5a7553d8182c;p=mit-scheme.git Change REPL to recognize and print multiple values. --- diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index d39267677..3c5a0fda9 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -858,7 +858,7 @@ USA. set-local-repl-buffer! start-inferior-repl!) (import (runtime user-interface) - default/write-result)) + default/write-values)) (define-package (edwin dired) (files "dired") diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm index cf4db8be6..3afa3e9bc 100644 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@ -902,20 +902,25 @@ If this is an error, the debugger examines the error condition." (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) @@ -1178,5 +1183,5 @@ If this is an error, the debugger examines the error condition." (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 diff --git a/src/runtime/emacs.scm b/src/runtime/emacs.scm index 489a79782..3bb21f0b5 100644 --- a/src/runtime/emacs.scm +++ b/src/runtime/emacs.scm @@ -123,26 +123,41 @@ USA. ;;;; 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 @@ -247,7 +262,7 @@ USA. (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) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 9364e399c..dfbad0c64 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -469,19 +469,25 @@ USA. (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) @@ -498,8 +504,8 @@ USA. 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) @@ -508,24 +514,23 @@ USA. 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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 7108745c9..79eac2251 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -236,7 +236,9 @@ USA. 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!)) @@ -4187,6 +4189,9 @@ USA. cmdl? condition-type:breakpoint condition/breakpoint? + default/repl-eval + default/repl-read + default/repl-write ge hook/repl-eval hook/repl-read @@ -4221,6 +4226,7 @@ USA. repl-read repl-reader-history-size repl-scode-eval + repl-get-hash-number repl-write repl/base repl/condition @@ -5259,7 +5265,7 @@ USA. 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) @@ -5273,7 +5279,7 @@ USA. port/read-finish port/read-start) (export (runtime swank) - port/write-result) + port/write-values) (initialization (initialize-package!))) (define-package (runtime thread) diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index e98d9428f..11a111769 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -278,10 +278,10 @@ USA. '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) diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index b5b423499..06d381ebf 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -309,30 +309,42 @@ USA. ;;;; 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)