From 5b27d9d25eee26b132d4ac5238f23e680188c2d0 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sat, 26 Jun 2010 21:55:13 +0200
Subject: [PATCH] add repl inport and outport fields and accessors

* module/system/repl/common.scm (<repl>): Add inport and outport fields
  and accessors.
  (make-repl): Add optional "debug" argument. Bind inport and outport to
  the current inport and output ports at the time of repl creation.
  (repl-read): Read from the repl inport.
  (repl-print): Write to the repl outport.

* module/system/repl/command.scm (read-datum, read-line, meta-command):
  Respect repl-inport, and bind the outport of meta-commands to the repl
  outport.
---
 module/system/repl/command.scm | 17 ++++++++---------
 module/system/repl/common.scm  | 18 +++++++++++-------
 2 files changed, 19 insertions(+), 16 deletions(-)

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index ca44c9028..0c3d70715 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -106,12 +106,12 @@
     (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
 
 (define (read-datum repl)
-  (read))
+  (read (repl-inport repl)))
 
 (define read-line
   (let ((orig-read-line read-line))
     (lambda (repl)
-      (orig-read-line))))
+      (orig-read-line (repl-inport repl)))))
 
 (define (meta-command repl)
   (let ((command (read-datum repl)))
@@ -129,14 +129,13 @@
        docstring
        (let* ((expression0
                (repl-reader ""
-                            (lambda args
-                              (let ((port (if (pair? args)
-                                              (car args)
-                                              (current-input-port))))
-                                ((language-reader (repl-language repl))
-                                 port (current-module))))))
+                            (lambda* (#:optional (port (repl-inport repl)))
+                              ((language-reader (repl-language repl))
+                               port (current-module)))))
               ...)
-         (apply (lambda* datums b0 b1 ...)
+         (apply (lambda* datums
+                  (with-output-to-port (repl-outport repl)
+                    (lambda () b0 b1 ...)))
                 (let ((port (open-input-string (read-line repl))))
                   (let lp ((out '()))
                     (let ((x (read port)))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index bc3fcaf69..b60a2c448 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -25,7 +25,7 @@
   #:use-module (system vm program)
   #:use-module (ice-9 control)
   #:export (<repl> make-repl repl-language repl-options
-            repl-tm-stats repl-gc-stats
+            repl-tm-stats repl-gc-stats repl-inport repl-outport repl-debug
             repl-welcome repl-prompt repl-read repl-compile repl-eval
             repl-parse repl-print repl-option-ref repl-option-set!
             repl-default-option-set! repl-default-prompt-set!
@@ -99,7 +99,8 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
 ;;; Repl type
 ;;;
 
-(define-record/keywords <repl> language options tm-stats gc-stats)
+(define-record/keywords <repl>
+  language options tm-stats gc-stats inport outport debug)
 
 (define repl-default-options
   '((compile-options . (#:warnings (unbound-variable arity-mismatch)))
@@ -107,11 +108,14 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
     (interp . #f)))
 
 (define %make-repl make-repl)
-(define (make-repl lang)
+(define* (make-repl lang #:optional debug)
   (%make-repl #:language (lookup-language lang)
               #:options repl-default-options
               #:tm-stats (times)
-              #:gc-stats (gc-stats)))
+              #:gc-stats (gc-stats)
+              #:inport (current-input-port)
+              #:outport (current-output-port)
+              #:debug debug))
 
 (define (repl-welcome repl)
   (display *version*)
@@ -130,7 +134,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
               (if (zero? level) "" (format #f " [~a]" level)))))))
 
 (define (repl-read repl)
-  ((language-reader (repl-language repl)) (current-input-port)
+  ((language-reader (repl-language repl)) (repl-inport repl)
                                           (current-module)))
 
 (define (repl-compile-options repl)
@@ -162,8 +166,8 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
         ;; should be printed with the generic printer, `write'. The
         ;; language-printer is something else: it prints expressions of
         ;; a given language, not the result of evaluation.
-	(write val)
-	(newline))))
+	(write val (repl-outport repl))
+	(newline (repl-outport repl)))))
 
 (define (repl-option-ref repl key)
   (assq-ref (repl-options repl) key))