Changeset 8554


Ignore:
Timestamp:
02/12/05 21:11:46 (16 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/bit-array-ops.lisp

    r4267 r8554  
    11;;; bit-array-ops.lisp
    22;;;
    3 ;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: bit-array-ops.lisp,v 1.2 2003-10-09 16:51:08 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: bit-array-ops.lisp,v 1.3 2005-02-12 21:11:46 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2020;;; Adapted from CMUCL.
    2121
    22 (in-package "SYSTEM")
     22(in-package #:system)
    2323
    2424(defun bit-array-same-dimensions-p (array1 array2)
     
    3131     (return nil)))))
    3232
     33(defun require-same-dimensions (array1 array2)
     34  (unless (bit-array-same-dimensions-p array1 array2)
     35    (error 'program-error
     36           "~S and ~S do not have the same dimensions."
     37           array1 array2)))
     38
    3339(defun pick-result-array (result-bit-array bit-array-1)
    3440  (case result-bit-array
     
    3844           :initial-element 0))
    3945    (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))
     46     (require-same-dimensions bit-array-1 result-bit-array)
    4447     result-bit-array)))
    4548
     
    5356               All the arrays must have the same rank and dimensions."
    5457        (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     (require-same-dimensions bit-array-1 bit-array-2)
    5859     (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
    5960       (dotimes (i (array-total-size result-bit-array) result-bit-array)
     
    6364                       1))))))
    6465
    65 (def-bit-array-op bit-and   logand)
    66 (def-bit-array-op bit-ior   logior)
    67 (def-bit-array-op bit-xor   logxor)
     66;; (def-bit-array-op bit-and   logand)
     67;; (def-bit-array-op bit-ior   logior)
     68;; (def-bit-array-op bit-xor   logxor)
    6869(def-bit-array-op bit-eqv   logeqv)
    69 (def-bit-array-op bit-nand  lognand)
     70;; (def-bit-array-op bit-nand  lognand)
    7071(def-bit-array-op bit-nor   lognor)
    7172(def-bit-array-op bit-andc1 logandc1)
     
    7374(def-bit-array-op bit-orc1  logorc1)
    7475(def-bit-array-op bit-orc2  logorc2)
     76
     77(defun bit-and (bit-array-1 bit-array-2 &optional result-bit-array)
     78  (require-same-dimensions bit-array-1 bit-array-2)
     79  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
     80    (if (and (simple-bit-vector-p bit-array-1)
     81             (simple-bit-vector-p bit-array-2)
     82             (simple-bit-vector-p result-bit-array))
     83        (%simple-bit-vector-bit-and bit-array-1 bit-array-2 result-bit-array)
     84        (dotimes (i (array-total-size result-bit-array) result-bit-array)
     85          (setf (row-major-aref result-bit-array i)
     86                (logand (row-major-aref bit-array-1 i)
     87                        (row-major-aref bit-array-2 i)))))))
     88
     89(defun bit-ior (bit-array-1 bit-array-2 &optional result-bit-array)
     90  (require-same-dimensions bit-array-1 bit-array-2)
     91  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
     92    (if (and (simple-bit-vector-p bit-array-1)
     93             (simple-bit-vector-p bit-array-2)
     94             (simple-bit-vector-p result-bit-array))
     95        (%simple-bit-vector-bit-ior bit-array-1 bit-array-2 result-bit-array)
     96        (dotimes (i (array-total-size result-bit-array) result-bit-array)
     97          (setf (row-major-aref result-bit-array i)
     98                (logior (row-major-aref bit-array-1 i)
     99                        (row-major-aref bit-array-2 i)))))))
     100
     101(defun bit-xor (bit-array-1 bit-array-2 &optional result-bit-array)
     102  (require-same-dimensions bit-array-1 bit-array-2)
     103  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
     104    (if (and (simple-bit-vector-p bit-array-1)
     105             (simple-bit-vector-p bit-array-2)
     106             (simple-bit-vector-p result-bit-array))
     107        (%simple-bit-vector-bit-xor bit-array-1 bit-array-2 result-bit-array)
     108        (dotimes (i (array-total-size result-bit-array) result-bit-array)
     109          (setf (row-major-aref result-bit-array i)
     110                (logxor (row-major-aref bit-array-1 i)
     111                        (row-major-aref bit-array-2 i)))))))
     112
     113(defun bit-nand (bit-array-1 bit-array-2 &optional result-bit-array)
     114  (require-same-dimensions bit-array-1 bit-array-2)
     115  (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
     116    (if (and (simple-bit-vector-p bit-array-1)
     117             (simple-bit-vector-p bit-array-2)
     118             (simple-bit-vector-p result-bit-array))
     119        (%simple-bit-vector-bit-nand bit-array-1 bit-array-2 result-bit-array)
     120        (dotimes (i (array-total-size result-bit-array) result-bit-array)
     121          (setf (row-major-aref result-bit-array i)
     122                (logand (lognand (row-major-aref bit-array-1 i)
     123                                 (row-major-aref bit-array-2 i))
     124                        1))))))
    75125
    76126(defun bit-not (bit-array &optional result-bit-array)
Note: See TracChangeset for help on using the changeset viewer.