Changeset 8556 for trunk/j/src/org/armedbear/lisp/bit-array-ops.lisp

Timestamp:

02/13/05 04:02:56 (16 years ago)

Author:

piso

Message:

Work in progress.

File:

• trunk/j/src/org/armedbear/lisp/bit-array-ops.lisp (modified) (4 diffs)

trunk/j/src/org/armedbear/lisp/bit-array-ops.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003-2005 Peter Graves
-;;; $Id: bit-array-ops.lisp,v 1.3 2005-02-12 21:11:46 piso Exp $
+;;; $Id: bit-array-ops.lisp,v 1.4 2005-02-13 04:02:56 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -67 +67 @@
 ;; (def-bit-array-op bit-ior   logior)
 ;; (def-bit-array-op bit-xor   logxor)
-(def-bit-array-op bit-eqv   logeqv)
+;; (def-bit-array-op bit-eqv   logeqv)
 ;; (def-bit-array-op bit-nand  lognand)
-(def-bit-array-op bit-nor   lognor)
-(def-bit-array-op bit-andc1 logandc1)
-(def-bit-array-op bit-andc2 logandc2)
-(def-bit-array-op bit-orc1  logorc1)
-(def-bit-array-op bit-orc2  logorc2)
+;; (def-bit-array-op bit-nor   lognor)
+;; (def-bit-array-op bit-andc1 logandc1)
+;; (def-bit-array-op bit-andc2 logandc2)
+;; (def-bit-array-op bit-orc1  logorc1)
+;; (def-bit-array-op bit-orc2  logorc2)
 
 (defun bit-and (bit-array-1 bit-array-2 &optional result-bit-array)
@@ -111 +111 @@
                         (row-major-aref bit-array-2 i)))))))
 
+(defun bit-eqv (bit-array-1 bit-array-2 &optional result-bit-array)
+  (require-same-dimensions bit-array-1 bit-array-2)
+  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
+    (if (and (simple-bit-vector-p bit-array-1)
+             (simple-bit-vector-p bit-array-2)
+             (simple-bit-vector-p result-bit-array))
+        (%simple-bit-vector-bit-eqv bit-array-1 bit-array-2 result-bit-array)
+        (dotimes (i (array-total-size result-bit-array) result-bit-array)
+          (setf (row-major-aref result-bit-array i)
+                (logand (logeqv (row-major-aref bit-array-1 i)
+                                (row-major-aref bit-array-2 i))
+                        1))))))
+
 (defun bit-nand (bit-array-1 bit-array-2 &optional result-bit-array)
   (require-same-dimensions bit-array-1 bit-array-2)
@@ -121 +134 @@
           (setf (row-major-aref result-bit-array i)
                 (logand (lognand (row-major-aref bit-array-1 i)
+                                 (row-major-aref bit-array-2 i))
+                        1))))))
+
+(defun bit-nor (bit-array-1 bit-array-2 &optional result-bit-array)
+  (require-same-dimensions bit-array-1 bit-array-2)
+  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
+    (if (and (simple-bit-vector-p bit-array-1)
+             (simple-bit-vector-p bit-array-2)
+             (simple-bit-vector-p result-bit-array))
+        (%simple-bit-vector-bit-nor bit-array-1 bit-array-2 result-bit-array)
+        (dotimes (i (array-total-size result-bit-array) result-bit-array)
+          (setf (row-major-aref result-bit-array i)
+                (logand (lognor (row-major-aref bit-array-1 i)
+                                (row-major-aref bit-array-2 i))
+                        1))))))
+
+(defun bit-andc1 (bit-array-1 bit-array-2 &optional result-bit-array)
+  (require-same-dimensions bit-array-1 bit-array-2)
+  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
+    (if (and (simple-bit-vector-p bit-array-1)
+             (simple-bit-vector-p bit-array-2)
+             (simple-bit-vector-p result-bit-array))
+        (%simple-bit-vector-bit-andc1 bit-array-1 bit-array-2 result-bit-array)
+        (dotimes (i (array-total-size result-bit-array) result-bit-array)
+          (setf (row-major-aref result-bit-array i)
+                (logand (logandc1 (row-major-aref bit-array-1 i)
+                                  (row-major-aref bit-array-2 i))
+                        1))))))
+
+(defun bit-andc2 (bit-array-1 bit-array-2 &optional result-bit-array)
+  (require-same-dimensions bit-array-1 bit-array-2)
+  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
+    (if (and (simple-bit-vector-p bit-array-1)
+             (simple-bit-vector-p bit-array-2)
+             (simple-bit-vector-p result-bit-array))
+        (%simple-bit-vector-bit-andc2 bit-array-1 bit-array-2 result-bit-array)
+        (dotimes (i (array-total-size result-bit-array) result-bit-array)
+          (setf (row-major-aref result-bit-array i)
+                (logand (logandc2 (row-major-aref bit-array-1 i)
+                                  (row-major-aref bit-array-2 i))
+                        1))))))
+
+(defun bit-orc1 (bit-array-1 bit-array-2 &optional result-bit-array)
+  (require-same-dimensions bit-array-1 bit-array-2)
+  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
+    (if (and (simple-bit-vector-p bit-array-1)
+             (simple-bit-vector-p bit-array-2)
+             (simple-bit-vector-p result-bit-array))
+        (%simple-bit-vector-bit-orc1 bit-array-1 bit-array-2 result-bit-array)
+        (dotimes (i (array-total-size result-bit-array) result-bit-array)
+          (setf (row-major-aref result-bit-array i)
+                (logand (logorc1 (row-major-aref bit-array-1 i)
+                                 (row-major-aref bit-array-2 i))
+                        1))))))
+
+(defun bit-orc2 (bit-array-1 bit-array-2 &optional result-bit-array)
+  (require-same-dimensions bit-array-1 bit-array-2)
+  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
+    (if (and (simple-bit-vector-p bit-array-1)
+             (simple-bit-vector-p bit-array-2)
+             (simple-bit-vector-p result-bit-array))
+        (%simple-bit-vector-bit-orc2 bit-array-1 bit-array-2 result-bit-array)
+        (dotimes (i (array-total-size result-bit-array) result-bit-array)
+          (setf (row-major-aref result-bit-array i)
+                (logand (logorc2 (row-major-aref bit-array-1 i)
                                  (row-major-aref bit-array-2 i))
                         1))))))