summaryrefslogtreecommitdiffstats
path: root/logical.scm
diff options
context:
space:
mode:
Diffstat (limited to 'logical.scm')
-rw-r--r--logical.scm185
1 files changed, 71 insertions, 114 deletions
diff --git a/logical.scm b/logical.scm
index 90808e6..5ea47f5 100644
--- a/logical.scm
+++ b/logical.scm
@@ -1,5 +1,5 @@
;;;; "logical.scm", bit access and operations for integers for Scheme
-;;; Copyright (C) 1991, 1993, 2001, 2003 Aubrey Jaffer
+;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -17,20 +17,6 @@
;promotional, or sales literature without prior written consent in
;each case.
-;@
-(define integer-expt
- (if (provided? 'inexact)
- expt
- (lambda (n k)
- (do ((x n (* x x))
- (j k (quotient j 2))
- (acc 1 (if (even? j) acc (* x acc))))
- ((<= j 1)
- (case j
- ((0) acc)
- ((1) (* x acc))
- (else (slib:error 'integer-expt n k))))))))
-
(define logical:boole-xor
'#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
#(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14)
@@ -71,6 +57,13 @@
(if (negative? x)
(+ -1 (quotient (+ 1 x) 16))
(quotient x 16)))
+
+(define (logical:reduce op4 ident)
+ (lambda args
+ (do ((res ident (op4 res (car rgs) 1 0))
+ (rgs args (cdr rgs)))
+ ((null? rgs) res))))
+
;@
(define logand
(letrec
@@ -87,7 +80,7 @@
(modulo n2 16))
scl)
acc)))))))
- (lambda (n1 n2) (lgand n2 n1 1 0))))
+ (logical:reduce lgand -1)))
;@
(define logior
(letrec
@@ -105,7 +98,7 @@
(- 15 (modulo n2 16))))
scl)
acc)))))))
- (lambda (n1 n2) (lgior n2 n1 1 0))))
+ (logical:reduce lgior 0)))
;@
(define logxor
(letrec
@@ -122,46 +115,52 @@
(modulo n2 16))
scl)
acc)))))))
- (lambda (n1 n2) (lgxor n2 n1 1 0))))
+ (logical:reduce lgxor 0)))
;@
(define (lognot n) (- -1 n))
;@
(define (logtest n1 n2)
- (not (zero? (logical:logand n1 n2))))
+ (not (zero? (logand n1 n2))))
;@
(define (logbit? index n)
- (logical:logtest (logical:integer-expt 2 index) n))
+ (logtest (expt 2 index) n))
;@
(define (copy-bit index to bool)
(if bool
- (logical:logior to (logical:ash 1 index))
- (logical:logand to (logical:lognot (logical:ash 1 index)))))
-
-;;@ This procedure is careful not to use more than DEG bits in
-;; computing (- (expt 2 DEG) 1)
-(define (logical:ones deg)
- (if (zero? deg) 0 (+ (* 2 (+ -1 (logical:integer-expt 2 (- deg 1)))) 1)))
-;@
-(define (bit-field n start end)
- (logical:logand (logical:ones (- end start))
- (logical:ash n (- start))))
+ (logior to (arithmetic-shift 1 index))
+ (logand to (lognot (arithmetic-shift 1 index)))))
;@
(define (bitwise-if mask n0 n1)
- (logical:logior (logical:logand mask n0)
- (logical:logand (logical:lognot mask) n1)))
-;@
-(define (copy-bit-field to start end from)
- (logical:bitwise-if (logical:ash (logical:ones (- end start)) start)
- (logical:ash from start)
- to))
+ (logior (logand mask n0)
+ (logand (lognot mask) n1)))
;@
-(define (ash n count)
+(define (bit-field n start end)
+ (logand (lognot (ash -1 (- end start)))
+ (arithmetic-shift n (- start))))
+;@
+(define (copy-bit-field to from start end)
+ (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start)
+ (arithmetic-shift from start)
+ to))
+;@
+(define (rotate-bit-field n count start end)
+ (define width (- end start))
+ (set! count (modulo count width))
+ (let ((mask (lognot (ash -1 width))))
+ (define zn (logand mask (arithmetic-shift n (- start))))
+ (logior (arithmetic-shift
+ (logior (logand mask (arithmetic-shift zn count))
+ (arithmetic-shift zn (- count width)))
+ start)
+ (logand (lognot (ash mask start)) n))))
+;@
+(define (arithmetic-shift n count)
(if (negative? count)
- (let ((k (logical:integer-expt 2 (- count))))
+ (let ((k (expt 2 (- count))))
(if (negative? n)
(+ -1 (quotient (+ 1 n) k))
(quotient n k)))
- (* (logical:integer-expt 2 count) n)))
+ (* (expt 2 count) n)))
;@
(define integer-length
(letrec ((intlen (lambda (n tot)
@@ -183,30 +182,33 @@
(modulo n 16))
tot))))))
(lambda (n)
- (cond ((negative? n) (logcnt (logical:lognot n) 0))
+ (cond ((negative? n) (logcnt (lognot n) 0))
((positive? n) (logcnt n 0))
(else 0)))))
-
-;;;; Bit order and lamination
-;@
-(define (logical:rotate k count len)
- (set! count (modulo count len))
- (logical:logior (logical:logand (ash k count) (logical:ones len))
- (logical:ash k (- count len))))
;@
+(define (log2-binary-factors n)
+ (+ -1 (integer-length (logand n (- n)))))
+
(define (bit-reverse k n)
- (do ((m (if (negative? n) (lognot n) n) (ash m -1))
+ (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1))
(k (+ -1 k) (+ -1 k))
- (rvs 0 (logior (ash rvs 1) (logand 1 m))))
+ (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m))))
((negative? k) (if (negative? n) (lognot rvs) rvs))))
;@
+(define (reverse-bit-field n start end)
+ (define width (- end start))
+ (let ((mask (lognot (ash -1 width))))
+ (define zn (logand mask (arithmetic-shift n (- start))))
+ (logior (arithmetic-shift (bit-reverse width zn) start)
+ (logand (lognot (ash mask start)) n))))
+;@
(define (integer->list k . len)
(if (null? len)
- (do ((k k (ash k -1))
+ (do ((k k (arithmetic-shift k -1))
(lst '() (cons (odd? k) lst)))
((<= k 0) lst))
(do ((idx (+ -1 (car len)) (+ -1 idx))
- (k k (ash k -1))
+ (k k (arithmetic-shift k -1))
(lst '() (cons (odd? k) lst)))
((negative? idx) lst))))
;@
@@ -216,66 +218,21 @@
((null? bs) acc)))
(define (booleans->integer . bools)
(list->integer bools))
-;@
-(define (bitwise:laminate . ks)
- (define nks (length ks))
- (define nbs (apply max (map integer-length ks)))
- (do ((kdx (+ -1 nbs) (+ -1 kdx))
- (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks))
- (ash ibs nks))))
- ((negative? kdx) ibs)))
-;@
-(define (bitwise:delaminate count k)
- (define nbs (* count (+ 1 (quotient (integer-length k) count))))
- (do ((kdx (- nbs count) (- kdx count))
- (lst (vector->list (make-vector count 0))
- (map (lambda (k bool) (+ (if bool 1 0) (ash k 1)))
- lst
- (integer->list (ash k (- kdx)) count))))
- ((negative? kdx) lst)))
-;;;; Gray-code
-;@
-(define (integer->gray-code k)
- (logxor k (ash k -1)))
-;@
-(define (gray-code->integer k)
- (if (negative? k)
- (slib:error 'gray-code->integer 'negative? k)
- (let ((kln (integer-length k)))
- (do ((d 1 (* d 2))
- (ans (logxor k (ash k -1)) ; == (integer->gray-code k)
- (logxor ans (ash ans (* d -2)))))
- ((>= (* 2 d) kln) ans)))))
-
-(define (grayter k1 k2)
- (define kl1 (integer-length k1))
- (define kl2 (integer-length k2))
- (if (eqv? kl1 kl2)
- (> (gray-code->integer k1) (gray-code->integer k2))
- (> kl1 kl2)))
-;@
-(define (gray-code<? k1 k2)
- (not (or (eqv? k1 k2) (grayter k1 k2))))
-(define (gray-code<=? k1 k2)
- (or (eqv? k1 k2) (not (grayter k1 k2))))
-(define (gray-code>? k1 k2)
- (and (not (eqv? k1 k2)) (grayter k1 k2)))
-(define (gray-code>=? k1 k2)
- (or (eqv? k1 k2) (grayter k1 k2)))
+;;;;@ SRFI-60 aliases
+(define ash arithmetic-shift)
+(define bitwise-ior logior)
+(define bitwise-xor logxor)
+(define bitwise-and logand)
+(define bitwise-not lognot)
+(define bit-count logcount)
+(define bit-set? logbit?)
+(define any-bits-set? logtest)
+(define first-set-bit log2-binary-factors)
+(define bitwise-merge bitwise-if)
+(provide 'srfi-60)
-(define logical:logand logand)
-(define logical:logior logior)
-;;(define logical:logxor logxor)
-(define logical:lognot lognot)
-(define logical:logtest logtest)
-;;(define logical:logbit? logbit?)
-;;(define logical:copy-bit copy-bit)
-(define logical:ash ash)
-;;(define logical:logcount logcount)
-;;(define logical:integer-length integer-length)
-;;(define logical:bit-field bit-field)
-;;(define bit-extract bit-field)
-(define logical:bitwise-if bitwise-if)
-;;(define logical:copy-bit-field copy-bit-field)
-(define logical:integer-expt integer-expt)
+;;; Legacy
+;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len))
+;;(define (logical:ones deg) (lognot (ash -1 deg)))
+;;(define integer-expt expt) ; legacy name