+;;; Populate the dispatch tables.
+(macrolet ((def-subseq-funs ()
+ `(progn
+ (set '%%vector-subseq-funs%%
+ (make-array (1+ sb!vm:widetag-mask)
+ :initial-element #'hairy-subseq-error))
+ ,@(map 'list
+ (lambda (saetp)
+ (let ((name (symbolicate "SUBSEQ/"
+ (sb!vm:saetp-primitive-type-name saetp))))
+ `(progn
+ (defun ,name (vector start end)
+ (declare (type (simple-array ,(sb!vm:saetp-specifier saetp) (*))
+ vector)
+ (index start end)
+ (optimize speed (safety 0)))
+ (subseq vector start end))
+ (setf (svref %%vector-subseq-funs%%
+ ,(sb!vm:saetp-typecode saetp))
+ #',name))))
+ sb!vm:*specialized-array-element-type-properties*))))
+ (def-subseq-funs))
+(macrolet ((define-reffer (saetp check-form)
+ (let* ((type (sb!vm:saetp-specifier saetp))
+ (atype `(simple-array ,type (*))))
+ `(named-lambda optimized-data-vector-ref (vector index)
+ (declare (optimize speed (safety 0)))
+ (data-vector-ref (the ,atype vector)
+ (locally
+ (declare (optimize (safety 1)))
+ (the index
+ (,@check-form index)))))))
+ (define-setter (saetp check-form)
+ (let* ((type (sb!vm:saetp-specifier saetp))
+ (atype `(simple-array ,type (*))))
+ `(named-lambda optimized-data-vector-set (vector index new-value)
+ (declare (optimize speed (safety 0)))
+ (data-vector-set (the ,atype vector)
+ (locally
+ (declare (optimize (safety 1)))
+ (the index
+ (,@check-form index)))
+ (locally
+ ;; SPEED 1 needed to avoid the compiler
+ ;; from downgrading the type check to
+ ;; a cheaper one.
+ (declare (optimize (speed 1)
+ (safety 1)))
+ (the ,type 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)))
+ (define-reffers (symbol deffer check-form slow-path)
+ `(progn
+ ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
+ ;; preserve the binding, so re-initiaize as NS doesn't have
+ ;; the energy to figure out to change that right now.
+ (setf ,symbol (make-array (1+ sb!vm::widetag-mask)
+ :initial-element #'hairy-ref-error))
+ ,@(loop for widetag in '(sb!vm:complex-vector-widetag
+ sb!vm:complex-vector-nil-widetag
+ sb!vm:complex-bit-vector-widetag
+ #!+sb-unicode sb!vm:complex-character-string-widetag
+ sb!vm:complex-base-string-widetag
+ sb!vm:simple-array-widetag
+ sb!vm:complex-array-widetag)
+ collect `(setf (svref ,symbol ,widetag) ,slow-path))
+ ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ for widetag = (sb!vm:saetp-typecode saetp)
+ collect `(setf (svref ,symbol ,widetag)
+ (,deffer ,saetp ,check-form))))))
+ (defun !hairy-data-vector-reffer-init ()
+ (define-reffers %%data-vector-reffers%% define-reffer
+ (progn)
+ #'slow-hairy-data-vector-ref)
+ (define-reffers %%data-vector-setters%% define-setter
+ (progn)
+ #'slow-hairy-data-vector-set)
+ (define-reffers %%data-vector-reffers/check-bounds%% define-reffer
+ (%check-bound vector (length vector))
+ #'slow-hairy-data-vector-ref/check-bounds)
+ (define-reffers %%data-vector-setters/check-bounds%% define-setter
+ (%check-bound vector (length vector))
+ #'slow-hairy-data-vector-set/check-bounds)))
+
+;;; (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 data-vector-ref-with-offset (array index offset)
+ (hairy-data-vector-ref array (+ index offset)))
+
+(defun invalid-array-p (array)
+ (and (array-header-p array)
+ (consp (%array-displaced-p array))))
+
+(declaim (ftype (function (array) nil) invalid-array-error))
+(defun invalid-array-error (array)
+ (aver (array-header-p array))
+ ;; Array invalidation stashes the original dimensions here...
+ (let ((dims (%array-displaced-p array))
+ (et (array-element-type array)))
+ (error 'invalid-array-error
+ :datum array
+ :expected-type
+ (if (cdr dims)
+ `(array ,et ,dims)
+ `(vector ,et ,@dims)))))
+
+(declaim (ftype (function (array integer integer &optional t) nil)
+ invalid-array-index-error))
+(defun invalid-array-index-error (array index bound &optional axis)
+ (if (invalid-array-p array)
+ (invalid-array-error array)
+ (error 'invalid-array-index-error
+ :array array
+ :axis axis
+ :datum index
+ :expected-type `(integer 0 (,bound)))))
+
+;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed