;;; These functions are only needed by the interpreter, 'cause the
;;; compiler inlines them.
;;; These functions are only needed by the interpreter, 'cause the
;;; compiler inlines them.
`(progn
(defun ,name (array)
(,name array))
(defun (setf ,name) (value array)
(setf (,name array) value)))))
`(progn
(defun ,name (array)
(,name array))
(defun (setf ,name) (value array)
(setf (,name array) value)))))
- (def-frob %array-fill-pointer)
- (def-frob %array-fill-pointer-p)
- (def-frob %array-available-elements)
- (def-frob %array-data-vector)
- (def-frob %array-displacement)
- (def-frob %array-displaced-p))
+ (def %array-fill-pointer)
+ (def %array-fill-pointer-p)
+ (def %array-available-elements)
+ (def %array-data-vector)
+ (def %array-displacement)
+ (def %array-displaced-p))
;;; It'd waste space to expand copies of error handling in every
;;; inline %WITH-ARRAY-DATA, so we have them call this function
;;; instead. This is just a wrapper which is known never to return.
(defun failed-%with-array-data (array start end)
(declare (notinline %with-array-data))
(%with-array-data array start end)
;;; It'd waste space to expand copies of error handling in every
;;; inline %WITH-ARRAY-DATA, so we have them call this function
;;; instead. This is just a wrapper which is known never to return.
(defun failed-%with-array-data (array start end)
(declare (notinline %with-array-data))
(%with-array-data array start end)
- `(cond ,@(mapcar #'(lambda (spec)
- `(,(if (eq (car spec) t)
- t
- `(subtypep ,type ',(car spec)))
- ,@(cdr spec)))
+ `(cond ,@(mapcar (lambda (spec)
+ `(,(if (eq (car spec) t)
+ t
+ `(subtypep ,type ',(car spec)))
+ ,@(cdr spec)))
- (error "There are ~D elements in the :INITIAL-CONTENTS, but ~
- the vector length is ~D."
+ (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
+ the vector length is ~W."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
(error "malformed :INITIAL-CONTENTS: Dimension of ~
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
(error "malformed :INITIAL-CONTENTS: Dimension of ~
+;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
+;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
+;;; definition is needed for the compiler to use in constant folding.)
+(defun data-vector-ref (array index)
+ (hairy-data-vector-ref array index))
+
(defun hairy-data-vector-set (array index new-value)
(with-array-data ((vector array) (index index) (end))
(defun hairy-data-vector-set (array index new-value)
(with-array-data ((vector array) (index index) (end))
+ new-value))
+ ;; For specialized arrays, the return
+ ;; from data-vector-set would have to
+ ;; be reboxed to be a (Lisp) return
+ ;; value; instead, we use the
+ ;; already-boxed value as the return.
+ new-value)))
(length subscripts) rank))
(if (array-header-p array)
(do ((subs (nreverse subscripts) (cdr subs))
(length subscripts) rank))
(if (array-header-p array)
(do ((subs (nreverse subscripts) (cdr subs))
(let ((index (first subscripts)))
(unless (< -1 index (length (the (simple-array * (*)) array)))
(if invalid-index-error-p
(let ((index (first subscripts)))
(unless (< -1 index (length (the (simple-array * (*)) array)))
(if invalid-index-error-p
- `(cond ,@(mapcar #'(lambda (stuff)
- (cons
- (let ((item (car stuff)))
- (cond ((eq item t)
- t)
- ((listp item)
- (cons 'or
- (mapcar #'(lambda (x)
- `(= type ,x))
- item)))
- (t
- `(= type ,item))))
- (cdr stuff)))
- stuff))))
+ `(cond ,@(mapcar (lambda (stuff)
+ (cons
+ (let ((item (car stuff)))
+ (cond ((eq item t)
+ t)
+ ((listp item)
+ (cons 'or
+ (mapcar (lambda (x)
+ `(= widetag ,x))
+ item)))
+ (t
+ `(= widetag ,item))))
+ (cdr stuff)))
+ stuff))))
(error "Vector axis is not zero: ~S" axis-number))
(length (the (simple-array * (*)) array)))
((>= axis-number (%array-rank array))
(error "Vector axis is not zero: ~S" axis-number))
(length (the (simple-array * (*)) array)))
((>= axis-number (%array-rank array))
old-dims new-dims)))
(macrolet ((bump-index-list (index limits)
`(do ((subscripts ,index (cdr subscripts))
old-dims new-dims)))
(macrolet ((bump-index-list (index limits)
`(do ((subscripts ,index (cdr subscripts))