From df872e6eda6781437a428d9e1d122a29f26c939e Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 17 Jan 2017 22:56:00 -0800 Subject: [PATCH] Implement u16 and u32 accessors for bytevectors. --- src/runtime/bytevector.scm | 141 ++++++++++++++++++++++++++++- src/runtime/predicate-metadata.scm | 3 +- src/runtime/runtime.pkg | 14 ++- 3 files changed, 155 insertions(+), 3 deletions(-) diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm index 23a439fb9..e5d8bd61d 100644 --- a/src/runtime/bytevector.scm +++ b/src/runtime/bytevector.scm @@ -252,4 +252,143 @@ USA. (define-integrable (non-character? cp) (or (and (fix:<= #xFDD0 cp) (fix:< cp #xFDF0)) - (fix:= (fix:and #xFFFE cp) #xFFFE))) \ No newline at end of file + (fix:= (fix:and #xFFFE cp) #xFFFE))) + +;;;; U16 accessors + +(define-integrable (bytes->u16be b0 b1) (fix:or (fix:lsh b0 8) b1)) +(define-integrable (u16be-byte0 u16) (fix:lsh u16 -8)) +(define-integrable (u16be-byte1 u16) (fix:and u16 #xFF)) + +(define-integrable (bytes->u16le b0 b1) (fix:or b0 (fix:lsh b1 8))) +(define-integrable (u16le-byte0 u16) (fix:and u16 #xFF)) +(define-integrable (u16le-byte1 u16) (fix:lsh u16 -8)) + +(define (u16? object) + (and (index-fixnum? object) + (fix:< object #x10000))) + +(define (bytevector-u16be-ref bytevector index) + (if (not (fix:< (fix:+ index 1) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u16be-ref)) + (bytes->u16be (bytevector-u8-ref bytevector index) + (bytevector-u8-ref bytevector (fix:+ index 1)))) + +(define (bytevector-u16be-set! bytevector index u16) + (if (not (fix:< (fix:+ index 1) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u16be-ref)) + (guarantee u16? u16 'bytevector-u16be-set!) + (bytevector-u8-set! bytevector index (u16be-byte0 u16)) + (bytevector-u8-set! bytevector (fix:+ index 1) (u16be-byte1 u16))) + +(define (bytevector-u16le-ref bytevector index) + (if (not (fix:< (fix:+ index 1) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u16le-ref)) + (bytes->u16le (bytevector-u8-ref bytevector index) + (bytevector-u8-ref bytevector (fix:+ index 1)))) + +(define (bytevector-u16le-set! bytevector index u16) + (if (not (fix:< (fix:+ index 1) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u16le-ref)) + (guarantee u16? u16 'bytevector-u16le-set!) + (bytevector-u8-set! bytevector index (u16le-byte0 u16)) + (bytevector-u8-set! bytevector (fix:+ index 1) (u16le-byte1 u16))) + +;;;; U32 accessors + +(define-syntax select-u32-code + (er-macro-transformer + (lambda (form rename compare) + (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form) + (if (fix:fixnum? #xFFFFFFFF) + (cadr form) + (caddr form))))) + +(select-u32-code + ;; Can use fixnums: + (begin + (define-integrable (bytes->u32be b0 b1 b2 b3) + (fix:or (fix:or (fix:lsh b0 24) + (fix:lsh b1 16)) + (fix:or (fix:lsh b2 8) + b3))) + + (define-integrable (u32be-byte0 u32) (fix:lsh u32 -24)) + (define-integrable (u32be-byte1 u32) (fix:and (fix:lsh u32 -16) #xFF)) + (define-integrable (u32be-byte2 u32) (fix:and (fix:lsh u32 -8) #xFF)) + (define-integrable (u32be-byte3 u32) (fix:and u32 #xFF)) + + (define (u32? object) + (and (index-fixnum? object) + (fix:<= object #xFFFFFFFF)))) + ;; Must use bignums: + (begin + (define-integrable (bytes->u32be b0 b1 b2 b3) + (int:+ (int:+ (int:* b0 #x1000000) + (int:* b1 #x10000)) + (int:+ (int:* b2 #x100) + b3))) + + (define-integrable (u32be-byte0 u32) + (int:quotient u32 #x1000000)) + + (define-integrable (u32be-byte1 u32) + (int:remainder (int:quotient u32 #x10000) #x100)) + + (define-integrable (u32be-byte2 u32) + (int:remainder (int:quotient u32 #x100) #x100)) + + (define-integrable (u32be-byte3 u32) + (int:remainder u32 #x100)) + + (define (u32? object) + (and (exact-nonnegative-integer? object) + (int:<= object #xFFFFFFFF))))) + +(define-integrable (bytes->u32le b0 b1 b2 b3) (bytes->u32be b3 b2 b1 b0)) +(define-integrable u32le-byte0 u32be-byte3) +(define-integrable u32le-byte1 u32be-byte2) +(define-integrable u32le-byte2 u32be-byte1) +(define-integrable u32le-byte3 u32be-byte0) + +(define (bytevector-u32be-ref bytevector index) + (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u32be-ref)) + (bytes->u32be (bytevector-u8-ref bytevector index) + (bytevector-u8-ref bytevector (fix:+ index 1)) + (bytevector-u8-ref bytevector (fix:+ index 2)) + (bytevector-u8-ref bytevector (fix:+ index 3)))) + +(define (bytevector-u32be-set! bytevector index u32) + (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u32be-ref)) + (guarantee u32? u32 'bytevector-u32be-set!) + (bytevector-u8-set! bytevector index (u32be-byte0 u32)) + (bytevector-u8-set! bytevector (fix:+ index 1) (u32be-byte1 u32)) + (bytevector-u8-set! bytevector (fix:+ index 2) (u32be-byte2 u32)) + (bytevector-u8-set! bytevector (fix:+ index 3) (u32be-byte3 u32))) + +(define (bytevector-u32le-ref bytevector index) + (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u32le-ref)) + (bytes->u32le (bytevector-u8-ref bytevector index) + (bytevector-u8-ref bytevector (fix:+ index 1)) + (bytevector-u8-ref bytevector (fix:+ index 2)) + (bytevector-u8-ref bytevector (fix:+ index 3)))) + +(define (bytevector-u32le-set! bytevector index u32) + (if (not (fix:< (fix:+ index 3) (bytevector-length bytevector))) + (error:bad-range-argument index 'bytevector-u32le-ref)) + (guarantee u32? u32 'bytevector-u32le-set!) + (bytevector-u8-set! bytevector index (u32le-byte0 u32)) + (bytevector-u8-set! bytevector (fix:+ index 1) (u32le-byte1 u32)) + (bytevector-u8-set! bytevector (fix:+ index 2) (u32le-byte2 u32)) + (bytevector-u8-set! bytevector (fix:+ index 3) (u32le-byte3 u32))) + +(define (register-mit-bytevector-predicates!) + (register-predicate! byte? 'byte '<= index-fixnum?) + (register-predicate! u16? 'u16 '<= index-fixnum?) + (register-predicate! u32? 'u32 + '<= (if (fix:fixnum? #xFFFFFFFF) + index-fixnum? + exact-nonnegative-integer?))) \ No newline at end of file diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 59234a447..85ca75a57 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -264,7 +264,6 @@ USA. (register-predicate! index-fixnum? 'index-fixnum '<= fix:fixnum? '<= exact-nonnegative-integer?) - (register-predicate! byte? 'byte '<= index-fixnum?) (register-predicate! negative-fixnum? 'negative-fixnum '<= fix:fixnum?) (register-predicate! positive-fixnum? 'positive-fixnum '<= fix:fixnum? @@ -277,6 +276,8 @@ USA. (register-predicate! flo:flonum? 'flonum '<= real?) + (register-mit-bytevector-predicates!) + ;; MIT/GNU Scheme: lists (register-predicate! alist? 'association-list '<= list?) (register-predicate! keyword-list? 'keyword-list '<= list?) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 54d65d483..c813299b4 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1149,13 +1149,25 @@ USA. bytevector-copy! bytevector-fill! bytevector-length + bytevector-u16be-ref + bytevector-u16be-set! + bytevector-u16le-ref + bytevector-u16le-set! + bytevector-u32be-ref + bytevector-u32be-set! + bytevector-u32le-ref + bytevector-u32le-set! bytevector-u8-ref bytevector-u8-set! bytevector=? bytevector? make-bytevector string->utf8 - utf8->string)) + u16? + u32? + utf8->string) + (export (runtime predicate-metadata) + register-mit-bytevector-predicates!)) (define-package (runtime 1d-property) (files "prop1d") -- 2.25.1