(library (srfi-60)
  (export ash logcount logbit? logtest bitwise-if 
	  logior logxor logand lognot 
	  (rename (ash arithmetic-shift)
		  (logcount bit-count)
		  (logbit? bit-set?)
		  (logtest any-bits-set?) 
		  (log2-binary-factors first-set-bit)
		  (bitwise-if bitwise-merge)
		  (logior bitwise-ior)
		  (logxor bitwise-xor)
		  (logand bitwise-and)
		  (lognot bitwise-not))
	  copy-bit bit-field copy-bit-field
	  rotate-bit-field bit-reverse reverse-bit-field 
	  integer->list list->integer booleans->integer)

  (import (rnrs base)
	  (rnrs control)
	  (only (rnrs r5rs) quotient modulo)
	  (rename
	   (only (rnrs arithmetic bitwise) 
		 bitwise-arithmetic-shift-left bitwise-length
		 bitwise-ior bitwise-xor bitwise-and bitwise-not)	   
	   (bitwise-arithmetic-shift-left ash)
	   (bitwise-length integer-length)
	   (bitwise-ior logior)
	   (bitwise-xor logxor)
	   (bitwise-and logand)
	   (bitwise-not lognot)))
		

  ;; Adapted from the reference implementation.

  (define (logical:ash-4 x)
    (if (negative? x)
	(+ -1 (quotient (+ 1 x) 16))
	(quotient x 16)))

  (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 (ash 1 index))
	(logand to (lognot (ash 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)))
	    (ash n (- start))))

  (define (copy-bit-field to from start end)
    (bitwise-if (ash (lognot (ash -1 (- end start))) start)
		(ash 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 (ash n (- start))))
      (logior (ash
	       (logior (logand mask (ash zn count))
		       (ash zn (- count width)))
	       start)
	      (logand (lognot (ash mask start)) n))))

  (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) (ash m -1))
	 (k (+ -1 k) (+ -1 k))
	 (rvs 0 (logior (ash 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 (ash n (- start))))
      (logior (ash (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))
	     (lst '() (cons (odd? k) lst)))
	    ((<= k 0) lst))
	(do ((idx (+ -1 (car len)) (+ -1 idx))
	     (k k (ash 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))

)