~ chicken-r7rs (master) 0ae37044699af4f6840d2a1c05625ec84890f159

commit 0ae37044699af4f6840d2a1c05625ec84890f159
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Jun 17 18:58:13 2014 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Tue Jun 17 18:58:13 2014 +0000

    #![no-]fold-case, check read's argument type

diff --git a/scheme.read.scm b/scheme.read.scm
index d9a4fab..ba56b86 100644
--- a/scheme.read.scm
+++ b/scheme.read.scm
@@ -1,6 +1,45 @@
 (module scheme.read (read)
   (import (except scheme read)
-	  (only chicken : current-read-table fx+ fx= optional unless when))
+	  (only chicken : current-read-table fx+ fx= optional unless when)
+	  (only chicken case-sensitive define-constant define-inline parameterize))
+
+  ;;;
+  ;;; 2.1 Identifiers
+  ;;;
+
+  ;; XXX Slot 14 indicates whether or not a port is case-folded.
+  ;; Hopefully this doesn't interfere with anything else.
+
+  (define-constant port-fold-case-slot 14)
+
+  (define-inline (port-fold-case p)
+    (##sys#slot p port-fold-case-slot))
+
+  (##sys#set-read-mark!
+   'fold-case
+   (lambda (p)
+     (##sys#setslot p port-fold-case-slot 'fold-case)
+     (read p)))
+
+  (##sys#set-read-mark!
+   'no-fold-case
+   (lambda (p)
+     (##sys#setslot p port-fold-case-slot 'no-fold-case)
+     (read p)))
+
+  (set! ##sys#read
+    (let ((read ##sys#read))
+      (lambda (port hook)
+	(parameterize ((case-sensitive
+			(case (port-fold-case port)
+			  ((fold-case) #f)
+			  ((no-fold-case) #t)
+			  (else (case-sensitive)))))
+	  (read port hook)))))
+
+  ;;;
+  ;;; 6.13.2 Input
+  ;;;
 
   (define (data? o)
     (not (procedure? o)))
@@ -68,6 +107,7 @@
        (##sys#setslot (##sys#slot read-table 3) 35 read-hash/shared)
        (##sys#setslot (##sys#slot read-table 3) 61 read-equal/shared))
      (lambda ()
+       (##sys#check-input-port port #t 'read)
        (read/shared port))
      (lambda ()
        (##sys#setslot (##sys#slot read-table 3) 35 read-hash/orig)
diff --git a/tests/run.scm b/tests/run.scm
index e6abac7..454e6c6 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -19,6 +19,18 @@
 
 (test-begin "r7rs tests")
 
+(test-group "2.1: Identifiers"
+  (test "#!(no-)fold-case"
+        '(FOO mooh qux blah foo BAR)
+        (append
+         (with-input-from-string
+          "FOO #!fold-case mooh QUX blah #!no-fold-case foo BAR" read-file)))
+  (test "#!(no-)fold-case only affects subsequent reads from the same port"
+        '(FOO bar baz downcased UPCASED)
+        (append
+         (with-input-from-string "FOO #!fold-case bar BAZ" read-file)
+         (with-input-from-string "downcased UPCASED" read-file))))
+
 (test-group "4.1.7: Inclusion"
   (test-group "include"
     (test "multiple filenames"