Skip to content
Snippets Groups Projects
Commit e2b96221 authored by phg's avatar phg
Browse files

Adjust-array has been updated to be ANSI compliant by allowing arrays which

were not created with :adjustable non-nil to be adjusted to new dimensions.

Adjustable-array-p has been updated to ANSI standards. It returns T if adjust
ADJUST-ARRAY would return an EQ array.
parent dae68b30
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.15 1991/12/02 17:10:41 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.16 1992/03/24 11:03:16 phg Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -180,7 +180,7 @@ ...@@ -180,7 +180,7 @@
length)) length))
(replace array initial-contents)) (replace array initial-contents))
array)) array))
;; It's either a complex array or a multidemsional array. ;; It's either a complex array or a multidimensional array.
(let* ((total-size (reduce #'* dimensions)) (let* ((total-size (reduce #'* dimensions))
(data (or displaced-to (data (or displaced-to
(data-vector-from-inits (data-vector-from-inits
...@@ -392,19 +392,17 @@ ...@@ -392,19 +392,17 @@
(setf (row-major-aref array (%array-row-major-index array subscripts)) (setf (row-major-aref array (%array-row-major-index array subscripts))
new-value)) new-value))
(defun row-major-aref (array index) (defun row-major-aref (array index)
"Returns the element of array corressponding to the row-major index. This is "Returns the element of array corressponding to the row-major index. This is
SETF'able." SETF'able."
(declare (optimize (safety 1))) (declare (optimize (safety 1)))
(row-major-aref array index)) (row-major-aref array index))
(defun %set-row-major-aref (array index new-value) (defun %set-row-major-aref (array index new-value)
(declare (optimize (safety 1))) (declare (optimize (safety 1)))
(setf (row-major-aref array index) new-value)) (setf (row-major-aref array index) new-value))
(defun svref (simple-vector index) (defun svref (simple-vector index)
"Returns the Index'th element of the given Simple-Vector." "Returns the Index'th element of the given Simple-Vector."
(declare (optimize (safety 1))) (declare (optimize (safety 1)))
...@@ -532,11 +530,17 @@ ...@@ -532,11 +530,17 @@
(%array-available-elements array) (%array-available-elements array)
(length (the vector array)))) (length (the vector array))))
(defun array-displacement (array)
"Returns values of :displaced-to and :displaced-index-offset options to
make-array, or the defaults nil and 0 if not a displaced array."
(declare (array array))
(values (%array-data-vector array) (%array-displacement array)))
(defun adjustable-array-p (array) (defun adjustable-array-p (array)
"Returns T if the given Array is adjustable, or NIL otherwise." "Returns T if (adjust-array array...) would return an array identical
to the argument, this happens for complex arrays."
(declare (array array)) (declare (array array))
(array-header-p array)) (not (typep array '(simple-array * (*)))))
;;;; Fill pointer frobbing stuff. ;;;; Fill pointer frobbing stuff.
...@@ -615,9 +619,7 @@ ...@@ -615,9 +619,7 @@
displaced-to displaced-index-offset) displaced-to displaced-index-offset)
"Adjusts the Array's dimensions to the given Dimensions and stuff." "Adjusts the Array's dimensions to the given Dimensions and stuff."
(let ((dimensions (if (listp dimensions) dimensions (list dimensions)))) (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
(cond ((not (array-header-p array)) (cond ((/= (the fixnum (length (the list dimensions)))
(error "~S is not an adjustable array." array))
((/= (the fixnum (length (the list dimensions)))
(the fixnum (array-rank array))) (the fixnum (array-rank array)))
(error "Number of dimensions not equal to rank of array.")) (error "Number of dimensions not equal to rank of array."))
((not (subtypep element-type (array-element-type array))) ((not (subtypep element-type (array-element-type array)))
...@@ -628,6 +630,7 @@ ...@@ -628,6 +630,7 @@
(when (and fill-pointer (> array-rank 1)) (when (and fill-pointer (> array-rank 1))
(error "Multidimensional arrays can't have fill pointers.")) (error "Multidimensional arrays can't have fill pointers."))
(cond (initial-contents (cond (initial-contents
;; Array former contents replaced by initial-contents.
(if (or initial-element-p displaced-to) (if (or initial-element-p displaced-to)
(error "Initial contents may not be specified with ~ (error "Initial contents may not be specified with ~
the :initial-element or :displaced-to option.")) the :initial-element or :displaced-to option."))
...@@ -636,12 +639,19 @@ ...@@ -636,12 +639,19 @@
dimensions array-size element-type dimensions array-size element-type
initial-contents initial-element initial-contents initial-element
initial-element-p))) initial-element-p)))
(set-array-header array array-data array-size (if (adjustable-array-p array)
(set-array-header array array-data array-size
(get-new-fill-pointer array array-size (get-new-fill-pointer array array-size
fill-pointer) fill-pointer)
0 dimensions nil))) 0 dimensions nil)
(if (array-header-p array)
;; Simple multidimensional or single dimensional array.
(make-array dimensions
:element-type element-type
:initial-contents initial-contents)
array-data))))
(displaced-to (displaced-to
;; no initial-contents supplied is already known ;; No initial-contents supplied is already established.
(when initial-element (when initial-element
(error "The :initial-element option may not be specified ~ (error "The :initial-element option may not be specified ~
with :displaced-to.")) with :displaced-to."))
...@@ -655,12 +665,20 @@ ...@@ -655,12 +665,20 @@
(if (< (the fixnum (array-total-size displaced-to)) (if (< (the fixnum (array-total-size displaced-to))
(the fixnum (+ displacement array-size))) (the fixnum (+ displacement array-size)))
(error "The :displaced-to array is too small.")) (error "The :displaced-to array is too small."))
(set-array-header array displaced-to array-size (if (adjustable-array-p array)
(get-new-fill-pointer array array-size ;; None of the original contents appear in adjusted array.
fill-pointer) (set-array-header array displaced-to array-size
displacement dimensions t))) (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) ((= array-rank 1)
(let ((old-length (%array-available-elements array)) (let ((old-length (array-total-size array))
(new-length (car dimensions)) (new-length (car dimensions))
new-data) new-data)
(declare (fixnum old-length new-length)) (declare (fixnum old-length new-length))
...@@ -677,10 +695,12 @@ ...@@ -677,10 +695,12 @@
:start2 old-start :end2 old-end)) :start2 old-start :end2 old-end))
(t (setf new-data (t (setf new-data
(shrink-vector old-data new-length)))) (shrink-vector old-data new-length))))
(set-array-header array new-data new-length (if (adjustable-array-p array)
(get-new-fill-pointer array new-length (set-array-header array new-data new-length
fill-pointer) (get-new-fill-pointer array new-length
0 dimensions nil)))) fill-pointer)
0 dimensions nil)
new-data))))
(t (t
(let ((old-length (%array-available-elements array)) (let ((old-length (%array-available-elements array))
(new-length (apply #'* dimensions))) (new-length (apply #'* dimensions)))
...@@ -699,8 +719,7 @@ ...@@ -699,8 +719,7 @@
new-data dimensions new-length element-type new-data dimensions new-length element-type
initial-element initial-element-p) initial-element initial-element-p)
(set-array-header array new-data new-length (set-array-header array new-data new-length
new-length 0 dimensions nil)))))))) new-length 0 dimensions nil)))))))))
array)
(defun get-new-fill-pointer (old-array new-array-size fill-pointer) (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
(cond ((not fill-pointer) (cond ((not fill-pointer)
...@@ -713,7 +732,7 @@ ...@@ -713,7 +732,7 @@
((not (array-has-fill-pointer-p old-array)) ((not (array-has-fill-pointer-p old-array))
(error "Cannot supply a non-NIL value (~S) for :fill-pointer ~ (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~
in adjust-array unless the array (~S) was originally ~ in adjust-array unless the array (~S) was originally ~
created with a fill pointer." created with a fill pointer."
fill-pointer fill-pointer
old-array)) old-array))
((numberp fill-pointer) ((numberp fill-pointer)
...@@ -752,6 +771,8 @@ ...@@ -752,6 +771,8 @@
((simple-array (unsigned-byte 32) (*)) 0) ((simple-array (unsigned-byte 32) (*)) 0)
((simple-array single-float (*)) (coerce 0 'single-float)) ((simple-array single-float (*)) (coerce 0 'single-float))
((simple-array double-float (*)) (coerce 0 'double-float))))) ((simple-array double-float (*)) (coerce 0 'double-float)))))
;; Only arrays have fill-pointers, but vectors have their length parameter
;; in the same place.
(setf (%array-fill-pointer vector) new-size) (setf (%array-fill-pointer vector) new-size)
vector) vector)
......
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