[PATCH] Honor and confine expansion-time side-effects to `current-reader'

[Ludovic Courtès]

Hi!

The attached patch allows expansion-time modifications of
`current-reader' to be taken into account.  For example:

   (define-macro (install-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

   => ok

This trick works with both the compiler and the interpreter.  I intended
to use it in Skribilo.

Furthermore, the `current-reader' fluid used at compilation-time by
default is different from the one in the compiler.  This is needed
because the REPL uses `current-reader' to install a wrapper around the
current language reader; when that language is Scheme, we enter an
infinite recursion if Scheme's reader honors `current-reader'.

The patch exposes the current compilation environment as a fluid, so
that language readers can look for the compile-time `current-reader'.
This is admittedly not very elegant, but I can't think of a better way.

Thanks,
Ludo'.

>From d4e1ea92049ff8e2cd20184a0d3bd717ffa4b2ae Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Mon, 17 Aug 2009 22:28:54 +0200
Subject: [PATCH 2/2] 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 |   16 +++++++++++++++-
 module/system/base/compile.scm  |   23 ++++++++++++++++++++---
 test-suite/tests/compiler.test  |   35 ++++++++++++++++++++++++++++++++++-
 3 files changed, 69 insertions(+), 5 deletions(-)

diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index df61858..f88537f 100644
--- a/module/language/scheme/spec.scm
+++ b/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))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index f3557cb..8b0d88f 100644
--- a/module/system/base/compile.scm
+++ b/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
@@ -196,6 +203,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)
@@ -213,9 +226,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)
@@ -245,7 +261,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))
 
 
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 2eb0e78..ed6f033 100644
--- a/test-suite/tests/compiler.test
+++ b/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))))))
-- 
1.6.1.3