廃止された 「SRFI-33: 整数のビット演算ライブラリ」 に関する議論では、 手続きの名前や引数の個数に関して一貫性がないという欠点があった。 また、SRFI-47 のブール配列と競合している。
私は論理整数演算とブール配列の両方を実装してきたが、 それらの用途が競合するということはなかった。 私はブール配列を用いて、 何百万というレコードを持つデータベース テーブルの 非常に高速なインデックスを構築した。 RAM を使い切ってしまうことを避けるために、 100万ビットの配列を作成することが必要であった。 そのため、ブール配列の手続きは、その結果を引数に渡された配列に格納するようにした。 これに対して、この SRFI で述べる手続きは純粋に関数的である。
参照実装は Scheme の整数演算のみを用いて実装した。
補数 (complement) は負の整数を表現する方法である。 1 の補数の fixnum は、 -(2n) から 2n の範囲の整数であり、0 の表現は２通りある。 2 の補数の fixnum は、 -(2n+1) から 2n の範囲の整数である。
ここでは整数が 2 の補数の負数を持つと仮定しているので、 整数の 2 の補数は単にマイナスを付けたものになる。 整数の 1 の補数は lognot により計算できる。
(define (lognot n) (- -1 n))
「ビット演算」の節では、 直交で完全な関数群を定義するのではなく、 前述の応用例をサポートするのに十分なだけの、 最小限のビット論理関数を定義するようにした。
logior, logxor, logand のうちのいずれか２つがあれば、 (lognot を組み合わせることで) すべての２項論理関数を構成することはできるが、 この３つがあれば、 任意の自明でない２項論理関数は、 これらのうちの１つの２項論理関数と 0 回または 1 回の lognot の呼び出しで、合成することができる。
bitwise-if は SRFI-33 の bitwise-merge と同じものである。
SRFI-33 へのエイリアスである bitwise-ior, bitwise-xor, bitwise-and, bitwise-not, bitwise-merge, any-bits-set?, bit-count も提供する。
log2-binary-factors (first-set-bit のエイリアス) は単純で有用な関数であるが、その実装は分かりにくいだろう。
(define (log2-binary-factors n) (+ -1 (integer-length (logand n (- n)))))
copy-bit-field の引数の順序は、 「ビットのフィールド」の他の手続きと一貫するように変更した。 start と end インデックス引数は引数リストの最後に配置した。 この順序は substring や SRFI-47 の配列の引数の順序と同じである。
この start と end インデックス引数は、 SRFI-33 の bit-field 手続きの最初に指定する size および position 引数とは互換性がない。
slib/logical.scm で定義されている手続き logical:rotate は、指定された個数の下位ビットを指定されたビット数だけローテートしていた。 この関数は非常に便利だが、適切な名前を付けることができなかった。 私はこの関数を rotate-bit-field に置き換え、 start 引数を追加した。 この新しい関数は、整数内の指定されたフィールド (start から end まで) をローテートし、それ以外のビットには何もしない。
もう１つ、名前が適切でない手続きが logical:ones である。 この手続きは、下位の k ビットが 1 である整数を生成する。 この関数の代わりに bit-field を用意した。 しかし、その定義は短すぎるので、私は次のような定義に置き換えた。
(lognot (ash -1 k))
bit-reverse 手続きは width 引数をとる唯一の手続きであった。 そこで、私はそれを reverse-bit-field に置き換えた。
Lamination と Gray-code に関する関数は slib/phil-spc.scm に移動した。
例:
(number->string (logand #b1100 #b1010) 2)
=> "1000"
例:
(number->string (logior #b1100 #b1010) 2)
=> "1110"
例:
(number->string (logxor #b1100 #b1010) 2)
=> "110"
例:
(number->string (lognot #b10000000) 2)
=> "-10000001"
(number->string (lognot #b0) 2)
=> "-1"
(logtest j k) == (not (zero? (logand j k))) (logtest #b0100 #b1011) => #f (logtest #b0100 #b0111) => #t
例:
(logcount #b10101010)
=> 4
(logcount 0)
=> 0
(logcount -2)
=> 1
例:
(integer-length #b10101010)
=> 8
(integer-length 0)
=> 0
(integer-length #b1111)
=> 4
(require 'printf)
(do ((idx 0 (+ 1 idx)))
((> idx 16))
(printf "%s(%3d) ==> %-5d %s(%2d) ==> %-5d\n"
'log2-binary-factors
(- idx) (log2-binary-factors (- idx))
'log2-binary-factors
idx (log2-binary-factors idx)))
-|
log2-binary-factors( 0) ==> -1 log2-binary-factors( 0) ==> -1
log2-binary-factors( -1) ==> 0 log2-binary-factors( 1) ==> 0
log2-binary-factors( -2) ==> 1 log2-binary-factors( 2) ==> 1
log2-binary-factors( -3) ==> 0 log2-binary-factors( 3) ==> 0
log2-binary-factors( -4) ==> 2 log2-binary-factors( 4) ==> 2
log2-binary-factors( -5) ==> 0 log2-binary-factors( 5) ==> 0
log2-binary-factors( -6) ==> 1 log2-binary-factors( 6) ==> 1
log2-binary-factors( -7) ==> 0 log2-binary-factors( 7) ==> 0
log2-binary-factors( -8) ==> 3 log2-binary-factors( 8) ==> 3
log2-binary-factors( -9) ==> 0 log2-binary-factors( 9) ==> 0
log2-binary-factors(-10) ==> 1 log2-binary-factors(10) ==> 1
log2-binary-factors(-11) ==> 0 log2-binary-factors(11) ==> 0
log2-binary-factors(-12) ==> 2 log2-binary-factors(12) ==> 2
log2-binary-factors(-13) ==> 0 log2-binary-factors(13) ==> 0
log2-binary-factors(-14) ==> 1 log2-binary-factors(14) ==> 1
log2-binary-factors(-15) ==> 0 log2-binary-factors(15) ==> 0
log2-binary-factors(-16) ==> 4 log2-binary-factors(16) ==> 4
(logbit? index n) == (logtest (expt 2 index) n) (logbit? 0 #b1101) => #t (logbit? 1 #b1101) => #f (logbit? 2 #b1101) => #t (logbit? 3 #b1101) => #t (logbit? 4 #b1101) => #f
#t であれば 1 になり、
bit が #f であれば 0 になる。
例:
(number->string (copy-bit 0 0 #t) 2) => "1" (number->string (copy-bit 2 0 #t) 2) => "100" (number->string (copy-bit 2 #b1111 #f) 2) => "1011"
例:
(number->string (bit-field #b1101101010 0 4) 2)
=> "1010"
(number->string (bit-field #b1101101010 4 9) 2)
=> "10110"
例:
(number->string (copy-bit-field #b1101101010 0 0 4) 2)
=> "1101100000"
(number->string (copy-bit-field #b1101101010 -1 0 4) 2)
=> "1101101111"
(number->string (copy-bit-field #b110100100010000 -1 5 9) 2)
=> "110100111110000"
(inexact->exact (floor (* n (expt 2 count))))
例:
(number->string (ash #b1 3) 2)
=> "1000"
(number->string (ash #b1010 -1) 2)
=> "101"
例:
(number->string (rotate-bit-field #b0100 3 0 4) 2)
=> "10"
(number->string (rotate-bit-field #b0100 -1 0 4) 2)
=> "10"
(number->string (rotate-bit-field #b110100100010000 -1 5 9) 2)
=> "110100010010000"
(number->string (rotate-bit-field #b110100100010000 1 5 9) 2)
=> "110100000110000"
(number->string (reverse-bit-field #xa7 0 8) 16)
=> "e5"
integer->list は
len 個のブール値で構成されるリストを返す。
リストの各要素は整数の各ビットに対応し、
1 のビットは #t に、0 のビットは #f になる。
len 引数のデフォルトは (integer-length k) である。
list->integer はブール値リスト list
のビットで構成される整数を返す。
#t は 1 のビット、#f は 0 のビットになる。
integer->list と list->integer
は
equal?
で比較する限り、逆変換になる。
;;;; "logical.scm", bit access and operations for integers for Scheme
;;; 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
;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 warranty 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: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 (logical:ash-4 x)
(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
((lgand
(lambda (n2 n1 scl acc)
(cond ((= n1 n2) (+ acc (* scl n1)))
((zero? n2) acc)
((zero? n1) acc)
(else (lgand (logical:ash-4 n2)
(logical:ash-4 n1)
(* 16 scl)
(+ (* (vector-ref (vector-ref logical:boole-and
(modulo n1 16))
(modulo n2 16))
scl)
acc)))))))
(logical:reduce lgand -1)))
;@
(define logior
(letrec
((lgior
(lambda (n2 n1 scl acc)
(cond ((= n1 n2) (+ acc (* scl n1)))
((zero? n2) (+ acc (* scl n1)))
((zero? n1) (+ acc (* scl n2)))
(else (lgior (logical:ash-4 n2)
(logical:ash-4 n1)
(* 16 scl)
(+ (* (- 15 (vector-ref
(vector-ref logical:boole-and
(- 15 (modulo n1 16)))
(- 15 (modulo n2 16))))
scl)
acc)))))))
(logical:reduce lgior 0)))
;@
(define logxor
(letrec
((lgxor
(lambda (n2 n1 scl acc)
(cond ((= n1 n2) acc)
((zero? n2) (+ acc (* scl n1)))
((zero? n1) (+ acc (* scl n2)))
(else (lgxor (logical:ash-4 n2)
(logical:ash-4 n1)
(* 16 scl)
(+ (* (vector-ref (vector-ref logical:boole-xor
(modulo n1 16))
(modulo n2 16))
scl)
acc)))))))
(logical:reduce lgxor 0)))
;@
(define (lognot n) (- -1 n))
;@
(define (logtest n1 n2)
(not (zero? (logand n1 n2))))
;@
(define (logbit? index n)
(logtest (expt 2 index) n))
;@
(define (copy-bit index to bool)
(if bool
(logior to (arithmetic-shift 1 index))
(logand to (lognot (arithmetic-shift 1 index)))))
;@
(define (bitwise-if mask n0 n1)
(logior (logand mask n0)
(logand (lognot mask) n1)))
;@
(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 (expt 2 (- count))))
(if (negative? n)
(+ -1 (quotient (+ 1 n) k))
(quotient n k)))
(* (expt 2 count) n)))
;@
(define integer-length
(letrec ((intlen (lambda (n tot)
(case n
((0 -1) (+ 0 tot))
((1 -2) (+ 1 tot))
((2 3 -3 -4) (+ 2 tot))
((4 5 6 7 -5 -6 -7 -8) (+ 3 tot))
(else (intlen (logical:ash-4 n) (+ 4 tot)))))))
(lambda (n) (intlen n 0))))
;@
(define logcount
(letrec ((logcnt (lambda (n tot)
(if (zero? n)
tot
(logcnt (quotient n 16)
(+ (vector-ref
'#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
(modulo n 16))
tot))))))
(lambda (n)
(cond ((negative? n) (logcnt (lognot n) 0))
((positive? n) (logcnt n 0))
(else 0)))))
;@
(define (log2-binary-factors n)
(+ -1 (integer-length (logand n (- n)))))
(define (bit-reverse k n)
(do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1))
(k (+ -1 k) (+ -1 k))
(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 (arithmetic-shift k -1))
(lst '() (cons (odd? k) lst)))
((<= k 0) lst))
(do ((idx (+ -1 (car len)) (+ -1 idx))
(k k (arithmetic-shift k -1))
(lst '() (cons (odd? k) lst)))
((negative? idx) lst))))
;@
(define (list->integer bools)
(do ((bs bools (cdr bs))
(acc 0 (+ acc acc (if (car bs) 1 0))))
((null? bs) acc)))
(define (booleans->integer . bools)
(list->integer bools))
;;;;@ 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)
;;; 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
Copyright (C) Aubrey Jaffer (2004, 2005). All Rights Reserved.
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.