From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 30 Jan 2017 03:08:41 +0000 (-0800)
Subject: Change parser to respect fold-case? in various places.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~24
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=650e90f60975cf3f8f47c87e81baa578380c6174;p=mit-scheme.git

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

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index b4a9e7e49..799e8acd4 100644
--- 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)))))
 
 (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)))
 
 (define-structure db
   (associate-positions? #f read-only #t)