diff --git a/src/ikarus.boot b/src/ikarus.boot index c7e6520..9362f18 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 025c80b..1618e12 100644 --- a/src/ikarus.bytevectors.ss +++ b/src/ikarus.bytevectors.ss @@ -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)])))) - - - - ) diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index 06027ee..f559d41 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -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) diff --git a/src/makefile.ss b/src/makefile.ss index bfbb517..bd9f664 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -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] diff --git a/src/tests/bytevectors.ss b/src/tests/bytevectors.ss index daab249..d53eef2 100644 --- a/src/tests/bytevectors.ss +++ b/src/tests/bytevectors.ss @@ -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))] ))