logical.stk 6.9 KB
Newer Older
1
;;;;
2 3 4 5 6
;;;; logical.stk	-- Logical operations
;;;;
;;;; Copyright © 2009 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;;
7 8 9 10
;;;; 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.
11
;;;;
12 13 14 15
;;;; 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.
16
;;;;
17 18
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
19
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
20
;;;; USA.
21
;;;;
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 17-Oct-2009 23:46 (eg)
;;;; Last file update: 18-Oct-2009 00: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.



#|
<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| eturns 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
71
 * (bit-and 5 3)      => 1
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
 * (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 logical:boole-xor
    '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
       #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14)
       #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13)
       #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12)
       #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11)
       #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10)
       #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9)
       #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8)
       #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7)
       #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6)
       #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5)
       #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4)
       #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3)
       #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2)
       #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1)
       #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)))
102

103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
  (define logical:boole-and
    '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
       #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1)
       #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2)
       #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3)
       #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4)
       #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5)
       #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6)
       #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7)
       #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8)
       #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9)
       #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10)
       #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11)
       #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12)
       #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13)
       #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14)
       #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
120

121 122 123 124
  (define (logical:ash-4 x)
    (if (negative? x)
	(+ -1 (quotient (+ 1 x) 16))
	(quotient x 16)))
125

126 127 128 129 130 131 132 133 134 135
  (define (logical:reduce op4 ident)
    (lambda args
      (do ((res ident (op4 res (car rgs) 1 0))
	   (rgs args (cdr rgs)))
	  ((null? rgs) res))))


  ;; ----------------------------------------------------------------------
  ;; bit-and
  ;; ----------------------------------------------------------------------
136
  (set! bit-and
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212
    (letrec
	((lgand
	  (lambda (n2 n1 scl acc)
	    (cond ((= n1 n2) (+ acc (* scl n1)))
		  ((zero? n2) acc)
		  ((zero? n1) acc)
		  (else (lgand (logical:ash-4 n2)
			       (logical:ash-4 n1)
			       (* 16 scl)
			       (+ (* (vector-ref (vector-ref logical:boole-and
							     (modulo n1 16))
						 (modulo n2 16))
				     scl)
				  acc)))))))
      (logical:reduce lgand -1)))

  ;; ----------------------------------------------------------------------
  ;; bit-or
  ;; ----------------------------------------------------------------------
  (set! bit-or
    (letrec
	((lgior
	  (lambda (n2 n1 scl acc)
	    (cond ((= n1 n2) (+ acc (* scl n1)))
		  ((zero? n2) (+ acc (* scl n1)))
		  ((zero? n1) (+ acc (* scl n2)))
		  (else (lgior (logical:ash-4 n2)
			       (logical:ash-4 n1)
			       (* 16 scl)
			       (+ (* (- 15 (vector-ref
					    (vector-ref logical:boole-and
							(- 15 (modulo n1 16)))
					    (- 15 (modulo n2 16))))
				     scl)
				  acc)))))))
      (logical:reduce lgior 0)))

  ;; ----------------------------------------------------------------------
  ;; bit-xor
  ;; ----------------------------------------------------------------------
  (set! bit-xor
    (letrec
	((lgxor
	  (lambda (n2 n1 scl acc)
	    (cond ((= n1 n2) acc)
		  ((zero? n2) (+ acc (* scl n1)))
		  ((zero? n1) (+ acc (* scl n2)))
		  (else (lgxor (logical:ash-4 n2)
			       (logical:ash-4 n1)
			       (* 16 scl)
			       (+ (* (vector-ref (vector-ref logical:boole-xor
							     (modulo n1 16))
						 (modulo n2 16))
				     scl)
				  acc)))))))
      (logical:reduce lgxor 0))))


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


;; ----------------------------------------------------------------------
;; bit-shift
;; ----------------------------------------------------------------------
(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)))