- element-type (array-element-type displaced-to)))
- (let ((displacement (or displaced-index-offset 0))
- (array-size (apply #'* dimensions)))
- (declare (fixnum displacement array-size))
- (if (< (the fixnum (array-total-size displaced-to))
- (the fixnum (+ displacement array-size)))
- (error "The :DISPLACED-TO array is too small."))
- (if (adjustable-array-p array)
- ;; None of the original contents appear in adjusted array.
- (set-array-header array displaced-to array-size
- (get-new-fill-pointer array array-size
- fill-pointer)
- displacement dimensions t)
- ;; simple multidimensional or single dimensional array
- (make-array dimensions
- :element-type element-type
- :displaced-to displaced-to
- :displaced-index-offset
- displaced-index-offset))))
- ((= array-rank 1)
- (let ((old-length (array-total-size array))
- (new-length (car dimensions))
- new-data)
- (declare (fixnum old-length new-length))
- (with-array-data ((old-data array) (old-start)
- (old-end old-length))
- (cond ((or (%array-displaced-p array)
- (< old-length new-length))
- (setf new-data
- (data-vector-from-inits
- dimensions new-length element-type
- initial-contents initial-contents-p
+ element-type (array-element-type displaced-to)))
+ (let ((displacement (or displaced-index-offset 0))
+ (array-size (apply #'* dimensions)))
+ (declare (fixnum displacement array-size))
+ (if (< (the fixnum (array-total-size displaced-to))
+ (the fixnum (+ displacement array-size)))
+ (error "The :DISPLACED-TO array is too small."))
+ (if (adjustable-array-p array)
+ ;; None of the original contents appear in adjusted array.
+ (set-array-header array displaced-to array-size
+ (get-new-fill-pointer array array-size
+ fill-pointer)
+ displacement dimensions t)
+ ;; simple multidimensional or single dimensional array
+ (make-array dimensions
+ :element-type element-type
+ :displaced-to displaced-to
+ :displaced-index-offset
+ displaced-index-offset))))
+ ((= array-rank 1)
+ (let ((old-length (array-total-size array))
+ (new-length (car dimensions))
+ new-data)
+ (declare (fixnum old-length new-length))
+ (with-array-data ((old-data array) (old-start)
+ (old-end old-length))
+ (cond ((or (and (array-header-p array)
+ (%array-displaced-p array))
+ (< old-length new-length))
+ (setf new-data
+ (data-vector-from-inits
+ dimensions new-length element-type
+ initial-contents initial-contents-p