;;;;
;;;; logical.stk        -- Logical operations
;;;;
;;;; Copyright © 2009-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@unice.fr]
;;;;    Creation date: 17-Oct-2009 23:46 (eg)
;;;;

(export bit-and bit-or bit-xor bit-not bit-shift)

#|
<doc EXT bit-and bit-or bit-xor bit-not bit-shift
 * (bit-and n1 n2 ...)
 * (bit-or n1 n2 ...)
 * (bit-xor n1 n2 ...)
 * (bit-not n)
 * (bit-shift n m)
 *
 * These procedures allow the manipulation of integers as bit fields.
 * The integers can be of arbitrary length. |Bit-and|, |bit-or| and
 * |bit-xor| respectively compute the bitwise ,(emph "and"), inclusive and
 * exclusive ,(emph "or"). |bit-not| returns the bitwise ,(emph "not") of |n|.
 * |bit-shift| returns the bitwise ,(emph "shift") of |n|. The integer |n|
 * is shifted left by |m| bits; If |m| is negative, |n| is shifted right by
 * |-m| bits.
 *
 * @lisp
 * (bit-or 5 3)       => 7
 * (bit-xor 5 3)      => 6
 * (bit-and 5 3)      => 1
 * (bit-not 5)        => -6
 * (bit-or 1 2 4 8)   => 15
 * (bit-shift 5 3)    => 40
 * (bit-shift 5 -1)   => 2
 * @end lisp
doc>
|#

(define bit-and #f)
(define bit-or  #f)
(define bit-xor #f)

(let ()
  (define (reduce fct lst base)
    (if (null? lst)
        base
        (fct (car lst)
             (reduce fct (cdr lst) base))))

  (set! bit-and (lambda lst (reduce %bit-and lst -1)))
  (set! bit-or  (lambda lst (reduce %bit-or  lst  0)))
  (set! bit-xor (lambda lst (reduce %bit-xor lst  0))))


(define (bit-not n)
  (- -1 n))

(define (bit-shift n m)
  (if (negative? m)
      (let ((k (expt 2 (- m))))
        (if (negative? n)
            (+ -1 (quotient (+ 1 n) k))
            (quotient n k)))
      (* (expt 2 m) n)))
