;;;;
;;;; srfi-60.stk        -- SRFI-60: Integers as Bits
;;;;
;;;; Copyright © 2005-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date:  9-Mar-2005 19:43 (eg)
;;;;

;;;; This implementation is an adaptation of the code given in the reference
;;;; implementation given in SRFI document. Its copyright is given
;;;; below

;;;; "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.


;; Use the binary versions of log-and lor-or (%log-and and %log-or) which are
;; faster than their n-ary counterpart
 


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

;; ----------------------------------------------------------------------
;;      logand, logior, logxor, lognot ...
;; ----------------------------------------------------------------------
(define logand bit-and)
(define logior bit-or)
(define logxor bit-xor)
(define lognot bit-not)

;; ----------------------------------------------------------------------
;;      bitwise-if ...
;; ----------------------------------------------------------------------
(define (bitwise-if mask n0 n1)
  (%bit-or (%bit-and mask n0)
           (%bit-and (bit-not mask) n1)))
;; ----------------------------------------------------------------------
;;      logtest ...
;; ----------------------------------------------------------------------
(define (logtest n1 n2)
  (not (zero? (%bit-and n1 n2))))

;; ----------------------------------------------------------------------
;;      logcount ...
;; ----------------------------------------------------------------------
(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)))))

;; ----------------------------------------------------------------------
;;      integer-length ...
;; ----------------------------------------------------------------------
;; Primitive is imported 
;; (define integer-length
;;   (symbol-value 'integer-length (find-module 'SCHEME)))

;; ----------------------------------------------------------------------
;;      log2-binary-factors ...
;; ----------------------------------------------------------------------
(define (log2-binary-factors n)
  (+ -1 (integer-length (%bit-and n (- n)))))

;; ----------------------------------------------------------------------
;;      logbit? ...
;; ----------------------------------------------------------------------
(define (logbit? index n)
  (logtest (expt 2 index) n))

;; ----------------------------------------------------------------------
;;      copy-bit ...
;; ----------------------------------------------------------------------
(define (copy-bit index to bool)
  (if bool
      (%bit-or  to (bit-shift 1 index))
      (%bit-and to (bit-not (bit-shift 1 index)))))

;; ----------------------------------------------------------------------
;;      bit-field ...
;; ----------------------------------------------------------------------
(define (bit-field n start end)
  (%bit-and (bit-not (bit-shift -1 (- end start)))
           (bit-shift n (- start))))
;; ----------------------------------------------------------------------
;;      copy-bit-field ...
;; ----------------------------------------------------------------------
(define (copy-bit-field to from start end)
  (bitwise-if (bit-shift (bit-not (bit-shift -1 (- end start))) start)
              (bit-shift from start)
              to))

;; ----------------------------------------------------------------------
;;      arithmetic-shift ...
;; ----------------------------------------------------------------------
(define arithmetic-shift bit-shift)

;; ----------------------------------------------------------------------
;;      rotate-bit-field ...
;; ----------------------------------------------------------------------
(define (rotate-bit-field n count start end)
  (let* ((width (- end start))
         (count (modulo count width))
         (mask  (bit-not (bit-shift -1 width)))
         (zn    (%bit-and mask (bit-shift n (- start)))))
    (%bit-or (bit-shift
             (%bit-or (%bit-and mask (bit-shift zn count))
                     (bit-shift zn (- count width)))
             start)
            (%bit-and (bit-not (bit-shift mask start)) n))))

;; ----------------------------------------------------------------------
;;      reverse-bit-field ...
;; ----------------------------------------------------------------------
(define (reverse-bit-field n start end)
  (define (bit-reverse k n)
    (do ((m (if (negative? n) (bit-not n) n) (bit-shift m -1))
         (k (+ -1 k) (+ -1 k))
         (rvs 0 (%bit-or (bit-shift rvs 1) (%bit-and 1 m))))
        ((negative? k) (if (negative? n) (bit-not rvs) rvs))))


  (let* ((width (- end start))
         (mask  (bit-not (bit-shift -1 width)))
         (zn    (%bit-and mask (bit-shift n (- start)))))
    (%bit-or (bit-shift (bit-reverse width zn) start)
             (%bit-and (bit-not (bit-shift mask start)) n))))


;; ----------------------------------------------------------------------
;;      integer->list ...
;; ----------------------------------------------------------------------
(define (integer->list k . len)
  (if (null? len)
      (do ((k k (bit-shift k -1))
           (lst '() (cons (odd? k) lst)))
          ((<= k 0) lst))
      (do ((idx (+ -1 (car len)) (+ -1 idx))
           (k k (bit-shift k -1))
           (lst '() (cons (odd? k) lst)))
          ((negative? idx) lst))))

;; ----------------------------------------------------------------------
;;      list->integer ...
;; ----------------------------------------------------------------------
(define (list->integer bools)
  (do ((bs bools (cdr bs))
       (acc 0 (+ acc acc (if (car bs) 1 0))))
      ((null? bs) acc)))

;; ----------------------------------------------------------------------
;;      boolean->integer ...
;; ----------------------------------------------------------------------
(define (booleans->integer . bools)
  (list->integer bools))

;;;;
;;;; SRFI-60 aliases
;;;;
(define bitwise-and logand)

(define ash arithmetic-shift)
(define bitwise-ior logior)
(define bitwise-xor logxor)

(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)

)  ;; End of SRFI-60 module

;; ----------------------------------------------------------------------

(provide "srfi/60")
