www

commit a93f583fc4087698beed14a0f3d17c8c3b3ed9f9
parent d0029ed1f5d57699d79df7dce808eea7c6c7be18
Author: AlexKnauth <alexander@knauth.org>
Date:   Wed, 22 Apr 2015 18:46:03 -0400

make language-info compose nicely

Diffstat:
M
afl/lang/language-info.rkt
 | 
15
+++++++++++++--
M
afl/lang/reader.rkt
 | 
7
++++---
M
afl/lang/runtime-config.rkt
 | 
7
++-----
M
afl/reader.rkt
 | 
5
+++--

4 files changed, 22 insertions(+), 12 deletions(-)
diff --git a/afl/lang/language-info.rkt b/afl/lang/language-info.rkt
@@ -2,9 +2,20 @@
 
 (provide get-language-info)
 
+(require racket/match)
+
 (define (get-language-info data)
+  (define other-get-info
+    (match data
+      [(vector mod sym data2)
+       ((dynamic-require mod sym) data2)]
+      [_ (lambda (key default) default)]))
   (lambda (key default)
     (case key
       [(configure-runtime)
-       '(#[afl/lang/runtime-config configure #f])]
-      [else default])))
+       (define config-vec '#[afl/lang/runtime-config configure #f])
+       (define other-config (other-get-info key default))
+       (cond [(list? other-config) (cons config-vec other-config)]
+             [else (list config-vec)])]
+      [else (other-get-info key default)])))
+
diff --git a/afl/lang/reader.rkt b/afl/lang/reader.rkt
@@ -23,9 +23,10 @@
      (lambda (orig-read-syntax)
        (define read-syntax (wrap-reader orig-read-syntax))
        (lambda args
-         (syntax-property (apply read-syntax args)
-                          'module-language
-                          '#(afl/lang/language-info get-language-info #f))))
+         (define stx (apply read-syntax args))
+         (define old-prop (syntax-property stx 'module-language))
+         (define new-prop `#(afl/lang/language-info get-language-info ,old-prop))
+         (syntax-property stx 'module-language new-prop)))
      (lambda (proc)
        (lambda (key defval)
          (define (fallback) (if proc (proc key defval) defval))
diff --git a/afl/lang/runtime-config.rkt b/afl/lang/runtime-config.rkt
@@ -5,8 +5,5 @@
 (require (only-in afl/reader make-afl-readtable))
 
 (define (configure data)
-  (define old-read (current-read-interaction))
-  (define (new-read src in)
-    (parameterize ([current-readtable (make-afl-readtable (current-readtable))])
-      (old-read src in)))
-  (current-read-interaction new-read))
+  (current-readtable (make-afl-readtable)))
+
diff --git a/afl/reader.rkt b/afl/reader.rkt
@@ -121,9 +121,10 @@
                   [%1 (string->id stx* arg-str "1")]
                   [body stx*])
       (intro
-       #'(lambda args
+       (syntax/loc stx
+         (lambda args
            (define-syntax % (make-rename-transformer #'%1))
-           body)))))
+           body))))))
 
 (module+ test
   ;; These test `parse`. See test.rkt for tests of readtable use per se.