Clean up the character abstraction to be more consistent.

* Change unicode-char? correspond to unicode-scalar-value?.
* Rename base-char? to bitless-char?.
* Eliminate char-integer-limit, unicode-char-code?, and char->scalar-value.

diff --git a/src/runtime/char.scm b/src/runtime/char.scm
index 4ddd4a9a66b64a580b297706cc85bbcea0cf3313..d024178769a952bb47980a6aaedb41adee68b1c3 100644 (file)
--- a/src/runtime/char.scm
+++ b/src/runtime/char.scm
@@ -36,7 +36,6 @@ USA.
 
 (define-integrable char-code-limit #x110000)
 (define-integrable char-bits-limit #x10)
-(define-integrable char-integer-limit #x2000000)
 
 (define-guarantee char "character")
 
@@ -54,6 +53,10 @@ USA.
 (define (char-bits char)
   (fix:lsh (char->integer char) -21))
 
+(define (bitless-char? object)
+  (and (char? object)
+       (fix:< (char->integer object) char-code-limit)))
+
 (define (char-bits-set? bits char)
   (guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-SET?)
   (fix:= bits (fix:and (char-bits char) bits)))
@@ -348,39 +351,28 @@ USA.
 
 (define (unicode-char? object)
   (and (char? object)
-       (unicode-char-code? (char->integer object))))
-
-(define (base-char? object)
-  (and (char? object)
-       (unicode-code-point? (char->integer object))))
-
-(define (unicode-char-code? object)
-  (and (unicode-scalar-value? object)
-       (not (non-character? object))))
+       (let ((cp (char->integer object)))
+        (and (fix:< object char-code-limit)
+             (not (utf16-surrogate? object))))))
 
 (define (unicode-scalar-value? object)
   (and (unicode-code-point? object)
        (not (utf16-surrogate? object))))
 
-(define-integrable (unicode-code-point? object)
+(define (unicode-code-point? object)
   (and (index-fixnum? object)
        (fix:< object char-code-limit)))
 
 (define-guarantee unicode-char "a Unicode character")
 (define-guarantee unicode-scalar-value "a Unicode scalar value")
 
-(define (char->code-point char #!optional caller)
-  (let ((n (char->integer char)))
-    (guarantee unicode-code-point? n caller)
-    n))
-
-(define (char->scalar-value char #!optional caller)
+(define (%char->scalar-value char #!optional caller)
   (let ((n (char->integer char)))
     (guarantee unicode-scalar-value? n caller)
     n))
 
 (define (char-general-category char)
-  (guarantee base-char? char 'char-general-category)
+  (guarantee bitless-char? char 'char-general-category)
   (ucd-gc-value char))
 
 (define (code-point-general-category cp)
@@ -421,14 +413,14 @@ USA.
 ;;;; UTF-{8,16,32} encoders
 
 (define (char-utf8-byte-length char)
-  (let ((sv (char->scalar-value char 'char-utf8-byte-length)))
+  (let ((sv (%char->scalar-value char 'char-utf8-byte-length)))
     (cond ((fix:< sv #x80) 1)
          ((fix:< sv #x800) 2)
          ((fix:< sv #x10000) 3)
          (else 4))))
 
 (define (encode-utf8-char! bytes index char)
-  (let ((sv (char->scalar-value char 'encode-utf8-char!)))
+  (let ((sv (%char->scalar-value char 'encode-utf8-char!)))
 
     (define-integrable (initial-byte leader offset)
       (fix:or leader (fix:lsh sv offset)))
@@ -456,13 +448,13 @@ USA.
           (fix:+ index 4)))))
 
 (define (char-utf16-byte-length char)
-  (if (fix:< (char->scalar-value char 'char-utf16-byte-length) #x10000)
+  (if (fix:< (%char->scalar-value char 'char-utf16-byte-length) #x10000)
       2
       4))
 
 (define (utf16-char-encoder setter caller)
   (lambda (bytes index char)
-    (let ((sv (char->scalar-value char caller)))
+    (let ((sv (%char->scalar-value char caller)))
       (cond ((fix:< sv #x10000)
             (setter bytes index sv)
             (fix:+ index 2))
@@ -481,12 +473,12 @@ USA.
   (utf16-char-encoder bytevector-u16le-set! 'encode-utf16le-char!))
 
 (define (char-utf32-byte-length char)
-  (char->scalar-value char 'char-utf32-byte-length)
+  (%char->scalar-value char 'char-utf32-byte-length)
   4)
 
 (define (utf32-char-encoder setter caller)
   (lambda (bytes index char)
-    (setter bytes index (char->scalar-value char caller))))
+    (setter bytes index (%char->scalar-value char caller))))
 
 (define encode-utf32be-char!
   (utf32-char-encoder bytevector-u32be-set! 'encode-utf32be-char!))

diff --git a/src/runtime/chrset.scm b/src/runtime/chrset.scm
index 56251effa9d4c928cdfb14962e41b6d6b16a9ae0..9b27294bdb88d219d8e98af400d4d589d2ef1cfb 100644 (file)
--- a/src/runtime/chrset.scm
+++ b/src/runtime/chrset.scm
@@ -284,7 +284,7 @@ USA.
 
 (define (%cpl-element->ranges elt)
   (cond ((%range? elt) (list elt))
-       ((base-char? elt) (list (char->integer elt)))
+       ((bitless-char? elt) (list (char->integer elt)))
        ((ustring? elt) (map char->integer (ustring->list elt)))
        (else #f)))
 
@@ -336,7 +336,7 @@ USA.
 
 (define (cpl-element? object)
   (or (%range? object)
-      (base-char? object)
+      (bitless-char? object)
       (ustring? object)
       (char-set? object)))
 
@@ -383,7 +383,7 @@ USA.
 ;;;; Accessors
 
 (define (char-in-set? char char-set)
-  (guarantee base-char? char 'char-in-set?)
+  (guarantee bitless-char? char 'char-in-set?)
   (%code-point-in-char-set? (char->integer char) char-set))
 
 (define (code-point-in-char-set? cp char-set)
@@ -495,14 +495,11 @@ USA.
 (define char-set:not-graphic)
 (define char-set:not-standard)
 (define char-set:standard)
-(define char-set:unicode)
 (define char-set:wsp)
 (define char-standard?)
 (define char-wsp?)
 (add-boot-init!
  (lambda ()
-   (set! char-set:unicode (compute-char-set unicode-char-code?))
-
    (set! char-set:graphic (%signal->char-set '(#x20 #x7F #xA0 #x100)))
    (set! char-set:not-graphic (char-set-invert char-set:graphic))
    (set! char-graphic? (char-set-predicate char-set:graphic))

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index f63ed45c6db60a505e3d39e1b5a1a232e9a896f8..f0f6b3c130b35472fb96eca6783bd753cf54b96d 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -289,8 +289,8 @@ USA.
    ;; MIT/GNU Scheme: misc
    (register-predicate! 8-bit-char? '8-bit-char '<= char?)
    (register-predicate! ascii-char? 'ascii-char '<= 8-bit-char?)
-   (register-predicate! base-char? 'base-char '<= char?)
    (register-predicate! bit-string? 'bit-string)
+   (register-predicate! bitless-char? 'bitless-char '<= char?)
    (register-predicate! cell? 'cell)
    (register-predicate! code-point-list? 'code-point-list '<= list?)
    (register-predicate! compiled-code-address? 'compiled-code-address)
@@ -312,13 +312,11 @@ USA.
    (register-predicate! stack-address? 'stack-address)
    (register-predicate! thread-mutex? 'thread-mutex)
    (register-predicate! undefined-value? 'undefined-value)
-   (register-predicate! unicode-char? 'unicode-char '<= base-char?)
+   (register-predicate! unicode-char? 'unicode-char '<= bitless-char?)
    (register-predicate! unicode-code-point? 'unicode-code-point
                        '<= index-fixnum?)
    (register-predicate! unicode-scalar-value? 'unicode-scalar-value
                        '<= unicode-code-point?)
-   (register-predicate! unicode-char-code? 'unicode-char-code
-                       '<= unicode-scalar-value?)
    (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?)
    (register-predicate! weak-list? 'weak-list)
    (register-predicate! weak-pair? 'weak-pair)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c640335d6cc57a566d59570805dfe854238e7913..04b209a00d60710ea6870d82dd87a6f5c8f0156e 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1431,12 +1431,11 @@ USA.
   (export ()
          8-bit-char?
          ascii-char?
-         base-char?
+         bitless-char?
          char-8-bit?
          char->digit
          char->integer
          char->name
-         char->scalar-value
          char-ascii?
          char-bit:control
          char-bit:hyper
@@ -1457,7 +1456,6 @@ USA.
          char-downcase
          char-foldcase
          char-general-category
-         char-integer-limit
          char-upcase
          char<=?
          char<?
@@ -1476,8 +1474,6 @@ USA.
          name->char
          radix?
          set-char-bits
-         unicode-char-code?
-         unicode-char?
          unicode-code-point?
          unicode-scalar-value?)
   (export (runtime)
@@ -1559,7 +1555,9 @@ USA.
          char-set:not-numeric
          char-set:not-upper-case
          char-set:not-whitespace
-         char-set:numeric)
+         char-set:numeric
+         char-set:unicode
+         unicode-char?)
   (export (runtime)
          char-set:folded-symbol-constituent
          char-set:folded-symbol-initial
@@ -1610,7 +1608,6 @@ USA.
          char-set:not-graphic
          char-set:not-standard
          char-set:standard
-         char-set:unicode
          char-set:wsp
          char-set=?
          char-set?

diff --git a/src/runtime/ucd-glue.scm b/src/runtime/ucd-glue.scm
index 8bfbd86f07dc1868db317b0bc8091a62cd3ff796..84a5030d843205b719a89e60bbe7d439c18ff0d9 100644 (file)
--- a/src/runtime/ucd-glue.scm
+++ b/src/runtime/ucd-glue.scm
@@ -60,6 +60,16 @@ USA.
 
 (define-deferred char-set:not-whitespace
   (char-set-invert char-set:whitespace))
+
+(define-deferred char-set:unicode
+  (compute-char-set
+   (lambda (cp)
+     (case (code-point-general-category cp)
+       ((other:surrogate other:not-assigned) #f)
+       (else #t)))))
+
+(define-deferred unicode-char?
+  (char-set-predicate char-set:unicode))
 \f
 ;;;; Scheme language:
 

diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm
index 090a4323dd933e54c054130e97db9777e08495d4..1d88176227f0fb6d4d15aef1047bb8a2ef4b72d5 100644 (file)
--- a/src/sf/gconst.scm
+++ b/src/sf/gconst.scm
@@ -32,7 +32,6 @@ USA.
 (define global-constant-objects
   '(CHAR-BITS-LIMIT
     CHAR-CODE-LIMIT
-    CHAR-INTEGER-LIMIT
     FALSE
     LAMBDA-TAG:UNNAMED                 ;needed for cold load
     SYSTEM-GLOBAL-ENVIRONMENT          ;suppresses warnings about (access ...)