Implement ustring-{lower,upper}-case?.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6acd8ce7f802405743bc2be5a0167dad099773dd..3e31bfa178fa83fa8bff3d1c30c969be5f5a0268 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1092,7 +1092,7 @@ USA.
          string-joiner
          string-joiner*
          ;; string-length
-         string-lower-case?
+         ;; string-lower-case?
          ;; string-map
          string-match-backward
          string-match-backward-ci
@@ -1121,7 +1121,7 @@ USA.
          string-trim-right
          ;; string-upcase
          string-upcase!
-         string-upper-case?
+         ;; string-upper-case?
          ;; string<=?
          ;; string<?
          ;; string=?
@@ -1190,6 +1190,7 @@ USA.
          (string-hash-mod ustring-hash)
          (string-head ustring-head)
          (string-length ustring-length)
+         (string-lower-case? ustring-lower-case?)
          (string-map ustring-map)
          (string-prefix-ci? ustring-prefix-ci?)
          (string-prefix? ustring-prefix?)
@@ -1199,6 +1200,7 @@ USA.
          (string-suffix? ustring-suffix?)
          (string-tail ustring-tail)
          (string-upcase ustring-upcase)
+         (string-upper-case? ustring-upper-case?)
          (string<=? ustring<=?)
          (string<? ustring<?)
          (string=? ustring=?)
@@ -1238,6 +1240,7 @@ USA.
          ustring-for-each
          ustring-hash
          ustring-head
+         ustring-lower-case?
          ustring-length
          ustring-map
          ustring-prefix-ci?
@@ -1249,6 +1252,7 @@ USA.
          ustring-suffix?
          ustring-tail
          ustring-upcase
+         ustring-upper-case?
          ustring<=?
          ustring<?
          ustring=?
@@ -1521,6 +1525,8 @@ USA.
          char-set:changes-when-case-folded
          ucd-nt-value)
   (export (runtime ustring)
+         char-changes-when-lower-cased?
+         char-changes-when-upper-cased?
          char-nfd-quick-check?
          ucd-ccc-value
          ucd-dm-value))

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index e8eeebd7f92a155ef34de9e7507f2a20a1fffa03..b386579b3779e47506010a7eacbee72d58751c4d 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -367,6 +367,104 @@ USA.
            ((not (pair? chars)))
          (ustring-set! result i (car chars)))
        result))))
+
+(define (ustring-lower-case? string)
+  (let* ((nfd (ustring->nfd string))
+        (end (ustring-length nfd)))
+    (let loop ((i 0))
+      (if (fix:< i end)
+         (and (not (char-changes-when-lower-cased? (ustring-ref nfd i)))
+              (loop (fix:+ i 1)))
+         #t))))
+
+(define (ustring-upper-case? string)
+  (let* ((nfd (ustring->nfd string))
+        (end (ustring-length nfd)))
+    (let loop ((i 0))
+      (if (fix:< i end)
+         (and (not (char-changes-when-upper-cased? (ustring-ref nfd i)))
+              (loop (fix:+ i 1)))
+         #t))))
+\f
+(define (ustring->nfd string)
+  (if (ustring-in-nfd? string)
+      string
+      (canonical-ordering! (canonical-decomposition string))))
+
+(define (ustring-in-nfd? string)
+  (let ((n (ustring-length string)))
+    (let loop ((i 0) (last-ccc 0))
+      (if (fix:< i n)
+         (let* ((char (ustring-ref string i))
+                (ccc (ucd-ccc-value char)))
+           (and (or (fix:= ccc 0)
+                    (fix:>= ccc last-ccc))
+                (char-nfd-quick-check? char)
+                (loop (fix:+ i 1) ccc)))
+         #t))))
+
+(define (canonical-decomposition string)
+  (let ((end (ustring-length string)))
+    (let ((result
+          (make-ustring
+           (do ((i 0 (fix:+ i 1))
+                (j 0 (fix:+ j (length (ucd-dm-value (ustring-ref string i))))))
+               ((not (fix:< i end)) j)))))
+      (let loop ((i 0) (j 0))
+       (if (fix:< i end)
+           (loop (fix:+ i 1)
+                 (do ((chars (ucd-dm-value (ustring-ref string i))
+                             (cdr chars))
+                      (j j (fix:+ j 1)))
+                     ((not (pair? chars)) j)
+                   (ustring-set! result j (car chars))))))
+      result)))
+
+(define (canonical-ordering! string)
+  (let ((end (ustring-length string)))
+
+    (define (scan-for-non-starter i)
+      (if (fix:< i end)
+         (let* ((char (ustring-ref string i))
+                (ccc (ucd-ccc-value char)))
+           (if (fix:= 0 ccc)
+               (scan-for-non-starter (fix:+ i 1))
+               (maybe-twiddle char ccc i)))))
+
+    (define (maybe-twiddle char1 ccc1 i1)
+      (let ((i2 (fix:+ i1 1)))
+       (if (fix:< i2 end)
+           (let* ((char2 (ustring-ref string i2))
+                  (ccc2 (ucd-ccc-value char2)))
+             (cond ((fix:= 0 ccc2)
+                    (scan-for-non-starter (fix:+ i2 1)))
+                   ((fix:<= ccc1 ccc2)
+                    (maybe-twiddle char2 ccc2 i2))
+                   (else
+                    (ustring-set! string i1 char2)
+                    (ustring-set! string i2 char1)
+                    (maybe-twiddle char1 ccc1 i2)))))))
+
+    (scan-for-non-starter 0))
+  string)
+
+#|
+(define (quick-check string qc-value)
+  (let ((n (ustring-length string)))
+    (let loop ((i 0) (last-ccc 0) (result #t))
+      (if (fix:< i n)
+         (let* ((char (ustring-ref string i))
+                (ccc (ucd-ccc-value char)))
+           (if (and (fix:> ccc 0)
+                    (fix:< ccc last-ccc))
+               #f
+               (let ((check (qc-value char)))
+                 (and check
+                      (if (eq? check 'maybe)
+                          (loop (fix:+ i 1) ccc check)
+                          (loop (fix:+ i 1) ccc result))))))
+         result))))
+|#
 \f
 (define (list->ustring chars)
   (if (every char-8-bit? chars)
@@ -669,82 +767,4 @@ USA.
     (if (fix:< i end)
        (and (proc (ref string i))
             (loop (fix:+ i 1)))
-       #t)))
-\f
-(define (ustring->nfd string)
-  (if (ustring-in-nfd? string)
-      string
-      (canonical-ordering! (canonical-decomposition string))))
-
-(define (ustring-in-nfd? string)
-  (let ((n (ustring-length string)))
-    (let loop ((i 0) (last-ccc 0))
-      (if (fix:< i n)
-         (let* ((char (ustring-ref string i))
-                (ccc (ucd-ccc-value char)))
-           (and (or (fix:= ccc 0)
-                    (fix:>= ccc last-ccc))
-                (char-nfd-quick-check? char)
-                (loop (fix:+ i 1) ccc)))
-         #t))))
-
-(define (canonical-decomposition string)
-  (let ((end (ustring-length string)))
-    (let ((result
-          (make-ustring
-           (do ((i 0 (fix:+ i 1))
-                (j 0 (fix:+ j (length (ucd-dm-value (ustring-ref string i))))))
-               ((not (fix:< i end)) j)))))
-      (let loop ((i 0) (j 0))
-       (if (fix:< i end)
-           (loop (fix:+ i 1)
-                 (do ((chars (ucd-dm-value (ustring-ref string i))
-                             (cdr chars))
-                      (j j (fix:+ j 1)))
-                     ((not (pair? chars)) j)
-                   (ustring-set! result j (car chars))))))
-      result)))
-
-(define (canonical-ordering! string)
-  (let ((end (ustring-length string)))
-
-    (define (scan-for-non-starter i)
-      (if (fix:< i end)
-         (let* ((char (ustring-ref string i))
-                (ccc (ucd-ccc-value char)))
-           (if (fix:= 0 ccc)
-               (scan-for-non-starter (fix:+ i 1))
-               (maybe-twiddle char ccc i)))))
-
-    (define (maybe-twiddle char1 ccc1 i1)
-      (let ((i2 (fix:+ i1 1)))
-       (if (fix:< i2 end)
-           (let* ((char2 (ustring-ref string i2))
-                  (ccc2 (ucd-ccc-value char2)))
-             (cond ((fix:= 0 ccc2)
-                    (scan-for-non-starter (fix:+ i2 1)))
-                   ((fix:<= ccc1 ccc2)
-                    (maybe-twiddle char2 ccc2 i2))
-                   (else
-                    (ustring-set! string i1 char2)
-                    (ustring-set! string i2 char1)
-                    (maybe-twiddle char1 ccc1 i2)))))))
-
-    (scan-for-non-starter 0))
-  string)
-
-(define (quick-check string qc-value)
-  (let ((n (ustring-length string)))
-    (let loop ((i 0) (last-ccc 0) (result #t))
-      (if (fix:< i n)
-         (let* ((char (ustring-ref string i))
-                (ccc (ucd-ccc-value char)))
-           (if (and (fix:> ccc 0)
-                    (fix:< ccc last-ccc))
-               #f
-               (let ((check (qc-value char)))
-                 (and check
-                      (if (eq? check 'maybe)
-                          (loop (fix:+ i 1) ccc check)
-                          (loop (fix:+ i 1) ccc result))))))
-         result))))
\ No newline at end of file
+       #t)))
\ No newline at end of file