251 lines
8.2 KiB
Scheme
251 lines
8.2 KiB
Scheme
;; SRFI-151 r6rs library implementation
|
|
;;
|
|
;; The following contains a combination of R6RS implementation along with
|
|
;; implementations pulled from the SRFI-151 implementation.
|
|
;;
|
|
;; The R6RS wrappers and simple functions are:
|
|
;; Copyright (c) 2018 - 2020 Andrew W. Keep
|
|
;;
|
|
;; The bitwise-eqv implementation is based on the Olin Shiver's SRFI-33
|
|
;; implementation from the SRFI-151 example library:
|
|
;; Olin Shivers is the sole author of this code, and he has placed it in the
|
|
;; public domain.
|
|
;;
|
|
;; The bitwise-fold, bitwise-for-each, bitwise-unfold, and
|
|
;; make-bitwise-generator functions are pulled from John Cowan's SRFI-151
|
|
;; implementation and are:
|
|
;; Copyright John Cowan 2017
|
|
|
|
#!r6rs
|
|
(library (srfi srfi-151)
|
|
(export
|
|
bitwise-not
|
|
bitwise-and bitwise-ior
|
|
bitwise-xor bitwise-eqv
|
|
bitwise-nand bitwise-nor
|
|
bitwise-andc1 bitwise-andc2
|
|
bitwise-orc1 bitwise-orc2
|
|
|
|
arithmetic-shift bit-count
|
|
integer-length bitwise-if
|
|
|
|
bit-set? copy-bit bit-swap
|
|
any-bit-set? every-bit-set?
|
|
first-set-bit
|
|
|
|
bit-field bit-field-any? bit-field-every?
|
|
bit-field-clear bit-field-set
|
|
bit-field-replace bit-field-replace-same
|
|
bit-field-rotate bit-field-reverse
|
|
|
|
bits->list list->bits bits->vector vector->bits
|
|
bits
|
|
bitwise-fold bitwise-for-each bitwise-unfold
|
|
make-bitwise-generator)
|
|
(import (rnrs))
|
|
|
|
;;; The bitwise-eqv implmentation is based on the one in the SRFI-151
|
|
;;; implementation, which extracted it from the SRFI-33 implementation which
|
|
;;; carried the following copyright information:
|
|
;;;
|
|
;;; Olin Shivers is the sole author of this code, and he has placed it in
|
|
;;; the public domain.
|
|
;;;
|
|
;;; A good implementation might choose to provide direct compiler/interpreter
|
|
;;; support for these derived functions, or might simply define them to be
|
|
;;; integrable -- i.e., inline-expanded.
|
|
;;;
|
|
;;; This is a general definition, but less than efficient. It should also
|
|
;;; receive primitive compiler/interpreter support so that the expensive
|
|
;;; n-ary mechanism is not invoked in the standard cases -- that is,
|
|
;;; an application of BITWISE-EQV should be rewritten into an equivalent
|
|
;;; tree applying some two-argument primitive to the arguments, in the
|
|
;;; same manner that statically-known n-ary applications of associative
|
|
;;; operations such as + and * are handled efficiently:
|
|
;;; (bitwise-eqv) => -1
|
|
;;; (bitwise-eqv i) => i
|
|
;;; (bitwise-eqv i j) => (%bitwise-eqv i j)
|
|
;;; (bitwise-eqv i j k) => (%bitwise-eqv (%bitwise-eqv i j) k)
|
|
;;; (bitwise-eqv i j k l) => (%bitwise-eqv (%bitwise-eqv (%bitwise-eqv i j) k) l)
|
|
;;;
|
|
;;; Note: this implementation takes the advice of the comment avove and
|
|
;;; implemets this using case lambade, though Chez Scheme's source optimizer
|
|
;;; is relied upon to produce the constants.
|
|
(define bitwise-eqv
|
|
(case-lambda
|
|
[() (bitwise-not (bitwise-xor))]
|
|
[(i) (bitwise-not (bitwise-xor i))]
|
|
[(i j) (bitwise-not (bitwise-xor i j))]
|
|
[(i . more)
|
|
(let loop ([i i] [more more])
|
|
(if (null? more)
|
|
i
|
|
(loop (bitwise-not (bitwise-xor i (car more))) (cdr more))))]))
|
|
|
|
(define bitwise-nand (lambda (i j) (bitwise-not (bitwise-and i j))))
|
|
(define bitwise-nor (lambda (i j) (bitwise-not (bitwise-ior i j))))
|
|
(define bitwise-andc1 (lambda (i j) (bitwise-and (bitwise-not i) j)))
|
|
(define bitwise-andc2 (lambda (i j) (bitwise-and i (bitwise-not j))))
|
|
(define bitwise-orc1 (lambda (i j) (bitwise-ior (bitwise-not i) j)))
|
|
(define bitwise-orc2 (lambda (i j) (bitwise-ior i (bitwise-not j))))
|
|
|
|
(define arithmetic-shift (lambda (i c) (bitwise-arithmetic-shift i c)))
|
|
|
|
(define bit-count
|
|
(lambda (i)
|
|
(if (< i 0)
|
|
(bitwise-bit-count (bitwise-not i))
|
|
(bitwise-bit-count i))))
|
|
|
|
(define integer-length (lambda (i) (bitwise-length i)))
|
|
|
|
(define bit-set? (lambda (index i) (bitwise-bit-set? i index)))
|
|
|
|
(define copy-bit
|
|
(lambda (index i bool)
|
|
(bitwise-copy-bit i index (if bool 1 0))))
|
|
|
|
(define bit-swap
|
|
(lambda (idx1 idx2 i)
|
|
(if (bitwise-bit-set? i idx1)
|
|
(if (bitwise-bit-set? i idx2)
|
|
i
|
|
(bitwise-copy-bit (bitwise-copy-bit i idx2 1) idx1 0))
|
|
(if (bitwise-bit-set? i idx2)
|
|
(bitwise-copy-bit (bitwise-copy-bit i idx2 0) idx1 1)
|
|
i))))
|
|
|
|
(define any-bit-set? (lambda (bits i) (not (zero? (bitwise-and bits i)))))
|
|
(define every-bit-set? (lambda (bits i) (= (bitwise-and bits i) bits)))
|
|
|
|
(define first-set-bit (lambda (i) (bitwise-first-bit-set i)))
|
|
|
|
(define bit-field (lambda (i s e) (bitwise-bit-field i s e)))
|
|
|
|
(define bit-field-any?
|
|
(lambda (i s e)
|
|
(not (zero? (bitwise-bit-field i s e)))))
|
|
|
|
(define bit-field-every?
|
|
(lambda (i s e)
|
|
(= (bitwise-bit-field i s e) (- (expt 2 (- e s)) 1))))
|
|
|
|
(define bit-field-clear
|
|
(lambda (i s e)
|
|
(bitwise-copy-bit-field i s e 0)))
|
|
|
|
(define bit-field-set
|
|
(lambda (i s e)
|
|
(bitwise-copy-bit-field i s e -1)))
|
|
|
|
(define bit-field-replace
|
|
(lambda (dest src s e)
|
|
(bitwise-copy-bit-field dest s e src)))
|
|
|
|
(define bit-field-replace-same
|
|
(lambda (dest src s e)
|
|
(bitwise-copy-bit-field dest s e (bitwise-bit-field src s e))))
|
|
|
|
(define bit-field-rotate
|
|
(lambda (i count start end)
|
|
(if (negative? count)
|
|
(bitwise-rotate-bit-field i start end (fx+ count (fx- end start)))
|
|
(bitwise-rotate-bit-field i start end count))))
|
|
|
|
(define bit-field-reverse
|
|
(lambda (i start end)
|
|
(bitwise-reverse-bit-field i start end)))
|
|
|
|
(define bits->list
|
|
(case-lambda
|
|
[(i)
|
|
(if (< i 0)
|
|
(bits->list i (integer-length i))
|
|
(let f ([i i])
|
|
(if (zero? i)
|
|
'()
|
|
(cons (odd? i) (f (bitwise-arithmetic-shift-right i 1))))))]
|
|
[(i n)
|
|
(let loop ([n n] [ls '()])
|
|
(if (fx=? n 0)
|
|
ls
|
|
(let ([n (fx- n 1)])
|
|
(loop n (cons (bitwise-bit-set? i n) ls)))))]))
|
|
|
|
(define bits->vector
|
|
(case-lambda
|
|
[(i)
|
|
(if (< i 0)
|
|
(bits->vector i (integer-length i))
|
|
(let f ([i i] [c 0])
|
|
(if (fx=? i 0)
|
|
(make-vector c)
|
|
(let ([v (f (bitwise-arithmetic-shift-right i 1) (fx+ c 1))])
|
|
(vector-set! v c (odd? i))))))]
|
|
[(i n)
|
|
(let ([v (make-vector n)])
|
|
(let loop ([n n])
|
|
(unless (fx=? n 0)
|
|
(let ([n (fx- n 1)])
|
|
(vector-set! v n (bitwise-bit-set? i n))
|
|
(loop n))))
|
|
v)]))
|
|
|
|
(define list->bits
|
|
(lambda (ls)
|
|
(let loop ([ls ls] [idx 0] [i 0])
|
|
(if (null? ls)
|
|
i
|
|
(loop (cdr ls) (fx+ idx 1)
|
|
(bitwise-copy-bit i idx (if (car ls) 1 0)))))))
|
|
|
|
(define vector->bits
|
|
(lambda (v)
|
|
(let loop ([n (vector-length v)] [i 0])
|
|
(if (fx=? n 0)
|
|
i
|
|
(let ([n (fx- n 1)])
|
|
(loop n (bitwise-copy-bit i n (if (vector-ref v n) 1 0))))))))
|
|
|
|
(define bits (lambda args (list->bits args)))
|
|
|
|
;; ---- from SRFI-151 other ---
|
|
;; The following functions: bitwise-fold, bitwise-for-each, bitwise-unfold,
|
|
;; and make-bitwise-generator are taken from John Cowan's implemtation
|
|
;; functions from the SRFI-151.
|
|
;;
|
|
;; Copyright John Cowan 2017
|
|
;;
|
|
(define bitwise-fold
|
|
(lambda (proc seed i)
|
|
(let ([n (integer-length i)])
|
|
(let loop ([idx 0] [r seed])
|
|
(if (fx=? idx n)
|
|
r
|
|
(loop (fx+ idx 1) (proc (bitwise-bit-set? i idx) r)))))))
|
|
|
|
(define bitwise-for-each
|
|
(lambda (proc i)
|
|
(let ([n (integer-length i)])
|
|
(let loop ([idx 0])
|
|
(unless (fx=? idx n)
|
|
(proc (bitwise-bit-set? i idx))
|
|
(loop (fx+ idx 1)))))))
|
|
|
|
(define bitwise-unfold
|
|
(lambda (stop? mapper successor seed)
|
|
(do ([state seed (successor state)]
|
|
[idx 0 (fx+ idx 1)]
|
|
[i 0 (bitwise-copy-bit i idx (if (mapper state) 1 0))])
|
|
((stop? state) i))))
|
|
|
|
(define make-bitwise-generator
|
|
(lambda (i)
|
|
(let ([idx 0])
|
|
(lambda ()
|
|
(let ([r (bitwise-bit-set? i idx)])
|
|
(set! idx (fx+ idx 1))
|
|
r)))))
|
|
;; ---- END from SRFI-151 other ---
|
|
)
|