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

* bytevector-sint-set! is almost ok.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-16 11:05:06 -04:00
parent e3bb91ad08
commit 8f885aa848
5 changed files with 233 additions and 28 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.

189
src/ikarus.bytevectors.ss
View File

@ -5,7 +5,7 @@
bytevector-copy! u8-list->bytevector bytevector->u8-list
bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref
bytevector-uint-set!
bytevector-uint-set! bytevector-sint-set!
bytevector->uint-list bytevector->sint-list)
(import
(except (ikarus)
@ -14,9 +14,10 @@
bytevector-copy! u8-list->bytevector bytevector->u8-list
bytevector-fill! bytevector-copy bytevector=?
bytevector-uint-ref bytevector-sint-ref
bytevector-uint-set!
bytevector-uint-set! bytevector-sint-set!
bytevector->uint-list bytevector->sint-list)
(ikarus system $fx)
(ikarus system $bignums)
(ikarus system $pairs)
(ikarus system $bytevectors))
@ -344,42 +345,178 @@
'() sref-big 'bytevector->sint-list)]
[else (error who "invalid endianness ~s" endianness)]))))
(module (bytevector-uint-set!)
(define (little-uint-set! x k n size)
(module (bytevector-uint-set! bytevector-sint-set!)
(define (lufx-set! x k1 n k2 who no)
(cond
[($fx= size 0)
(unless (zero? n)
(error 'bytevector-uint-set! "value out of range"))]
[($fx= k1 k2)
(unless ($fxzero? n)
(error who "number ~s does not fit" no))]
[else
(let-values ([(q r) (quotient+remainder n 256)])
(little-uint-set! x ($fxadd1 k) q ($fxsub1 size))
($bytevector-set! x k r))]))
(define (big-uint-set! x k1 n k2)
(lufx-set! x ($fxadd1 k1) ($fxsra n 8) k2 who no)
($bytevector-set! x k1 ($fxlogand n 255))]))
(define (lsfx-set! x k1 n k2 who no)
(cond
[($fx= k1 k2)
(unless (zero? n)
(error 'bytevector-uint-set! "value out of range"))]
[($fx= k1 k2)
(unless ($fx= n -1) ;;; BUG: does not catch all errors
(error who "number ~s does not fit" no))]
[else
(let-values ([(q r) (quotient+remainder n 256)])
(let ([k2 ($fxsub1 k2)])
(big-uint-set! x k1 q k2)
($bytevector-set! x k2 r)))]))
(lsfx-set! x ($fxadd1 k1) ($fxsra n 8) k2 who no)
($bytevector-set! x k1 ($fxlogand n 255))]))
(define (bufx-set! x k1 n k2 who no)
(cond
[($fx= k1 k2)
(unless ($fxzero? n)
(error who "number ~s does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bufx-set! x k1 ($fxsra n 8) k2 who no)
($bytevector-set! x k2 ($fxlogand n 255)))]))
(define (bsfx-set! x k1 n k2 who no)
(cond
[($fx= k1 k2)
(unless ($fx= n -1)
(error who "number ~s does not fit" no))]
[else
(let ([k2 ($fxsub1 k2)])
(bsfx-set! x k1 ($fxsra n 8) k2 who no)
($bytevector-set! x k2 ($fxlogand n 255)))]))
(define (lbn-copy! x k n i j)
(unless ($fx= i j)
($bytevector-set! x k ($bignum-byte-ref n i))
(lbn-copy! x ($fxadd1 k) n ($fxadd1 i) j)))
(define (bbn-copy! x k n i j)
(unless ($fx= i j)
(let ([k ($fxsub1 k)])
($bytevector-set! x k ($bignum-byte-ref n i))
(bbn-copy! x k n ($fxadd1 i) j))))
(define (bv-zero! x i j)
(unless ($fx= i j)
($bytevector-set! x i 0)
(bv-zero! x ($fxadd1 i) j)))
(define (lbn-neg-copy! x xi n ni xj nj c)
(cond
[($fx= ni nj)
(case ($fxsra c 7)
[(#x01) ;;; borrow is 0, last byte was negative
(bv-neg-zero! x xi xj)]
[(#x00) ;;; borrow is 0, last byte was positive
(if ($fx< xi xj)
(bv-neg-zero! x xi xj)
(error 'bytevector-sint-set! "number ~s does not fit" n))]
[else (error 'lbn-neg-copy! "BUG: not handled ~s" c)])]
[else
(let ([c ($fx- ($fx+ 255 ($fxsra c 8)) ($bignum-byte-ref n ni))])
(lbn-neg-copy! x ($fxadd1 xi) n ($fxadd1 ni) xj nj c)
($bytevector-set! x xi ($fxlogand c 255)))]))
(define (lbn-pos-copy! x xi n ni nj xj c)
(cond
[($fx= ni nj)
(cond
[(or ($fx<= c 127) ($fx< xi xj))
;;; last byte was positive
(bv-zero! x xi xj)]
[else
(error 'bytevector-sint-set! "number ~s does not fit" n)])]
[else
(let ([c ($bignum-byte-ref n ni)])
(lbn-pos-copy! x ($fxadd1 xi) n ($fxadd1 ni) nj xj c)
($bytevector-set! x xi ($fxlogand c 255)))]))
(define (bv-neg-zero! x i j)
(unless ($fx= i j)
($bytevector-set! x i 255)
(bv-neg-zero! x ($fxadd1 i) j)))
(define (bignum-bytes n)
(let ([i ($bignum-size n)])
(let ([i-1 ($fxsub1 i)])
(if ($fxzero? ($bignum-byte-ref n i-1))
(let ([i-2 ($fxsub1 i-1)])
(if ($fxzero? ($bignum-byte-ref n i-2))
(let ([i-3 ($fxsub1 i-2)])
(if ($fxzero? ($bignum-byte-ref n i-3))
(let ([i-4 ($fxsub1 i-3)])
(if ($fxzero? ($bignum-byte-ref n i-4))
(error 'bignum-bytes "BUG: malformed bignum")
i-3))
i-2))
i-1))
i))))
(define bytevector-uint-set!
(lambda (x k n endianness size)
(define who 'bytevector-uint-set!)
(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))
(unless (or (and (fixnum? n) ($fx>= n 0)) (and (bignum? n) (>= n 0)))
(error who "invalid value ~s" n))
(case endianness
[(little) (little-uint-set! x k n size)]
[(big) (big-uint-set! x k n ($fx+ k size))]
[(little)
(cond
[(fixnum? n) (lufx-set! x k n ($fx+ k size) who n)]
[(bignum? n)
(if ($bignum-positive? n)
(let ([sz (bignum-bytes n)])
(cond
[($fx= sz size)
(lbn-copy! x k n 0 sz)]
[($fx< sz size)
(lbn-copy! x k n 0 sz)
(bv-zero! x ($fx+ k sz) ($fx+ k size))]
[else (error who "number ~s does not fit" n)]))
(error who "value ~s must be positive" n))]
[else (error who "invalid value argument ~s" n)])]
[(big)
(cond
[(fixnum? n) (bufx-set! x k n ($fx+ k size) who n)]
[(bignum? n)
(if ($bignum-positive? n)
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(bbn-copy! x ($fx+ k size) n 0 sz)]
[($fx< sz size)
(bbn-copy! x ($fx+ k size) n 0 sz)
(bv-zero! x k ($fx+ k ($fx- size sz)))]
[else (error who "number ~s does not fit" n)]))
(error who "value ~s must be positive" n))]
[else (error who "invalid value argument ~s" n)])]
[else (error who "invalid endianness ~s" endianness)])))
(define bytevector-sint-set!
(lambda (x k n endianness size)
(define who 'bytevector-sint-set!)
(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))
(case endianness
[(little)
(cond
[(fixnum? n) (lsfx-set! x k n ($fx+ k size) who n)]
[(bignum? n)
(if ($bignum-positive? n)
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(lbn-pos-copy! x k n 0 size sz 255)]
[else (error who "number ~s does not fit" n)]))
(let ([sz (bignum-bytes n)])
(cond
[($fx<= sz size)
(lbn-neg-copy! x k n 0 size sz 256)]
[else (error who "number ~s does not fit" n)])))]
[else (error who "invalid value argument ~s" n)])]
[(big)
(cond
[(fixnum? n) (bsfx-set! x k n ($fx+ k size) who n)]
;[(bignum? n)
; (if ($bignum-positive? n)
; (let ([sz ($bignum-size n)])
; (cond
; [($fx<= sz size)
; (bbn-copy! x ($fx+ k size) n 0 sz)]
; [($fx< sz size)
; (bbn-copy! x ($fx+ k size) n 0 sz)
; (bv-zero! x k ($fx+ k ($fx- size sz)))]
; [else (error who "number ~s does not fit" n)]))
; (error who "value ~s must be positive" n))]
[else (error who "invalid value argument ~s" n)])]
[else (error who "invalid endianness ~s" endianness)]))))
)

27
src/ikarus.compiler.ss
View File

@ -133,6 +133,12 @@
[$bytevector-u8-ref 2 value]
[$bytevector-s8-ref 2 value]
[$bytevector-set! 3 effect]
;;; bignums
[$make-bignum 2 value]
[$bignum-positive? 1 pred]
[$bignum-size 1 value]
[$bignum-byte-ref 2 value]
[$bignum-byte-set! 3 effect]
;;; symbols
[$make-symbol 1 value]
[$symbol-value 1 value]
@ -1925,6 +1931,7 @@
port? input-port? output-port? $bytevector-set!
$bytevector-length $bytevector-u8-ref $bytevector-s8-ref
$make-bytevector $bytevector-ref bytevector?
$bignum-byte-ref $bignum-positive? $bignum-size
$make-port/input $make-port/output $make-port/both
$port-handler
$port-input-buffer $port-input-index $port-input-size
@ -3261,6 +3268,12 @@
[($fx<= $char<=) (compare-and-branch 'jle rand* Lt Lf ac)]
[($fx> $char>) (compare-and-branch 'jg rand* Lt Lf ac)]
[($fx>= $char>=) (compare-and-branch 'jge rand* Lt Lf ac)]
[($bignum-positive?)
(list*
(movl (Simple (car rand*)) eax)
(movl (mem (- 0 record-tag) eax) eax)
(andl (int bignum-sign-mask) eax)
(cond-branch 'je Lt Lf ac))]
[(vector?)
(indirect-type-pred vector-mask vector-tag fx-mask fx-tag
rand* Lt Lf ac)]
@ -3668,6 +3681,12 @@
(indirect-ref arg* (fx- disp-bytevector-length bytevector-tag) ac)]
[($string-length)
(indirect-ref arg* (fx- disp-string-length string-tag) ac)]
[($bignum-size)
(indirect-ref arg* (fx- 0 record-tag)
(list*
(sarl (int bignum-length-shift) eax)
(sall (int (* 2 fx-shift)) eax)
ac))]
[($symbol-string)
(indirect-ref arg* (fx- disp-symbol-record-string record-tag) ac)]
[($symbol-unique-string)
@ -3802,6 +3821,14 @@
(movb (mem (fx- disp-bytevector-data bytevector-tag) ebx) al)
(sall (int fx-shift) eax)
ac)]
[($bignum-byte-ref)
(list* (movl (Simple (cadr arg*)) ebx)
(sarl (int fx-shift) ebx)
(addl (Simple (car arg*)) ebx)
(movl (int 0) eax)
(movb (mem (fx- disp-bignum-data record-tag) ebx) al)
(sall (int fx-shift) eax)
ac)]
[($string-ref)
(list* (movl (Simple (cadr arg*)) ebx)
(sarl (int fx-shift) ebx)

3
src/makefile.ss
View File

@ -286,6 +286,7 @@
[bytevector-uint-ref i]
[bytevector-sint-ref i]
[bytevector-uint-set! i]
[bytevector-sint-set! i]
[bytevector->uint-list i]
[bytevector->sint-list i]
@ -500,7 +501,7 @@
[$bytevector-set! $bytes]
[$make-bignum $bignums]
[$bignum-sign $bignums]
[$bignum-positive? $bignums]
[$bignum-size $bignums]
[$bignum-byte-ref $bignums]
[$bignum-byte-set! $bignums]

42
src/tests/bytevectors.ss
View File

@ -107,7 +107,47 @@
(bytevector->u8-list b)))]
[(lambda (x) (equal? x '(1 2 3 4)))
(bytevector->u8-list '#vu8(1 2 3 4))]
[(lambda (x) (= x #xFFFFFFFF))
(let ([b (make-bytevector 4 0)])
(bytevector-sint-set! b 0 -1 'little 4)
(bytevector-uint-ref b 0 'little 4))]
[(lambda (x) (= x #xFFFFFF00))
(let ([b (make-bytevector 4 0)])
(bytevector-sint-set! b 0 -256 'little 4)
(bytevector-uint-ref b 0 'little 4))]
[(lambda (x) (= x #xFFFF0000))
(let ([b (make-bytevector 4 0)])
(bytevector-sint-set! b 0 (- (expt 256 2)) 'little 4)
(bytevector-uint-ref b 0 'little 4))]
[(lambda (x) (= x #xFFFFFFFFFFFF0000))
(let ([b (make-bytevector 8 0)])
(bytevector-sint-set! b 0 (- (expt 256 2)) 'little 8)
(bytevector-uint-ref b 0 'little 8))]
[(lambda (x) (= x #xFFFFFFFF00000000))
(let ([b (make-bytevector 8 0)])
(bytevector-sint-set! b 0 (- (expt 256 4)) 'little 8)
(bytevector-uint-ref b 0 'little 8))]
[(lambda (x) (= x #xFF00000000000000))
(let ([b (make-bytevector 8 0)])
(bytevector-sint-set! b 0 (- (expt 256 7)) 'little 8)
(bytevector-uint-ref b 0 'little 8))]
[(lambda (x) (= x (- 1 (expt 2 63))))
(let ([b (make-bytevector 8 0)])
(bytevector-sint-set! b 0 (- 1 (expt 2 63)) 'little 8)
(bytevector-sint-ref b 0 'little 8))]
[(lambda (x) (= x #x7FFFFFFF))
(let ([b (make-bytevector 4 38)])
(bytevector-sint-set! b 0 (sub1 (expt 2 31)) 'little 4)
(bytevector-sint-ref b 0 'little 4))]
[(lambda (x) (= x #x-80000000))
(let ([b (make-bytevector 4 38)])
(bytevector-sint-set! b 0 (- (expt 2 31)) 'little 4)
(bytevector-sint-ref b 0 'little 4))]
[(lambda (x) (= x #x-100000000))
(let ([b (make-bytevector 5 38)])
(bytevector-sint-set! b 0 (- (expt 2 32)) 'little 5)
(printf "b=~s\n" b)
(bytevector-sint-ref b 0 'little 5))]
))