diff options
Diffstat (limited to 'logical.scm')
| -rw-r--r-- | logical.scm | 185 |
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 |