From 40647e32ce881c10042cf0ed33d1d266fea48c96 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 2 Mar 2017 21:51:32 -0800
Subject: [PATCH] Use canonical caseless matching for symbols.

---
 src/runtime/runtime.pkg |  3 +++
 src/runtime/symbol.scm  |  2 +-
 src/runtime/ustring.scm | 28 +++++++++++++++++++++++-----
 3 files changed, 27 insertions(+), 6 deletions(-)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a9f3c926b..d98ccbeb1 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -974,6 +974,7 @@ USA.
 	  string
 	  string*
 	  string->list
+	  string->nfd
 	  string->vector
 	  string-any
 	  string-append
@@ -987,6 +988,7 @@ USA.
 	  string-ci>?
 	  string-compare
 	  string-compare-ci
+	  string-canonical-foldcase
 	  string-copy
 	  string-copy!
 	  string-count
@@ -1290,6 +1292,7 @@ USA.
 	  char-set:changes-when-case-folded
 	  ucd-nt-value)
   (export (runtime ustring)
+	  char-changes-when-case-folded?
 	  char-changes-when-lower-cased?
 	  char-changes-when-upper-cased?
 	  char-nfd-quick-check?
diff --git a/src/runtime/symbol.scm b/src/runtime/symbol.scm
index 12e398d72..4b31d7bc5 100644
--- a/src/runtime/symbol.scm
+++ b/src/runtime/symbol.scm
@@ -101,7 +101,7 @@ USA.
   (if (ascii-string? string)
       ;; Needed during cold load.
       (%legacy-string->bytevector (ascii-string-foldcase string))
-      (string->utf8 (string-foldcase string))))
+      (string->utf8 (string-canonical-foldcase string))))
 
 (define (ascii-string? string)
   (and (legacy-string? string)
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 978656060..366b9a538 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -474,22 +474,40 @@ USA.
 		(loop (fix:+ index 1))))))))
 
 (define (string-lower-case? string)
-  (let* ((nfd (string->nfd string))
-	 (end (string-length nfd)))
+  (nfd-string-lower-case? (string->nfd string)))
+
+(define (string-upper-case? string)
+  (nfd-string-upper-case? (string->nfd string)))
+
+(define (nfd-string-lower-case? nfd)
+  (let ((end (string-length nfd)))
     (let loop ((i 0))
       (if (fix:< i end)
 	  (and (not (char-changes-when-lower-cased? (string-ref nfd i)))
 	       (loop (fix:+ i 1)))
 	  #t))))
 
-(define (string-upper-case? string)
-  (let* ((nfd (string->nfd string))
-	 (end (string-length nfd)))
+(define (nfd-string-upper-case? nfd)
+  (let ((end (string-length nfd)))
     (let loop ((i 0))
       (if (fix:< i end)
 	  (and (not (char-changes-when-upper-cased? (string-ref nfd i)))
 	       (loop (fix:+ i 1)))
 	  #t))))
+
+(define (nfd-string-case-folded? nfd)
+  (let ((end (string-length nfd)))
+    (let loop ((i 0))
+      (if (fix:< i end)
+	  (and (not (char-changes-when-case-folded? (string-ref nfd i)))
+	       (loop (fix:+ i 1)))
+	  #t))))
+
+(define (string-canonical-foldcase string)
+  (let ((nfd (string->nfd string)))
+    (if (nfd-string-case-folded? nfd)
+	nfd
+	(string->nfd (string-foldcase string)))))
 
 ;;;; Normalization
 
-- 
2.25.1