Change parser to respect fold-case? in various places.

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index b4a9e7e4968b2fdc87cc1ce92c958c29691b48be..799e8acd428938224bc27c39ab79e3087d0c1404 100644 (file)
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -738,14 +738,19 @@ USA.
            ((#\\)
             (let ((char
                    (let ((char (%read-char/no-eof port db)))
-                     (cond ((char-ci=? char #\n) #\newline)
-                           ((char-ci=? char #\t) #\tab)
-                           ((char-ci=? char #\v) #\vt)
-                           ((char-ci=? char #\b) #\bs)
-                           ((char-ci=? char #\r) #\return)
-                           ((char-ci=? char #\f) #\page)
-                           ((char-ci=? char #\a) #\bel)
+                     (cond ((%char-ci=? db char #\a) #\bel)
+                           ((%char-ci=? db char #\b) #\bs)
+                           ((%char-ci=? db char #\n) #\newline)
+                           ((%char-ci=? db char #\r) #\return)
+                           ((%char-ci=? db char #\t) #\tab)
                            ((char=? char #\x) (parse-hex-scalar-value port db))
+                           ((or (char=? char #\")
+                                (char=? char #\\)
+                                (char=? char #\|))
+                            char)
+                           ;; MIT/GNU extensions:
+                           ((%char-ci=? db char #\f) #\page)
+                           ((%char-ci=? db char #\v) #\vt)
                            ((char->digit char 8) (octal->char char port db))
                            (else char)))))
               (write-char char port*)
@@ -789,16 +794,16 @@ USA.
 (define (handler:false port db ctx char1 char2)
   ctx
   (let ((string (parse-atom/no-quoting port db (list char1 char2))))
-    (if (not (or (string-ci=? string "#f")
-                (string-ci=? string "#false")))
+    (if (not (or (%string-ci=? db string "#f")
+                (%string-ci=? db string "#false")))
        (error:illegal-boolean string)))
   #f)
 
 (define (handler:true port db ctx char1 char2)
   ctx
   (let ((string (parse-atom/no-quoting port db (list char1 char2))))
-    (if (not (or (string-ci=? string "#t")
-                (string-ci=? string "#true")))
+    (if (not (or (%string-ci=? db string "#t")
+                (%string-ci=? db string "#true")))
        (error:illegal-boolean string)))
   #t)
 
@@ -840,21 +845,22 @@ USA.
                                 char))
                           port*)
               (if (not (at-end?))
-                  (loop)))))))))
+                  (loop)))))
+        (db-fold-case? db)))))
 \f
 (define (handler:named-constant port db ctx char1 char2)
   ctx char1 char2
   (let ((name (parse-atom/no-quoting port db '())))
-    (cond ((string-ci=? name "null") '())
-         ((string-ci=? name "false") #f)
-         ((string-ci=? name "true") #t)
-         ((string-ci=? name "optional") lambda-tag:optional)
-         ((string-ci=? name "rest") lambda-tag:rest)
-         ((string-ci=? name "key") lambda-tag:key)
-         ((string-ci=? name "aux") lambda-tag:aux)
-         ((string-ci=? name "eof") (eof-object))
-         ((string-ci=? name "default") (default-object))
-         ((string-ci=? name "unspecific") unspecific)
+    (cond ((%string-ci=? db name "null") '())
+         ((%string-ci=? db name "false") #f)
+         ((%string-ci=? db name "true") #t)
+         ((%string-ci=? db name "optional") lambda-tag:optional)
+         ((%string-ci=? db name "rest") lambda-tag:rest)
+         ((%string-ci=? db name "key") lambda-tag:key)
+         ((%string-ci=? db name "aux") lambda-tag:aux)
+         ((%string-ci=? db name "eof") (eof-object))
+         ((%string-ci=? db name "default") (default-object))
+         ((%string-ci=? db name "unspecific") unspecific)
          (else (error:illegal-named-constant name)))))
 
 (define (handler:uri port db ctx char1 char2)
@@ -929,6 +935,16 @@ USA.
     (if (eof-object? char)
        (error:premature-eof port))
     char))
+
+(define (%char-ci=? db c1 c2)
+  (if (db-fold-case? db)
+      (char-ci=? c1 c2)
+      (char=? c1 c2)))
+
+(define (%string-ci=? db s1 s2)
+  (if (db-fold-case? db)
+      (ustring-ci=? s1 s2)
+      (ustring=? s1 s2)))
 \f
 (define-structure db
   (associate-positions? #f read-only #t)