From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 2 Dec 2019 08:59:19 +0000 (-0800)
Subject: Add support for case-folding of character sets.
X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~23
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4e70d47e03c877f0ace24a82e3317af710ad3534;p=mit-scheme.git

Add support for case-folding of character sets.
---

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index dcf606f25..9994b77b4 100644
--- 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)))))
 
 ;;;; 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))
 
 ;;;; Char-Set Compiler
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 773349ac4..331192233 100644
--- 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