Changeset 8554 for trunk/j/src/org/armedbear/lisp/bit-array-ops.lisp
- Timestamp:
- 02/12/05 21:11:46 (16 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/bit-array-ops.lisp
r4267 r8554 1 1 ;;; bit-array-ops.lisp 2 2 ;;; 3 ;;; Copyright (C) 2003 Peter Graves4 ;;; $Id: bit-array-ops.lisp,v 1. 2 2003-10-09 16:51:08piso 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 $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 20 20 ;;; Adapted from CMUCL. 21 21 22 (in-package "SYSTEM")22 (in-package #:system) 23 23 24 24 (defun bit-array-same-dimensions-p (array1 array2) … … 31 31 (return nil))))) 32 32 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 33 39 (defun pick-result-array (result-bit-array bit-array-1) 34 40 (case result-bit-array … … 38 44 :initial-element 0)) 39 45 (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) 44 47 result-bit-array))) 45 48 … … 53 56 All the arrays must have the same rank and dimensions." 54 57 (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) 58 59 (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) 59 60 (dotimes (i (array-total-size result-bit-array) result-bit-array) … … 63 64 1)))))) 64 65 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) 68 69 (def-bit-array-op bit-eqv logeqv) 69 (def-bit-array-op bit-nand lognand)70 ;; (def-bit-array-op bit-nand lognand) 70 71 (def-bit-array-op bit-nor lognor) 71 72 (def-bit-array-op bit-andc1 logandc1) … … 73 74 (def-bit-array-op bit-orc1 logorc1) 74 75 (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)))))) 75 125 76 126 (defun bit-not (bit-array &optional result-bit-array)
Note: See TracChangeset
for help on using the changeset viewer.