From: Chris Hanson Date: Thu, 26 Jan 2017 23:21:55 +0000 (-0800) Subject: bytevectors: Implement bytevector-hash; fix a couple of bugs and simplify. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~79 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d46e0115741d6f107170188c71d35bbea08fae95;p=mit-scheme.git bytevectors: Implement bytevector-hash; fix a couple of bugs and simplify. --- diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm index 6180def91..ec2faa8f2 100644 --- 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))) ;;;; 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?))) -(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)) -(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 1d6a1f68e..59e15f178 100644 --- 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!