big-array.lisp

(defconstant array-max-size (1- array-total-size-limit))
(defstruct bigvector
  total-size
  slice-size
  last-slice-size
  slices)

(declaim (inline allocate-vector))
(defun allocate-vector (size element-type)
  (declare (type integer size))
  (multiple-value-bind (nslices last-slice-size)
      (truncate size array-max-size)
    (if (plusp last-slice-size)
        (incf nslices)
        (setf last-slice-size array-max-size))
    (let ((v (make-bigvector :total-size size
                             :slice-size array-max-size
                             :last-slice-size last-slice-size
                             :slices (make-array nslices))))
      ;; (bigvector-slices v) could be a bigvector too!
      (dotimes (i nslices)
        (setf (aref (bigvector-slices v) i)
              (cl:make-array (if (= i (1- nslices))
                                 last-slice-size
                                 array-max-size)
                             :element-type element-type)))
      v)))

#+(and lispworks bigarray)
(lw:defadvice (make-array make-bigarray :around)
    (dimensions &rest parameters &key (element-type t)
                initial-element initial-contents adjustable
                fill-pointer displaced-to displaced-index-offset
&allow-other-keys)
  (if (and (integerp dimensions)
           (> dimensions array-max-size)
           (null adjustable)
           (null fill-pointer)
           (null displaced-to)
           (null displaced-index-offset)
           (null initial-element)
           (null initial-contents))
    (allocate-vector dimensions element-type)
    (apply #'lw:call-next-advice dimensions parameters)))

#+(and lispworks bigarray)
(lw:defadvice (aref aref-bigarray :around)
    (array &rest subscripts)
  (cond ((arrayp array)
         (apply #'lw:call-next-advice array subscripts))
        (t
         (assert (= 1 (length subscripts)))
         (multiple-value-bind (slice index)
             (truncate (first subscripts) array-max-size)
           ;; Notice the recursive call to aref:
           (lw:call-next-advice
            (lw:call-next-advice (bigvector-slices array) slice) index)))))

#+(and lispworks bigarray)
(lw:defadvice ((setf aref) set-aref-bigarray :around)
    (new-value array &rest subscripts)
  (cond ((arrayp array)
         (apply #'lw:call-next-advice new-value array subscripts))
        (t
         (assert (= 1 (length subscripts)))
         (multiple-value-bind (slice index)
             (truncate (first subscripts) array-max-size)
           ;; Notice the recursive call to aref:
           (lw:call-next-advice new-value (aref (bigvector-slices
array) slice) index)))))

#+(and lispworks bigarray)
(lw:defadvice (elt elt-bigarray :around)
    (sequence index)
  (cond ((bigvector-p sequence) (aref sequence index))
        (t (lw:call-next-advice sequence index))))

;; #+(and lispworks bigarray)
;; (lw:defadvice ((setf elt) set-elt-bigarray :around)
;;     (new-value sequence index)
;;   (cond ((bigvector-p array) (setf (aref array index) new-value))
;;         (t (lw:call-next-advice new-value sequence index))))

#+(and lispworks bigarray)
(lw:defadvice (length length-bigarray :around)
    (sequence)
  (cond ((bigvector-p sequence)
         (bigvector-total-size sequence))
        (t (lw:call-next-advice sequence))))