Skip to content
Snippets Groups Projects
Commit 85f79adc authored by wlott's avatar wlott
Browse files

Fixed make-array to allow :initial-contents to be built out of any kind

of sequence, not just lists.

Fixed vector-push and vector-push-extend to return the original fill
pointer, not the new fill pointer.

Fixed vector-pop to return the value indexed by the new fill pointer, not
the original fill pointer.
parent c51c62e0
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.12 1991/05/28 17:13:35 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.13 1991/06/05 10:54:52 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -257,17 +257,20 @@ ...@@ -257,17 +257,20 @@
(setf (aref vector index) contents) (setf (aref vector index) contents)
(incf index)) (incf index))
(t (t
(unless (typep contents 'sequence)
(error "Malformed :initial-contents. ~S is not a ~
sequence, but ~D more layer~:P needed."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims)) (unless (= (length contents) (car dims))
(error "Malformed :initial-contents. Dimension of ~ (error "Malformed :initial-contents. Dimension of ~
axis ~D is ~D, but ~S is ~D long." axis ~D is ~D, but ~S is ~D long."
axis (car dims) contents (length contents))) axis (car dims) contents (length contents)))
(unless (listp contents) (if (listp contents)
(error "Malformed :initial-contents. ~S is an atom, ~ (dolist (content contents)
but ~D more layer~:P needed." (frob (1+ axis) (cdr dims) content))
contents (dotimes (i (length contents))
(- (length dimensions) axis))) (frob (1+ axis) (cdr dims) (aref contents i))))))))
(dolist (content contents)
(frob (1+ axis) (cdr dims) content))))))
(frob 0 dimensions initial-contents)))) (frob 0 dimensions initial-contents))))
...@@ -560,7 +563,7 @@ ...@@ -560,7 +563,7 @@
(defun vector-push (new-el array) (defun vector-push (new-el array)
"Attempts to set the element of Array designated by the fill pointer "Attempts to set the element of Array designated by the fill pointer
to New-El and increment fill pointer by one. If the fill pointer is to New-El and increment fill pointer by one. If the fill pointer is
too large, Nil is returned, otherwise the new fill pointer value is too large, Nil is returned, otherwise the index of the pushed element is
returned." returned."
(declare (vector array)) (declare (vector array))
(let ((fill-pointer (fill-pointer array))) (let ((fill-pointer (fill-pointer array)))
...@@ -569,7 +572,8 @@ ...@@ -569,7 +572,8 @@
nil) nil)
(t (t
(setf (aref array fill-pointer) new-el) (setf (aref array fill-pointer) new-el)
(setf (%array-fill-pointer array) (1+ fill-pointer)))))) (setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))))
(defun vector-push-extend (new-el array &optional (defun vector-push-extend (new-el array &optional
(extension (if (zerop (length array)) (extension (if (zerop (length array))
...@@ -583,22 +587,21 @@ ...@@ -583,22 +587,21 @@
(when (= fill-pointer (%array-available-elements array)) (when (= fill-pointer (%array-available-elements array))
(adjust-array array (+ fill-pointer extension))) (adjust-array array (+ fill-pointer extension)))
(setf (aref array fill-pointer) new-el) (setf (aref array fill-pointer) new-el)
(setf (%array-fill-pointer array) (1+ fill-pointer)))) (setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))
(defun vector-pop (array) (defun vector-pop (array)
"Attempts to decrease the fill-pointer by 1 and return the element "Attempts to decrease the fill-pointer by 1 and return the element
pointer to by the new fill pointer. If the new value of the fill pointer to by the new fill pointer. If the original value of the fill
pointer is 0, an error occurs." pointer is 0, an error occurs."
(declare (vector array)) (declare (vector array))
(let ((fill-pointer (fill-pointer array))) (let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer)) (declare (fixnum fill-pointer))
(cond ((zerop fill-pointer) (if (zerop fill-pointer)
(error "Nothing left to pop.")) (error "Nothing left to pop.")
(t (aref array
(setf (%array-fill-pointer array) (setf (%array-fill-pointer array)
(1- fill-pointer)) (1- fill-pointer))))))
(aref array fill-pointer)))))
;;;; Adjust-array ;;;; Adjust-array
......
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