From: Chris Hanson <org/chris-hanson/cph>
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)