source: trunk/source/lib/arrays-fry.lisp @ 13066

; -*- Mode:Lisp; Package:CCL; -*-
;;;
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")

(defun bit (bit-array &rest subscripts)
  "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
  (declare (dynamic-extent subscripts))
  (unless (eq (array-element-type bit-array) 'bit)
    (report-bad-arg bit-array '(array bit)))
  (apply #'aref bit-array subscripts))

(defun %bitset (bit-array &rest stuff)
  (declare (dynamic-extent stuff))
  (unless (eq (array-element-type bit-array) 'bit)
    (report-bad-arg bit-array '(array bit)))
  (apply #'aset bit-array stuff))

(defun sbit (v &optional (sub0 nil sub0-p) &rest others)
  "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
  (declare (dynamic-extent others))
  (if sub0-p
    (if others
      (apply #'bit v sub0 others)
      ( sbit (require-type v 'simple-bit-vector) sub0))
    (bit v)))

(defun %sbitset (v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
  (declare (dynamic-extent newval-was-really-sub1))
  (if newval-p
    (if newval-was-really-sub1
      (apply #'%bitset v sub0 newval newval-was-really-sub1)
      (progn
        (unless (typep v 'simple-bit-vector)
          (report-bad-arg v 'simple-bit-vector))
        (uvset v sub0 newval)))
    (%bitset v sub0)))

(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
   (bit-boole boole-and bit-array1 bit-array2 result-bit-array))

(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGIOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole  boole-ior bit-array1 bit-array2 result-bit-array))

(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGXOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
   (bit-boole  boole-xor bit-array1 bit-array2 result-bit-array))

(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGEQV on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole boole-eqv bit-array1 bit-array2 result-bit-array))

(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGNAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole boole-nand bit-array1 bit-array2 result-bit-array))

(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGNOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole boole-nor bit-array1 bit-array2 result-bit-array))

(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGANDC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole boole-andc1 bit-array1 bit-array2 result-bit-array))

(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGANDC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole boole-andc2 bit-array1 bit-array2 result-bit-array))

(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGORC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole boole-orc1 bit-array1 bit-array2 result-bit-array))

(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
  "Perform a bit-wise LOGORC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. All the arrays must have the same rank and dimensions."
  (bit-boole boole-orc2 bit-array1 bit-array2 result-bit-array))

(defun bit-not (bit-array &optional result-bit-array)
  "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. Both arrays must have the same rank and dimensions."
  (bit-boole boole-nor bit-array bit-array result-bit-array))

(defun result-bit-array (bit-array-1 bit-array-2 result)
  ; Check that the two bit-array args are bit-arrays with
  ; compatible dimensions.  If "result" is specified as T,
  ; return bit-array-1.  If result is unspecified, return
  ; a new bit-array of the same dimensions as bit-array-2.
  ; Otherwise, make sure that result is a bit-array of the
  ; same dimensions as the other two arguments and return
  ; it.
  (let* ((typecode-1 (typecode bit-array-1))
         (typecode-2 (typecode bit-array-2)))
    (declare (fixnum typecode-1 typecode-2))
    (flet ((bit-array-dimensions (bit-array typecode)
             (declare (fixnum typecode))
             (if (= typecode target::subtag-bit-vector)
               (uvsize bit-array)
               (let* ((array-p (= typecode target::subtag-arrayH))
                      (vector-p (= typecode target::subtag-vectorH)))
                 (if (and (or array-p vector-p) 
                          (= (the fixnum (%array-header-subtype bit-array)) target::subtag-bit-vector))
                   (if vector-p
                     (array-dimension bit-array 0)
                     (array-dimensions bit-array))
                   (report-bad-arg bit-array '(array bit))))))
           (check-matching-dimensions (a1 d1 a2 d2)
             (unless (equal d1 d2)
               (error "~s and ~s have different dimensions." a1 a2))
             a2))
      (let* ((dims-1 (bit-array-dimensions bit-array-1 typecode-1))
             (dims-2 (bit-array-dimensions bit-array-2 typecode-2)))
        (check-matching-dimensions bit-array-1 dims-1 bit-array-2 dims-2)
        (if result
          (if (eq result t)
            bit-array-1
            (check-matching-dimensions bit-array-2 dims-2 result (bit-array-dimensions result (typecode result))))
          (make-array dims-2 :element-type 'bit :initial-element 0))))))




  
(defun bit-boole (opcode array1 array2 result-array)
  (unless (eql opcode (logand 15 opcode))
    (setq opcode (require-type opcode '(mod 16))))
  (let* ((result (result-bit-array array1 array2 result-array)))
    (if (and (typep array1 'simple-bit-vector)
             (typep array2 'simple-bit-vector)
             (typep result 'simple-bit-vector))
      (%simple-bit-boole opcode array1 array2 result)
      (multiple-value-bind (v1 i1) (array-data-and-offset array1)
        (declare (simple-bit-vector v1) (fixnum i1))
        (multiple-value-bind (v2 i2) (array-data-and-offset array2)
          (declare (simple-bit-vector v2) (fixnum i2))
          (multiple-value-bind (v3 i3) (array-data-and-offset result)
            (declare (simple-bit-vector v3) (fixnum i3))
            (let* ((e3 (+ i3 (the fixnum (array-total-size result)))))
              (declare (fixnum e3))
              (do* ( )
                   ((= i3 e3) result)
                (setf (sbit v3 i3) 
                      (logand (boole opcode (sbit v1 i1) (sbit v2 i2)) 1))
                (incf i1)
                (incf i2)
                (incf i3)))))))))


          
          




; shrink-vector is called only in sequences-2. None of the calls depend on
; the side affect of setting the passed-in symbol to the [possibly new]
; returned vector
; Since there hasn't been such a thing as sequences-2 in about 7 years,
; this is especially puzzling.
(eval-when (:compile-toplevel :execute :load-toplevel)
  (defmacro shrink-vector (vector to-size)
    `(setq ,vector (%shrink-vector ,vector ,to-size)))
  )


; new and faulty def
(defun %shrink-vector (vector to-size)
  (cond ((eq (length vector) to-size)
         vector)
        ((array-has-fill-pointer-p vector)
         (setf (fill-pointer vector) to-size)
         vector)
        (t (subseq vector 0 to-size))))


; this could be put into print-db as it was in ccl-pr-4.2
; Or it (and print-db) could just be flushed ... tough one.
(defun multi-dimension-array-to-list (array)
  "Produces a nested list of the elements in array."
  (mdal-aux array (array-dimensions array) nil 
            (array-dimensions array)))

(defun mdal-aux (array all-dimensions use-dimensions 
                       remaining-dimensions)
  (if (= (length all-dimensions) (length use-dimensions))
    (apply 'aref array use-dimensions)
    (do ((index 0 (1+ index))
         (d-length (car remaining-dimensions))
         (result nil))
        ((= d-length index) result)
      (setq result 
            (append result (list (mdal-aux array all-dimensions
                                           (append use-dimensions 
                                                   (list index))
                                           (cdr remaining-dimensions))))))))

(defun adjust-array (array dims
                           &key (element-type nil element-type-p)
                           (initial-element nil initial-element-p)
                           (initial-contents nil initial-contents-p)
                           (fill-pointer nil fill-pointer-p)
                           displaced-to
                           displaced-index-offset
                           &aux (subtype (array-element-subtype array)))
  "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
  (when (and element-type-p
             (neq (element-type-subtype element-type) subtype))
    (error "~S is not of element type ~S" array element-type))
  (when (integerp dims)(setq dims (list dims))) ; because %displace-array wants the list
  (if (neq (list-length dims)(array-rank array))
    (error "~S has wrong rank for adjusting to dimensions ~S" array dims))
  (let ((size 1)
        (explicitp nil))
    (dolist (dim dims)
      (when (< dim 0)(report-bad-arg dims '(integer 0 *)))
      (setq size (* size dim)))
    (when (and (neq fill-pointer t)
               (array-has-fill-pointer-p array)
               (< size (or fill-pointer (fill-pointer array))))
      (error "Cannot adjust array ~S to size less than fill pointer ~S"
             array (or fill-pointer (fill-pointer array))))
    (when (and fill-pointer (not (array-has-fill-pointer-p array)))
      (error "~S does not have a fill pointer" array))
    (when (and displaced-index-offset (null displaced-to))
      (error "Cannot specify ~S without ~S" :displaced-index-offset :displaced-to))
    (when (and initial-element-p initial-contents-p)
      (error "Cannot specify both ~S and ~S" :initial-element :initial-contents))
    (cond 
      ((not (adjustable-array-p array))
       (let ((new-array (make-array-1  dims 
                                       (array-element-type array) T
                                       displaced-to
                                       displaced-index-offset
                                       nil
                                       (or fill-pointer
                                           (and (array-has-fill-pointer-p array)
                                                (fill-pointer array)))
                                       initial-element initial-element-p
                                       initial-contents initial-contents-p
                                       size)))
                     
         (when (and (null initial-contents-p)
                    (null displaced-to))
           (multiple-value-bind (array-data offs) (array-data-and-offset array)
             (let ((new-array-data (array-data-and-offset new-array))) 
               (cond ((null dims)
                      (uvset new-array-data 0 (uvref array-data offs)))
                     (T
                      (init-array-data array-data offs (array-dimensions array) 
                                       new-array-data 0 dims))))))
         (setq array new-array)))
      (T (cond 
           (displaced-to
            (if (and displaced-index-offset 
                     (or (not (fixnump displaced-index-offset))
                         (< displaced-index-offset 0)))
              (report-bad-arg displaced-index-offset '(integer 0 #.most-positive-fixnum)))
            (when (or initial-element-p initial-contents-p)
              (error "Cannot specify initial values for displaced arrays"))
            (unless (eq subtype (array-element-subtype displaced-to))
              (error "~S is not of element type ~S"
                     displaced-to (array-element-type array)))
            (do* ((vec displaced-to (displaced-array-p vec)))
                 ((null vec) ())
              (when (eq vec array)
                (error "Array cannot be displaced to itself.")))
            (setq explicitp t))
           (T
            (setq displaced-to (%alloc-misc size subtype))
            (cond (initial-element-p
                   (dotimes (i (the fixnum size)) (uvset displaced-to i initial-element)))
                  (initial-contents-p
                   (if (null dims) (uvset displaced-to 0 initial-contents)
                     (init-uvector-contents displaced-to 0 dims initial-contents))))
            (cond ((null dims)
                   (uvset displaced-to 0 (aref array)))
                  ((not initial-contents-p)
                   (multiple-value-bind (vec offs) (array-data-and-offset array)
                     (init-array-data vec offs (array-dimensions array) displaced-to 0 dims))))))
         (%displace-array array dims size displaced-to (or displaced-index-offset 0) explicitp)))
    (when fill-pointer-p
      (cond
        ((eq fill-pointer t)
         (set-fill-pointer array size))
        (fill-pointer
         (set-fill-pointer array fill-pointer))))
    array))

(defun array-dims-sizes (dims)
   (if (or (atom dims) (null (%cdr dims))) dims
     (let ((ndims (array-dims-sizes (%cdr dims))))
       (cons (* (%car dims) (%car ndims)) ndims))))

(defun init-array-data (vec off dims nvec noff ndims)
   (init-array-data-aux vec off dims (array-dims-sizes (cdr dims))
                        nvec noff ndims (array-dims-sizes (cdr ndims))))

(defun init-array-data-aux (vec off dims siz nvec noff ndims nsiz)
   (when (null siz)
      (return-from init-array-data-aux
         (init-vector-data vec off (car dims) nvec noff (car ndims))))
   (let ((count (pop dims))
         (size (pop siz))
         (ncount (pop ndims))
         (nsize (pop nsiz)))
     (dotimes (i (if (%i< count ncount) count ncount))
        (declare (fixnum i))
        (init-array-data-aux vec off dims siz nvec noff ndims nsiz)
        (setq off (%i+ off size) noff (%i+ noff nsize)))))

(defun init-vector-data (vec off len nvec noff nlen)
  (dotimes (i (if (%i< len nlen) len nlen))
     (declare (fixnum i))
     (uvset nvec noff (uvref vec off))
     (setq off (%i+ off 1) noff (%i+ noff 1))))

;;; only caller is adjust-array

(defun %displace-array (array dims size data offset explicitp)
  (let* ((typecode (typecode array))
         (array-p (eql typecode target::subtag-arrayH))
         (vector-p (eql typecode target::subtag-vectorH)))
    (unless (or array-p vector-p)
      (error "Array ~S cannot be displaced" array))
    (unless (fixnump offset) (report-bad-arg offset '(integer 0 #.most-positive-fixnum)))
    (unless (adjustable-array-p data)
      (multiple-value-bind (ndata noffset) (displaced-array-p data)
        (if ndata (setq data ndata offset (%i+ offset noffset)))))
    (unless (and (fixnump size) (%i<= (%i+ offset size) (array-total-size data)))
      (error "Offset ~S + size ~S must be less than size of array displaced-to" offset size))
    (let* ((flags (%svref array target::vectorH.flags-cell)))
      (declare (fixnum flags))
      (setf (%svref array target::vectorH.flags-cell)
            (if (> (the fixnum (typecode data)) target::subtag-vectorH)
              (bitclr $arh_disp_bit flags)
              (bitset $arh_disp_bit flags)))
      (setf (%svref array target::vectorH.flags-cell)
            (if explicitp
              (bitset $arh_exp_disp_bit flags)
              (bitclr $arh_exp_disp_bit flags)))
      (setf (%svref array target::arrayH.data-vector-cell) data)
      (if array-p
        (progn
          (do ((i target::arrayH.dim0-cell (1+ i)))
              ((null dims))
            (declare (fixnum i))
            (setf (%svref array i) (pop dims)))
          (setf (%svref array target::arrayH.physsize-cell) size)
          (setf (%svref array target::arrayH.displacement-cell) offset))
        (progn
          (if (or (not (logbitp $arh_fill_bit flags))
                  (> (the fixnum (%svref array target::vectorH.logsize-cell)) size))
            (setf (%svref array target::vectorH.logsize-cell) size))
          (setf (%svref array target::vectorH.physsize-cell) size)
          (setf (%svref array target::vectorH.displacement-cell) offset)))
      array)))



(defun array-row-major-index (array &lexpr subscripts)
  (let ((rank  (array-rank array))
        (nsubs (%lexpr-count subscripts))
        (sum 0))
    (declare (fixnum sum rank))
    (unless (eql rank nsubs)
      (%err-disp $xndims array nsubs))    
      (if (eql 0 rank)
        0
        (do* ((i (1- rank) (1- i))
              (dim (array-dimension array i) (array-dimension array i))
              (last-size 1 size)
              (size dim (* dim size)))
             (nil)
          (declare (fixnum i last-size size))
          (let ((s (%lexpr-ref subscripts nsubs i)))
            (unless (fixnump s)
              (setq s (require-type s 'fixnum)))
            (when (or (< s 0) (>= s dim))
              (%err-disp $XARROOB (%apply-lexpr 'list subscripts) array))
            (incf sum (the fixnum (* s last-size)))
            (when (eql i 0) (return sum)))))))

(defun array-in-bounds-p (array &lexpr subscripts)
  "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
  (let ((rank  (array-rank array))
        (nsubs (%lexpr-count subscripts)))
    (declare (fixnum nsubs rank))    
    (if (not (eql nsubs rank))
      (%err-disp $xndims array nsubs)
      (if (eql 0 rank)
        0
        (do* ((i (1- rank) (1- i))
              (dim (array-dimension array i) (array-dimension array i)))
             (nil)
          (declare (fixnum i dim))
          (let ((s  (%lexpr-ref subscripts nsubs i)))
            (if (typep s 'fixnum)
              (locally (declare (fixnum s))
                (if (or (< s 0)(>= s dim)) (return nil)))
              (if (typep s 'bignum)
                (return nil)
                (report-bad-arg s 'integer)))
            (when (eql i 0) (return t))))))))

(defun row-major-aref (array index)
  "Return the element of array corressponding to the row-major index. This is
   SETF'able."
  (multiple-value-bind (displaced-to offset) (displaced-array-p array)
    (aref (or displaced-to array) (+ index offset))))

(defun row-major-aset (array index new)
  (multiple-value-bind (displaced-to offset) (displaced-array-p array)
    (setf (aref (or displaced-to array) (+ index offset)) new)))

(defsetf row-major-aref row-major-aset)
             


; end