1 | ;;; bit-array-ops.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003 Peter Graves |
---|
4 | ;;; $Id: bit-array-ops.lisp,v 1.1 2003-10-09 16:41:53 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | ;;; Adapted from CMUCL. |
---|
21 | |
---|
22 | (in-package "SYSTEM") |
---|
23 | |
---|
24 | (defun bit-array-same-dimensions-p (array1 array2) |
---|
25 | (declare (type (array bit) array1 array2)) |
---|
26 | (and (= (array-rank array1) |
---|
27 | (array-rank array2)) |
---|
28 | (dotimes (index (array-rank array1) t) |
---|
29 | (when (/= (array-dimension array1 index) |
---|
30 | (array-dimension array2 index)) |
---|
31 | (return nil))))) |
---|
32 | |
---|
33 | (defun pick-result-array (result-bit-array bit-array-1) |
---|
34 | (case result-bit-array |
---|
35 | ((t) bit-array-1) |
---|
36 | ((nil) (make-array (array-dimensions bit-array-1) |
---|
37 | :element-type 'bit |
---|
38 | :initial-element 0)) |
---|
39 | (t |
---|
40 | (unless (bit-array-same-dimensions-p bit-array-1 |
---|
41 | result-bit-array) |
---|
42 | (error 'program-error "~S and ~S do not have the same dimensions" |
---|
43 | bit-array-1 result-bit-array)) |
---|
44 | result-bit-array))) |
---|
45 | |
---|
46 | (defmacro def-bit-array-op (name function) |
---|
47 | `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) |
---|
48 | ,(format nil |
---|
49 | "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ |
---|
50 | BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ |
---|
51 | If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ |
---|
52 | RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ |
---|
53 | All the arrays must have the same rank and dimensions." |
---|
54 | (symbol-name function)) |
---|
55 | (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2) |
---|
56 | (error 'program-error "~S and ~S do not have the same dimensions" |
---|
57 | bit-array-1 bit-array-2)) |
---|
58 | (let* ((result-bit-array (pick-result-array result-bit-array bit-array-1)) |
---|
59 | (end3 (array-total-size result-bit-array))) |
---|
60 | (do ((index-1 0 (1+ index-1)) |
---|
61 | (index-2 0 (1+ index-2)) |
---|
62 | (index-3 0 (1+ index-3))) |
---|
63 | ((>= index-3 end3) result-bit-array) |
---|
64 | (setf (row-major-aref result-bit-array index-3) |
---|
65 | (logand (,function (row-major-aref bit-array-1 index-1) |
---|
66 | (row-major-aref bit-array-2 index-2)) |
---|
67 | 1)))))) |
---|
68 | |
---|
69 | (def-bit-array-op bit-and logand) |
---|
70 | (def-bit-array-op bit-ior logior) |
---|
71 | (def-bit-array-op bit-xor logxor) |
---|
72 | (def-bit-array-op bit-eqv logeqv) |
---|
73 | (def-bit-array-op bit-nand lognand) |
---|
74 | (def-bit-array-op bit-nor lognor) |
---|
75 | (def-bit-array-op bit-andc1 logandc1) |
---|
76 | (def-bit-array-op bit-andc2 logandc2) |
---|
77 | (def-bit-array-op bit-orc1 logorc1) |
---|
78 | (def-bit-array-op bit-orc2 logorc2) |
---|
79 | |
---|
80 | (defun bit-not (bit-array &optional result-bit-array) |
---|
81 | "Performs a bit-wise logical NOT on the elements of BIT-ARRAY, |
---|
82 | putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, |
---|
83 | BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is |
---|
84 | created. Both arrays must have the same rank and dimensions." |
---|
85 | (let* ((result-bit-array (pick-result-array result-bit-array bit-array)) |
---|
86 | (dst-end (array-total-size result-bit-array))) |
---|
87 | (do ((src-index 0 (1+ src-index)) |
---|
88 | (dst-index 0 (1+ dst-index))) |
---|
89 | ((>= dst-index dst-end) result-bit-array) |
---|
90 | (setf (row-major-aref result-bit-array dst-index) |
---|
91 | (logxor (row-major-aref bit-array src-index) 1))))) |
---|