From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 3 Dec 2019 07:41:42 +0000 (-0800)
Subject: Round out the named char-set abstraction.
X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~16
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ba498552e9622c5cea73e83e5ed6bc87ea320849;p=mit-scheme.git

Round out the named char-set abstraction.
---

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index 9994b77b4..1f4851fa1 100644
--- a/src/runtime/char-set.scm
+++ b/src/runtime/char-set.scm
@@ -413,29 +413,7 @@ USA.
       (char? object)
       (string? object)
       (char-set? object)
-      (name->char-set object)))
-
-(define (name->char-set name)
-  (case name
-    ((alphabetic alpha) char-set:alphabetic)
-    ((alphanumeric alphanum alnum) char-set:alphanumeric)
-    ((ascii) char-set:ascii)
-    ((cased) char-set:cased)
-    ((control cntrl) char-set:control)
-    ((graphic graph) char-set:graphic)
-    ((hex-digit xdigit) char-set:hex-digit)
-    ((lower-case lower) char-set:lower-case)
-    ((newline nl) char-set:newline)
-    ((no-newline nonl) char-set:no-newline)
-    ((numeric num) char-set:numeric)
-    ((printing print) char-set:printing)
-    ((punctuation punct) char-set:punctuation)
-    ((symbol) char-set:symbol)
-    ((title-case title) char-set:title-case)
-    ((unicode any) char-set:unicode)
-    ((upper-case upper) char-set:upper-case)
-    ((whitespace white space) char-set:whitespace)
-    (else #f)))
+      (char-set-name? object)))
 
 (define (cpl->ilist cpl)
   (let loop ((cpl cpl) (ranges '()) (ilist '()))
@@ -462,6 +440,57 @@ USA.
 		 (error:not-a cpl-element? elt))))
 	(ilist-union (ranges->ilist ranges) ilist))))
 
+;;;; Named char sets
+
+(define (char-set-name? object)
+  (and (find-named-char-set object) #t))
+
+(define (char-set-names)
+  (map caar (named-char-sets)))
+
+(define (name->char-set name)
+  (let ((p (find-named-char-set name)))
+    (and p
+	 (cdr p))))
+
+(define (char-set->name char-set)
+  (let ((p
+	 (find (lambda (p)
+		 (char-set= char-set (cdr p)))
+	       (named-char-sets))))
+    (and p
+	 (caar p))))
+
+(define (find-named-char-set name)
+  (find (lambda (p)
+	  (memq name (car p)))
+	(named-char-sets)))
+
+(define (named-char-sets)
+  (force %named-char-sets))
+
+;; DELAY compensates for boot dependencies.
+(define %named-char-sets
+  (delay
+    `(((alphabetic alpha) . ,char-set:alphabetic)
+      ((alphanumeric alphanum alnum) . ,char-set:alphanumeric)
+      ((ascii) . ,char-set:ascii)
+      ((cased) . ,char-set:cased)
+      ((control cntrl) . ,char-set:control)
+      ((graphic graph) . ,char-set:graphic)
+      ((hex-digit xdigit) . ,char-set:hex-digit)
+      ((lower-case lower) . ,char-set:lower-case)
+      ((newline nl) . ,char-set:newline)
+      ((no-newline nonl) . ,char-set:no-newline)
+      ((numeric num) . ,char-set:numeric)
+      ((printing print) . ,char-set:printing)
+      ((punctuation punct) . ,char-set:punctuation)
+      ((symbol) . ,char-set:symbol)
+      ((title-case title) . ,char-set:title-case)
+      ((unicode any) . ,char-set:unicode)
+      ((upper-case upper) . ,char-set:upper-case)
+      ((whitespace white space) . ,char-set:whitespace))))
+
 ;;;; Predicates
 
 (define (char-set= . char-sets)
@@ -634,7 +663,7 @@ USA.
   (char-set-range-fold (range-fold-char-mapper kons) knil char-set))
 
 (define (char-set-fold-right kons knil char-set)
-  (char-set-range-fold (range-fold-right-char-mapper kons) knil char-set))
+  (char-set-range-fold-right (range-fold-right-char-mapper kons) knil char-set))
 
 (define (char-set-unfold f p g seed #!optional base-set)
   (list->char-set
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 540e30945..c08dba7fd 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1642,6 +1642,7 @@ USA.
 	  char-set*
 	  char-set->code-points
 	  char-set->list		;SRFI 14
+	  char-set->name
 	  char-set->string		;SRFI 14
 	  char-set-adjoin		;SRFI 14
 	  char-set-any			;SRFI 14
@@ -1668,6 +1669,8 @@ USA.
 	  char-set-intersection*
 	  char-set-invert
 	  char-set-map			;SRFI 14
+	  char-set-name?
+	  char-set-names
 	  char-set-predicate
 	  char-set-range-fold
 	  char-set-range-fold-right
@@ -1696,6 +1699,7 @@ USA.
 	  compute-char-set
 	  end-of-char-set?		;SRFI 14
 	  list->char-set		;SRFI 14
+	  name->char-set
 	  re-char-pattern->code-points
 	  re-compile-char-set
 	  string->char-set		;SRFI 14