Refactor symbol implementation to use UTF-8 bytevectors for names.

Primitives handle this correctly since they accept either a legacy string or a
bytevector.  As long as no one peeks behind the abstraction this should be
transparent.

However, symbols with non-ASCII names will produce non-legacy strings when
asked.  AFAIK there are none currently in use.

diff --git a/src/compiler/base/infnew.scm b/src/compiler/base/infnew.scm
index 99d11e5bcc520c39c3e93ec9eef1a3b6383d95c4..5dd26fef3efc880b69b3087e235639697186001d 100644 (file)
--- a/src/compiler/base/infnew.scm
+++ b/src/compiler/base/infnew.scm
@@ -272,14 +272,14 @@ USA.
                label-bindings)
       (let ((map-label/fail
             (lambda (label)
-              (let ((key (system-pair-car label)))
+              (let ((key (symbol-name label)))
                 (let ((datum (hash-table/get labels key no-datum)))
                   (if (eq? datum no-datum)
                       (error "Missing label:" key))
                   datum))))
            (map-label/false
             (lambda (label)
-              (hash-table/get labels (system-pair-car label) #f))))
+              (hash-table/get labels (symbol-name label) #f))))
        (for-each (lambda (label)
                    (set-dbg-label/external?! (map-label/fail label) true))
                  external-labels)
@@ -321,7 +321,7 @@ USA.
        (let ((offsets (make-rb-tree = <)))
         (for-each (lambda (binding)
                     (let ((offset (cdr binding))
-                          (name (system-pair-car (car binding))))
+                          (name (symbol-name (car binding))))
                       (let ((datum (rb-tree/lookup offsets offset #f)))
                         (if datum
                             (set-cdr! datum (cons name (cdr datum)))

diff --git a/src/runtime/error.scm b/src/runtime/error.scm
index d3064e2dc67155f2fb222104cc72e2cacc96834d..4a3feea9c63c31de4a7444d491b686c7225fe1a2 100644 (file)
--- a/src/runtime/error.scm
+++ b/src/runtime/error.scm
@@ -66,7 +66,7 @@ USA.
           (lambda (n-fields field-indexes)
             (%make-condition-type
              (cond ((string? name) (string-copy name))
-                   ((symbol? name) (symbol->utf8-string name))
+                   ((symbol? name) (symbol->string name))
                    ((not name) "(anonymous)")
                    (else
                     (error:wrong-type-argument name "condition-type name"

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 9cd20059b42bce80bfb0bef6a1aef3c2a636918a..033c1845c280f47f8cb4e2e456a3925aa5e51c9b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -712,6 +712,7 @@ USA.
   (parent (runtime))
   (export ()
          ;; BEGIN deprecated bindings
+         (substring->symbol string->symbol)
          (symbol-append symbol)
          error:not-interned-symbol
          error:not-symbol
@@ -727,20 +728,14 @@ USA.
          string->uninterned-symbol
          string-head->symbol
          string-tail->symbol
-         substring->symbol
          symbol
          symbol->string
-         symbol->utf8-string
-         symbol->wide-string
          symbol-hash
-         symbol-hash-mod
          symbol-name
          symbol<?
          symbol>?
          symbol?
-         uninterned-symbol?
-         utf8-string->symbol
-         utf8-string->uninterned-symbol))
+         uninterned-symbol?))
 
 (define-package (runtime microcode-data)
   (files "udata")
@@ -1220,7 +1215,9 @@ USA.
          ;; vector->ustring
          )
   (export (runtime predicate-metadata)
-         register-ustring-predicates!))
+         register-ustring-predicates!)
+  (export (runtime symbol)
+         %ustring*))
 
 (define-package (runtime bytevector)
   (files "bytevector")
@@ -1263,7 +1260,9 @@ USA.
          utf32le->string
          utf8->string)
   (export (runtime predicate-metadata)
-         register-mit-bytevector-predicates!))
+         register-mit-bytevector-predicates!)
+  (export (runtime symbol)
+         %legacy-string->bytevector))
 
 (define-package (runtime 1d-property)
   (files "prop1d")

diff --git a/src/runtime/symbol.scm b/src/runtime/symbol.scm
index 45e3eb1fada2dac99c397d9190d8c3c54b5186b0..2ab047c631f9a67df1940e4a8ab289ae8c429d25 100644 (file)
--- a/src/runtime/symbol.scm
+++ b/src/runtime/symbol.scm
@@ -44,125 +44,62 @@ USA.
 (define-guarantee interned-symbol "interned symbol")
 (define-guarantee uninterned-symbol "uninterned symbol")
 
-(define (string->uninterned-symbol string)
-  (make-uninterned-symbol (if (string? string)
-                             (or (ascii-string-copy string)
-                                 (string->utf8-string string))
-                             (wide-string->utf8-string string))))
-
-(define (utf8-string->uninterned-symbol string)
-  (make-uninterned-symbol (if (utf8-string? string)
-                             (string-copy string)
-                             (wide-string->utf8-string string))))
-
-(define (make-uninterned-symbol string)
+(define (string->uninterned-symbol string #!optional start end)
   ((ucode-primitive system-pair-cons) (ucode-type uninterned-symbol)
-                                     string
+                                     (string->utf8 string start end)
                                      (make-unmapped-unbound-reference-trap)))
 
-(define (string->symbol string)
-  ((ucode-primitive string->symbol) (if (string? string)
-                                       (or (ascii-string-copy string)
-                                           (string->utf8-string string))
-                                       (wide-string->utf8-string string))))
+(define (string->symbol string #!optional start end)
+  ((ucode-primitive string->symbol) (string->utf8 string start end)))
 
-(define (utf8-string->symbol string)
-  (if (utf8-string? string)
-      (or ((ucode-primitive find-symbol) string)
-         ((ucode-primitive string->symbol) (string-copy string)))
-      ((ucode-primitive string->symbol) (wide-string->utf8-string string))))
-
-(define (substring->symbol string start end)
-  (guarantee-substring string start end 'SUBSTRING->SYMBOL)
-  ((ucode-primitive string->symbol) (string->utf8-string string start end)))
+(define (symbol->string symbol)
+  (guarantee symbol? symbol 'symbol->string)
+  (utf8->string
+   (let ((name (system-pair-car symbol)))
+     (cond ((bytevector? name) name)
+          ((legacy-string? name) (%legacy-string->bytevector name))
+          (else (error "Illegal symbol name:" name))))))
 
 (define (string-head->symbol string end)
-  (substring->symbol string 0 end))
+  (string->symbol (ustring-copy string 0 end)))
 
 (define (string-tail->symbol string start)
-  (substring->symbol string start (string-length string)))
+  (string->symbol (ustring-copy string start)))
 
 (define (symbol . objects)
-  ((ucode-primitive string->symbol) (apply utf8-string objects)))
-\f
+  (string->symbol (%ustring* objects 'symbol)))
+
 (define (intern string)
-  ((ucode-primitive string->symbol)
-   (utf8-string-downcase
-    (if (string? string)
-       string
-       (wide-string->utf8-string string)))))
+  (string->symbol (cold-load-downcase string)))
 
 (define (intern-soft string)
-  ((ucode-primitive find-symbol)
-   (utf8-string-downcase
-    (if (string? string)
-       string
-       (wide-string->utf8-string string)))))
+  ((ucode-primitive find-symbol) (string->utf8 (cold-load-downcase string))))
 
-(define (utf8-string-downcase string)
+(define (cold-load-downcase string)
   (if (ascii-string? string)
       ;; Needed during cold load.
-      (string-downcase string)
-      (call-with-utf8-input-string string
-       (lambda (input)
-         (call-with-utf8-output-string
-           (lambda (output)
-             (let loop ()
-               (let ((c (read-char input)))
-                 (if (not (eof-object? c))
-                     (begin
-                       (write-char (char-downcase c) output)
-                       (loop)))))))))))
+      (legacy-string-downcase string)
+      (ustring-downcase string)))
 
 (define (ascii-string? string)
-  (let ((end (string-length string)))
-    (let loop ((i 0))
-      (if (fix:< i end)
-         (and (fix:< (vector-8b-ref string i) #x80)
-              (loop (fix:+ i 1)))
-         #t))))
+  (and (legacy-string? string)
+       (let ((end (legacy-string-length string)))
+        (let loop ((i 0))
+          (if (fix:< i end)
+              (and (fix:< (vector-8b-ref string i) #x80)
+                   (loop (fix:+ i 1)))
+              #t)))))
 
 (define (symbol-name symbol)
-  (guarantee-symbol symbol 'SYMBOL-NAME)
-  (system-pair-car symbol))
-
-(define (symbol-hash symbol)
-  (string-hash (symbol-name symbol)))
-
-(define (symbol-hash-mod symbol modulus)
-  (string-hash-mod (symbol-name symbol) modulus))
-
-(define (%symbol<? x y)
-  (let ((sx (system-pair-car x))
-       (sy (system-pair-car y)))
-    (let ((lx (string-length sx))
-         (ly (string-length sy)))
-      (let ((l (if (fix:< lx ly) lx ly)))
-       (let loop ((i 0))
-         (cond ((fix:= i l)
-                (fix:< lx ly))
-               ((fix:= (vector-8b-ref sx i) (vector-8b-ref sy i))
-                (loop (fix:+ i 1)))
-               (else
-                (fix:< (vector-8b-ref sx i) (vector-8b-ref sy i)))))))))
+  (if (not (symbol? symbol))
+      (error:not-a symbol? symbol 'symbol-name))
+  (object-new-type (ucode-type string) (system-pair-car symbol)))
+
+(define (symbol-hash symbol #!optional modulus)
+  (legacy-string-hash (symbol-name symbol) modulus))
 
 (define (symbol<? x y)
-  (guarantee-symbol x 'SYMBOL<?)
-  (guarantee-symbol y 'SYMBOL<?)
-  (%symbol<? x y))
+  (legacy-string<? (symbol-name x) (symbol-name y)))
 
 (define (symbol>? x y)
-  (guarantee-symbol x 'SYMBOL>?)
-  (guarantee-symbol y 'SYMBOL>?)
-  (%symbol<? y x))
-
-(define (symbol->utf8-string symbol)
-  (string-copy (symbol-name symbol)))
-
-(define (symbol->wide-string symbol)
-  (utf8-string->wide-string (symbol-name symbol)))
-
-(define (symbol->string symbol)
-  ;; `Gensyms' are constructed with this, so try the fast copy first.
-  (or (ascii-string-copy (symbol-name symbol))
-      (utf8-string->string (symbol-name symbol))))
\ No newline at end of file
+  (legacy-string<? (symbol-name y) (symbol-name x)))
\ No newline at end of file

diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index caacd85e8f2049968c93b77bd5de3f5d419f5434..d36ece1e2654dbf3b19184432a300a4062f0622d 100644 (file)
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -91,7 +91,7 @@ USA.
 
 (define (output/letrec names values body)
   (let ((temps (map (lambda (name)
-                     (utf8-string->uninterned-symbol
+                     (string->uninterned-symbol
                       (string-append (symbol-name (identifier->symbol name))
                                      "-value"))) names)))
     (output/let
@@ -426,7 +426,7 @@ USA.
     (let ((mapping-table (rename-database/mapping-table renames)))
       (or (hash-table/get mapping-table key #f)
          (let ((mapped-identifier
-                (utf8-string->uninterned-symbol
+                (string->uninterned-symbol
                  (symbol-name (identifier->symbol identifier)))))
            (hash-table/put! mapping-table key mapped-identifier)
            (hash-table/put! (rename-database/unmapping-table renames)
@@ -445,7 +445,7 @@ USA.
       ;; with a nicer name.  The decorations on this name are just
       ;; that -- decorations, for human legibility.  It is the use of
       ;; an uninterned symbol that guarantees uniqueness.
-      (utf8-string->uninterned-symbol
+      (string->uninterned-symbol
        (string-append "."
                      (symbol-name (identifier->symbol identifier))
                      "."

diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index e86945f17b07144895ba8e2ae5fd29435e0df2cd..4430bc40a3010f19c50917d96a8885ae44d41cf1 100644 (file)
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -549,7 +549,7 @@ USA.
 ;;;; Output
 
 (define (uri->symbol uri)
-  (utf8-string->symbol (uri->string uri)))
+  (string->symbol (uri->string uri)))
 
 (define (write-uri uri port)
   (write-string (uri->string uri) port))

diff --git a/src/xml/turtle.scm b/src/xml/turtle.scm
index cda67b6c98f57ae7456266fd4f0bfa55464af82d..988b478636d81ed40a3d5c2d4bdc1f95c2b0c715 100644 (file)
--- a/src/xml/turtle.scm
+++ b/src/xml/turtle.scm
@@ -202,7 +202,7 @@ USA.
 
 (define parse:language
   (*parser
-   (map utf8-string->symbol
+   (map string->symbol
        (match (seq (+ (char-set char-set:turtle-lower))
                    (* (seq "-"
                            (+ (char-set char-set:turtle-lower+digit)))))))))

diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index 829a3d33996dcfce58fe4785b88f165dcfe6d1d2..3f654b4550204d15621523b943f1db693e75b535 100644 (file)
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -142,7 +142,7 @@ USA.
        (begin
          (if (not (string-predicate object))
              (error:bad-range-argument object constructor))
-         (utf8-string->symbol object))
+         (string->symbol object))
        (begin
          (guarantee-symbol object constructor)
          (if (not (string-predicate (symbol-name object)))
@@ -233,7 +233,7 @@ USA.
   (let ((s (symbol-name qname)))
     (let ((c (string-find-next-char s #\:)))
       (if c
-         (utf8-string->symbol (string-head s c))
+         (string->symbol (string-head s c))
          (null-xml-name-prefix)))))
 
 (define (xml-qname-local qname)
@@ -244,5 +244,5 @@ USA.
   (let ((s (symbol-name qname)))
     (let ((c (string-find-next-char s #\:)))
       (if c
-         (utf8-string->symbol (string-tail s (fix:+ c 1)))
+         (string->symbol (string-tail s (fix:+ c 1)))
          qname))))
\ No newline at end of file

diff --git a/src/xml/xml-rpc.scm b/src/xml/xml-rpc.scm
index 96ed74ccf5499a2d6c19c42a81d1e573b24de732..2307499fd0e55d6cb22b2f765487f993d81d2c5f 100644 (file)
--- a/src/xml/xml-rpc.scm
+++ b/src/xml/xml-rpc.scm
@@ -82,7 +82,7 @@ USA.
       (require (xml-name=? (xml-element-name elt) '|methodCall|))
       (values (let ((s (content-string (named-child '|methodName| elt))))
                (require (re-string-match "\\`[a-zA-Z0-9_.:/]+\\'" s))
-               (utf8-string->symbol s))
+               (string->symbol s))
              (let ((elt (%named-child 'params elt)))
                (if elt
                    (parse-params elt)
@@ -248,7 +248,7 @@ USA.
          (named-children 'value (single-named-child 'data elt))))
     ((struct)
      (map (lambda (elt)
-           (cons (utf8-string->symbol
+           (cons (string->symbol
                   (content-string (named-child 'name elt)))
                  (decode-value (named-child 'value elt))))
          (named-children 'member elt)))
@@ -291,7 +291,7 @@ USA.
           ((string? object)
            (encode-string object))
           ((symbol? object)
-           (encode-string (symbol->utf8-string object)))
+           (encode-string (symbol->string object)))
           ((decoded-time? object)
            (rpc-elt:date-time (decoded-time->xml-rpc-iso8601-string object)))
           ((and (pair? object)
@@ -302,7 +302,7 @@ USA.
            (rpc-elt:struct
             (map (lambda (item)
                    (rpc-elt:member
-                    (rpc-elt:name (symbol->utf8-string (car item)))
+                    (rpc-elt:name (symbol->string (car item)))
                     (encode-value (cdr item))))
                  (cdr object))))
           ((list? object)