Honor and confine expansion-time side-effects to `current-reader'.

* module/language/scheme/spec.scm (scheme)[#:reader]: Honor the
  compilation environment's `current-reader'.

* module/system/base/compile.scm (*compilation-environment*): New
  fluid.
  (current-compilation-environment): New procedure.
  (make-compilation-module): Provide a fresh `current-reader' fluid.
  (read-and-compile): Set `*compilation-environment*' appropriately.
  (compile): Likewise.

* test-suite/tests/compiler.test (read-and-compile): New.
  ("current-reader"): New test prefix.

module/language/scheme/spec.scm

@@ -19,6 +19,7 @@
 ;;; Code:
 
 (define-module (language scheme spec)
+  #:use-module (system base compile)
   #:use-module (system base language)
   #:use-module (language scheme compile-tree-il)
   #:use-module (language scheme decompile-tree-il)
@@ -37,7 +38,20 @@
 (define-language scheme
   #:title	"Guile Scheme"
   #:version	"0.5"
-  #:reader	read
+  #:reader      (lambda args
+                  ;; Read using the compilation environment's current reader.
+                  ;; Don't use the current module's `current-reader' because
+                  ;; it might be set, e.g., to the REPL's reader, so we'd
+                  ;; enter an infinite recursion.
+                  ;; FIXME: Handle `read-options' as well.
+                  (let* ((mod  (current-compilation-environment))
+                         (cr   (and (module? mod)
+                                    (module-ref mod 'current-reader)))
+                         (read (if (and cr (fluid-ref cr))
+                                   (fluid-ref cr)
+                                   read)))
+                    (apply read args)))
+
   #:compilers   `((tree-il . ,compile-tree-il))
   #:decompilers `((tree-il . ,decompile-tree-il))
   #:evaluator	(lambda (x module) (primitive-eval x))

module/system/base/compile.scm

@@ -28,6 +28,7 @@
   #:use-module (ice-9 receive)
   #:export (syntax-error 
             *current-language*
+            current-compilation-environment
             compiled-file-name compile-file compile-and-load
             compile
             decompile)
@@ -63,6 +64,12 @@
 (define (current-language)
   (fluid-ref *current-language*))
 
+(define *compilation-environment* (make-fluid))
+(define (current-compilation-environment)
+  "Return the current compilation environment (a module) or #f.  This
+function should only be called from stages in the compiler tower."
+  (fluid-ref *compilation-environment*))
+
 (define (call-once thunk)
   (let ((entered #f))
     (dynamic-wind
@@ -199,6 +206,12 @@
 
   (let ((m (make-module)))
     (beautify-user-module! m)
+
+    ;; Provide a separate `current-reader' fluid so that the Scheme language
+    ;; reader doesn't get to see the REPL's settings for `current-reader',
+    ;; which would lead to an infinite loop.
+    (module-define! m 'current-reader (make-fluid))
+
     m))
 
 (define (language-default-environment lang)
@@ -216,9 +229,12 @@
   (let ((from (ensure-language from))
         (to (ensure-language to)))
     (let ((joint (find-language-joint from to)))
-      (with-fluids ((*current-language* from))
+      (with-fluids ((*current-language* from)
+                    (*compilation-environment*
+                     (or env
+                         (language-default-environment from))))
         (let lp ((exps '()) (env #f)
-                 (cenv (or env (language-default-environment from))))
+                 (cenv (fluid-ref *compilation-environment*)))
           (let ((x ((language-reader (current-language)) port)))
             (cond
              ((eof-object? x)
@@ -248,7 +264,8 @@
 
   (receive (exp env cenv)
       (let ((env (or env (language-default-environment from))))
-        (compile-fold (compile-passes from to opts) x env opts))
+        (with-fluids ((*compilation-environment* env))
+          (compile-fold (compile-passes from to opts) x env opts)))
     exp))
 
 

test-suite/tests/compiler.test

@@ -18,7 +18,11 @@
 (define-module (test-suite tests compiler)
   :use-module (test-suite lib)
   :use-module (test-suite guile-test)
-  :use-module (system base compile))
+  :use-module (system base compile)
+  :use-module ((system vm vm) #:select (the-vm vm-load)))
+
+(define read-and-compile
+  (@@ (system base compile) read-and-compile))
 
 
 
@@ -66,3 +70,32 @@
       (beautify-user-module! m)
       (compile '(define round round) #:env m)
       (eq? round (module-ref m 'round)))))
+
+
+(with-test-prefix "current-reader"
+
+  (pass-if "default compile-time current-reader differs"
+    (not (eq? (compile 'current-reader)
+              current-reader)))
+
+  (pass-if "compile-time changes are honored and isolated"
+    ;; Make sure changing `current-reader' as the side-effect of a defmacro
+    ;; actually works.
+    (let ((r     (fluid-ref current-reader))
+          (input (open-input-string
+                  "(define-macro (install-reader!)
+                     ;;(format #t \"current-reader = ~A~%\" current-reader)
+                     (fluid-set! current-reader
+                                 (let ((first? #t))
+                                   (lambda args
+                                     (if first?
+                                         (begin
+                                           (set! first? #f)
+                                           ''ok)
+                                         (read (open-input-string \"\"))))))
+                     #f)
+                   (install-reader!)
+                   this-should-be-ignored")))
+      (and (eq? (vm-load (the-vm) (read-and-compile input))
+                'ok)
+           (eq? r (fluid-ref current-reader))))))