bytevectors: Implement bytevector-hash; fix a couple of bugs and simplify.

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 6180def912f20737ea4f226597fe33171d838d05..ec2faa8f284c395f9d0e5e749e19dea0efb1e06e 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -105,6 +105,12 @@ USA.
               (and (fix:= (bytevector-u8-ref b1 index)
                           (bytevector-u8-ref b2 index))
                    (loop (fix:+ index 1))))))))
+
+;; String hash primitives work on bytevectors too.
+(define (bytevector-hash bytevector #!optional modulus)
+  (if (default-object? modulus)
+      ((ucode-primitive string-hash) bytevector)
+      ((ucode-primitive string-hash-mod) bytevector modulus)))
 \f
 ;;;; U16 accessors
 
@@ -151,6 +157,7 @@ USA.
 (define-syntax select-u32-code
   (er-macro-transformer
    (lambda (form rename compare)
+     rename compare
      (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
      (if (fix:fixnum? #xFFFFFFFF)
         (cadr form)
@@ -245,27 +252,13 @@ USA.
                               index-fixnum?
                               exact-nonnegative-integer?)))
 \f
-(define (string-encoder char-byte-length encode-char! caller)
+(define-integrable (string-encoder char-byte-length allocator encode-char!
+                                  caller)
   (lambda (string #!optional start end)
-    (guarantee string? string caller)
-    (let* ((end
-           (if (default-object? end)
-               (string-length string)
-               (begin
-                 (guarantee index-fixnum? end caller)
-                 (if (not (fix:<= end (string-length string)))
-                     (error:bad-range-argument end caller))
-                 end)))
-          (start
-           (if (default-object? start)
-               0
-               (begin
-                 (guarantee index-fixnum? start caller)
-                 (if (not (fix:<= start end))
-                     (error:bad-range-argument start caller))
-                 start))))
+    (let* ((end (fix:end-index end (string-length string) caller))
+          (start (fix:start-index start end caller)))
       (let ((bytes
-            (allocate-bytevector
+            (allocator
              (let loop ((index start) (n-bytes 0))
                (if (fix:< index end)
                    (loop (fix:+ index 1)
@@ -278,6 +271,10 @@ USA.
                    (encode-char! bytes to (string-ref string from)))))
        bytes))))
 
+;; Make sure UTF-8 bytevectors have null termination.
+(define (utf8-allocator k)
+  (legacy-string->bytevector (make-string k)))
+
 (define string->utf8)
 (define string->utf16be)
 (define string->utf16le)
@@ -286,68 +283,54 @@ USA.
 (add-boot-init!
  (lambda ()
    (set! string->utf8
-        (string-encoder char-utf8-byte-length encode-utf8-char!
-                        'string->utf8))
+        (string-encoder char-utf8-byte-length utf8-allocator
+                        encode-utf8-char! 'string->utf8))
    (set! string->utf16be
-        (string-encoder char-utf16-byte-length encode-utf16be-char!
-                        'string->utf16be))
+        (string-encoder char-utf16-byte-length allocate-bytevector
+                        encode-utf16be-char! 'string->utf16be))
    (set! string->utf16le
-        (string-encoder char-utf16-byte-length encode-utf16le-char!
-                        'string->utf16le))
+        (string-encoder char-utf16-byte-length allocate-bytevector
+                        encode-utf16le-char! 'string->utf16le))
    (set! string->utf32be
-        (string-encoder char-utf32-byte-length encode-utf32be-char!
-                        'string->utf32be))
+        (string-encoder char-utf32-byte-length allocate-bytevector
+                        encode-utf32be-char! 'string->utf32be))
    (set! string->utf32le
-        (string-encoder char-utf32-byte-length encode-utf32le-char!
-                        'string->utf32le))
+        (string-encoder char-utf32-byte-length allocate-bytevector
+                        encode-utf32le-char! 'string->utf32le))
    unspecific))
 \f
-(define (bytes-decoder getter initial->length char-length decode-char step noun
-                      caller)
+(define-integrable (bytes-decoder getter initial->length char-length decode-char
+                                 step noun caller)
   (lambda (bytevector #!optional start end)
-    (guarantee bytevector? bytevector caller)
-    (let* ((end
-           (if (default-object? end)
-               (bytevector-length bytevector)
-               (begin
-                 (guarantee index-fixnum? end caller)
-                 (if (not (fix:<= end (bytevector-length bytevector)))
-                     (error:bad-range-argument end caller))
-                 end)))
-         (start
-          (if (default-object? start)
-              0
-              (begin
-                (guarantee index-fixnum? start caller)
-                (if (not (fix:<= start end))
-                    (error:bad-range-argument start caller))
-                start)))
-         (truncated
-          (lambda (index)
-            (error (string "Truncated " noun " sequence:")
-                   (bytevector-copy bytevector
-                                    index
-                                    (fix:min (fix:+ index 4) end))))))
-      (let ((string
-            (make-string
-             (let loop ((index start) (n-chars 0))
-               (if (fix:<= (fix:+ index step) end)
-                   (let ((n (initial->length (getter bytevector start))))
-                     (let ((index* (fix:+ index n)))
-                       (if (not (fix:<= index* end))
-                           (truncated index))
-                       (loop index* (fix:+ n-chars 1))))
-                   (begin
-                     (if (fix:< index end)
-                         (truncated index))
-                     n-chars))))))
-       (let loop ((from start) (to 0))
-         (if (fix:< from end)
-             (let ((char (decode-char bytevector start)))
-               (string-set! string to char)
-               (loop (fix:+ from (char-length char))
-                     (fix:+ to 1)))))
-       string))))
+    (let* ((end (fix:end-index end (bytevector-length bytevector) caller))
+          (start (fix:start-index start end caller))
+          (string
+           (make-string
+            (let (
+                  (truncated
+                   (lambda (index)
+                     (error (string "Truncated " noun " sequence:")
+                            (bytevector-copy bytevector
+                                             index
+                                             (fix:min (fix:+ index 4) end))))))
+              (let loop ((index start) (n-chars 0))
+                (if (fix:<= (fix:+ index step) end)
+                    (let ((n (initial->length (getter bytevector start))))
+                      (let ((index* (fix:+ index n)))
+                        (if (not (fix:<= index* end))
+                            (truncated index))
+                        (loop index* (fix:+ n-chars 1))))
+                    (begin
+                      (if (fix:< index end)
+                          (truncated index))
+                      n-chars)))))))
+      (let loop ((from start) (to 0))
+       (if (fix:< from end)
+           (let ((char (decode-char bytevector from)))
+             (string-set! string to char)
+             (loop (fix:+ from (char-length char))
+                   (fix:+ to 1)))))
+      string)))
 
 (define utf8->string)
 (define utf16be->string)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1d6a1f68e569b5731566211a8371ea9979a53c8b..59e15f17827a52a4dd95681a8d96640c48da6c90 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1149,6 +1149,7 @@ USA.
          bytevector-copy
          bytevector-copy!
          bytevector-fill!
+         bytevector-hash
          bytevector-length
          bytevector-u16be-ref
          bytevector-u16be-set!