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

added fxrotate-bit-field

This commit is contained in:
Abdulaziz Ghuloum 2008-07-27 10:53:31 -07:00
parent 282fa962a8
commit d84dd99061
3 changed files with 51 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/ikarus.not-yet-implemented.ss
View File

@ -3,7 +3,6 @@
(export (export
bitwise-copy-bit-field bitwise-reverse-bit-field bitwise-copy-bit-field bitwise-reverse-bit-field
bitwise-rotate-bit-field bitwise-if fxreverse-bit-field bitwise-rotate-bit-field bitwise-if fxreverse-bit-field
fxrotate-bit-field
make-custom-binary-input/output-port make-custom-binary-input/output-port
make-custom-textual-input/output-port make-custom-textual-input/output-port
open-file-input/output-port output-port-buffer-mode open-file-input/output-port output-port-buffer-mode
@ -18,7 +17,6 @@
(import (except (ikarus) (import (except (ikarus)
bitwise-copy-bit-field bitwise-reverse-bit-field bitwise-copy-bit-field bitwise-reverse-bit-field
bitwise-rotate-bit-field bitwise-if fxreverse-bit-field bitwise-rotate-bit-field bitwise-if fxreverse-bit-field
fxrotate-bit-field
make-custom-binary-input/output-port make-custom-binary-input/output-port
make-custom-textual-input/output-port make-custom-textual-input/output-port
open-file-input/output-port output-port-buffer-mode open-file-input/output-port output-port-buffer-mode
@ -57,7 +55,7 @@
string-downcase string-titlecase string-upcase string-downcase string-titlecase string-upcase
bitwise-if bitwise-if
bitwise-rotate-bit-field bitwise-copy-bit-field bitwise-reverse-bit-field bitwise-rotate-bit-field bitwise-copy-bit-field bitwise-reverse-bit-field
fxreverse-bit-field fxrotate-bit-field fxreverse-bit-field
;;; not top priority at the moment ;;; not top priority at the moment
make-eqv-hashtable make-hashtable equal-hash make-eqv-hashtable make-hashtable equal-hash
hashtable-hash-function hashtable-equivalence-function hashtable-hash-function hashtable-equivalence-function

65
scheme/ikarus.numerics.ss
View File

@ -2731,21 +2731,24 @@
[($fx= x 1) 0] [($fx= x 1) 0]
[($fx= x 0) (die 'log "undefined around 0")] [($fx= x 0) (die 'log "undefined around 0")]
[($fx> x 0) (foreign-call "ikrt_fx_log" x)] [($fx> x 0) (foreign-call "ikrt_fx_log" x)]
[else (die 'log "negative argument" x)])] [else (make-rectangular (log (- x)) (acos -1))])]
[(flonum? x) [(flonum? x)
(cond (cond
[(>= x 0) (foreign-call "ikrt_fl_log" x)] [(fl>=? x 0.0) (foreign-call "ikrt_fl_log" x)]
[else (die 'log "negative argument" x)])] [else
(make-rectangular
(log (fl- 0.0 x))
(acos -1))])]
[(bignum? x) [(bignum? x)
(unless ($bignum-positive? x) (if ($bignum-positive? x)
(die 'log "negative argument" x)) (let ([v (log (inexact x))])
(let ([v (log (inexact x))]) (cond
(cond [(infinite? v)
[(infinite? v) (let-values ([(s r) (exact-integer-sqrt x)])
(let-values ([(s r) (exact-integer-sqrt x)]) ;;; could the [dropped] residual ever affect the answer?
;;; could the [dropped] residual ever affect the answer? (fl* 2.0 (log s)))]
(fl* 2.0 (log s)))] [else v]))
[else v]))] (make-rectangular (log (- x)) (acos -1)))]
[(ratnum? x) [(ratnum? x)
;;; FIXME: incorrect as per bug 180170 ;;; FIXME: incorrect as per bug 180170
(- (log (numerator x)) (log (denominator x)))] (- (log (numerator x)) (log (denominator x)))]
@ -3129,7 +3132,7 @@
(if (flfinite? x) (if (flfinite? x)
(cond (cond
[(flonum? eps) [(flonum? eps)
(if (flfinite? eps) (go x eps) +nan.0)] (if (flfinite? eps) (go x eps) +0.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps)) [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)] (go x eps)]
[else (die who "not a number" eps)]) [else (die who "not a number" eps)])
@ -3142,7 +3145,7 @@
[(or (fixnum? x) (bignum? x) (ratnum? x)) [(or (fixnum? x) (bignum? x) (ratnum? x))
(cond (cond
[(flonum? eps) [(flonum? eps)
(if (flfinite? eps) (go x eps) +nan.0)] (if (flfinite? eps) (go x eps) +0.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps)) [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)] (go x eps)]
[else (die who "not a number" eps)])] [else (die who "not a number" eps)])]
@ -3430,7 +3433,7 @@
fxlength fxlength
fxbit-set? fxbit-set?
fxcopy-bit fxcopy-bit
fxcopy-bit-field fxcopy-bit-field fxrotate-bit-field
fxbit-field) fxbit-field)
(import (import
(ikarus system $fx) (ikarus system $fx)
@ -3442,7 +3445,7 @@
fxlength fxlength
fxbit-set? fxbit-set?
fxcopy-bit fxcopy-bit
fxcopy-bit-field fxcopy-bit-field fxrotate-bit-field
fxbit-field)) fxbit-field))
(module (bitwise-first-bit-set fxfirst-bit-set) (module (bitwise-first-bit-set fxfirst-bit-set)
@ -3652,6 +3655,36 @@
(die who "not a fixnum" i)) (die who "not a fixnum" i))
(die who "not a fixnum" x))) (die who "not a fixnum" x)))
(define ($fxrotate-bit-field x i j c w)
(let ([m ($fxsll ($fxsub1 ($fxsll 1 w)) i)])
(let ([x0 ($fxlogand x m)])
(let ([lt ($fxsll x0 c)] [rt ($fxsra x0 ($fx- w c))])
(let ([x0 ($fxlogand ($fxlogor lt rt) m)])
($fxlogor x0 ($fxlogand x ($fxlognot m))))))))
(define (fxrotate-bit-field x i j c)
(define who 'fxrotate-bit-field)
(if (fixnum? x)
(if (fixnum? i)
(if ($fx>= i 0)
(if (fixnum? j)
(if ($fx< j (fixnum-width))
(let ([w ($fx- j i)])
(if ($fx>= w 0)
(if (fixnum? c)
(if (and ($fx>= c 0) ($fx< c w))
($fxrotate-bit-field x i j c w)
(die who "count is invalid" c))
(die who "count is not a fixnum" c))
(die who "field width is negative" i j)))
(die who "end index is out of range" j))
(die who "end index is not a fixnum" j))
(die who "start index is out of range" i))
(die who "start index is not a fixnum" i))
(die who "not a fixnum" x)))
(define (fxbit-field x i j) (define (fxbit-field x i j)
(define who 'fxbit-field) (define who 'fxbit-field)
(if (fixnum? x) (if (fixnum? x)

2
scheme/last-revision
View File

@ -1 +1 @@
1557 1558