Round out the named char-set abstraction.

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index 9994b77b4a9c7357407266cf486caa2913899ef6..1f4851fa1f7a2ca6ba4e6bcf868cc05174d634e1 100644 (file)
--- 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))))
 \f
+;;;; 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))))
+\f
 ;;;; 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 540e3094569a21d43d0b56bd33941b9d43a79a40..c08dba7fdfcfeaacdd582d8e6fb91376f9062b29 100644 (file)
--- 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