diff --git a/src/ikarus.boot b/src/ikarus.boot index 52d1d13..ecaba1d 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.bytevectors.ss b/src/ikarus.bytevectors.ss index 05c8952..e37b52b 100644 --- a/src/ikarus.bytevectors.ss +++ b/src/ikarus.bytevectors.ss @@ -4,6 +4,8 @@ bytevector-u8-ref bytevector-u8-set! bytevector-s8-set! bytevector-copy! u8-list->bytevector bytevector->u8-list bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-native-ref bytevector-s32-native-set! bytevector-u16-ref bytevector-u16-set! bytevector-u32-ref bytevector-u32-set! bytevector-s32-ref bytevector-s32-set! @@ -21,6 +23,8 @@ bytevector-u8-ref bytevector-u8-set! bytevector-s8-set! bytevector-copy! u8-list->bytevector bytevector->u8-list bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-native-ref bytevector-s32-native-set! bytevector-u16-ref bytevector-u16-set! bytevector-u32-ref bytevector-u32-set! bytevector-s32-ref bytevector-s32-set! @@ -123,21 +127,6 @@ (error 'bytevector-u16-native-ref "invalid index ~s" i)) (error 'bytevector-u16-native-ref "~s is not a bytevector" x)))) - (define bytevector-u32-native-ref ;;; HARDCODED - (lambda (x i) - (if (bytevector? x) - (if (and (fixnum? i) - ($fx<= 0 i) - ($fx< i ($fx- ($bytevector-length x) 3)) - ($fxzero? ($fxlogand i 3))) - (+ (* ($bytevector-u8-ref x i) #x1000000) - ($fxlogor - ($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 16) - ($fxlogor - ($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 8) - ($bytevector-u8-ref x ($fx+ i 3))))) - (error 'bytevector-u32-native-ref "invalid index ~s" i)) - (error 'bytevector-u32-native-ref "~s is not a bytevector" x)))) (define bytevector-u16-native-set! ;;; HARDCODED (lambda (x i n) @@ -156,25 +145,6 @@ (error 'bytevector-u16-native-set! "invalid value ~s" n)) (error 'bytevector-u16-native-set! "~s is not a bytevector" x)))) - (define bytevector-u32-native-set! ;;; HARDCODED - (lambda (x i n) - (if (bytevector? x) - (if (and (or (fixnum? n) (bignum? n)) - (<= 0 n) - (<= n #xFFFFFFFF)) - (if (and (fixnum? i) - ($fx<= 0 i) - ($fx< i ($fx- ($bytevector-length x) 3)) - ($fxzero? ($fxlogand i 3))) - (begin - ($bytevector-set! x i (quotient n #x1000000)) - ($bytevector-set! x ($fx+ i 1) (quotient x #x10000)) - ($bytevector-set! x ($fx+ i 2) (quotient x #x100)) - ($bytevector-set! x ($fx+ i 3) (remainder n #x100))) - (error 'bytevector-u32-native-set! "invalid index ~s" i)) - (error 'bytevector-u32-native-set! "invalid value ~s" n)) - (error 'bytevector-u32-native-set! "~s is not a bytevector" x)))) - (define bytevector-s16-native-set! ;;; HARDCODED (lambda (x i n) (if (bytevector? x) @@ -249,6 +219,21 @@ (error 'bytevector-u32-ref "invalid index ~s" i)) (error 'bytevector-u32-ref "~s is not a bytevector" x)))) + (define bytevector-u32-native-ref + (lambda (x i) + (if (bytevector? x) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx= 0 ($fxlogand i 3)) + ($fx< i ($fx- ($bytevector-length x) 3))) + (+ (sll ($bytevector-u8-ref x i) 24) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 16) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 8) + ($bytevector-u8-ref x ($fx+ i 3))))) + (error 'bytevector-u32-native-ref "invalid index ~s" i)) + (error 'bytevector-u32-native-ref "~s is not a bytevector" x)))) (define bytevector-s32-ref (lambda (x i end) @@ -275,6 +260,22 @@ (error 'bytevector-s32-ref "invalid index ~s" i)) (error 'bytevector-s32-ref "~s is not a bytevector" x)))) + (define bytevector-s32-native-ref + (lambda (x i) + (if (bytevector? x) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx= 0 ($fxlogand i 3)) + ($fx< i ($fx- ($bytevector-length x) 3))) + (+ (sll ($bytevector-s8-ref x i) 24) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 16) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 8) + ($bytevector-u8-ref x ($fx+ i 3))))) + (error 'bytevector-s32-native-ref "invalid index ~s" i)) + (error 'bytevector-s32-native-ref "~s is not a bytevector" x)))) + (define bytevector-u16-set! (lambda (x i n end) (if (bytevector? x) @@ -328,6 +329,52 @@ (error 'bytevector-u32-set! "invalid value ~s" n)) (error 'bytevector-u32-set! "~s is not a bytevector" x)))) + (define bytevector-u32-native-set! + (lambda (x i n) + (if (bytevector? x) + (if (if (fixnum? n) + ($fx>= n 0) + (if (bignum? n) + (<= 0 n #xFFFFFFFF) + #f)) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx= 0 ($fxlogand i 3)) + ($fx< i ($fx- ($bytevector-length x) 3))) + (begin + (let ([b (sra n 16)]) + ($bytevector-set! x i ($fxsra b 8)) + ($bytevector-set! x ($fx+ i 1) b)) + (let ([b (logand n #xFFFF)]) + ($bytevector-set! x ($fx+ i 2) ($fxsra b 8)) + ($bytevector-set! x ($fx+ i 3) b))) + (error 'bytevector-u32-native-set! "invalid index ~s" i)) + (error 'bytevector-u32-native-set! "invalid value ~s" n)) + (error 'bytevector-u32-native-set! "~s is not a bytevector" x)))) + + + (define bytevector-s32-native-set! + (lambda (x i n) + (if (bytevector? x) + (if (if (fixnum? n) + #t + (if (bignum? n) + (<= #x-80000000 n #x7FFFFFFF) + #f)) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx= 0 ($fxlogand i 3)) + ($fx< i ($fx- ($bytevector-length x) 3))) + (begin + (let ([b (sra n 16)]) + ($bytevector-set! x i ($fxsra b 8)) + ($bytevector-set! x ($fx+ i 1) b)) + (let ([b (logand n #xFFFF)]) + ($bytevector-set! x ($fx+ i 2) ($fxsra b 8)) + ($bytevector-set! x ($fx+ i 3) b))) + (error 'bytevector-s32-native-set! "invalid index ~s" i)) + (error 'bytevector-s32-native-set! "invalid value ~s" n)) + (error 'bytevector-s32-native-set! "~s is not a bytevector" x)))) (define bytevector-s32-set! (lambda (x i n end) diff --git a/src/makefile.ss b/src/makefile.ss index 16adedb..641f7ee 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -408,12 +408,16 @@ [bytevector-u32-set! i] [bytevector-s32-ref i] [bytevector-s32-set! i] - [bytevector-u16-native-ref i] - [bytevector-u16-native-set! i] [bytevector-s16-ref i] [bytevector-s16-set! i] + [bytevector-u16-native-ref i] + [bytevector-u16-native-set! i] [bytevector-s16-native-ref i] [bytevector-s16-native-set! i] + [bytevector-u32-native-ref i] + [bytevector-u32-native-set! i] + [bytevector-s32-native-ref i] + [bytevector-s32-native-set! i] [bytevector->u8-list i] [u8-list->bytevector i] [bytevector-copy! i] diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index 532a47b..51a10d7 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -368,8 +368,8 @@ [bytevector-s16-native-set! C bv] [bytevector-s16-ref C bv] [bytevector-s16-set! C bv] - [bytevector-s32-native-ref S bv] - [bytevector-s32-native-set! S bv] + [bytevector-s32-native-ref C bv] + [bytevector-s32-native-set! C bv] [bytevector-s32-ref C bv] [bytevector-s32-set! C bv] [bytevector-s64-native-ref S bv] @@ -384,8 +384,8 @@ [bytevector-u16-native-set! C bv] [bytevector-u16-ref C bv] [bytevector-u16-set! C bv] - [bytevector-u32-native-ref S bv] - [bytevector-u32-native-set! S bv] + [bytevector-u32-native-ref C bv] + [bytevector-u32-native-set! C bv] [bytevector-u32-ref C bv] [bytevector-u32-set! C bv] [bytevector-u64-native-ref S bv]