111 lines
3.3 KiB
Scheme
111 lines
3.3 KiB
Scheme
#!r6rs
|
|
;; SRFI-60 R6RS implementation
|
|
;;
|
|
;; Builds out the SRFI-60 specified bitwise operators using the set of bitwise
|
|
;; operators that is part of the standard R6RS library. In some cases these
|
|
;; could directly use Chez Scheme library procedures directly, but this library
|
|
;; does not do that yet.
|
|
;;
|
|
;; Copyright (c) 2018 - 2020 Andrew W. Keep
|
|
|
|
(library (srfi :60 integer-bits)
|
|
(export logand bitwise-and logior bitwise-ior logxor bitwise-xor lognot
|
|
bitwise-not bitwise-if bitwise-merge logtest any-bits-set? logcount
|
|
bit-count integer-length log2-binary-factors first-set-bit logbit?
|
|
bit-set? copy-bit bit-field copy-bit-field ash arithmetic-shift
|
|
rotate-bit-field reverse-bit-field integer->list
|
|
list->integer booleans->integer)
|
|
(import (rnrs))
|
|
|
|
(define logand
|
|
(case-lambda
|
|
[() (bitwise-and)]
|
|
[(i) i]
|
|
[(i j) (bitwise-and i j)]
|
|
[(i j k) (bitwise-and i j k)]
|
|
[args (apply bitwise-and args)]))
|
|
|
|
(define logior
|
|
(case-lambda
|
|
[() (bitwise-ior)]
|
|
[(i) i]
|
|
[(i j) (bitwise-ior i j)]
|
|
[(i j k) (bitwise-ior i j k)]
|
|
[args (apply bitwise-ior args)]))
|
|
|
|
(define logxor
|
|
(case-lambda
|
|
[() (bitwise-xor)]
|
|
[(i) i]
|
|
[(i j) (bitwise-xor i j)]
|
|
[(i j k) (bitwise-xor i j k)]
|
|
[args (apply bitwise-xor args)]))
|
|
|
|
(define lognot (lambda (n) (bitwise-not n)))
|
|
|
|
(define bitwise-merge (lambda (m n0 n1) (bitwise-if m n0 n1)))
|
|
|
|
(define logtest (lambda (j k) (not (zero? (logand j k)))))
|
|
(define any-bits-set? (lambda (j k) (not (zero? (logand j k)))))
|
|
|
|
(define logcount
|
|
(lambda (n)
|
|
(if (< n 0)
|
|
(bitwise-bit-count (bitwise-not n))
|
|
(bitwise-bit-count n))))
|
|
|
|
(define bit-count
|
|
(lambda (n)
|
|
(if (< n 0)
|
|
(bitwise-bit-count (bitwise-not n))
|
|
(bitwise-bit-count n))))
|
|
|
|
(define integer-length (lambda (n) (bitwise-length n)))
|
|
|
|
(define log2-binary-factors (lambda (n) (bitwise-first-bit-set n)))
|
|
(define first-set-bit (lambda (n) (bitwise-first-bit-set n)))
|
|
|
|
(define logbit? (lambda (i n) (bitwise-bit-set? n i)))
|
|
(define bit-set? (lambda (i n) (bitwise-bit-set? n i)))
|
|
|
|
(define copy-bit (lambda (i n b) (bitwise-copy-bit n i (if b 1 0))))
|
|
|
|
(define bit-field (lambda (n s e) (bitwise-bit-field n s e)))
|
|
|
|
(define copy-bit-field
|
|
(lambda (to from s e)
|
|
(bitwise-copy-bit-field to s e from)))
|
|
|
|
(define ash (lambda (n count) (bitwise-arithmetic-shift n count)))
|
|
(define arithmetic-shift
|
|
(lambda (n count)
|
|
(bitwise-arithmetic-shift n count)))
|
|
|
|
(define rotate-bit-field
|
|
(lambda (n count start end)
|
|
(bitwise-rotate-bit-field n start end count)))
|
|
|
|
(define reverse-bit-field
|
|
(lambda (n start end)
|
|
(bitwise-reverse-bit-field n start end)))
|
|
|
|
(define integer->list
|
|
(case-lambda
|
|
[(k len) (let loop ([i len] [ls '()])
|
|
(if (fx=? i 0)
|
|
ls
|
|
(let ([i (fx- i 1)])
|
|
(loop i (cons (bitwise-bit-set? k i) ls)))))]
|
|
[(k) (integer->list k (bitwise-length k))]))
|
|
|
|
(define list->integer
|
|
(lambda (ls)
|
|
(let loop ([ls ls] [i 0] [n 0])
|
|
(if (null? ls)
|
|
n
|
|
(loop (cdr ls) (fx+ i 1) (bitwise-copy-bit n i (if (car ls) 1 0)))))))
|
|
|
|
(define booleans->integer
|
|
(lambda args
|
|
(list->integer args))))
|