Add support for case-folding of character sets.

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index dcf606f259dce2e8011a1c9e8c8cfbab1fc2974f..9994b77b4a9c7357407266cf486caa2913899ef6 100644 (file)
--- a/src/runtime/char-set.scm
+++ b/src/runtime/char-set.scm
@@ -508,6 +508,11 @@ USA.
                    (cdr ilists))
             (loop (cdr ilists)))
        #t)))
+
+(define (char-set-ci-predicate char-set)
+  (let ((char-set (char-set-foldcase char-set)))
+    (lambda (char)
+      (char-set-contains? char-set (char-foldcase char)))))
 \f
 ;;;; Iterators
 
@@ -860,6 +865,27 @@ USA.
        (values (ilist->char-set (ilist-difference* ilist ilists))
                (ilist->char-set (fold ilist-intersection ilist ilists))))
       (values char-set char-set)))
+
+(define (domain-mapper proc proc-domain)
+  (let ((domain (char-set->ilist proc-domain)))
+    (lambda (char-set)
+      (ilist->char-set
+       (let ((ilist (char-set->ilist char-set)))
+        (ilist-union (ilist-difference ilist domain)
+                     (ilist-map proc (ilist-intersection ilist domain))))))))
+
+(define char-set-foldcase)
+(define char-set-downcase)
+(define char-set-upcase)
+(defer-boot-action 'ucd
+  (lambda ()
+    (set! char-set-foldcase
+         (domain-mapper char-foldcase char-set:changes-when-case-folded))
+    (set! char-set-downcase
+         (domain-mapper char-downcase char-set:changes-when-lower-cased))
+    (set! char-set-upcase
+         (domain-mapper char-upcase char-set:changes-when-upper-cased))
+    unspecific))
 \f
 ;;;; Char-Set Compiler
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 773349ac49aae5d982fdfbe29613d44653532a34..3311922337fabf1fc3962538f9f5cfe826cb2457 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1645,6 +1645,7 @@ USA.
          char-set->string              ;SRFI 14
          char-set-adjoin               ;SRFI 14
          char-set-any                  ;SRFI 14
+         char-set-ci-predicate
          char-set-complement           ;SRFI 14
          char-set-contains?            ;SRFI 14
          char-set-copy                 ;SRFI 14
@@ -1654,11 +1655,13 @@ USA.
          char-set-delete               ;SRFI 14
          char-set-diff+intersection    ;SRFI 14
          char-set-difference           ;SRFI 14
+         char-set-downcase
          char-set-empty?
          char-set-every                ;SRFI 14
          char-set-filter               ;SRFI 14
          char-set-fold                 ;SRFI 14
          char-set-fold-right
+         char-set-foldcase
          char-set-for-each             ;SRFI 14
          char-set-hash                 ;SRFI 14
          char-set-intersection         ;SRFI 14
@@ -1673,6 +1676,7 @@ USA.
          char-set-unfold               ;SRFI 14
          char-set-union                ;SRFI 14
          char-set-union*
+         char-set-upcase
          char-set-xor                  ;SRFI 14
          char-set-xor*
          char-set:ascii                ;SRFI 14