diff options
Diffstat (limited to 'logical.scm')
| -rw-r--r-- | logical.scm | 150 |
1 files changed, 150 insertions, 0 deletions
diff --git a/logical.scm b/logical.scm new file mode 100644 index 0000000..1cc0726 --- /dev/null +++ b/logical.scm @@ -0,0 +1,150 @@ +;;;; "logical.scm", bit access and operations for integers for Scheme +;;; Copyright (C) 1991, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define logical:integer-expt + (if (provided? 'inexact) + expt + (lambda (n k) + (logical:ipow-by-squaring n k 1 *)))) + +(define (logical:ipow-by-squaring x k acc proc) + (cond ((zero? k) acc) + ((= 1 k) (proc acc x)) + (else (logical:ipow-by-squaring (proc x x) + (quotient k 2) + (if (even? k) acc (proc acc x)) + proc)))) + +(define (logical:logand n1 n2) + (cond ((= n1 n2) n1) + ((zero? n1) 0) + ((zero? n2) 0) + (else + (+ (* (logical:logand (logical:ash-4 n1) (logical:ash-4 n2)) 16) + (vector-ref (vector-ref logical:boole-and (modulo n1 16)) + (modulo n2 16)))))) + +(define (logical:logior n1 n2) + (cond ((= n1 n2) n1) + ((zero? n1) n2) + ((zero? n2) n1) + (else + (+ (* (logical:logior (logical:ash-4 n1) (logical:ash-4 n2)) 16) + (- 15 (vector-ref (vector-ref logical:boole-and + (- 15 (modulo n1 16))) + (- 15 (modulo n2 16)))))))) + +(define (logical:logxor n1 n2) + (cond ((= n1 n2) 0) + ((zero? n1) n2) + ((zero? n2) n1) + (else + (+ (* (logical:logxor (logical:ash-4 n1) (logical:ash-4 n2)) 16) + (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) + (modulo n2 16)))))) + +(define (logical:lognot n) (- -1 n)) + +(define (logical:logtest int1 int2) + (not (zero? (logical:logand int1 int2)))) + +(define (logical:logbit? index int) + (logical:logtest (logical:integer-expt 2 index) int)) + +(define (logical:bit-extract n start end) + (logical:logand (- (logical:integer-expt 2 (- end start)) 1) + (logical:ash n (- start)))) + +(define (logical:ash int cnt) + (if (negative? cnt) + (let ((n (logical:integer-expt 2 (- cnt)))) + (if (negative? int) + (+ -1 (quotient (+ 1 int) n)) + (quotient int n))) + (* (logical:integer-expt 2 cnt) int))) + +(define (logical:ash-4 x) + (if (negative? x) + (+ -1 (quotient (+ 1 x) 16)) + (quotient x 16))) + +(define (logical:logcount n) + (cond ((zero? n) 0) + ((negative? n) (logical:logcount (logical:lognot n))) + (else + (+ (logical:logcount (logical:ash-4 n)) + (vector-ref '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4) + (modulo n 16)))))) + +(define (logical:integer-length n) + (case n + ((0 -1) 0) + ((1 -2) 1) + ((2 3 -3 -4) 2) + ((4 5 6 7 -5 -6 -7 -8) 3) + (else (+ 4 (logical:integer-length (logical:ash-4 n)))))) + +(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) + #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13) + #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12) + #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11) + #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10) + #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9) + #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) + #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7) + #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6) + #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5) + #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) + #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3) + #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) + #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1) + #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0))) + +(define logical:boole-and + '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) + #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1) + #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2) + #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3) + #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4) + #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5) + #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6) + #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7) + #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8) + #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9) + #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10) + #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11) + #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12) + #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13) + #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) + +(define logand logical:logand) +(define logior logical:logior) +(define logxor logical:logxor) +(define lognot logical:lognot) +(define logtest logical:logtest) +(define logbit? logical:logbit?) +(define ash logical:ash) +(define logcount logical:logcount) +(define integer-length logical:integer-length) +(define bit-extract logical:bit-extract) +(define ipow-by-squaring logical:ipow-by-squaring) +(define integer-expt logical:integer-expt) |