From 8f19de52e9788395320a60d1d04eeb03b4adbf35 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Sun, 18 Dec 2016 20:21:48 +0100
Subject: [PATCH] =?UTF-8?q?Add=20#lang=20afl/unhygienic=20=E2=80=A6?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 afl/reader.rkt                         | 14 ++++++++++++++
 afl/unhygienic/lang/language-info.rkt  | 21 +++++++++++++++++++++
 afl/unhygienic/lang/reader.rkt         | 18 ++++++++++++++++++
 afl/unhygienic/lang/runtime-config.rkt |  9 +++++++++
 4 files changed, 62 insertions(+)
 create mode 100644 afl/unhygienic/lang/language-info.rkt
 create mode 100644 afl/unhygienic/lang/reader.rkt
 create mode 100644 afl/unhygienic/lang/runtime-config.rkt

diff --git a/afl/reader.rkt b/afl/reader.rkt
index 7eafc73..9b66015 100644
--- 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
new file mode 100644
index 0000000..dae2368
--- /dev/null
+++ 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
new file mode 100644
index 0000000..9f6ee84
--- /dev/null
+++ 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
new file mode 100644
index 0000000..453c0bc
--- /dev/null
+++ 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))
+