www

commit 8f19de52e9788395320a60d1d04eeb03b4adbf35
parent 50cc9ca667dbf3397db791da86c1ff31b34587a3
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Sun, 18 Dec 2016 20:21:48 +0100

Add #lang afl/unhygienic …

Diffstat:
M
afl/reader.rkt
 | 
14
++++++++++++++
A
afl/unhygienic/lang/language-info.rkt
 | 
21
+++++++++++++++++++++
A
afl/unhygienic/lang/reader.rkt
 | 
18
++++++++++++++++++
A
afl/unhygienic/lang/runtime-config.rkt
 | 
9
+++++++++

4 files changed, 62 insertions(+), 0 deletions(-)
diff --git a/afl/reader.rkt b/afl/reader.rkt
@@ -4,6 +4,7 @@
          afl-read
          afl-read-syntax
          wrap-reader
+         wrap-reader-unhygienic
          use-afl-readtable
          current-arg-string
          (rename-out
@@ -57,6 +58,19 @@
 (define (wrap-reader p)
   (extend-reader p make-afl-readtable))
 
+(require syntax/strip-context)
+(define ((wrap-reader-unhygienic p) . p-args)
+  (strip-context
+   (apply (extend-reader p
+                         (λ ([orig-rt (current-readtable)]
+                             #:outer-scope outer-scope
+                             #:arg-str [arg-str (current-arg-string)])
+                           (make-afl-readtable orig-rt
+                                               #:outer-scope (λ (stx [mode 'flip]) stx)
+                                               #:arg-str arg-str))
+                         #:hygiene? #f)
+          p-args)))
+
 (define (make-afl-readtable [orig-rt (current-readtable)]
                             #:outer-scope outer-scope
                             #:arg-str [arg-str (current-arg-string)])
diff --git a/afl/unhygienic/lang/language-info.rkt b/afl/unhygienic/lang/language-info.rkt
@@ -0,0 +1,21 @@
+#lang racket/base
+
+(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)
+       (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/unhygienic/lang/reader.rkt b/afl/unhygienic/lang/reader.rkt
@@ -0,0 +1,18 @@
+#lang lang-extension
+#:lang-extension afl make-afl-lang-reader
+#:lang-reader afl-lang
+(require lang-reader/lang-reader
+         (only-in "../../reader.rkt" wrap-reader-unhygienic))
+
+(define (make-afl-lang-reader lang-reader)
+  (define/lang-reader [-read -read-syntax -get-info] lang-reader)
+  (make-lang-reader
+   (wrap-reader-unhygienic -read)
+   (let ([read-syntax (wrap-reader-unhygienic -read-syntax)])
+     (lambda args
+       (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)))
+   -get-info))
+
diff --git a/afl/unhygienic/lang/runtime-config.rkt b/afl/unhygienic/lang/runtime-config.rkt
@@ -0,0 +1,9 @@
+#lang racket/base
+
+(provide configure)
+
+(require (only-in afl/reader use-afl-readtable))
+
+(define (configure data)
+  (use-afl-readtable))
+