Char-set refactor: fill out some missing SRFI 14 procedures.

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index 05efb2edfcf63319425baa3a71a749a9765d5137..d5086458f72413b4dc10a2e47f7334334c85444f 100644 (file)
--- a/src/runtime/char-set.scm
+++ b/src/runtime/char-set.scm
@@ -491,6 +491,9 @@ USA.
 \f
 ;;;; Constructors
 
+(define (char-set-copy char-set)
+  (guarantee char-set? char-set 'char-set-copy))
+
 (define (char-set . cpl)
   (char-set* cpl))
 
@@ -498,8 +501,21 @@ USA.
   (guarantee code-point-list? cpl 'char-set*)
   (ilist->char-set (cpl->ilist cpl)))
 
-(define (string->char-set string)
-  (char-set* (map char->integer (string->list string))))
+(define (->char-set object)
+  (cond ((char? object) (char-set object))
+       ((string? object) (string->char-set object))
+       ((char-set? object) object)
+       (else (error:bad-range-argument object '->char-set))))
+
+(define (list->char-set chars #!optional base-set)
+  (ilist->char-set
+   (let ((ilist (chars->ilist chars)))
+     (if (default-object? base-set)
+        ilist
+        (ilist-union ilist (char-set->ilist base-set))))))
+
+(define (string->char-set string #!optional base-set)
+  (list->char-set (string->list string) base-set))
 
 (define (compute-char-set procedure)
 
@@ -519,6 +535,20 @@ USA.
 
   (ilist->char-set
    (reverse! (find-start #xE000 #x110000 (find-start 0 #xD800 '())))))
+
+(define (ucs-range->char-set lower upper #!optional error? base-set)
+  (declare (ignore error?))
+  (guarantee index-fixnum? lower 'ucs-range->char-set)
+  (guarantee index-fixnum? upper 'ucs-range->char-set)
+  (if (not (fix:<= lower upper))
+      (error:bad-range-argument lower 'ucs-range->char-set))
+  (if (not (fix:<= upper #x110000))
+      (error:bad-range-argument upper 'ucs-range->char-set))
+  (ilist->char-set
+   (if (default-object? base-set)
+       (list lower upper)
+       (ilist-union (list lower upper)
+                   (char-set->ilist base-set)))))
 \f
 ;;;; Queries
 
@@ -631,9 +661,26 @@ USA.
 \f
 ;;;; Algebra
 
+(define (char-set-adjoin char-set . chars)
+  (if (pair? chars)
+      (ilist->char-set
+       (ilist-union (char-set->ilist char-set)
+                   (chars->ilist chars)))
+      char-set))
+
+(define (char-set-delete char-set . chars)
+  (if (pair? chars)
+      (ilist->char-set
+       (ilist-difference (char-set->ilist char-set)
+                        (chars->ilist chars)))
+      char-set))
+
 (define (char-set-invert char-set)
   (ilist->char-set (ilist-invert (char-set->ilist char-set))))
 
+(define (char-set-complement char-set)
+  (char-set-difference char-set:full char-set))
+
 (define (char-set-union . char-sets)
   (char-set-union* char-sets))
 
@@ -665,11 +712,34 @@ USA.
 (define (char-set-difference char-set . char-sets)
   (if (pair? char-sets)
       (ilist->char-set
-       (fold (lambda (cs1 cs2)
-              (ilist-difference cs2 cs1))
-            (char-set->ilist char-set)
-            (map char-set->ilist char-sets)))
+       (ilist-difference* (char-set->ilist char-set)
+                         (map char-set->ilist char-sets)))
       char-set))
+
+(define (ilist-difference* ilist ilists)
+  (fold (lambda (ilist1 ilist2)
+         (ilist-difference ilist2 ilist1))
+       ilist
+       ilists))
+\f
+(define (char-set-xor . char-sets)
+  (char-set-xor* char-sets))
+
+(define (char-set-xor* char-sets)
+  (guarantee list? char-sets 'char-set-xor*)
+  (if (pair? char-sets)
+      (ilist->char-set
+       (fold ilist-xor
+            (char-set->ilist (car char-sets))
+            (map char-set->ilist (cdr char-sets))))))
+
+(define (char-set-diff+intersection char-set . char-sets)
+  (if (pair? char-sets)
+      (let ((ilist (char-set->ilist char-set))
+           (ilists (map char-set->ilist char-sets)))
+       (values (ilist->char-set (ilist-difference* ilist ilists))
+               (ilist->char-set (fold ilist-intersection ilist ilists))))
+      (values char-set char-set)))
 \f
 ;;;; Char-Set Compiler
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 3e894097d509e6236b7020e50368c23288693b30..fcf1b78a3292a519fc6e384ab1f564c6c297eb73 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1611,23 +1611,39 @@ USA.
   (files "char-set")
   (parent (runtime))
   (export deprecated ()
+         (ascii-range->char-set ucs-range->char-set)
          (char-set->scalar-values char-set->code-points)
+         (char-set-member? char-set-contains?)
          (chars->char-set char-set*)
          (scalar-values->char-set char-set*)
          (well-formed-scalar-value-list? code-point-list?)
-         (char-set-member? char-set-contains?)
          char-set-members)
   (export ()
-         (char-set-complement char-set-invert)
+         (char-set-adjoin! char-set-adjoin)
+         (char-set-complement! char-set-complement)
+         (char-set-delete! char-set-delete)
+         (char-set-diff+intersection! char-set-diff+intersection)
+         (char-set-difference! char-set-difference)
+         (char-set-intersection! char-set-intersection)
+         (char-set-union! char-set-union)
+         (char-set-xor! char-set-xor)
          (char-set=? char-set=)
+          (list->char-set! list->char-set)
+          (string->char-set! string->char-set)
+          (ucs-range->char-set! ucs-range->char-set)
+         ->char-set                    ;SRFI 14
          8-bit-char-set?
-         ascii-range->char-set
          char-ctl?
          char-in-set?
-         char-set                      ;SRFI 14
+         char-set                      ;SRFI 14 (extended)
          char-set*
          char-set->code-points
+         char-set-adjoin               ;SRFI 14
+         char-set-complement           ;SRFI 14
          char-set-contains?            ;SRFI 14
+         char-set-copy                 ;SRFI 14
+         char-set-delete               ;SRFI 14
+         char-set-diff+intersection    ;SRFI 14
          char-set-difference           ;SRFI 14
          char-set-empty?
          char-set-hash                 ;SRFI 14
@@ -1638,6 +1654,8 @@ USA.
          char-set-size                 ;SRFI 14
          char-set-union                ;SRFI 14
          char-set-union*
+         char-set-xor                  ;SRFI 14
+         char-set-xor*
          char-set:ascii                ;SRFI 14
          char-set:blank                ;SRFI 14
          char-set:ctls
@@ -1652,9 +1670,11 @@ USA.
          code-point-list?
          code-point-in-char-set?
          compute-char-set
+         list->char-set                ;SRFI 14
          re-char-pattern->code-points
          re-compile-char-set
          string->char-set              ;SRFI 14
+         ucs-range->char-set           ;SRFI 14
          )
   (export (runtime regexp regsexp)
          cpl-element?