1 ;;; logical-operations.lop
2 ;;; mlogand, mlogior, mlogxor, mlognot and mbitnor
4 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
5 ;;; All rights reserved.
7 ;;; Redistribution and use in source and binary forms, with or without
8 ;;; modification, are permitted provided that the following conditions
11 ;;; * Redistributions of source code must retain the above copyright
12 ;;; notice, this list of conditions and the following disclaimer.
14 ;;; * Redistributions in binary form must reproduce the above
15 ;;; copyright notice, this list of conditions and the following
16 ;;; disclaimer in the documentation and/or other materials
17 ;;; provided with the distribution.
19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35 (def-binary-op "mlogand" logand bit-matrix bit-matrix bit-matrix
)
36 (def-binary-op "mlogand" logand ub8-matrix ub8-matrix ub8-matrix
)
37 (def-binary-op "mlogand" logand ub16-matrix ub16-matrix ub16-matrix
)
38 (def-binary-op "mlogand" logand ub32-matrix ub32-matrix ub32-matrix
)
39 (def-binary-op "mlogand" logand integer-matrix integer-matrix integer-matrix
)
42 (def-binary-op "mlogior" logior bit-matrix bit-matrix bit-matrix
)
43 (def-binary-op "mlogior" logior ub8-matrix ub8-matrix ub8-matrix
)
44 (def-binary-op "mlogior" logior ub16-matrix ub16-matrix ub16-matrix
)
45 (def-binary-op "mlogior" logior ub32-matrix ub32-matrix ub32-matrix
)
46 (def-binary-op "mlogior" logior integer-matrix integer-matrix integer-matrix
)
49 (def-binary-op "mlogxor" logxor bit-matrix bit-matrix bit-matrix
)
50 (def-binary-op "mlogxor" logxor ub8-matrix ub8-matrix ub8-matrix
)
51 (def-binary-op "mlogxor" logxor ub16-matrix ub16-matrix ub16-matrix
)
52 (def-binary-op "mlogxor" logxor ub32-matrix ub32-matrix ub32-matrix
)
53 (def-binary-op "mlogxor" logxor integer-matrix integer-matrix integer-matrix
)
56 (def-unary-op "mlognot" lognot integer-matrix integer-matrix
)
57 (def-unary-op "mlognot" lognot fixnum-matrix fixnum-matrix
)
58 (def-unary-op "mlognot" lognot sb8-matrix sb8-matrix
)
59 (def-unary-op "mlognot" lognot sb16-matrix sb16-matrix
)
60 (def-unary-op "mlognot" lognot sb32-matrix sb32-matrix
)
62 (defmacro defmbitnor
(name type-1 type-2 accumulator-type
&key suffix
)
63 (let ((class-1 (find-class `,type-1
))
64 (class-2 (find-class `,type-2
)))
65 (let ((element-type-1 (element-type class-1
))
66 (element-type-2 (element-type class-2
))
67 (accumulator-element-type (element-type (find-class `,accumulator-type
))))
68 (let ((max (max (maxval class-1
) (maxval class-2
))))
70 (defmethod ,(ch-util:make-intern
(concatenate 'string name
"-range" suffix
))
71 ((m ,type-1
) (n ,type-2
) startr endr startc endc
)
72 (destructuring-bind (mr mc
) (dim m
)
73 (let ((p (make-instance ',accumulator-type
:rows mr
:cols mc
)))
74 (with-typed-mref (m ,element-type-1
)
75 (with-typed-mref (n ,element-type-2
)
76 (with-typed-mref (p ,accumulator-element-type
)
77 (do ((i startr
(1+ i
)))
79 (declare (dynamic-extent i
) (type fixnum i
))
80 (do ((j startc
(1+ j
)))
82 (declare (dynamic-extent j
) (type fixnum j
))
84 (logand ,max
(lognor (mref m i j
) (mref n i j
)))))))))
87 (defmethod ,(ch-util:make-intern
(concatenate 'string name suffix
))
88 ((m ,type-1
) (n ,type-2
))
89 (destructuring-bind (mr mc
) (dim m
)
90 (,(ch-util:make-intern
(concatenate 'string name
"-range" suffix
)) m n
0 (1- mr
) 0 (1- mc
)))))))))
92 (defmacro defmbitnor
! (name type-1 type-2 accumulator-type
&key suffix
)
93 (declare (ignore accumulator-type
))
94 (let ((class-1 (find-class `,type-1
))
95 (class-2 (find-class `,type-2
)))
96 (let ((element-type-1 (element-type class-1
))
97 (element-type-2 (element-type class-2
)))
98 (let ((max (max (maxval class-1
) (maxval class-2
))))
100 (defmethod ,(ch-util:make-intern
(concatenate 'string name
"!-range" suffix
))
101 ((m ,type-1
) (n ,type-2
) startr endr startc endc
)
102 (with-typed-mref (m ,element-type-1
)
103 (with-typed-mref (n ,element-type-2
)
104 (do ((i startr
(1+ i
)))
106 (declare (dynamic-extent i
) (type fixnum i
))
107 (do ((j startc
(1+ j
)))
109 (declare (dynamic-extent j
) (type fixnum j
))
111 (logand ,max
(lognor (mref m i j
) (mref n i j
)))))))
114 (defmethod ,(ch-util:make-intern
(concatenate 'string name
"!" suffix
))
115 ((m ,type-1
) (n ,type-2
))
116 (destructuring-bind (mr mc
) (dim m
)
117 (,(ch-util:make-intern
(concatenate 'string name
"!-range" suffix
)) m n
0 (1- mr
) 0 (1- mc
))))
122 (defun bitnor (integer1 integer2 andmask
)
123 (logand andmask
(lognor integer1 integer2
)))
125 (macrolet ((frob (name type-1 type-2 type-3
&key suffix
)
127 (defmbitnor ,name
,type-1
,type-2
,type-3
:suffix
,suffix
)
128 (defmbitnor! ,name
,type-1
,type-2
,type-3
:suffix
,suffix
))))
130 (frob "mbitnor" bit-matrix bit-matrix bit-matrix
)
131 (frob "mbitnor" ub8-matrix ub8-matrix ub8-matrix
)
132 (frob "mbitnor" ub16-matrix ub16-matrix ub16-matrix
)
133 (frob "mbitnor" ub32-matrix ub32-matrix ub32-matrix
))
