conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added bytevector-u32-native-ref, bytevector-u32-native-set!, 

bytevector-s32-native-ref, and bytevector-s32-native-set!
This commit is contained in:
Abdulaziz Ghuloum 2007-09-13 01:57:36 -04:00
parent d6ed7b8a4d
commit e6f678bb52
4 changed files with 91 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

115
src/ikarus.bytevectors.ss
View File

@ -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)

8
src/makefile.ss
View File

@ -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]

8
src/todo-r6rs.ss
View File

@ -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]