Skip to content
Snippets Groups Projects
Commit 26e7aeea authored by pmai's avatar pmai
Browse files

o When created displaced arrays, MAKE-ARRAY (unlike ADJUST-ARRAY)

  didn't check whether the specified element-type was a subtype of the
  array-element-type of the displaced-to array.
o One case in ADJUST-ARRAY didn't check for an array-header before
  calling %array-displaced-p on an array, so that sometimes an array
  element was accessed and checked instead.  Fixed this, and prevented
  ADJUST-ARRAY from shrinking non-adjustable arrays in-place, since
  this can violate naive user expectations for little gain.
parent e87367e4
No related branches found
No related tags found
No related merge requests found
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.31 2000/05/13 12:28:41 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.32 2001/11/21 22:45:36 pmai Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -232,6 +232,11 @@
(when (or initial-element-p initial-contents)
(error "Neither :initial-element nor :initial-contents ~
can be specified along with :displaced-to"))
(unless (subtypep element-type
(array-element-type displaced-to))
(error "One can't displace an array of type ~S into ~
another of type ~S."
element-type (array-element-type displaced-to)))
(let ((offset (or displaced-index-offset 0)))
(when (> (+ offset total-size)
(array-total-size displaced-to))
......@@ -746,17 +751,23 @@
(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-element
initial-element-p))
(replace new-data old-data
:start2 old-start :end2 old-end))
(t (setf new-data
(shrink-vector old-data new-length))))
(cond
((and (adjustable-array-p array)
(not (%array-displaced-p array))
(<= new-length old-length))
;; Shrink underlying vector in-place. We don't do this
;; for non-adjustable arrays, since that might confuse
;; user expectations about adjust-array consing a fresh
;; array in that case.
(setf new-data (shrink-vector old-data new-length)))
(t
(setf new-data
(data-vector-from-inits
dimensions new-length element-type
initial-contents initial-element
initial-element-p))
(replace new-data old-data
:start2 old-start :end2 old-end)))
(if (adjustable-array-p array)
(set-array-header array new-data new-length
(get-new-fill-pointer array new-length
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment