Refactor the character set abstraction:

* Clarify the use of "code point" versus "scalar value".

* Rename well-formed-scalar-value-list? to code-point-list? and broaden its
  scope to allow characters, strings, and character sets.

* Rename scalar-values->char-set to char-set* and broaden its domain to include
  any code-point-list?.

* Rename char-set->scalar-values to char-set->code-points.

* Implement char-in-set? which is char-member? with the args reversed.  This
  makes it consistent with scalar-value-in-char-set?.  Deprecate char-member?.

* Implement char-set-union* and char-set-intersection*.

* Eliminate all of the "alphabet" names which are obsolete.

* Eliminate guarantee-char-set and error:not-char-set.

diff --git a/src/runtime/chrset.scm b/src/runtime/chrset.scm
index 945c920d2cc73931f22b7f6958449b6558a335f4..22053ee4c73dcf7bf3fcffea1e44eb70f66a3a79 100644 (file)
--- a/src/runtime/chrset.scm
+++ b/src/runtime/chrset.scm
@@ -29,35 +29,26 @@ USA.
 
 (declare (usual-integrations))
 \f
-;;; The character set is stored in two parts.  The LOW part is a
-;;; bit-vector encoding of the scalar values below %LOW-LIMIT.  The
-;;; HIGH part is a sequence of scalar-value ranges, each of which has
-;;; an inclusive START and an exclusive END.  The ranges in the
-;;; sequence are all disjoint from one another, and no two ranges are
-;;; adjacent.  These ranges are sorted so that their STARTs are in
-;;; order.
+;;; The character set is stored in two parts.  The LOW part is a bit-vector
+;;; encoding of the code points below %LOW-LIMIT.  The HIGH part is a sequence
+;;; of code-point ranges, each of which has an inclusive START and an
+;;; exclusive END.  The ranges in the sequence are all disjoint from one
+;;; another, and no two ranges are adjacent.  These ranges are sorted so that
+;;; their STARTs are in order.
 ;;;
-;;; The HIGH range sequence is implemented as a vector of alternating
-;;; START and END points.  The vector always has an even number of
-;;; points.
+;;; The HIGH range sequence is implemented as a vector of alternating START and
+;;; END points.  The vector always has an even number of points.
 ;;;
-;;; For simplicity, character sets are allowed to contain ranges that
-;;; contain illegal scalar values.  However, CHAR-SET-MEMBER? doesn't
-;;; accept illegal characters.
-
-(define-structure (char-set (type-descriptor <char-set>)
-                           (constructor %%make-char-set)
-                           (conc-name %char-set-))
-  (low #f read-only #t)
-  (high #f read-only #t)
+;;; For simplicity, character sets are allowed to contain any code point.
+;;; However, CHAR-SET-MEMBER? only accepts scalar values.
+
+(define-record-type <char-set>
+    (%%make-char-set low high table)
+    char-set?
+  (low %char-set-low)
+  (high %char-set-high)
   ;; Backwards compatibility:
-  (table #f read-only #t))
-
-(define-guarantee char-set "character set")
-
-(define (guarantee-char-sets char-sets #!optional caller)
-  (for-each (lambda (char-set) (guarantee-char-set char-set caller))
-           char-sets))
+  (table %char-set-table))
 
 (define (%make-char-set low high)
   (%%make-char-set low high
@@ -98,22 +89,23 @@ USA.
 
 (define-guarantee 8-bit-char-set "an 8-bit char-set")
 \f
-;;;; Conversion to and from scalar-values list
+;;;; Code-point lists
 
-(define (well-formed-scalar-value-list? ranges)
-  (list-of-type? ranges well-formed-scalar-value-range?))
+(define (code-point-list? object)
+  (list-of-type? object cpl-element?))
 
-(define (well-formed-scalar-value-range? range)
-  (if (pair? range)
-      (and (index-fixnum? (car range))
-          (index-fixnum? (cdr range))
-          (fix:<= (car range) (cdr range))
-          (fix:<= (cdr range) char-code-limit))
-      (and (index-fixnum? range)
-          (fix:< range char-code-limit))))
+(define (cpl-element? object)
+  (or (%range? object)
+      (unicode-char? object)
+      (ustring? object)
+      (char-set? object)))
 
-(define-guarantee well-formed-scalar-value-list "a Unicode scalar-value list")
-(define-guarantee well-formed-scalar-value-range "a Unicode scalar-value range")
+(define (%range? object)
+  (or (and (pair? object)
+          (unicode-code-point? (car object))
+          (unicode-code-point? (cdr object))
+          (fix:<= (car object) (cdr object)))
+      (unicode-code-point? object)))
 
 (define (%make-range start end)
   (if (fix:= (fix:- end start) 1)
@@ -130,13 +122,15 @@ USA.
       (cdr range)
       (fix:+ range 1)))
 \f
-(define (char-set->scalar-values char-set)
-  (guarantee-char-set char-set 'CHAR-SET->SCALAR-VALUES)
+;;;; Convert char-set to code-point list
+
+(define (char-set->code-points char-set)
+  (guarantee char-set? char-set 'char-set->code-points)
   (reverse!
-   (%high->scalar-values (%char-set-high char-set)
-                        (%low->scalar-values (%char-set-low char-set)))))
+   (%high->code-points (%char-set-high char-set)
+                      (%low->code-points (%char-set-low char-set)))))
 
-(define (%low->scalar-values low)
+(define (%low->code-points low)
 
   (define (find-start i result)
     (if (fix:< i %low-limit)
@@ -155,7 +149,7 @@ USA.
 
   (find-start 0 '()))
 
-(define (%high->scalar-values high result)
+(define (%high->code-points high result)
   (let ((n (vector-length high)))
     (define (loop i result)
       (if (fix:< i n)
@@ -174,18 +168,45 @@ USA.
                                 (vector-ref high 1))
                    (cdr result)))
        (loop 0 result))))
+\f
+;;;; General char-set constructor
 
-(define (scalar-values->char-set ranges)
-  (guarantee-well-formed-scalar-value-list ranges 'SCALAR-VALUES->CHAR-SET)
-  (%scalar-values->char-set ranges))
-
-(define (%scalar-values->char-set ranges)
+(define (char-set . chars)
+  (char-set* chars))
+
+(define (char-set* cpl)
+  (guarantee-list-of cpl-element? cpl 'char-set*)
+  (char-set-union* (%cpl->char-sets cpl)))
+
+(define (%cpl->char-sets cpl)
+  (let loop ((cpl cpl) (ranges '()) (char-sets '()))
+    (cond ((not (pair? cpl))
+          (cons (%ranges->char-set ranges) char-sets))
+         ((%cpl-element->ranges (car cpl))
+          => (lambda (ranges*)
+               (loop (cdr cpl)
+                     (append ranges* ranges)
+                     char-sets)))
+         ((char-set? (car cpl))
+          (loop (cdr cpl)
+                ranges
+                (cons (car cpl) char-sets)))
+         (else
+          (error:not-a cpl-element? (car cpl))))))
+
+(define (%cpl-element->ranges elt)
+  (cond ((%range? elt) (list elt))
+       ((unicode-char? elt) (list (char->integer elt)))
+       ((ustring? elt) (map char->integer (ustring->list elt)))
+       (else #f)))
+
+(define (%ranges->char-set ranges)
   (receive (low-ranges high-ranges)
-      (%split-ranges (%canonicalize-scalar-value-list ranges))
-    (%make-char-set (%scalar-values->low low-ranges)
-                   (%scalar-values->high high-ranges))))
+      (%split-ranges (%canonicalize-ranges ranges))
+    (%make-char-set (%code-points->low low-ranges)
+                   (%code-points->high high-ranges))))
 
-(define (%scalar-values->low ranges)
+(define (%code-points->low ranges)
   (let ((low (%make-low 0)))
     (for-each (lambda (range)
                (let ((end (%range-end range)))
@@ -195,7 +216,7 @@ USA.
              ranges)
     low))
 
-(define (%scalar-values->high ranges)
+(define (%code-points->high ranges)
   (let ((high (make-vector (fix:* 2 (length ranges)))))
     (do ((ranges ranges (cdr ranges))
         (i 0 (fix:+ i 2)))
@@ -204,9 +225,8 @@ USA.
       (vector-set! high (fix:+ i 1) (%range-end (car ranges))))
     high))
 \f
-(define (%canonicalize-scalar-value-list ranges)
-  ;; Sort ranges in order, delete empty ranges, then merge adjacent
-  ;; ranges.
+(define (%canonicalize-ranges ranges)
+  ;; Sorts ranges in order, deletes empty ranges, then merges adjacent ranges.
   (let ((ranges
         (filter! (lambda (range)
                    (fix:< (%range-start range)
@@ -264,38 +284,38 @@ USA.
 \f
 ;;;; Predicates
 
-(define (char-set-member? char-set char)
-  (guarantee-char-set char-set 'CHAR-SET-MEMBER?)
-  (guarantee-char char 'CHAR-SET-MEMBER?)
-  (%scalar-value-in-char-set? (char-code char) char-set))
-
-(define (scalar-value-in-char-set? scalar-value char-set)
-  (guarantee-unicode-scalar-value scalar-value 'SCALAR-VALUE-IN-CHAR-SET?)
-  (guarantee-char-set char-set 'SCALAR-VALUE-IN-CHAR-SET?)
-  (%scalar-value-in-char-set? scalar-value char-set))
-
-(define (%scalar-value-in-char-set? value char-set)
-  (if (fix:< value %low-limit)
-      (%low-ref (%char-set-low char-set) value)
+(define (char-in-set? char char-set)
+  (guarantee unicode-char? char 'char-in-set?)
+  (guarantee char-set? char-set 'char-in-set?)
+  (%scalar-value-in-char-set? (char->integer char) char-set))
+
+(define (scalar-value-in-char-set? sv char-set)
+  (guarantee unicode-scalar-value? sv 'scalar-value-in-char-set?)
+  (guarantee char-set? char-set 'scalar-value-in-char-set?)
+  (%scalar-value-in-char-set? sv char-set))
+
+(define (%scalar-value-in-char-set? sv char-set)
+  (if (fix:< sv %low-limit)
+      (%low-ref (%char-set-low char-set) sv)
       (let ((high (%char-set-high char-set)))
        (let loop ((lower 0) (upper (vector-length high)))
          (if (fix:< lower upper)
              (let ((i (fix:* 2 (fix:quotient (fix:+ lower upper) 4))))
-               (cond ((fix:< value (vector-ref high i))
+               (cond ((fix:< sv (vector-ref high i))
                       (loop lower i))
-                     ((fix:>= value (vector-ref high (fix:+ i 1)))
+                     ((fix:>= sv (vector-ref high (fix:+ i 1)))
                       (loop (fix:+ i 2) upper))
                      (else #t)))
              #f)))))
 
 (define (char-set-predicate char-set)
-  (guarantee-char-set char-set 'CHAR-SET-PREDICATE)
+  (guarantee char-set? char-set 'CHAR-SET-PREDICATE)
   (lambda (char)
     (char-set-member? char-set char)))
 
 (define (char-set=? char-set . char-sets)
-  (guarantee-char-set char-set 'CHAR-SET=?)
-  (guarantee-char-sets char-sets 'CHAR-SET=?)
+  (guarantee char-set? char-set 'CHAR-SET=?)
+  (guarantee-list-of char-set? char-sets 'CHAR-SET=?)
   (every (lambda (char-set*)
           (%=? char-set* char-set))
         char-sets))
@@ -323,7 +343,7 @@ USA.
 ;;;; Mapping operations
 
 (define (char-set-invert char-set)
-  (guarantee-char-set char-set 'CHAR-SET-INVERT)
+  (guarantee char-set? char-set 'CHAR-SET-INVERT)
   (%invert char-set))
 
 (define (%invert cs1)
@@ -365,7 +385,10 @@ USA.
        (vector %low-limit char-code-limit))))
 \f
 (define (char-set-union . char-sets)
-  (guarantee-char-sets char-sets 'CHAR-SET-UNION)
+  (char-set-union* char-sets))
+
+(define (char-set-union* char-sets)
+  (guarantee-list-of char-set? char-sets 'char-set-union*)
   (reduce %union %null-char-set char-sets))
 
 (define (%union cs1 cs2)
@@ -375,7 +398,10 @@ USA.
           cs2))
 
 (define (char-set-intersection . char-sets)
-  (guarantee-char-sets char-sets 'CHAR-SET-INTERSECTION)
+  (char-set-intersection* char-sets))
+
+(define (char-set-intersection* char-sets)
+  (guarantee-list-of char-set? char-sets 'char-set-intersection*)
   (reduce %intersection %null-char-set char-sets))
 
 (define (%intersection cs1 cs2)
@@ -385,8 +411,8 @@ USA.
           cs2))
 
 (define (char-set-difference char-set . char-sets)
-  (guarantee-char-set char-set 'CHAR-SET-DIFFERENCE)
-  (guarantee-char-sets char-sets 'CHAR-SET-DIFFERENCE)
+  (guarantee char-set? char-set 'char-set-difference)
+  (guarantee-list-of char-set? char-sets 'char-set-difference)
   (fold-left %difference char-set char-sets))
 
 (define (%difference cs1 cs2)
@@ -489,21 +515,21 @@ USA.
 ;;;; Standard character sets
 
 (define-deferred char-set:upper-case
-  (scalar-values->char-set '((#x41 . #x5B) (#xC0 . #xD7) (#xD8 . #xDE))))
+  (char-set* '((#x41 . #x5B) (#xC0 . #xD7) (#xD8 . #xDE))))
 (define-deferred char-set:not-upper-case (char-set-invert char-set:upper-case))
 (define-deferred char-upper-case? (char-set-predicate char-set:upper-case))
 
 (define-deferred char-set:lower-case
-  (scalar-values->char-set '((#x61 . #x7B) (#xE0 . #xF7) (#xF8 . #xFF))))
+  (char-set* '((#x61 . #x7B) (#xE0 . #xF7) (#xF8 . #xFF))))
 (define-deferred char-set:not-lower-case (char-set-invert char-set:lower-case))
 (define-deferred char-lower-case? (char-set-predicate char-set:lower-case))
 
-(define-deferred char-set:numeric (scalar-values->char-set '((#x30 . #x3A))))
+(define-deferred char-set:numeric (char-set* '((#x30 . #x3A))))
 (define-deferred char-set:not-numeric (char-set-invert char-set:numeric))
 (define-deferred char-numeric? (char-set-predicate char-set:numeric))
 
 (define-deferred char-set:graphic
-  (scalar-values->char-set '((#x20 . #x7F) (#xA0 . #x100))))
+  (char-set* '((#x20 . #x7F) (#xA0 . #x100))))
 (define-deferred char-set:not-graphic (char-set-invert char-set:graphic))
 (define-deferred char-graphic? (char-set-predicate char-set:graphic))
 
@@ -534,11 +560,9 @@ USA.
 
 ;;; Used in RFCs:
 
-(define-deferred char-set:ascii
-  (scalar-values->char-set '((#x00 . #x80))))
+(define-deferred char-set:ascii (char-set* '((#x00 . #x80))))
 
-(define-deferred char-set:ctls
-  (scalar-values->char-set '((#x00 . #x20) #x7F)))
+(define-deferred char-set:ctls (char-set* '((#x00 . #x20) #x7F)))
 (define-deferred char-ctl? (char-set-predicate char-set:ctls))
 
 (define-deferred char-set:wsp (char-set #\space #\tab))
@@ -546,8 +570,11 @@ USA.
 \f
 ;;;; Backwards compatibility
 
+(define (char-set-member? char-set char)
+  (char-in-set? char char-set))
+
 (define (string->char-set string)
-  (scalar-values->char-set (map char->integer (string->list string))))
+  (char-set* (map char->integer (string->list string))))
 
 ;; Returns ASCII string:
 (define (char-set->string char-set)
@@ -555,7 +582,7 @@ USA.
 
 ;; Returns only ASCII members:
 (define (char-set-members char-set)
-  (guarantee-char-set char-set 'CHAR-SET-MEMBERS)
+  (guarantee char-set? char-set 'CHAR-SET-MEMBERS)
   (let ((low (%char-set-low char-set)))
     (let loop ((code 0))
       (if (fix:< code #x80)
@@ -565,16 +592,6 @@ USA.
              (loop (fix:+ code 1)))
          '()))))
 
-(define (char-set . chars)
-  (for-each (lambda (char)
-             (guarantee-char char 'CHAR-SET))
-           chars)
-  (%scalar-values->char-set (map char->integer chars)))
-
-(define (chars->char-set chars)
-  (guarantee-list-of-type chars char? "character" 'CHARS->CHAR-SET)
-  (%scalar-values->char-set (map char->integer chars)))
-
 (define (ascii-range->char-set start end)
   (if (not (index-fixnum? start))
       (error:wrong-type-argument start "index fixnum" 'ASCII-RANGE->CHAR-SET))
@@ -584,34 +601,4 @@ USA.
       (error:bad-range-argument start 'ASCII-RANGE->CHAR-SET))
   (if (not (fix:<= end #x100))
       (error:bad-range-argument end 'ASCII-RANGE->CHAR-SET))
-  (%scalar-values->char-set (list (cons start end))))
-
-(define (alphabet->char-set char-set)
-  char-set)
-
-(define (char-set->alphabet char-set)
-  char-set)
-
-(define (char-in-alphabet? char char-set)
-  (char-set-member? char-set char))
-
-(define (alphabet->scalar-values char-set)
-  (map (lambda (range)
-        (if (pair? range)
-            (cons (car range)
-                  (fix:- (cdr range) 1))
-            range))
-       (char-set->scalar-values char-set)))
-
-(define (scalar-values->alphabet ranges)
-  (guarantee-well-formed-scalar-value-list ranges 'SCALAR-VALUES->ALPHABET)
-  (%scalar-values->char-set
-   (map (lambda (range)
-         (if (pair? range)
-             (cons (car range)
-                   (if (fix:< (cdr range) char-code-limit)
-                       (fix:+ (cdr range) 1)
-                       (error:bad-range-argument (cdr range)
-                                                 'SCALAR-VALUES->ALPHABET)))
-             range))
-       ranges)))
\ No newline at end of file
+  (char-set (cons start end)))
\ No newline at end of file

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 16078c50521c86bc3c73e4669dc21306a8fe3570..3618cde8988d0dc82001a4807349491296cfbfdc 100644 (file)
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -306,7 +306,7 @@ USA.
   value)
 
 (define (char-set-converter value)
-  (guarantee-char-set value)
+  (guarantee char-set? value)
   value)
 
 (define (keyword-style-converter value)
@@ -967,8 +967,8 @@ USA.
                environment)))
         (atom-delimiters (get-param:parser-atom-delimiters environment))
         (constituents (get-param:parser-constituents environment)))
-    (guarantee-char-set atom-delimiters #f)
-    (guarantee-char-set constituents #f)
+    (guarantee char-set? atom-delimiters #f)
+    (guarantee char-set? constituents #f)
     (make-db (get-param:parser-associate-positions? environment)
             atom-delimiters
             (overridable-value

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index bed365b92296009a5f97db8c8ab20ef73335db8e..eb2b8dd95b1f0672a13c2da57c97d51fa147c20c 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -290,6 +290,7 @@ USA.
    (register-predicate! ascii-char? 'ascii-char '<= 8-bit-char?)
    (register-predicate! bit-string? 'bit-string)
    (register-predicate! cell? 'cell)
+   (register-predicate! code-point-list? 'code-point-list '<= list?)
    (register-predicate! compiled-code-address? 'compiled-code-address)
    (register-predicate! compiled-code-block? 'compiled-code-block)
    (register-predicate! compiled-expression? 'compiled-expression)
@@ -310,8 +311,10 @@ USA.
    (register-predicate! thread-mutex? 'thread-mutex)
    (register-predicate! undefined-value? 'undefined-value)
    (register-predicate! unicode-char? 'unicode-char '<= char?)
-   (register-predicate! unicode-scalar-value? 'unicode-scalar-value
+   (register-predicate! unicode-code-point? 'unicode-code-point
                        '<= index-fixnum?)
+   (register-predicate! unicode-scalar-value? 'unicode-scalar-value
+                       '<= unicode-code-point?)
    (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?)
    (register-predicate! weak-list? 'weak-list)
    (register-predicate! weak-pair? 'weak-pair)

diff --git a/src/runtime/regsexp.scm b/src/runtime/regsexp.scm
index 60c12594c445d557356f10a22abfcefe3b5c1bc3..4187524b254a2b0dfa3ee64660ab2978022a6013 100644 (file)
--- a/src/runtime/regsexp.scm
+++ b/src/runtime/regsexp.scm
@@ -77,21 +77,6 @@ USA.
        (else
         (error "Ill-formed regular s-expression:" regsexp))))
 
-(define (%compile-char-set items)
-  (scalar-values->char-set
-   (append-map (lambda (item)
-                (cond ((well-formed-scalar-value-range? item)
-                       (list item))
-                      ((unicode-char? item)
-                       (list (char->integer item)))
-                      ((char-set? item)
-                       (char-set->scalar-values item))
-                      ((string? item)
-                       (map char->integer (string->list item)))
-                      (else
-                       (error "Ill-formed char-set item:" item))))
-              items)))
-
 (define (%compile-group-key key)
   (if (not (or (fix:fixnum? key)
               (unicode-char? key)
@@ -151,11 +136,11 @@ USA.
 
 (define-rule '(CHAR-SET * DATUM)
   (lambda items
-    (insn:char-set (%compile-char-set items))))
+    (insn:char-set (char-set* items))))
 
 (define-rule '(INVERSE-CHAR-SET * DATUM)
   (lambda items
-    (insn:inverse-char-set (%compile-char-set items))))
+    (insn:inverse-char-set (char-set* items))))
 
 (define-rule '(LINE-START) (lambda () (insn:line-start)))
 (define-rule '(LINE-END) (lambda () (insn:line-end)))

diff --git a/src/runtime/rgxcmp.scm b/src/runtime/rgxcmp.scm
index 4c0667a0361de380b00f5e22d76ff688505ada3b..30c69a05ebe26e45266bbd5d690cf345bcc198f1 100644 (file)
--- a/src/runtime/rgxcmp.scm
+++ b/src/runtime/rgxcmp.scm
@@ -265,7 +265,7 @@ USA.
 (define (re-compile-char-set pattern negate?)
   (receive (scalar-values negate?*)
       (re-char-pattern->scalar-values pattern)
-    (let ((char-set (scalar-values->char-set scalar-values)))
+    (let ((char-set (char-set* scalar-values)))
       (if (if negate? (not negate?*) negate?*)
          (char-set-invert char-set)
          char-set))))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 9a2e6567bae254175faed17c582c7a57aae18138..40ba8e67a84ab56f997bf46bff57361d7a552220 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1401,31 +1401,13 @@ USA.
   (parent (runtime))
   (export ()
          ;; BEGIN deprecated bindings
-         (8-bit-alphabet? 8-bit-char-set?)
-         (alphabet char-set)
-         (alphabet+ char-set-union)
-         (alphabet- char-set-difference)
-         (alphabet->string char-set->string)
-         (alphabet-predicate char-set-predicate)
-         (alphabet? char-set?)
-         (error:not-8-bit-alphabet error:not-8-bit-char-set)
-         (error:not-alphabet error:not-char-set)
-         (guarantee-8-bit-alphabet guarantee-8-bit-char-set)
-         (guarantee-alphabet guarantee-char-set)
-         (string->alphabet string->char-set)
-         alphabet->char-set
-         alphabet->scalar-values
-         char-in-alphabet?
-         char-set->alphabet
+         (char-set->scalar-values char-set->code-points)
+         (chars->char-set char-set*)
+         (scalar-values->char-set char-set*)
+         (well-formed-scalar-value-list? code-point-list?)
+         char-set-member?
          error:not-8-bit-char-set
-         error:not-char-set
-         error:not-well-formed-scalar-value-list
-         error:not-well-formed-scalar-value-range
          guarantee-8-bit-char-set
-         guarantee-char-set
-         guarantee-well-formed-scalar-value-list
-         guarantee-well-formed-scalar-value-range
-         scalar-values->alphabet
          ;; END deprecated bindings
          8-bit-char-set?
          ascii-range->char-set
@@ -1433,17 +1415,20 @@ USA.
          char-alphanumeric?
          char-ctl?
          char-graphic?
+         char-in-set?
          char-lower-case?
          char-numeric?
          char-set
-         char-set->scalar-values
+         char-set*
+         char-set->code-points
          char-set-difference
          char-set-intersection
+         char-set-intersection*
          char-set-invert
-         char-set-member?
          char-set-members
          char-set-predicate
          char-set-union
+         char-set-union*
          char-set:alphabetic
          char-set:alphanumeric
          char-set:ascii
@@ -1470,12 +1455,10 @@ USA.
          char-upper-case?
          char-whitespace?
          char-wsp?
-         chars->char-set
+         code-point-list?
+         char-set*
          scalar-value-in-char-set?
-         scalar-values->char-set
-         string->char-set
-         well-formed-scalar-value-list?
-         well-formed-scalar-value-range?)
+         string->char-set)
   (export (runtime string)
          (char-set-table %char-set-table)))
 
@@ -5651,14 +5634,6 @@ USA.
   (export ()
          ;; BEGIN deprecated bindings
          (input-port->parser-buffer textual-input-port->parser-buffer)
-         (match-parser-buffer-char-in-alphabet match-parser-buffer-char-in-set)
-         (match-parser-buffer-char-in-alphabet-no-advance
-          match-parser-buffer-char-in-set-no-advance)
-         (match-parser-buffer-char-not-in-alphabet
-          match-parser-buffer-char-not-in-set)
-         (match-parser-buffer-char-not-in-alphabet-no-advance
-          match-parser-buffer-char-not-in-set-no-advance)
-         (match-utf8-char-in-alphabet match-parser-buffer-char-in-set)
          ;; END deprecated bindings
          *match-string
          *match-symbol

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 7766f5a2b06f18d0623dcf9eda81891fbe03cd16..83275c6d4e4d4e691a5293cd5c6a9acd5402f8f6 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -1359,12 +1359,12 @@ USA.
 \f
 (define (string-find-next-char-in-set string char-set)
   (guarantee-string string 'STRING-FIND-NEXT-CHAR-IN-SET)
-  (guarantee-char-set char-set 'STRING-FIND-NEXT-CHAR-IN-SET)
+  (guarantee char-set? char-set 'STRING-FIND-NEXT-CHAR-IN-SET)
   (%substring-find-next-char-in-set string 0 (string-length string) char-set))
 
 (define (substring-find-next-char-in-set string start end char-set)
   (guarantee-substring string start end 'SUBSTRING-FIND-NEXT-CHAR-IN-SET)
-  (guarantee-char-set char-set 'SUBSTRING-FIND-NEXT-CHAR-IN-SET)
+  (guarantee char-set? char-set 'SUBSTRING-FIND-NEXT-CHAR-IN-SET)
   (%substring-find-next-char-in-set string start end char-set))
 
 (define-integrable (%substring-find-next-char-in-set string start end char-set)
@@ -1373,13 +1373,13 @@ USA.
 
 (define (string-find-previous-char-in-set string char-set)
   (guarantee-string string 'STRING-FIND-PREVIOUS-CHAR-IN-SET)
-  (guarantee-char-set char-set 'STRING-FIND-PREVIOUS-CHAR-IN-SET)
+  (guarantee char-set? char-set 'STRING-FIND-PREVIOUS-CHAR-IN-SET)
   (%substring-find-previous-char-in-set string 0 (string-length string)
                                        char-set))
 
 (define (substring-find-previous-char-in-set string start end char-set)
   (guarantee-substring string start end 'SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET)
-  (guarantee-char-set char-set 'SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET)
+  (guarantee char-set? char-set 'SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET)
   (%substring-find-previous-char-in-set string start end char-set))
 
 (define (%substring-find-previous-char-in-set string start end char-set)
@@ -1678,8 +1678,4 @@ USA.
                                           string2 start2 end2
                                           procedure)
   (guarantee-substring string1 start1 end1 procedure)
-  (guarantee-substring string2 start2 end2 procedure))
-
-(define-integrable (guarantee-char-set object procedure)
-  (if (not (char-set? object))
-      (error:wrong-type-argument object "character set" procedure)))
\ No newline at end of file
+  (guarantee-substring string2 start2 end2 procedure))
\ No newline at end of file

diff --git a/src/xml/turtle.scm b/src/xml/turtle.scm
index 7f7469fae0d889f6be2b9c87ece25e40318fe2e0..8f36c7b91f6563c31f7419e5630a08de19c1d7cb 100644 (file)
--- a/src/xml/turtle.scm
+++ b/src/xml/turtle.scm
@@ -279,7 +279,7 @@ USA.
                  char-set:turtle-digit))
 
 (define char-set:name-start-char
-  (scalar-values->char-set
+  (char-set*
    '((#x0041 . #x005B)
      #x005F
      (#x0061 . #x007B)
@@ -298,7 +298,7 @@ USA.
 
 (define char-set:name-char
   (char-set-union char-set:name-start-char
-                 (scalar-values->char-set
+                 (char-set*
                   '(#x002D
                     (#x0030 . #x003A)
                     #x00B7
@@ -309,7 +309,7 @@ USA.
   (char-set-difference char-set:name-start-char (char-set #\_)))
 
 (define char-set:character
-  (scalar-values->char-set '((#x20 . #x5C) (#x5D . #x110000))))
+  (char-set* '((#x20 . #x5C) (#x5D . #x110000))))
 
 (define char-set:ucharacter
   (char-set-difference char-set:character (char-set #\>)))

diff --git a/src/xml/xml-chars.scm b/src/xml/xml-chars.scm
index e82ac03ca20e41a1091fadaebbe426b700254639..692698e3ce3e337102a72c144c9f137da1d16549 100644 (file)
--- a/src/xml/xml-chars.scm
+++ b/src/xml/xml-chars.scm
@@ -29,7 +29,7 @@ USA.
 (declare (usual-integrations))
 
 (define char-set:xml-base-char
-  (scalar-values->char-set
+  (char-set*
    '((#x0041 . #x005B)
      (#x0061 . #x007B)
      (#x00C0 . #x00D7)
@@ -234,13 +234,13 @@ USA.
      (#xAC00 . #xD7A4))))
 
 (define char-set:xml-ideographic
-  (scalar-values->char-set
+  (char-set*
    '(#x3007
      (#x3021 . #x302A)
      (#x4E00 . #x9FA6))))
 
 (define char-set:xml-combining-char
-  (scalar-values->char-set
+  (char-set*
    '((#x0300 . #x0346)
      (#x0360 . #x0362)
      (#x0483 . #x0487)
@@ -338,7 +338,7 @@ USA.
      #x309A)))
 
 (define char-set:xml-digit
-  (scalar-values->char-set
+  (char-set*
    '((#x0030 . #x003A)
      (#x0660 . #x066A)
      (#x06F0 . #x06FA)
@@ -356,7 +356,7 @@ USA.
      (#x0F20 . #x0F2A))))
 
 (define char-set:xml-extender
-  (scalar-values->char-set
+  (char-set*
    '(#x00B7
      #x02D0
      #x02D1
@@ -370,7 +370,7 @@ USA.
      (#x30FC . #x30FF))))
 
 (define char-set:xml-char
-  (scalar-values->char-set
+  (char-set*
    '(#x0009
      #x000A
      #x000D

diff --git a/tests/runtime/test-char-set.scm b/tests/runtime/test-char-set.scm
index 82543f4ac9c0cd670d37dbb0f42bfb0dc1e4255a..ca6352dcd9890582cfe84e794c5f76deb4f2f6eb 100644 (file)
--- a/tests/runtime/test-char-set.scm
+++ b/tests/runtime/test-char-set.scm
@@ -39,14 +39,14 @@ USA.
         interesting-svls)))
 
 (define (svl-round-trip svl)
-  (char-set->scalar-values (scalar-values->char-set svl)))
+  (char-set->code-points (char-set* svl)))
 
 (define-test 'random-svl-round-trip
   (lambda ()
     (map (lambda (svl)
           (run-sub-test
            (lambda ()
-             (guarantee-well-formed-scalar-value-list svl)
+             (guarantee code-point-list? svl)
              (assert-equal-canonical-svls (canonicalize-svl svl)
                                           (svl-round-trip svl)))))
         (append! (append-map! (lambda (i)
@@ -84,7 +84,7 @@ USA.
                  (run-sub-test
                   (lambda ()
                     (assert-boolean=
-                     (char-set-member? (scalar-values->char-set svl)
+                     (char-set-member? (char-set* svl)
                                        (integer->char value))
                      (named-call 'SVL-MEMBER? svl-member? svl value)))
                   'EXPRESSION `(CHAR-SET-MEMBER? ,svl ,value)))
@@ -117,7 +117,7 @@ USA.
         interesting-svls)))
 
 (define (svl-invert-thru svl)
-  (char-set->scalar-values (char-set-invert (scalar-values->char-set svl))))
+  (char-set->code-points (char-set-invert (char-set* svl))))
 
 (define (svl-invert-direct svl)
 
@@ -144,9 +144,9 @@ USA.
                  (run-sub-test
                   (lambda ()
                     (assert-equal
-                     (char-set->scalar-values
-                      (operation (scalar-values->char-set svl1)
-                                 (scalar-values->char-set svl2)))
+                     (char-set->code-points
+                      (operation (char-set* svl1)
+                                 (char-set* svl2)))
                      (svl-direct (trim-empty-segments svl1)
                                  (trim-empty-segments svl2))))
                   'EXPRESSION `(,name ,svl1 ,svl2)))

diff --git a/tests/runtime/test-regsexp.scm b/tests/runtime/test-regsexp.scm
index 938703f5c5724bdfadcab48a64c34fa33c8e89a8..30b6e9956e9b64335205b3533c45a41ab197bdf5 100644 (file)
--- a/tests/runtime/test-regsexp.scm
+++ b/tests/runtime/test-regsexp.scm
@@ -377,14 +377,14 @@ USA.
      ((seq "a" (inverse-char-set "ab") "c")
       ("abc" #f)
       "adc")
-     ((seq "a" (char-set ,(char-set->alphabet char-set:alphabetic)) "c")
+     ((seq "a" (char-set ,char-set:alphabetic) "c")
       "abc"
       "adc")
-     ((seq "a" (+ (char-set ,(char-set->alphabet char-set:numeric))) "c")
+     ((seq "a" (+ (char-set ,char-set:numeric)) "c")
       "a019c")
-     ((seq "A" (+ (char-set ,(char-set->alphabet char-set:lower-case))) "C")
+     ((seq "A" (+ (char-set ,char-set:lower-case)) "C")
       "AabC")
-     ((seq "a" (+ (char-set ,(char-set->alphabet char-set:upper-case))) "c")
+     ((seq "a" (+ (char-set ,char-set:upper-case)) "c")
       "aBCc")
      ((seq "a" (** 20 (char-set "ab")))
       "aaaaabaaaabaaaabaaaab")