>From b7cae3fb33d2cc059c4016709e4d0630eee1610d Mon Sep 17 00:00:00 2001
From: David Thompson <address@hidden>
Date: Sun, 29 Sep 2013 18:01:31 -0400
Subject: [PATCH] Add read-wrapper REPL option.

* module/system/repl/common.scm (repl-default-options): Add read-wrapper
  REPL option.

* module/system/repl/repl.scm (prompting-meta-read): Use read-wrapper
  REPL option.
---
 module/system/repl/common.scm |  4 ++++
 module/system/repl/repl.scm   | 35 ++++++++++++++++++++++-------------
 2 files changed, 26 insertions(+), 13 deletions(-)

diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 5da7c48..030d5de 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -125,6 +125,10 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
                    ((not print) #f)
                    ((procedure? print) print)
                    (else (error "Invalid print procedure" print)))))
+     (read-wrapper
+      ,(lambda (thunk)
+         (thunk))
+      #f)
      (value-history
       ,(value-history-enabled?)
       ,(lambda (x)
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 1649556..97adf72 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -107,20 +107,29 @@
 ;; to be able to re-use the existing readline machinery.
 ;;
 ;; Catches read errors, returning *unspecified* in that case.
+;;
+;; The reader thunk is passed into the read-wrapper procedure. The state
+;; of the stack is maintained, in case of the thunk being called outside
+;; of the current thread.
 (define (prompting-meta-read repl)
-  (catch #t
-    (lambda ()
-      (repl-reader (lambda () (repl-prompt repl))
-                   (meta-reader (repl-language repl) (current-module))))
-    (lambda (key . args)
-      (case key
-        ((quit)
-         (apply throw key args))
-        (else
-         (format (current-output-port) "While reading expression:\n")
-         (print-exception (current-output-port) #f key args)
-         (flush-all-input)
-         *unspecified*)))))
+  (let ((read-wrapper (repl-option-ref repl 'read-wrapper))
+        (stack (fluid-ref *repl-stack*)))
+    (read-wrapper
+     (lambda ()
+       (with-fluids ((*repl-stack* stack))
+         (catch #t
+           (lambda ()
+             (repl-reader (lambda () (repl-prompt repl))
+                          (meta-reader (repl-language repl) (current-module))))
+           (lambda (key . args)
+             (case key
+               ((quit)
+                (apply throw key args))
+               (else
+                (format (current-output-port) "While reading expression:\n")
+                (print-exception (current-output-port) #f key args)
+                (flush-all-input)
+                *unspecified*)))))))))
 
 
 
-- 
1.8.4.rc3