Skip to content
Snippets Groups Projects
Commit 7862b94e authored by emarsden's avatar emarsden
Browse files

Two unrelated fixes to ADJUST-ARRAY:

  - (adjust-array (make-array nil :initial-element 'zob) nil)
    was losing the :initial-element information

  - ADJUST-ARRAY was sometimes returning the same array despite
    ADJUSTABLE-ARRAY-P returning nil for that array (fix from SBCL)

Fixes a number of AJUST-ARRAY.* tests in Paul Dietz's ANSI compliance
suite.
parent cf98504f
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.37 2003/07/23 09:39:25 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.38 2004/04/06 17:18:03 emarsden Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -778,26 +778,34 @@
(t
(let ((old-length (%array-available-elements array))
(new-length (apply #'* dimensions)))
(declare (fixnum old-length new-length))
(with-array-data ((old-data array) (old-start)
(old-end old-length))
(declare (ignore old-end))
(let ((new-data (if (or (%array-displaced-p array)
(> new-length old-length))
(data-vector-from-inits
dimensions new-length
element-type () nil
initial-element initial-element-p)
old-data)))
(if (or (zerop old-length) (zerop new-length))
(when initial-element-p (fill new-data initial-element))
(zap-array-data old-data (array-dimensions array)
old-start
new-data dimensions new-length
element-type initial-element
initial-element-p))
(set-array-header array new-data new-length
new-length 0 dimensions nil)))))))))
(declare (fixnum old-length new-length))
(cond ((null dimensions)
array)
(t
(with-array-data ((old-data array) (old-start)
(old-end old-length))
(declare (ignore old-end))
(let ((new-data (if (or (%array-displaced-p array)
(> new-length old-length))
(data-vector-from-inits
dimensions new-length
element-type () nil
initial-element initial-element-p)
old-data)))
(if (or (zerop old-length) (zerop new-length))
(when initial-element-p (fill new-data initial-element))
(zap-array-data old-data (array-dimensions array)
old-start
new-data dimensions new-length
element-type initial-element
initial-element-p))
(if (adjustable-array-p array)
(set-array-header array new-data new-length
new-length 0 dimensions nil)
(let ((new-array
(make-array-header vm:simple-array-type array-rank)))
(set-array-header new-array new-data new-length
new-length 0 dimensions nil)))))))))))))
(defun get-new-fill-pointer (old-array new-array-size fill-pointer)
(cond ((not fill-pointer)
......
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