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

* Added bytevector-uint-ref, bytevector-sint-ref, bytevector->uint-list, 

and bytevector->sint-list
This commit is contained in:
Abdulaziz Ghuloum 2007-05-15 19:27:36 -04:00
parent 3629e0b0d9
commit 4062b00c29
5 changed files with 208 additions and 6 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.

156
src/ikarus.bytevectors.ss
View File

@ -3,13 +3,17 @@
(export make-bytevector bytevector-length bytevector-s8-ref (export make-bytevector bytevector-length bytevector-s8-ref
bytevector-u8-ref bytevector-u8-set! bytevector-s8-set! bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!
bytevector-copy! u8-list->bytevector bytevector->u8-list bytevector-copy! u8-list->bytevector bytevector->u8-list
bytevector-fill! bytevector-copy bytevector=?) bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref
bytevector->uint-list bytevector->sint-list)
(import (import
(except (ikarus) (except (ikarus)
make-bytevector bytevector-length bytevector-s8-ref make-bytevector bytevector-length bytevector-s8-ref
bytevector-u8-ref bytevector-u8-set! bytevector-s8-set! bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!
bytevector-copy! u8-list->bytevector bytevector->u8-list bytevector-copy! u8-list->bytevector bytevector->u8-list
bytevector-fill! bytevector-copy bytevector=?) bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref
bytevector->uint-list bytevector->sint-list)
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $bytevectors)) (ikarus system $bytevectors))
@ -191,6 +195,154 @@
($bytevector-set! dst di ($bytevector-u8-ref src si)) ($bytevector-set! dst di ($bytevector-u8-ref src si))
(f src ($fxadd1 si) dst ($fxadd1 di) sj)))]))) (f src ($fxadd1 si) dst ($fxadd1 di) sj)))])))
(module (bytevector-uint-ref bytevector-sint-ref
bytevector->uint-list bytevector->sint-list)
(define (uref-big x ib il) ;; ib included, il excluded
(cond
[($fx= il ib) 0]
[else
(let ([b ($bytevector-u8-ref x ib)])
(cond
[($fx= b 0) (uref-big x ($fxadd1 ib) il)]
[else
(case ($fx- il ib)
[(1) b]
[(2) ($fx+ ($fxsll b 8)
($bytevector-u8-ref x ($fxsub1 il)))]
[(3)
($fx+ ($fxsll ($fx+ ($fxsll b 8)
($bytevector-u8-ref x ($fxadd1 ib)))
8)
($bytevector-u8-ref x ($fxsub1 il)))]
[else
(let ([im ($fxsra ($fx+ il ib) 1)])
(+ (uref-big x im il)
(* (uref-big x ib im)
(expt 256 ($fx- il im)))))])]))]))
(define (uref-little x il ib) ;; il included, ib excluded
(cond
[($fx= il ib) 0]
[else
(let ([ib^ ($fxsub1 ib)])
(let ([b ($bytevector-u8-ref x ib^)])
(cond
[($fx= b 0) (uref-little x il ib^)]
[else
(case ($fx- ib il)
[(1) b]
[(2) ($fx+ ($fxsll b 8) ($bytevector-u8-ref x il))]
[(3)
($fx+ ($fxsll ($fx+ ($fxsll b 8)
($bytevector-u8-ref x ($fxadd1 il)))
8)
($bytevector-u8-ref x il))]
[else
(let ([im ($fxsra ($fx+ il ib) 1)])
(+ (uref-little x il im)
(* (uref-little x im ib)
(expt 256 ($fx- im il)))))])])))]))
(define (sref-big x ib il) ;; ib included, il excluded
(cond
[($fx= il ib) -1]
[else
(let ([b ($bytevector-u8-ref x ib)])
(cond
[($fx= b 0) (uref-big x ($fxadd1 ib) il)]
[($fx= b 255) (sref-big-neg x ($fxadd1 ib) il)]
[($fx< b 128) (uref-big x ib il)]
[else (- (uref-big x ib il) (expt 256 ($fx- il ib)))]))]))
(define (sref-big-neg x ib il) ;; ib included, il excluded
(cond
[($fx= il ib) -1]
[else
(let ([b ($bytevector-u8-ref x ib)])
(cond
[($fx= b 255) (sref-big-neg x ($fxadd1 ib) il)]
[else (- (uref-big x ib il) (expt 256 ($fx- il ib)))]))]))
(define (sref-little x il ib) ;; il included, ib excluded
(cond
[($fx= il ib) -1]
[else
(let ([ib^ ($fxsub1 ib)])
(let ([b ($bytevector-u8-ref x ib^)])
(cond
[($fx= b 0) (uref-little x il ib^)]
[($fx= b 255) (sref-little-neg x il ib^)]
[($fx< b 128) (uref-little x il ib)]
[else (- (uref-little x il ib) (expt 256 ($fx- ib il)))])))]))
(define (sref-little-neg x il ib) ;; il included, ib excluded
(cond
[($fx= il ib) -1]
[else
(let ([ib^ ($fxsub1 ib)])
(let ([b ($bytevector-u8-ref x ib^)])
(cond
[($fx= b 255) (sref-little-neg x il ib^)]
[else (- (uref-little x il ib) (expt 256 ($fx- ib il)))])))]))
(define bytevector-sint-ref
(lambda (x k endianness size)
(define who 'bytevector-sint-ref)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
(let ([n ($bytevector-length x)])
(unless ($fx< k n) (error who "index ~s is out of range" k))
(let ([end ($fx+ k size)])
(unless (and ($fx>= end 0) ($fx<= end n))
(error who "~s+~s is out of range" k size))
(case endianness
[(little) (sref-little x k end)]
[(big) (sref-big x k end)]
[else (error who "invalid endianness ~s" endianness)])))))
(define bytevector-uint-ref
(lambda (x k endianness size)
(define who 'bytevector-uint-ref)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? k) ($fx>= k 0)) (error who "invalid index ~s" k))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
(let ([n ($bytevector-length x)])
(unless ($fx< k n) (error who "index ~s is out of range" k))
(let ([end ($fx+ k size)])
(unless (and ($fx>= end 0) ($fx<= end n))
(error who "~s+~s is out of range" k size))
(case endianness
[(little) (uref-little x k end)]
[(big) (uref-big x k end)]
[else (error who "invalid endianness ~s" endianness)])))))
(define (bytevector->some-list x k n ls proc who)
(cond
[($fx= n 0) ls]
[else
(let ([i ($fx- n k)])
(cond
[($fx>= i 0)
(bytevector->some-list x k i (cons (proc x i n) ls) proc who)]
[else
(error who "invalid size ~s" k)]))]))
(define bytevector->uint-list
(lambda (x endianness size)
(define who 'bytevector->uint-list)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
(case endianness
[(little) (bytevector->some-list x size ($bytevector-length x)
'() uref-little 'bytevector->uint-list)]
[(big) (bytevector->some-list x size ($bytevector-length x)
'() uref-big 'bytevector->uint-list)]
[else (error who "invalid endianness ~s" endianness)])))
(define bytevector->sint-list
(lambda (x endianness size)
(define who 'bytevector->sint-list)
(unless (bytevector? x) (error who "~s is not a bytevector" x))
(unless (and (fixnum? size) ($fx>= size 1)) (error who "invalid size ~s" size))
(case endianness
[(little) (bytevector->some-list x size ($bytevector-length x)
'() sref-little 'bytevector->sint-list)]
[(big) (bytevector->some-list x size ($bytevector-length x)
'() sref-big 'bytevector->sint-list)]
[else (error who "invalid endianness ~s" endianness)])))
)
) )

4
src/ikarus.numerics.ss
View File

@ -23,7 +23,7 @@
(library (ikarus generic-arithmetic) (library (ikarus generic-arithmetic)
(export + - * zero? = < <= > >= add1 sub1 quotient remainder (export + - * zero? = < <= > >= add1 sub1 quotient remainder
positive? positive? expt
quotient+remainder number->string string->number) quotient+remainder number->string string->number)
(import (import
(ikarus system $fx) (ikarus system $fx)
@ -31,7 +31,7 @@
(ikarus system $strings) (ikarus system $strings)
(except (ikarus) + - * zero? = < <= > >= add1 sub1 quotient (except (ikarus) + - * zero? = < <= > >= add1 sub1 quotient
remainder quotient+remainder number->string positive? remainder quotient+remainder number->string positive?
string->number)) string->number expt))
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))

5
src/makefile.ss
View File

@ -283,6 +283,10 @@
[bytevector-copy i] [bytevector-copy i]
[bytevector-fill! i] [bytevector-fill! i]
[bytevector=? i] [bytevector=? i]
[bytevector-uint-ref i]
[bytevector-sint-ref i]
[bytevector->uint-list i]
[bytevector->sint-list i]
[for-each i r] [for-each i r]
[map i r] [map i r]
@ -322,6 +326,7 @@
[+ i r] [+ i r]
[add1 i] [add1 i]
[sub1 i] [sub1 i]
[expt i]
[number? i r] [number? i r]
[bignum? i] [bignum? i]
[integer? i] [integer? i]

49
src/tests/bytevectors.ss
View File

@ -34,12 +34,57 @@
(bytevector-u8-ref b 0) (bytevector-u8-ref b 0)
(bytevector-s8-ref b 1) (bytevector-s8-ref b 1)
(bytevector-u8-ref b 1)))] (bytevector-u8-ref b 1)))]
[(lambda (x) (equal? x '(1 2 3 1 2 3 4 8))) [(lambda (x) (equal? x '(1 2 3 1 2 3 4 8)))
(let ([b (u8-list->bytevector '(1 2 3 4 5 6 7 8))]) (let ([b (u8-list->bytevector '(1 2 3 4 5 6 7 8))])
(bytevector-copy! b 0 b 3 4) (bytevector-copy! b 0 b 3 4)
(bytevector->u8-list b))] (bytevector->u8-list b))]
[(lambda (x) (= x 17))
(bytevector-uint-ref
(u8-list->bytevector '(17))
0 'little 1)]
[(lambda (x) (= x 17))
(bytevector-uint-ref
(u8-list->bytevector '(17))
0 'big 1)]
[(lambda (x) (= x (+ 17 (* 54 256))))
(bytevector-uint-ref
(u8-list->bytevector '(17 54))
0 'little 2)]
[(lambda (x) (= x (+ 17 (* 54 256))))
(bytevector-uint-ref
(u8-list->bytevector (reverse '(17 54)))
0 'big 2)]
[(lambda (x) (= x (+ 17 (* 54 256) (* 98 256 256))))
(bytevector-uint-ref
(u8-list->bytevector '(17 54 98))
0 'little 3)]
[(lambda (x) (= x (+ 17 (* 54 256) (* 98 256 256))))
(bytevector-uint-ref
(u8-list->bytevector (reverse '(17 54 98)))
0 'big 3)]
[(lambda (x) (= x (+ 17 (* 54 256) (* 98 256 256) (* 120 256 256 256))))
(bytevector-uint-ref
(u8-list->bytevector '(17 54 98 120))
0 'little 4)]
[(lambda (x) (= x #x123897348738947983174893204982390489))
(bytevector-uint-ref
(u8-list->bytevector
'(#x89 #x04 #x39 #x82 #x49 #x20 #x93 #x48 #x17
#x83 #x79 #x94 #x38 #x87 #x34 #x97 #x38 #x12))
0 'little 18)]
[(lambda (x) (= x #x123897348738947983174893204982390489))
(bytevector-uint-ref
(u8-list->bytevector
(reverse
'(#x89 #x04 #x39 #x82 #x49 #x20 #x93 #x48 #x17
#x83 #x79 #x94 #x38 #x87 #x34 #x97 #x38 #x12)))
0 'big 18)]
[(lambda (x) (equal? x '(513 65283 513 513)))
(let ([b (u8-list->bytevector '(1 2 3 255 1 2 1 2))])
(bytevector->uint-list b 'little 2))]
[(lambda (x) (equal? x '(513 -253 513 513)))
(let ([b (u8-list->bytevector '(1 2 3 255 1 2 1 2))])
(bytevector->sint-list b 'little 2))]
)) ))