~ chicken-r7rs (master) a89690390d8d86f6311338da39b7f885440e30ec

commit a89690390d8d86f6311338da39b7f885440e30ec
Author:     Moritz Heidkamp <moritz@twoticketsplease.de>
AuthorDate: Mon May 27 07:22:14 2013 +0000
Commit:     Moritz Heidkamp <moritz@twoticketsplease.de>
CommitDate: Mon May 27 07:22:14 2013 +0000

    r7rs: Long boolean read syntax

diff --git a/r7rs.meta b/r7rs.meta
new file mode 100644
index 0000000..ced9daf
--- /dev/null
+++ b/r7rs.meta
@@ -0,0 +1,7 @@
+((synopsis "R7RS compatibility")
+ (author "The Chicken Team")
+ (category lang-exts)
+ (license "BSD")
+ (depends)
+ (test-depends)
+ (foreign-depends))
diff --git a/r7rs.scm b/r7rs.scm
new file mode 100644
index 0000000..687628b
--- /dev/null
+++ b/r7rs.scm
@@ -0,0 +1,26 @@
+(module r7rs
+
+()
+
+(import chicken scheme)
+(use srfi-13)
+
+(define (read-asserted-ci-symbol port valid-symbols error-message)
+  (let ((sym (##sys#read port ##sys#default-read-info-hook)))
+    (or (and (symbol? sym)
+             (memq (string->symbol (string-downcase (symbol->string sym))) valid-symbols))
+        (##sys#read-error port error-message sym))))
+
+(let ((old-hook ##sys#user-read-hook))
+  (set! ##sys#user-read-hook
+        (lambda (char port)
+          (case char
+            ((#\f #\F)
+             (read-asserted-ci-symbol port '(f false) "invalid `false' read syntax")
+             #f)
+            ((#\t #\T)
+             (read-asserted-ci-symbol port '(t true) "invalid `true' read syntax")
+             #t)
+            (else (old-hook))))))
+
+)
diff --git a/r7rs.setup b/r7rs.setup
new file mode 100644
index 0000000..8046c71
--- /dev/null
+++ b/r7rs.setup
@@ -0,0 +1,7 @@
+(compile -d0 -O2 -J -s r7rs.scm)
+(compile -d0 -O2 -s r7rs.import.scm)
+
+(install-extension
+ 'r7rs
+ '("r7rs.so" "r7rs.import.so")
+ '((version "0.0.1")))
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..d15d114
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,11 @@
+(use r7rs test)
+
+(define (read-from-string s)
+  (with-input-from-string s read))
+
+(test-group "long boolean literalsa"
+ (test #t (read-from-string "#t"))
+ (test #f (read-from-string "#f"))
+ (test #t (read-from-string "#true"))
+ (test #f (read-from-string "#false"))
+ (test-error (read-from-string "#faux")))