;;;; functions to implement arrays

  This software is part of the SBCL system . See the README file for
;;;; more information.
;;;;
  This software is derived from the CMU CL system , which was
  written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-VM")

(declaim (inline adjustable-array-p
                 array-displacement))

;;;; miscellaneous accessor functions

;;; These functions are only needed by the interpreter, 'cause the
  compiler inlines them .
(macrolet ((def (name)
             `(progn
                (defun ,name (array)
                  (,name array))
                (defun (setf ,name) (value array)
                  (setf (,name array) value)))))
  (def %array-fill-pointer)
  (def %array-available-elements)
  (def %array-data)
  (def %array-displacement)
  (def %array-displaced-p)
  (def %array-displaced-from))

(defun %array-rank (array)
  (%array-rank array))

(defun %array-dimension (array axis)
  (%array-dimension array axis))

(defun %check-bound (array bound index)
  (declare (type index bound)
           (fixnum index))
  (%check-bound array bound index))

(defun check-bound (array bound index)
  (declare (type index bound)
           (fixnum index))
  (%check-bound array bound index)
  index)

(defun %with-array-data/fp (array start end)
  (%with-array-data-macro array start end :check-bounds t :check-fill-pointer t))

(defun %with-array-data (array start end)
  (%with-array-data-macro array start end :check-bounds t :array-header-p t))

(defun %data-vector-and-index (array index)
  (if (array-header-p array)
      (multiple-value-bind (vector index)
          (%with-array-data array index nil)
        (values vector index))
      (values (truly-the (simple-array * (*)) array) index)))


;;;; MAKE-ARRAY
(defun %integer-vector-widetag-and-n-bits-shift (signed high)
  (let ((unsigned-table
          #.(let ((map (make-array (1+ n-word-bits))))
              (loop for saetp across
                    (reverse *specialized-array-element-type-properties*)
                    for ctype = (saetp-ctype saetp)
                    when (and (numeric-type-p ctype)
                              (eq (numeric-type-class ctype) 'integer)
                              (zerop (numeric-type-low ctype)))
                    do (fill map (cons (saetp-typecode saetp)
                                       (saetp-n-bits-shift saetp))
                             :end (1+ (integer-length (numeric-type-high ctype)))))
              map))
        (signed-table
          #.(let ((map (make-array (1+ n-word-bits))))
              (loop for saetp across
                    (reverse *specialized-array-element-type-properties*)
                    for ctype = (saetp-ctype saetp)
                    when (and (numeric-type-p ctype)
                              (eq (numeric-type-class ctype) 'integer)
                              (minusp (numeric-type-low ctype)))
                    do (fill map (cons (saetp-typecode saetp)
                                       (saetp-n-bits-shift saetp))
                             :end (+ (integer-length (numeric-type-high ctype)) 2)))
              map)))
    (cond ((> high n-word-bits)
           (values #.simple-vector-widetag
                   #.(1- (integer-length n-word-bits))))
          (signed
           (let ((x (aref signed-table high)))
             (values (car x) (cdr x))))
          (t
           (let ((x (aref unsigned-table high)))
             (values (car x) (cdr x)))))))

  This is a bit complicated , but calling subtypep over all
;;; specialized types is exceedingly slow
(defun %vector-widetag-and-n-bits-shift (type)
  (macrolet ((with-parameters ((arg-type &key intervals)
                               (&rest args) &body body)
               (let ((type-sym (gensym)))
                 `(let (,@(loop for arg in args
                                collect `(,arg '*)))
                    (declare (ignorable ,@args))
                    (when (consp type)
                      (let ((,type-sym (cdr type)))
                        (block nil
                          ,@(loop for arg in args
                                  collect
                                  `(cond ((consp ,type-sym)
                                          (let ((value (pop ,type-sym)))
                                            (if (or (eq value '*)
                                                    (typep value ',arg-type)
                                                    ,(if intervals
                                                         `(and (consp value)
                                                               (null (cdr value))
                                                               (typep (car value)
                                                                      ',arg-type))))
                                                (setf ,arg value)
                                                (ill-type))))
                                         ((null ,type-sym)
                                          (return))
                                         (t
                                          (ill-type)))))
                        (when ,type-sym
                          (ill-type))))
                    ,@body)))
             (ill-type ()
               `(go fastidiously-parse))
             (result (widetag)
               (let ((value (symbol-value widetag)))
                 `(values ,value
                          ,(saetp-n-bits-shift
                            (find value
                                  *specialized-array-element-type-properties*
                                  :key #'saetp-typecode))))))
    (flet ((integer-interval-widetag (low high)
             (if (minusp low)
                 (%integer-vector-widetag-and-n-bits-shift
                  t
                  (1+ (max (integer-length low) (integer-length high))))
                 (%integer-vector-widetag-and-n-bits-shift
                  nil
                  (max (integer-length low) (integer-length high))))))
      (tagbody
         (binding*
             ((consp (consp type))
              (type-name (if consp (car type) type))
              ((widetag n-bits-shift)
               (case type-name
                 ((t)
                  (when consp
                    (ill-type))
                  (result simple-vector-widetag))
                 ((base-char standard-char #-sb-unicode character)
                  (when consp
                    (ill-type))
                  (result simple-base-string-widetag))
                 #+sb-unicode
                 ((character extended-char)
                  (when consp
                    (ill-type))
                  (result simple-character-string-widetag))
                 (bit
                  (when consp
                    (ill-type))
                  (result simple-bit-vector-widetag))
                 (fixnum
                  (when consp
                    (ill-type))
                  (result simple-array-fixnum-widetag))
                 (unsigned-byte
                  (with-parameters ((integer 1)) (high)
                    (if (eq high '*)
                        (result simple-vector-widetag)
                        (%integer-vector-widetag-and-n-bits-shift nil high))))
                 (signed-byte
                  (with-parameters ((integer 1)) (high)
                    (if (eq high '*)
                        (result simple-vector-widetag)
                        (%integer-vector-widetag-and-n-bits-shift t high))))
                 (double-float
                  (with-parameters (double-float :intervals t) (low high)
                    (if (and (not (eq low '*))
                             (not (eq high '*))
                             (if (or (consp low) (consp high))
                                 (>= (type-bound-number low) (type-bound-number high))
                                 (> low high)))
                        (result simple-array-nil-widetag)
                        (result simple-array-double-float-widetag))))
                 (single-float
                  (with-parameters (single-float :intervals t) (low high)
                    (if (and (not (eq low '*))
                             (not (eq high '*))
                             (if (or (consp low) (consp high))
                                 (>= (type-bound-number low) (type-bound-number high))
                                 (> low high)))
                        (result simple-array-nil-widetag)
                        (result simple-array-single-float-widetag))))
                 (mod
                  (if (and (consp type)
                           (consp (cdr type))
                           (null (cddr type))
                           (typep (cadr type) '(integer 1)))
                      (%integer-vector-widetag-and-n-bits-shift
                       nil (integer-length (1- (cadr type))))
                      (ill-type)))
                 #+long-float
                 (long-float
                  (with-parameters (long-float :intervals t) (low high)
                    (if (and (not (eq low '*))
                             (not (eq high '*))
                             (if (or (consp low) (consp high))
                                 (>= (type-bound-number low) (type-bound-number high))
                                 (> low high)))
                        (result simple-array-nil-widetag)
                        (result simple-array-long-float-widetag))))
                 (integer
                  (with-parameters (integer :intervals t) (low high)
                    (let ((low (if (consp low)
                                   (1+ (car low))
                                   low))
                          (high (if (consp high)
                                    (1- (car high))
                                    high)))
                      (cond ((or (eq high '*)
                                 (eq low '*))
                             (result simple-vector-widetag))
                            ((> low high)
                             (result simple-array-nil-widetag))
                            (t
                             (integer-interval-widetag low high))))))
                 (complex
                  (with-parameters (t) (subtype)
                    (if (eq subtype '*)
                        (result simple-vector-widetag)
                        (let ((ctype (specifier-type type)))
                          (cond ((eq ctype *empty-type*)
                                 (result simple-array-nil-widetag))
                                ((union-type-p ctype)
                                 (cond ((csubtypep ctype (specifier-type '(complex double-float)))
                                        (result
                                         simple-array-complex-double-float-widetag))
                                       ((csubtypep ctype (specifier-type '(complex single-float)))
                                        (result
                                         simple-array-complex-single-float-widetag))
                                       #+long-float
                                       ((csubtypep ctype (specifier-type '(complex long-float)))
                                        (result
                                         simple-array-complex-long-float-widetag))
                                       (t
                                        (result simple-vector-widetag))))
                                (t
                                 (case (numeric-type-format ctype)
                                   (double-float
                                    (result
                                     simple-array-complex-double-float-widetag))
                                   (single-float
                                    (result
                                     simple-array-complex-single-float-widetag))
                                   #+long-float
                                   (long-float
                                    (result
                                     simple-array-complex-long-float-widetag))
                                   (t
                                    (result simple-vector-widetag)))))))))
                 ((nil)
                  (result simple-array-nil-widetag))
                 (t
                  (go fastidiously-parse)))))
           (return-from %vector-widetag-and-n-bits-shift
             (values widetag n-bits-shift)))
       fastidiously-parse)
      ;; Do things the hard way after falling through the tagbody.
      (let* ((ctype (type-or-nil-if-unknown type))
             (ctype (and ctype
                         (sb-kernel::replace-hairy-type ctype))))
        (typecase ctype
          (null (result simple-vector-widetag))
          (union-type
           (let ((types (union-type-types ctype)))
             (cond ((not (every #'numeric-type-p types))
                    (result simple-vector-widetag))
                   ((csubtypep ctype (specifier-type 'integer))
                    (block nil
                      (integer-interval-widetag
                       (dx-flet ((low (x)
                                      (or (numeric-type-low x)
                                          (return (result simple-vector-widetag)))))
                         (reduce #'min types :key #'low))
                       (dx-flet ((high (x)
                                       (or (numeric-type-high x)
                                           (return (result simple-vector-widetag)))))
                         (reduce #'max types :key #'high)))))
                   ((csubtypep ctype (specifier-type 'double-float))
                    (result simple-array-double-float-widetag))
                   ((csubtypep ctype (specifier-type 'single-float))
                    (result simple-array-single-float-widetag))
                   #+long-float
                   ((csubtypep ctype (specifier-type 'long-float))
                    (result simple-array-long-float-widetag))
                   ((csubtypep ctype (specifier-type 'complex-double-float))
                    (result simple-array-complex-double-float-widetag))
                   ((csubtypep ctype (specifier-type 'complex-single-float))
                    (result simple-array-complex-single-float-widetag))
                   (t
                    (result simple-vector-widetag)))))
          (intersection-type
           (let ((types (intersection-type-types ctype)))
             (loop for type in types
                   unless (hairy-type-p type)
                   return (%vector-widetag-and-n-bits-shift (type-specifier type)))))
          (character-set-type
           #-sb-unicode (result simple-base-string-widetag)
           #+sb-unicode
           (if (loop for (start . end)
                     in (character-set-type-pairs ctype)
                     always (and (< start base-char-code-limit)
                                 (< end base-char-code-limit)))
               (result simple-base-string-widetag)
               (result simple-character-string-widetag)))
          (t
           (let ((expansion (type-specifier ctype)))
             (if (equal expansion type)
                 (result simple-vector-widetag)
                 (%vector-widetag-and-n-bits-shift expansion)))))))))

(defun %complex-vector-widetag (widetag)
  (macrolet ((make-case ()
               `(case widetag
                  ,@(loop for saetp across *specialized-array-element-type-properties*
                          for complex = (saetp-complex-typecode saetp)
                          when complex
                          collect (list (saetp-typecode saetp) complex))
                  (t
                   #.complex-vector-widetag))))
    (make-case)))

(declaim (inline vector-length-in-words))
(defun vector-length-in-words (length n-bits-shift)
  (declare (type (integer 0 7) n-bits-shift))
  (let ((mask (ash (1- n-word-bits) (- n-bits-shift)))
        (shift (- n-bits-shift
                  (1- (integer-length n-word-bits)))))
    (ash (+ length mask) shift)))

  N - BITS - SHIFT is the shift amount needed to turn LENGTH into array - size - in - bits ,
;;; i.e. log(2,bits-per-elt)
(defun allocate-vector-with-widetag (#+ubsan poisoned widetag length n-bits-shift)
  (declare (type (unsigned-byte 8) widetag)
           (type index length))
   : add SAETP - N - PAD - ELEMENTS " by hand " since there is
             ;; but a single case involving it now.
         (full-length (+ length (if (= widetag simple-base-string-widetag) 1 0)))
  Be careful not to allocate backing storage for element type NIL .
  Both it and type BIT have N - BITS - SHIFT = 0 , so the determination
  of true size ca n't be left up to VECTOR - LENGTH - IN - WORDS .
         ;; VECTOR-LENGTH-IN-WORDS potentially returns a machine-word-sized
         ;; integer, so it doesn't match the primitive type restriction of
  POSITIVE - FIXNUM for the last argument of the vector   .
         (nwords (the fixnum
                      (if (/= widetag simple-array-nil-widetag)
                          (vector-length-in-words full-length n-bits-shift)
                          0))))
  first arg to allocate - vector must be a constant
                      (allocate-vector t widetag length nwords)
                      (allocate-vector nil widetag length nwords))
    #-ubsan (allocate-vector widetag length nwords)))

(declaim (ftype (sfunction (array) (integer 128 255)) array-underlying-widetag))
(defun array-underlying-widetag (array)
  (macrolet ((generate-table ()
               (macrolet ((to-index (x) `(ash ,x -2)))
                 (let ((table (sb-xc:make-array 64 :initial-element 0
                                                :element-type '(unsigned-byte 8))))
                   (dovector (saetp *specialized-array-element-type-properties*)
                     (let* ((typecode (saetp-typecode saetp))
                            (complex-typecode (saetp-complex-typecode saetp)))
                       (setf (aref table (to-index typecode)) typecode)
                       (when complex-typecode
                         (setf (aref table (to-index complex-typecode)) typecode))))
                   (setf (aref table (to-index simple-array-widetag)) 0
                         (aref table (to-index complex-vector-widetag)) 0
                         (aref table (to-index complex-array-widetag)) 0)
                   table)))
             (to-index (x) `(ash ,x -2)))
  (named-let recurse ((x array))
    (let ((result (aref (generate-table)
                        (to-index (%other-pointer-widetag x)))))
      (if (= 0 result)
          (recurse (%array-data x))
          (truly-the (integer 128 255) result))))))

;; Complain in various ways about wrong MAKE-ARRAY and ADJUST-ARRAY arguments,
  returning the two initialization arguments needed for DATA - VECTOR - FROM - INITS .
  This is an unhygienic macro which would be a MACROLET other than for
;; doing so would entail moving toplevel defuns around for no good reason.
(defmacro check-make-array-initargs (displaceable &optional element-type size)
  `(cond ,@(when displaceable
             `((displaced-to
                (when (or element-p contents-p)
                  (if (and element-p contents-p)
                      (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
                               may be specified with the :DISPLACED-TO option")
                      (error "~S may not be specified with the :DISPLACED-TO option"
                             (if element-p :initial-element :initial-contents))))
                (unless (= (array-underlying-widetag displaced-to) widetag)
  Require exact match on upgraded type ( lp#1331299 )
                  (error "Can't displace an array of type ~/sb-impl:print-type-specifier/ ~
                           into another of type ~/sb-impl:print-type-specifier/"
                         ,element-type (array-element-type displaced-to)))
                (when (< (array-total-size displaced-to)
                         (+ displaced-index-offset ,size))
                  (error "The :DISPLACED-TO array is too small.")))
               (offset-p
                (error "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))))
         ((and element-p contents-p)
          (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
         (element-p  (values :initial-element initial-element))
         (contents-p (values :initial-contents initial-contents))))
(defmacro make-array-bad-fill-pointer (actual max adjective)
  ;; There was a comment implying that this should be TYPE-ERROR
  ;; but I don't see that as a spec requirement.
  `(error "Can't supply a value for :FILL-POINTER (~S) that is larger ~
           than the~A size of the vector (~S)" ,actual ,adjective ,max))

(declaim (inline %save-displaced-array-backpointer
                 %save-displaced-new-array-backpointer))
(defun %save-displaced-array-backpointer (array data)
  (flet ((purge (pointers)
           (remove-if (lambda (value)
                        (or (not value) (eq array value)))
                      pointers
                      :key #'weak-pointer-value)))
    (let ((old-data (%array-data array)))
      (unless (eq old-data data)
        ;; Add backpointer to the new data vector if it has a header.
        (when (array-header-p data)
          (setf (%array-displaced-from data)
                (cons (make-weak-pointer array)
                      (purge (%array-displaced-from data)))))
        ;; Remove old backpointer, if any.
        (when (array-header-p old-data)
          (setf (%array-displaced-from old-data)
                (purge (%array-displaced-from old-data))))))))

(defun %save-displaced-new-array-backpointer (array data)
  (flet ((purge (pointers)
           (remove-if-not #'weak-pointer-value pointers)))
    (when (array-header-p data)
      (setf (%array-displaced-from data)
            (cons (make-weak-pointer array)
                  (purge (%array-displaced-from data)))))))

(defmacro populate-dimensions (header list-or-index rank)
  `(if (listp ,list-or-index)
       (let ((dims ,list-or-index))
         (dotimes (axis ,rank)
           (declare ((integer 0 ,array-rank-limit) axis))
           (%set-array-dimension ,header axis (pop dims))))
       (%set-array-dimension ,header 0 ,list-or-index)))

(declaim (inline rank-and-total-size-from-dims))
(defun rank-and-total-size-from-dims (dims)
  (cond ((not (listp dims)) (values 1 (the index dims)))
        ((not dims) (values 0 1))
        (t (let ((rank 1) (product (car dims)))
             (declare (array-rank rank) (index product))
             (dolist (dim (cdr dims) (values rank product))
               (setq product (* product (the index dim)))
               (incf rank))))))

(declaim (inline widetag->element-type))
(defun widetag->element-type (widetag)
  (svref #.(let ((a (make-array 32 :initial-element 0)))
             (dovector (saetp *specialized-array-element-type-properties* a)
               (let ((tag (saetp-typecode saetp)))
                 (setf (aref a (ash (- tag #x80) -2)) (saetp-specifier saetp)))))
         (- (ash widetag -2) 32)))

(defun initial-contents-error (content-length length)
  (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
                                the vector length is ~W."
         content-length length))

  Widetag is the widetag of the underlying vector ,
;;; it'll be the same as the resulting array widetag only for simple vectors
(defun %make-array (dimensions widetag n-bits
                    &key
                      element-type
                      (initial-element nil element-p)
                      (initial-contents nil contents-p)
                      adjustable fill-pointer
                      displaced-to
                      (displaced-index-offset 0 offset-p))
  (declare (ignore element-type))
  (binding* (((array-rank total-size) (rank-and-total-size-from-dims dimensions))
             ((initialize initial-data)
              ;; element-type might not be supplied, but widetag->element is always good
              (check-make-array-initargs t (widetag->element-type widetag) total-size))
             (simple (and (null fill-pointer)
                          (not adjustable)
                          (null displaced-to))))

    (cond ((and simple (= array-rank 1))
           (let ((vector ; a (SIMPLE-ARRAY * (*))
                  (allocate-vector-with-widetag #+ubsan (not (or element-p contents-p))
                                                widetag total-size n-bits)))
             ;; presence of at most one :INITIAL-thing keyword was ensured above
             (cond (element-p
                    (fill vector initial-element))
                   (contents-p
                    (let ((content-length (length initial-contents)))
                      (unless (= total-size content-length)
                        (initial-contents-error content-length total-size)))
                    (replace vector initial-contents))
                   #+ubsan
                   (t
                    ;; store the function which bears responsibility for creation of this
                    ;; array in case we need to blame it for not initializing.
                    (set-vector-extra-data (if (= widetag simple-vector-widetag) ; no shadow bits.
                                               vector ; use the LENGTH slot directly
                                               (vector-extra-data vector))
                                           (ash (sap-ref-word (current-fp) n-word-bytes) 3)) ; XXX: magic
                    (cond ((= widetag simple-vector-widetag)
                           (fill vector (%make-lisp-obj unwritten-vector-element-marker)))
                          ((array-may-contain-random-bits-p widetag)
                           ;; Leave the last word alone for base-string,
                           ;; in case the mandatory trailing null is part of a data word.
                           (dotimes (i (- (vector-length-in-words total-size n-bits)
                                          (if (= widetag simple-base-string-widetag) 1 0)))
                             (setf (%vector-raw-bits vector i) sb-ext:most-positive-word))))))
             vector))
          (t
           ;; it's non-simple or multidimensional, or both.
           (when fill-pointer
             (unless (= array-rank 1)
               (error "Only vectors can have fill pointers."))
             (when (and (integerp fill-pointer) (> fill-pointer total-size))
               (make-array-bad-fill-pointer fill-pointer total-size "")))
           (let* ((data (or displaced-to
                            (data-vector-from-inits dimensions total-size widetag n-bits
                                                    initialize initial-data)))
                  (array (make-array-header
                          (cond ((= array-rank 1)
                                 (%complex-vector-widetag widetag))
                                (simple simple-array-widetag)
                                (t complex-array-widetag))
                          array-rank)))
             (cond (fill-pointer
                    (logior-array-flags array +array-fill-pointer-p+)
                    (setf (%array-fill-pointer array)
                          (if (eq fill-pointer t) total-size fill-pointer)))
                   (t
                    (reset-array-flags array +array-fill-pointer-p+)
                    (setf (%array-fill-pointer array) total-size)))
             (setf (%array-available-elements array) total-size)
             (setf (%array-data array) data)
             (setf (%array-displaced-from array) nil)
             (cond (displaced-to
                    (setf (%array-displacement array) (or displaced-index-offset 0))
                    (setf (%array-displaced-p array) t)
                    (%save-displaced-new-array-backpointer array data))
                   (t
                    (setf (%array-displaced-p array) nil)))
             (populate-dimensions array dimensions array-rank)
             array)))))

(defun make-array (dimensions &rest args
                   &key (element-type t)
                        initial-element initial-contents
                        adjustable
                        fill-pointer
                        displaced-to
                        displaced-index-offset)
  (declare (ignore initial-element
                   initial-contents adjustable
                   fill-pointer displaced-to displaced-index-offset))
  (declare (explicit-check))
  (multiple-value-bind (widetag shift) (%vector-widetag-and-n-bits-shift element-type)
    (apply #'%make-array dimensions widetag shift args)))

(defun make-static-vector (length &key
                           (element-type '(unsigned-byte 8))
                           (initial-contents nil contents-p)
                           (initial-element nil element-p))
  "Allocate vector of LENGTH elements in static space. Only allocation
of specialized arrays is supported."
  STEP 1 : check inputs fully
  ;;
  ;; This way of doing explicit checks before the vector is allocated
  ;; is expensive, but probably worth the trouble as once we've allocated
  ;; the vector we have no way to get rid of it anymore...
  (when (eq t (upgraded-array-element-type element-type))
    (error "Static arrays of type ~/sb-impl:print-type-specifier/ not supported."
           element-type))
  (check-make-array-initargs nil) ; for effect
  (when contents-p
    (unless (= length (length initial-contents))
      (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
              vector length is ~W."
             (length initial-contents)
             length))
    (unless (every (lambda (x) (typep x element-type)) initial-contents)
      (error ":INITIAL-CONTENTS contains elements not of type ~
               ~/sb-impl:print-type-specifier/."
             element-type)))
  (when element-p
    (unless (typep initial-element element-type)
      (error ":INITIAL-ELEMENT ~S is not of type ~
               ~/sb-impl:print-type-specifier/."
             initial-element element-type)))
  STEP 2
  ;;
  ;; Allocate and possibly initialize the vector.
  (multiple-value-bind (type n-bits-shift)
      (%vector-widetag-and-n-bits-shift element-type)
    (let* ((full-length
   : add SAETP - N - PAD - ELEMENTS " by hand " since there is
             ;; but a single case involving it now.
             (+ length (if (= type simple-base-string-widetag) 1 0)))
           (vector
             (allocate-static-vector type length
                                     (vector-length-in-words full-length
                                                             n-bits-shift))))
      (cond (element-p
             (fill vector initial-element))
            (contents-p
             (replace vector initial-contents))
            (t
             vector)))))

#+darwin-jit
(defun make-static-code-vector (length initial-contents)
  "Allocate vector of LENGTH elements in static space. Only allocation
of specialized arrays is supported."
  (let ((vector (allocate-static-code-vector simple-array-unsigned-byte-8-widetag
                                             length
                                             (* length n-word-bytes))))
    (with-pinned-objects (initial-contents)
      (jit-memcpy (vector-sap vector) (vector-sap initial-contents) length))
    vector))

;;; DATA-VECTOR-FROM-INITS returns a simple rank-1 array that has the
  specified array characteristics .  is only used to pass
  to FILL - DATA - VECTOR for error checking on the structure of
;;; initial-contents.
(defun data-vector-from-inits (dimensions total-size widetag n-bits initialize initial-data)
  (declare (fixnum widetag n-bits)) ; really just that they're non-nil
  (let ((data (allocate-vector-with-widetag #+ubsan (not initialize) widetag total-size n-bits)))
    (ecase initialize
     (:initial-element
      (fill (the vector data) initial-data))
     (:initial-contents
  DIMENSIONS can be supplied as a list or integer now
      (dx-let ((list-of-dims (list dimensions))) ; ok if already a list
        (fill-data-vector data
                          (if (listp dimensions) dimensions list-of-dims)
                          initial-data)))
     ((nil)))
    data))

(defun vector (&rest objects)
  "Construct a SIMPLE-VECTOR from the given objects."
  (let ((v (make-array (length objects))))
    (do-rest-arg ((x i) objects 0 v)
      (setf (aref v i) x))))


;;;; accessor/setter functions

  Dispatch to an optimized routine the data vector accessors for
;;; each different specialized vector type. Do dispatching by looking
  up the widetag in the array rather than with the typecases , which
  as of 1.0.5 compiles to a naive sequence of linear TYPEPs . Also
;;; provide separate versions where bounds checking has been moved
;;; from the callee to the caller, since it's much cheaper to do once
;;; the type information is available. Finally, for each of these
;;; routines also provide a slow path, taken for arrays that are not
;;; vectors or not simple.
;;; FIXME: how is this not redundant with DEFINE-ARRAY-DISPATCH?
;;; Which is to say, why did DEFINE-ARRAY-DISPATCH decide to do
;;; something different instead of figuring out how to unify the ways
  that we call an element of an array accessed by widetag ?
(macrolet ((def (name table-name)
             `(progn
                (define-load-time-global ,table-name
                    (make-array ,(1+ widetag-mask)))
                (declaim (type (simple-array function (,(1+ widetag-mask)))
                               ,table-name))
                (defmacro ,name (array-var)
                  `(the function
  Assigning TAG to 0 initially produces slightly better
                     ;; code than would be generated by the more natural expression
                     ;;   (let ((tag (if (%other-ptr ...) (widetag ...) 0)))
                     ;; but either way is suboptimal. As expressed, if the array-var
                     ;; is known to satisfy %other-pointer-p, then it performs a
                     ;; move-immediate-to-register which is clobbered right away
  by a zero - extending load . A peephole pass could eliminate
  the first move as effectless .   If expressed the other way ,
                     ;; it would produce a jump around a jump because the compiler
                     ;; is unwilling to *unconditionally* assign 0 into a register
                     ;; to begin with. It actually wants to guard an immediate load
                     ;; when it doesn't need to, as if both consequents of the IF
                     ;; have side-effects that should not happen.
                     (let ((tag 0))
                       (when (%other-pointer-p ,array-var)
                         (setf tag (%other-pointer-widetag ,array-var)))
                       (svref ,',table-name tag)))))))
  (def !find-data-vector-setter %%data-vector-setters%%)
  (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
  Used by DO - VECTOR - DATA -- which in turn appears in DOSEQUENCE expansion ,
  ;; meaning we can have post-build dependences on this.
  (def %find-data-vector-reffer %%data-vector-reffers%%)
  (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))

  Like  , but more magical -- ca n't use this on host .
(defmacro sb-impl::do-vector-data ((elt vector &optional result) &body body)
  (multiple-value-bind (forms decls) (parse-body body nil)
    (with-unique-names (index vec start end ref)
      `(with-array-data ((,vec ,vector)
                         (,start)
                         (,end)
                         :check-fill-pointer t)
         (let ((,ref (%find-data-vector-reffer ,vec)))
           (declare (function ,ref))
           (do ((,index ,start (1+ ,index)))
               ((>= ,index ,end)
                (let ((,elt nil))
                  ,@(sb-impl::filter-dolist-declarations decls)
                  ,elt
                  ,result))
             (let ((,elt (funcall ,ref ,vec ,index)))
               ,@decls
               (tagbody ,@forms))))))))

(macrolet ((%ref (accessor-getter extra-params)
             `(sb-c::%funcall-no-nargs (,accessor-getter array) array index ,@extra-params))
           (define (accessor-name slow-accessor-name accessor-getter
                                  extra-params check-bounds)
             `(progn
                (defun ,accessor-name (array index ,@extra-params)
                  (declare (explicit-check))
                  (declare (optimize speed
                                     ;; (SAFETY 0) is ok. All calls to
                                     ;; these functions are generated by
                                     ;; the compiler, so argument count
                                     ;; checking isn't needed. Type checking
  is done implicitly via the widetag
                                     ;; dispatch.
                                     (safety 0)))
                  (%ref ,accessor-getter ,extra-params))
                (defun ,slow-accessor-name (array index ,@extra-params)
                  (declare (optimize speed (safety 0))
                           (array array))
                  (if (not (%array-displaced-p array))
                      ;; The reasonably quick path of non-displaced complex
                      ;; arrays.
                      (let ((array (%array-data array)))
                        (%ref ,accessor-getter ,extra-params))
                      ;; The real slow path.
                      (with-array-data
                          ((array array)
                           (index (locally
                                      (declare (optimize (speed 1) (safety 1)))
                                    (,@check-bounds index)))
                           (end)
                           :force-inline t)
                        (declare (ignore end))
                        (%ref ,accessor-getter ,extra-params)))))))
  (define hairy-data-vector-ref slow-hairy-data-vector-ref
    %find-data-vector-reffer
    nil (progn))
  (define hairy-data-vector-set slow-hairy-data-vector-set
    !find-data-vector-setter
    (new-value) (progn))
  (define hairy-data-vector-ref/check-bounds
      slow-hairy-data-vector-ref/check-bounds
    !find-data-vector-reffer/check-bounds
    nil (check-bound array (%array-dimension array 0)))
  (define hairy-data-vector-set/check-bounds
      slow-hairy-data-vector-set/check-bounds
    !find-data-vector-setter/check-bounds
    (new-value) (check-bound array (%array-dimension array 0))))

(defun hairy-ref-error (array index &optional new-value)
  (declare (ignore index new-value)
           (optimize (sb-c:verify-arg-count 0)))
  (error 'type-error
         :datum array
         :expected-type 'vector))

(macrolet ((define-reffer (saetp check-form)
             (let* ((type (saetp-specifier saetp))
                    (atype `(simple-array ,type (*))))
               `(named-lambda (optimized-data-vector-ref ,type) (vector index)
                  (declare (optimize speed (safety 0))
                           ;; Obviously these all coerce raw words to lispobjs
                           ;; so don't keep spewing notes about it.
                           (muffle-conditions compiler-note)
                           (ignorable index))
                  ,(if type
                       `(data-vector-ref (the ,atype vector)
                                         (the index
                                              (locally
                                                  (declare (optimize (safety 1)))
                                                (,@check-form index))))
                       `(data-nil-vector-ref (the ,atype vector) index)))))
           (define-setter (saetp check-form)
             (let* ((type (saetp-specifier saetp))
                    (atype `(simple-array ,type (*))))
               `(named-lambda (optimized-data-vector-set ,type) (vector index new-value)
                  (declare (optimize speed (safety 0)))
                  ;; Impossibly setting an elt of an (ARRAY NIL)
                  ;; returns no value. And nobody cares.
                  (declare (muffle-conditions compiler-note))
                  (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 :context 'sb-c::aref-context) new-value)))
                  ;; Low-level setters return no value
                  new-value)))
           (define-reffers (symbol deffer check-form slow-path)
             `(progn
  FIXME /  : ca n't just FILL here , because genesis does n't
  preserve the binding , so re - initiaize as NS does n't have
                ;; the energy to figure out to change that right now.
                (setf ,symbol (make-array (1+ widetag-mask)
                                          :initial-element #'hairy-ref-error))
                ,@(loop for widetag in '(complex-vector-widetag
                                         complex-bit-vector-widetag
                                         #+sb-unicode complex-character-string-widetag
                                         complex-base-string-widetag
                                         simple-array-widetag
                                         complex-array-widetag)
                        collect `(setf (svref ,symbol ,widetag) ,slow-path))
                ,@(loop for saetp across *specialized-array-element-type-properties*
                        for widetag = (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)
  (declare (explicit-check))
  (hairy-data-vector-ref array index))

(defun data-vector-ref-with-offset (array index offset)
  (declare (explicit-check))
  (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)
  (declare (optimize allow-non-returning-tail-call))
  (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 t integer &optional t) nil)
                invalid-array-index-error))
(defun invalid-array-index-error (array index bound &optional axis)
  (declare (optimize allow-non-returning-tail-call))
  (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
(defun %array-row-major-index (array &rest subscripts)
  (declare (truly-dynamic-extent subscripts)
           (array array))
  (let ((length (length subscripts)))
    (cond ((array-header-p array)
           (let ((rank (%array-rank array)))
             (unless (= rank length)
               (error "Wrong number of subscripts, ~W, for array of rank ~W."
                      length rank))
             (do ((axis (1- rank) (1- axis))
                  (chunk-size 1)
                  (result 0))
                 ((minusp axis) result)
               (declare (fixnum axis chunk-size result))
               (let ((index (fast-&rest-nth axis subscripts))
                     (dim (%array-dimension array axis)))
                 (unless (and (fixnump index) (< -1 index dim))
                   (invalid-array-index-error array index dim axis))
                 (setf result
                       (truly-the fixnum
                                  (+ result
                                     (truly-the fixnum (* chunk-size index))))
                       chunk-size (truly-the fixnum (* chunk-size dim)))))))
          ((/= length 1)
           (error "Wrong number of subscripts, ~W, for array of rank 1."
                  length))
          (t
           (let ((index (fast-&rest-nth 0 subscripts))
                 (length (length (the (simple-array * (*)) array))))
             (unless (and (fixnump index) (< -1 index length))
               (invalid-array-index-error array index length))
             index)))))

(defun array-in-bounds-p (array &rest subscripts)
  "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
  (declare (truly-dynamic-extent subscripts))
  (let ((length (length subscripts)))
    (cond ((array-header-p array)
           (let ((rank (%array-rank array)))
             (unless (= rank length)
               (error "Wrong number of subscripts, ~W, for array of rank ~W."
                      length rank))
             (loop for i below length
                   for s = (fast-&rest-nth i subscripts)
                   always (and (typep s '(and fixnum unsigned-byte))
                               (< s (%array-dimension array i))))))
          ((/= length 1)
           (error "Wrong number of subscripts, ~W, for array of rank 1."
                  length))
          (t
           (let ((subscript (fast-&rest-nth 0 subscripts)))
             (and (typep subscript '(and fixnum unsigned-byte))
                  (< subscript
                     (length (truly-the (simple-array * (*)) array)))))))))

(defun array-row-major-index (array &rest subscripts)
  (declare (truly-dynamic-extent subscripts))
  (apply #'%array-row-major-index array subscripts))

(defun aref (array &rest subscripts)
  "Return the element of the ARRAY specified by the SUBSCRIPTS."
  (declare (truly-dynamic-extent subscripts))
  (row-major-aref array (apply #'%array-row-major-index array subscripts)))

  ( setf aref / bit / sbit ) are implemented using setf - functions ,
  because they have to work with ( setf ( apply # ' aref array subscripts ) )
  All other setfs can be done using setf - functions too , but I
;;; haven't found technical advantages or disadvantages for either
;;; scheme.
(defun (setf aref) (new-value array &rest subscripts)
  (declare (truly-dynamic-extent subscripts)
           (type array array))
  (setf (row-major-aref array (apply #'%array-row-major-index array subscripts))
        new-value))

(defun row-major-aref (array index)
  "Return the element of array corresponding to the row-major index. This is
   SETFable."
  (declare (optimize (safety 1)))
  (row-major-aref array index))

(defun %set-row-major-aref (array index new-value)
  (declare (optimize (safety 1)))
  (setf (row-major-aref array index) new-value))

(defun svref (simple-vector index)
  "Return the INDEXth element of the given Simple-Vector."
  (declare (optimize (safety 1)))
  (aref simple-vector index))

(defun %svset (simple-vector index new)
  (declare (optimize (safety 1)))
  (setf (aref simple-vector index) new))

(defun bit (bit-array &rest subscripts)
  "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
  (declare (type (array bit) bit-array)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (row-major-aref bit-array (apply #'%array-row-major-index bit-array subscripts)))

(defun (setf bit) (new-value bit-array &rest subscripts)
  (declare (type (array bit) bit-array)
           (type bit new-value)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (setf (row-major-aref bit-array
                        (apply #'%array-row-major-index bit-array subscripts))
        new-value))

(defun sbit (simple-bit-array &rest subscripts)
  "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
  (declare (type (simple-array bit) simple-bit-array)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (row-major-aref simple-bit-array
                  (apply #'%array-row-major-index simple-bit-array subscripts)))

(defun (setf sbit) (new-value bit-array &rest subscripts)
  (declare (type (simple-array bit) bit-array)
           (type bit new-value)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (setf (row-major-aref bit-array
                        (apply #'%array-row-major-index bit-array subscripts))
        new-value))

;;;; miscellaneous array properties

(define-load-time-global *saetp-widetag-ctype* (make-array 32 :initial-element (make-unbound-marker)))

(defun array-element-ctype (array)
  ;; same as (SPECIFIER-TYPE (ARRAY-ELEMENT-TYPE ARRAY)) but more efficient
  (svref *saetp-widetag-ctype*
         (- (ash (array-underlying-widetag array) -2) 32)))

(defun array-element-type (array)
  "Return the type of the elements of the array"
  (truly-the (or list symbol)
             (widetag->element-type (array-underlying-widetag array))))

(defun array-rank (array)
  "Return the number of dimensions of ARRAY."
  (%array-rank array))

(defun array-dimension (array axis-number)
  "Return the length of dimension AXIS-NUMBER of ARRAY."
  (declare (array array) (type index axis-number))
  (cond ((not (array-header-p array))
         (unless (= axis-number 0)
           (error "Vector axis is not zero: ~S" axis-number))
         (length (the (simple-array * (*)) array)))
        ((>= axis-number (%array-rank array))
         (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
                axis-number array (%array-rank array)))
        (t
         (%array-dimension array axis-number))))

(defun array-dimensions (array)
  "Return a list whose elements are the dimensions of the array"
  (declare (explicit-check))
  (cond ((array-header-p array)
         (do ((results nil (cons (%array-dimension array index) results))
              (index (1- (%array-rank array)) (1- index)))
             ((minusp index) results)))
        ((typep array 'vector)
         (list (length array)))
        (t
         (sb-c::%type-check-error/c array 'object-not-array-error nil))))

(defun array-total-size (array)
  "Return the total number of elements in the Array."
  (declare (explicit-check))
  (cond ((array-header-p array)
         (%array-available-elements array))
        ((typep array 'vector)
         (length array))
        (t
         (sb-c::%type-check-error/c array 'object-not-array-error nil))))

(defun array-displacement (array)
  "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
   options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
  (declare (type array array))
  (if (and (array-header-p array) ; if unsimple and
           (%array-displaced-p array)) ; displaced
      (values (%array-data array) (%array-displacement array))
      (values nil 0)))

(defun adjustable-array-p (array)
  "Return T if and only if calling ADJUST-ARRAY on ARRAY will return
   the identical object."
  (declare (array array))
  ;; Note that this appears not to be a fundamental limitation.
  ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
  ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
  -- CSR , 2004 - 03 - 01 .
  (not (typep array 'simple-array)))

;;;; fill pointer frobbing stuff

(setf (info :function :predicate-truth-constraint 'array-has-fill-pointer-p)
      '(and vector (not simple-array)))
(defun array-has-fill-pointer-p (array)
  "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
  (array-has-fill-pointer-p array))

(defun fill-pointer-error (vector)
  (declare (optimize allow-non-returning-tail-call)
           (optimize (sb-c::verify-arg-count 0)))
  (error 'simple-type-error
         :datum vector
         :expected-type '(and vector (satisfies array-has-fill-pointer-p))
         :format-control "~S is not an array with a fill pointer."
         :format-arguments (list vector)))


(defun fill-pointer (vector)
  "Return the FILL-POINTER of the given VECTOR."
  (declare (explicit-check))
  (fill-pointer vector))

(defun %set-fill-pointer (vector new)
  (declare (explicit-check))
  (cond ((not (and (arrayp vector)
                   (array-has-fill-pointer-p vector)))
         (fill-pointer-error vector))
        (t
         (let ((max (%array-available-elements vector)))
           (when (> (the fixnum new) max)
             (error 'simple-type-error
                    :datum new
                    :expected-type (list 'integer 0 max)
                    :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)"
                    :format-arguments (list new max)))
           (setf (%array-fill-pointer vector) (truly-the index new))))))

  FIXME : It 'd probably make sense to use a MACROLET to share the
  guts of VECTOR - PUSH between VECTOR - PUSH - EXTEND . Such a macro
  should probably be based on the VECTOR - PUSH - EXTEND code ( which is
  new ca . sbcl-0.7.0 ) rather than the VECTOR - PUSH code ( which dates
  back to CMU CL ) .
(defun vector-push (new-element array)
  "Attempt to set the element of ARRAY designated by its fill pointer
   to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
   too large, NIL is returned, otherwise the index of the pushed element is
   returned."
  (declare (explicit-check))
  (let ((fill-pointer (fill-pointer array)))
    (cond ((= fill-pointer (%array-available-elements array))
           nil)
          (t
           (locally (declare (optimize (safety 0)))
             (setf (aref array fill-pointer) new-element))
           (setf (%array-fill-pointer array) (1+ fill-pointer))
           fill-pointer))))

#-system-tlabs
(defmacro reallocate-vector-with-widetag (old-vector &rest args)
  (declare (ignore old-vector))
  `(allocate-vector-with-widetag ,@args))

;;; This does not try to allow for resizing (ARRAY NIL) - there's no backing storage anyway.
;;; However, ADJUST-ARRAY apparently thinks it can resize non-simple arrays of
  element type NIL , but fails in ZAP - ARRAY - DATA - AUX . e.g. :
    ( adjust - array ( make - array ' ( 10 10 ) : element - type nil ) ' ( 20 20 ) )
  allocates a non - simple 10x10 array pointing to a ( SIMPLE - ARRAY NIL 100 )
  and then gets " An attempt to access an array of element - type NIL was made "
;;; because it doesn't know not to try to copy elements.
;;; So unless we think that that is one of the most pressing issues that demands
;;; a fix, who cares how we reallocate?
;;; If you're manipulating such arrays, quite literally you deserve to lose.
  FIXME : does not support # + ubsan , which is fairly bit - rotted , so ... meh .
#+system-tlabs
(defun reallocate-vector-with-widetag (old-vector widetag length n-bits-shift)
  (declare (type (unsigned-byte 8) widetag)
           (type index length))
   : add SAETP - N - PAD - ELEMENTS " by hand " since there is
  ;; but a single case involving it now.
  (let* ((full-length (+ length (if (= widetag simple-base-string-widetag) 1 0)))
         (nwords (the fixnum (vector-length-in-words full-length n-bits-shift))))
    (if (sb-vm::force-to-heap-p old-vector)
        (locally (declare (sb-c::tlab :system))
          (allocate-vector widetag length nwords))
        (allocate-vector widetag length nwords))))

(defun extend-vector (vector min-extension)
  (declare (optimize speed)
           (vector vector))
  (let* ((old-length (length vector))
         (min-extension (or min-extension
                            (min old-length
                                 (- array-dimension-limit old-length))))
         (new-length (the index (+ old-length
                                   (max 1 min-extension))))
         (fill-pointer (1+ old-length)))
    (declare (fixnum new-length min-extension))
    (with-array-data ((old-data vector) (old-start)
                      (old-end old-length))
      (let* ((widetag (%other-pointer-widetag old-data))
             (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag))
             (new-data
              ;; FIXME: mark prefix of shadow bits assigned, suffix unassigned
              (reallocate-vector-with-widetag old-data #+ubsan nil
                                              widetag new-length n-bits-shift)))
        ;; Copy the data
        (if (= widetag simple-vector-widetag) ; the most common case
            (replace (truly-the simple-vector new-data) ; transformed
                     (truly-the simple-vector old-data)
                     :start2 old-start :end2 old-end)
            (let ((copier (blt-copier-for-widetag widetag)))
              (if copier
                  (funcall (truly-the function copier) old-data old-start new-data 0 old-length)
                  (replace new-data old-data :start2 old-start :end2 old-end))))
        (setf (%array-data vector) new-data
              (%array-available-elements vector) new-length
              (%array-fill-pointer vector) fill-pointer
              (%array-displacement vector) 0
              (%array-displaced-p vector) nil)
        (%set-array-dimension vector 0 new-length)
        vector))))

(defun vector-push-extend (new-element vector &optional min-extension)
  (declare (type (or null (and index (integer 1))) min-extension))
  (declare (explicit-check))
  (let* ((fill-pointer (fill-pointer vector))
         (new-fill-pointer (1+ fill-pointer)))
    (if (= fill-pointer (%array-available-elements vector))
        (extend-vector vector min-extension)
        (setf (%array-fill-pointer vector) new-fill-pointer))
    ;; disable bounds checking
    (locally (declare (optimize (safety 0)))
      (setf (aref vector fill-pointer) new-element))
    fill-pointer))

(defun vector-pop (array)
  "Decrease the fill pointer by 1 and return the element pointed to by the
  new fill pointer."
  (declare (explicit-check))
  (let ((fill-pointer (fill-pointer array)))
    (if (zerop fill-pointer)
        (error "There is nothing left to pop.")
        ;; disable bounds checking (and any fixnum test)
        (locally (declare (optimize (safety 0)))
          (aref array
                (setf (%array-fill-pointer array)
                      (1- fill-pointer)))))))


;;;; ADJUST-ARRAY

(defun adjust-array (array dimensions &key
                           (element-type (array-element-type array) element-type-p)
                           (initial-element nil element-p)
                           (initial-contents nil contents-p)
                           fill-pointer
                           displaced-to (displaced-index-offset 0 offset-p))
  "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
  (when (invalid-array-p array)
    (invalid-array-error array))
  (binding*
      (((rank new-total-size) (rank-and-total-size-from-dims dimensions))
       (widetag
        (let ((widetag (array-underlying-widetag array)))
          (unless (= (array-rank array) rank) ; "drive-by" check of the rank
            (error "Expected ~D new dimension~:P for array, but received ~D."
                   (array-rank array) rank))
          (if (or (not element-type-p)
  Quick pass if ELEMENT - TYPE is same as the element type based on widetag
                  (equal element-type (widetag->element-type widetag))
                  (= (%vector-widetag-and-n-bits-shift element-type) widetag))
              widetag
              (error "The new element type, ~/sb-impl:print-type-specifier/, is incompatible ~
                      with old type, ~/sb-impl:print-type-specifier/."
                     element-type (array-element-type array)))))
       (new-fill-pointer
        (cond (fill-pointer
               (unless (array-has-fill-pointer-p array)
                 (if (/= rank 1)
                     (error "Only vectors can have fill pointers.")
                     ;; I believe the sentence saying that this is an error pre-dates the removal
                     ;; of the restriction of calling ADJUST-ARRAY only on arrays that
                     ;; are actually adjustable. Making a new array should always work,
                     ;; so I think this may be a bug in the spec.
                     (fill-pointer-error array)))
               (cond ((eq fill-pointer t) new-total-size)
                     ((<= fill-pointer new-total-size) fill-pointer)
                     (t (make-array-bad-fill-pointer fill-pointer new-total-size " new"))))
              ((array-has-fill-pointer-p array)
               ;; "consequences are unspecified if array is adjusted to a size smaller than its fill pointer"
               (let ((old-fill-pointer (%array-fill-pointer array)))
                 (when (< new-total-size old-fill-pointer)
                   (error "can't adjust vector ~S to a size (~S) smaller than ~
                           its current fill pointer (~S)"
                          array new-total-size old-fill-pointer))
                 old-fill-pointer))))
       ((initialize initial-data)
        (check-make-array-initargs t element-type new-total-size))
       (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag)))

    (cond
      (displaced-to ; super easy - just repoint ARRAY to new data
       (if (adjustable-array-p array)
           (set-array-header array displaced-to new-total-size new-fill-pointer
                             displaced-index-offset dimensions t nil)
           (%make-array dimensions widetag n-bits-shift
                        :displaced-to displaced-to
                        :displaced-index-offset displaced-index-offset)))
      (contents-p ; array former contents replaced by INITIAL-CONTENTS
       (let ((array-data (data-vector-from-inits dimensions new-total-size widetag n-bits-shift
                                                 initialize initial-data)))
         (cond ((adjustable-array-p array)
                (set-array-header array array-data new-total-size new-fill-pointer
                                  0 dimensions nil nil))
               ((array-header-p array)
                ;; simple multidimensional array.
  fill - pointer vectors satisfy ADJUSTABLE - ARRAY - P ( in SBCL , that is )
  and therefore are handled by the first stanza of the cond .
                (%make-array dimensions widetag n-bits-shift
                             :initial-contents initial-contents))
               (t
                array-data))))
      ((= rank 1)
       (let ((old-length (array-total-size array)))
         ;; Because ADJUST-ARRAY has to ignore any fill-pointer when
         ;; copying from the old data, we can't just pass ARRAY as the
  second argument of REPLACE .
         (with-array-data ((old-data array) (old-start) (old-end old-length))
           (let ((new-data
                  (if (and (= new-total-size old-length)
                           (not (and (array-header-p array) (%array-displaced-p array))))
                      ;; if total size is unchanged, and it was not a displaced array,
                      ;; then this array owns the data and can retain it.
                      old-data
                      (let ((data
                             (reallocate-vector-with-widetag old-data #+ubsan t
                                                             widetag new-total-size
                                                             n-bits-shift)))
                        (replace data old-data
                                 :start1 0 :end1 new-total-size
                                 :start2 old-start :end2 old-end)
                        (when (and element-p (> new-total-size old-length))
                          (fill data initial-element :start old-length))
                        data))))
             (if (adjustable-array-p array)
                 (set-array-header array new-data new-total-size new-fill-pointer
                                   0 dimensions nil nil)
                 new-data)))))
      (t
           (let ((old-total-size (%array-available-elements array)))
             (with-array-data ((old-data array) (old-start) (old-end old-total-size))
               (declare (ignore old-end))
               (let ((new-data (if (or (and (array-header-p array)
                                            (%array-displaced-p array))
                                       (> new-total-size old-total-size)
                                       (not (adjustable-array-p array)))
                                   (data-vector-from-inits dimensions new-total-size widetag
                                                           n-bits-shift initialize initial-data)
                                   old-data)))
                 (if (or (zerop old-total-size) (zerop new-total-size))
                     (when element-p (fill new-data initial-element))
                     (zap-array-data old-data (array-dimensions array)
                                     old-start
                                     new-data dimensions new-total-size
                                     element-type initial-element
                                     element-p))
                 (if (adjustable-array-p array)
                     (set-array-header array new-data new-total-size
                                       nil 0 dimensions nil nil)
                     (let ((new-array (make-array-header simple-array-widetag rank)))
                       (set-array-header new-array new-data new-total-size
                                         nil 0 dimensions nil t))))))))))

  Destructively alter VECTOR , changing its length to NEW - LENGTH ,
;;; which must be less than or equal to its current length. This can
;;; be called on vectors without a fill pointer but it is slightly
;;; dangerous to do so: shrinking the size of an object accessible
;;; to another thread could cause it to access an out-of-bounds element.
  GC should generally be fine no matter what happens , because it either
;;; reads the old length or the new length. If it reads the old length,
;;; then the whole vector is skipped if unboxed; if it reads the new length,
;;; then the next object is a filler.
;;; Exception: for SIMPLE-VECTOR we always zeroized the unused tail,
;;; because the garbage collector can scan certain pages without regard
;;; to object boundaries. The situation we need to avoid is this:
;;;       "old" #(...............|.....)
        " new " # ( .......... ) Fill| .....
;;;                              ^ page boundary
  where GC reads the objects on the page just after the filler
;;; because it doesn't know not to.
;;;
(defmacro make-filler (n)
  `(logior (ash ,n #+64-bit 32 #-64-bit ,n-widetag-bits) filler-widetag))
(defmacro filler-nwords (header)
  `(ash ,header #+64-bit -32 #-64-bit ,(- n-widetag-bits)))

(defun %shrink-vector (vector new-length
                              &aux (old-length (length vector))
                                   (new-length* new-length))
  (declare (vector vector))
  (cond
    ((simple-vector-p vector)
  We do in fact call % SHRINK - VECTOR a lot from sequence functions
     ;; that overallocate a temporary result. In all places where that happens,
     ;; the discarded suffix was never used. So assuming pre-zeroed heap,
     ;; it kind of just worked. But I don't want to assume that.
  For what it 's worth , adding this assertion prior to FILL :
    ( WHEN ( FIND 0 VECTOR : START OLD - LENGTH : TEST # ' NEQ ) ( BUG " No can do " ) )
     ;; produced no failures in the regression suite.
     (when (< new-length old-length) (fill vector 0 :start new-length)))
    ((not (or (array-header-p vector) (typep vector '(simple-array nil (*)))))
      (when (simple-base-string-p vector)
        ;; We can blindly store the hidden #\null at NEW-LENGTH, but it would
        ;; appear to be an out-of-bounds access if the length is not
        ;; changing at all. i.e. while it's safe to always do a store,
        ;; the length check has to be skipped.
        (locally (declare (optimize (sb-c:insert-array-bounds-checks 0)))
          (setf (schar vector new-length) (code-char 0)))
        ;; Now treat both the old and new lengths as if they include
        ;; the byte that holds the implicit string terminator.
        (incf old-length)
        (incf new-length*))
      (let* ((n-bits-shift (aref %%simple-array-n-bits-shifts%%
                                 (%other-pointer-widetag vector)))
             (old-nwords (ceiling (ash old-length n-bits-shift) n-word-bits))
             (new-nwords (ceiling (ash new-length* n-bits-shift) n-word-bits)))
        (when (< new-nwords old-nwords)
          (with-pinned-objects (vector)
  VECTOR - SAP is only for unboxed vectors . Use the vop directly .
            (let ((data (%primitive vector-sap vector)))
              ;; There is no requirement to zeroize memory corresponding
              ;; to unused array elements.
              ;; However, it's slightly nicer if the padding word (if present) is 0.
              (when (oddp new-nwords)
                (setf (sap-ref-word data (ash new-nwords word-shift)) 0))
              (let* ((aligned-old (align-up old-nwords 2))
                     (aligned-new (align-up new-nwords 2)))
                ;; Only if physically shrunk as determined by PRIMITIVE-OBJECT-SIZE
                ;; will we need to (and have adequate room to) place a filler.
                (when (< aligned-new aligned-old)
                  (let ((diff (- aligned-old aligned-new)))
                    ;; Certainly if the vector is unboxed it can't possibly matter
  if GC sees this bit pattern prior to setting the new length ;
                    ;; but even for SIMPLE-VECTOR, it's OK, it turns out.
                    (setf (sap-ref-word data (ash aligned-new word-shift))
                          (make-filler diff)))))))))))
  ;; Only arrays have fill-pointers, but vectors have their length
  ;; parameter in the same place.
  (setf (%array-fill-pointer vector) new-length)
  vector)

(defun shrink-vector (vector new-length)
  (declare (vector vector))
  (cond
    ((eq (length vector) new-length)
     vector)
    ((array-has-fill-pointer-p vector)
     (setf (%array-fill-pointer vector) new-length)
     vector)
    (t (subseq vector 0 new-length))))

;;; BIG THREAD SAFETY NOTE
;;;
;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
;;; thread unsafe. They are nonatomic, and can mess with parallel
;;; code using the same arrays.
;;;
;;; A likely seeming fix is an additional level of indirection:
;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
;;; would hold everything ARRAY-HEADER now holds. This allows
;;; consing up a new ARRAY-INFO and replacing it atomically in
;;; the ARRAY-HEADER.
;;;
;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
;;; one: not only is it needed extremely rarely, which makes
;;; any thread safety bugs involving it look like rare random
;;; corruption, but because it walks the chain *upwards*, which
;;; may violate user expectations.

;;; Fill in array header with the provided information, and return the array.
(defun set-array-header (array data length fill-pointer displacement dimensions
                         displacedp newp)
  (labels ((%walk-displaced-array-backpointers (array new-length)
             (dolist (p (%array-displaced-from array))
               (let ((from (weak-pointer-value p)))
                 (when (and from (eq array (%array-data from)))
                   (let ((requires (+ (%array-available-elements from)
                                      (%array-displacement from))))
                     (unless (>= new-length requires)
                       ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
                       ;;
                       ;;   "If A is displaced to B, the consequences are unspecified if B is
                       ;;   adjusted in such a way that it no longer has enough elements to
                       ;;   satisfy A.
                       ;;
                       ;; since we're hanging on a weak pointer here, we can't signal an
                       ;; error right now: the array that we're looking at might be
  garbage . Instead , we set all dimensions to zero so that next
                       ;; safe access to the displaced array will trap. Additionally, we
                       ;; save the original dimensions, so we can signal a more
                       ;; understandable error when the time comes.
                       (%walk-displaced-array-backpointers from 0)
                       (setf (%array-fill-pointer from) 0
                             (%array-available-elements from) 0
                             (%array-displaced-p from) (array-dimensions array))
                       (dotimes (i (%array-rank from))
                         (%set-array-dimension from i 0)))))))))
    (if newp
        (setf (%array-displaced-from array) nil)
        (%walk-displaced-array-backpointers array length))
    (when displacedp
      (%save-displaced-array-backpointer array data))
    (setf (%array-data array) data)
    (setf (%array-available-elements array) length)
    (cond (fill-pointer
           (setf (%array-fill-pointer array) fill-pointer)
           (logior-array-flags array +array-fill-pointer-p+))
          (t
           (setf (%array-fill-pointer array) length)
           (reset-array-flags array +array-fill-pointer-p+)))
    (setf (%array-displacement array) displacement)
    (populate-dimensions array dimensions (array-rank array))
    (setf (%array-displaced-p array) displacedp)
    array))

;;; User visible extension
(declaim (ftype (sfunction (array) (simple-array * (*))) array-storage-vector))
(defun array-storage-vector (array)
  "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.

In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
vector. Multidimensional arrays, arrays with fill pointers, and adjustable
arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
ARRAY, which this function returns.

Important note: the underlying vector is an implementation detail. Even though
this function exposes it, changes in the implementation may cause this
function to be removed without further warning."
   : Without TRULY - THE the system is not smart enough to figure out that
  ;; the return value is always of the known type.
  (truly-the (simple-array * (*))
             (cond ((not (array-header-p array))
                    array)
                   ((%array-displaced-p array)
                    (error "~S cannot be used with displaced arrays. Use ~S instead."
                           'array-storage-vector 'array-displacement))
                   (t
                    (%array-data array)))))


  ZAP - ARRAY - DATA for ADJUST - ARRAY

;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
  the NEW - DATA in an arrangement specified by the NEW - DIMS . OFFSET
;;; is a displaced offset to be added to computed indices of OLD-DATA.
(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
                       element-type initial-element initial-element-p)
  (declare (list old-dims new-dims)
           (fixnum new-length))
  ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
  at least in SBCL .
  ;; NEW-DIMS comes from the user.
  (setf old-dims (nreverse old-dims)
        new-dims (reverse new-dims))
  (cond ((eq old-data new-data)
         ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
         ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
         ;; EQ; in this case, a temporary must be used and filled
         ;; appropriately. specified initial-element.
  FIXME : transforming this TYPEP to someting a bit faster
         ;; would be a win...
         (unless (or (not initial-element-p)
                     (typep initial-element element-type))
           (error "~S can't be used to initialize an array of type ~
                    ~/sb-impl:print-type-specifier/."
                  initial-element element-type))
         (let ((temp (if initial-element-p
                         (make-array new-length :initial-element initial-element)
                         (make-array new-length))))
           (declare (simple-vector temp))
           (zap-array-data-aux old-data old-dims offset temp new-dims)
           (dotimes (i new-length)
             (setf (aref new-data i) (aref temp i)))
           ;; Kill the temporary vector to prevent garbage retention.
           (%shrink-vector temp 0)))
        (t
         ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
         ;; already been filled with any
         (zap-array-data-aux old-data old-dims offset new-data new-dims))))

(defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
  (declare (fixnum offset))
  (let ((limits (mapcar (lambda (x y)
                          (declare (fixnum x y))
                          (1- (the fixnum (min x y))))
                        old-dims new-dims)))
    (macrolet ((bump-index-list (index limits)
                 `(do ((subscripts ,index (cdr subscripts))
                       (limits ,limits (cdr limits)))
                      ((null subscripts) :eof)
                    (cond ((< (the fixnum (car subscripts))
                              (the fixnum (car limits)))
                           (rplaca subscripts
                                   (1+ (the fixnum (car subscripts))))
                           (return ,index))
                          (t (rplaca subscripts 0))))))
      (do ((index (make-list (length old-dims) :initial-element 0)
                  (bump-index-list index limits)))
          ((eq index :eof))
        (setf (aref new-data (row-major-index-from-dims index new-dims))
              (aref old-data
                    (+ (the fixnum (row-major-index-from-dims index old-dims))
                       offset)))))))

;;; Figure out the row-major-order index of an array reference from a
;;; list of subscripts and a list of dimensions. This is for internal
;;; calls only, and the subscripts and dim-list variables are assumed
;;; to be reversed from what the user supplied.
(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
  (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
       (rev-dim-list rev-dim-list (cdr rev-dim-list))
       (chunk-size 1)
       (result 0))
      ((null rev-dim-list) result)
    (declare (fixnum chunk-size result))
    (setq result (+ result
                    (the fixnum (* (the fixnum (car rev-subscripts))
                                   chunk-size))))
    (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))

;;;; some bit stuff

(defun bit-array-same-dimensions-p (array1 array2)
  (declare (type (array bit) array1 array2))
  (let ((rank (array-rank array1)))
    (and (= rank (array-rank array2))
         (if (= rank 1)
             (= (array-total-size array1)
                (array-total-size array2))
             (dotimes (index rank t)
               (when (/= (%array-dimension array1 index)
                         (%array-dimension array2 index))
                 (return nil)))))))

(defun copy-array-header (array)
  (let* ((rank (%array-rank array))
         (size (%array-available-elements array))
         (result (make-array-header simple-array-widetag
                                    rank)))
    (loop for i below rank
          do (%set-array-dimension result i
                                   (%array-dimension array i)))
  fill - pointer - p defaults to 0
    (setf (%array-displaced-from result) nil
          (%array-displaced-p result) nil
          (%array-fill-pointer result) size
          (%array-available-elements result) size)
    result))

(defun pick-result-array (result-bit-array bit-array-1)
  (case result-bit-array
    ((t) bit-array-1)
    ((nil)
     (if (vectorp bit-array-1)
         (make-array (array-total-size bit-array-1)
                     :element-type 'bit
                     :initial-element 0)
         (let ((header (copy-array-header bit-array-1)))
           (setf (%array-data header)
                 (make-array (%array-available-elements bit-array-1)
                             :element-type 'bit
                             :initial-element 0))
           header)))
    (t
     (unless (bit-array-same-dimensions-p bit-array-1
                                          result-bit-array)
       (error "~S and ~S don't have the same dimensions."
              bit-array-1 result-bit-array))
     result-bit-array)))

  This used to be a DEFMACRO , but depending on the target 's support for Unicode ,
;;; it got a constant-folding-error in the FORMAT call when producing the load-time
  macro .      returns true , so then we want to know whether the
  result is a base - string which entails calling SB - KERNEL : SIMPLE - BASE - STRING - P
  which has no definition in the cross - compiler . ( We could add one of course )

;;; Bit array operations are allowed to leave arbitrary values in the
;;; trailing bits of the result. Examples:
  * ( format t " ~b~% " ( % vector - raw - bits ( bit - not # * 1001 ) 0 ) )
;;;   1111111111111111111111111111111111111111111111111111111111110110
  * ( format t " ~b~% " ( % vector - raw - bits ( bit - nor # * 1001 # * 1010 ) 0 ) )
;;;   1111111111111111111111111111111111111111111111111111111111110010
;;; But because reading is more common than writing, it seems that a better
;;; technique might be to enforce an invariant that the last word contain 0
  in all unused bits so that EQUAL and SXHASH become far simpler .

(macrolet ((def-bit-array-op (name function)
  `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
     ,(format nil
              "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
               BIT-ARRAY-2,~%  putting the results in RESULT-BIT-ARRAY. ~
               If RESULT-BIT-ARRAY is T,~%  BIT-ARRAY-1 is used. If ~
               RESULT-BIT-ARRAY is NIL or omitted, a new array is~%  created. ~
               All the arrays must have the same rank and dimensions."
              (symbol-name function))
     (declare (type (array bit) bit-array-1 bit-array-2)
              (type (or (array bit) (member t nil)) result-bit-array))
     (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
       (error "~S and ~S don't have the same dimensions."
              bit-array-1 bit-array-2))
     (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
       (if (and (simple-bit-vector-p bit-array-1)
                (simple-bit-vector-p bit-array-2)
                (simple-bit-vector-p result-bit-array))
           (locally (declare (optimize (speed 3) (safety 0)))
             (,name bit-array-1 bit-array-2 result-bit-array))
           (with-array-data ((data1 bit-array-1) (start1) (end1))
             (with-array-data ((data2 bit-array-2) (start2) (end2))
               (with-array-data ((data3 result-bit-array) (start3) (end3))
                 (if (and (zerop start1)
                          (zerop start2)
                          (zerop start3)
                          (= (length data1) end1)
                          (= (length data2) end2)
                          (= (length data3) end3))
                     (locally (declare (optimize (speed 3) (safety 0)))
                       (,name data1 data2 data3))
                     (do ((index-1 start1 (1+ index-1))
                          (index-2 start2 (1+ index-2))
                          (index-3 start3 (1+ index-3)))
                         ((>= index-3 end3))
                       (declare (type index index-1 index-2 index-3))
                       (setf (sbit data3 index-3)
                             (logand (,function (sbit data1 index-1)
                                                (sbit data2 index-2))
                                     1))))
                 result-bit-array))))))))

(def-bit-array-op bit-and logand)
(def-bit-array-op bit-ior logior)
(def-bit-array-op bit-xor logxor)
(def-bit-array-op bit-eqv logeqv)
(def-bit-array-op bit-nand lognand)
(def-bit-array-op bit-nor lognor)
(def-bit-array-op bit-andc1 logandc1)
(def-bit-array-op bit-andc2 logandc2)
(def-bit-array-op bit-orc1 logorc1)
(def-bit-array-op bit-orc2 logorc2)
  end MACROLET

(defun bit-not (bit-array &optional result-bit-array)
  "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. Both arrays must have the same rank and dimensions."
  (declare (type (array bit) bit-array)
           (type (or (array bit) (member t nil)) result-bit-array))
  (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
    (if (and (simple-bit-vector-p bit-array)
             (simple-bit-vector-p result-bit-array))
        (locally (declare (optimize (speed 3) (safety 0)))
          (bit-not bit-array result-bit-array))
        (with-array-data ((src bit-array) (src-start) (src-end))
          (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
            (if (and (zerop src-start)
                     (zerop dst-start)
                     (= src-end (length src))
                     (= dst-end (length dst)))
                (locally (declare (optimize (speed 3) (safety 0)))
                  (bit-not src dst))
                (do ((src-index src-start (1+ src-index))
                     (dst-index dst-start (1+ dst-index)))
                    ((>= dst-index dst-end))
                  (declare (type index src-index dst-index))
                  (setf (sbit dst dst-index)
                        (logxor (sbit src src-index) 1))))
            result-bit-array)))))

;;;; array type dispatching

;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
;;; defines the functions
;;;
;;; DISPATCH-FOO/SIMPLE-BASE-STRING
;;; DISPATCH-FOO/SIMPLE-CHARACTER-STRING
;;; DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
;;; ...
;;;
  PARAMS are the function parameters in the definition of each
;;; specializer function. The array being specialized must be the
  first parameter in PARAMS . A type declaration for this parameter
;;; is automatically inserted into the body of each function.
;;;
  The dispatch table % % FOO - FUNS%% is defined and populated by these
;;; functions. The table is padded by the function
  HAIRY - FOO - DISPATCH - ERROR , also defined by DEFINE - ARRAY - DISPATCH .
;;;
;;; Finally, the DISPATCH-FOO macro is defined which does the actual
  dispatching when called . It expects arguments that match PARAMS .
;;;
(defmacro sb-impl::!define-array-dispatch (style dispatch-name params nil-array &body body)
  #-(or x86 x86-64) (setq style :call)
  (let ((table-name (symbolicate "%%" dispatch-name "-FUNS%%"))
        (error-name (symbolicate "HAIRY-" dispatch-name "-ERROR")))
    (declare (ignorable table-name))
    `(progn
       (defun ,error-name (,(first params) &rest rest)
         (declare (ignore rest))
         (error 'type-error
                :datum ,(first params)
                :expected-type '(simple-array * (*))))

       ,@(ecase style
    (:call
     `((define-load-time-global ,table-name ,(sb-xc:make-array (1+ widetag-mask)))

       ;; This SUBSTITUTE call happens ** after ** all the SETFs below it.
  DEFGLOBAL 's initial value is dumped by genesis as a vector filled
       ;; with 0 (it would not work if the vector held function objects).
       ;; Then the SETFs happen, as cold-load can process %SVSET, which
       ;; is great, because it means that hairy sequence dispatch may occur
       ;; as early as you'd like in cold-init without regard to file order.
       ;; However when it comes to actually executing the toplevel forms
       ;; that were compiled into thunks of target code to invoke,
       ;; all the known good entries must be preserved.
       (nsubstitute #',error-name 0 ,table-name)

       ,@(loop for info across *specialized-array-element-type-properties*
               for typecode = (saetp-typecode info)
               for specifier = (saetp-specifier info)
               for primitive-type-name = (saetp-primitive-type-name info)
               collect (let ((fun-name (symbolicate (string dispatch-name)
                                                    "/" primitive-type-name)))
                         `(progn
                            (defun ,fun-name ,params
                              (declare (type (simple-array ,specifier (*))
                                             ,(first params)))
                              ,@(if (null specifier)
                                    nil-array
                                    body))
                            (setf (svref ,table-name ,typecode) #',fun-name))))
       (defmacro ,dispatch-name (&rest args)
         (check-type (first args) symbol)
         (let ((tag (gensym "TAG")))
           `(funcall
             (truly-the function
               (let ((,tag 0))
                 (when (%other-pointer-p ,(first args))
                   (setf ,tag (%other-pointer-widetag ,(first args))))
                 (svref (truly-the (simple-vector 256) (load-time-value ,',table-name t))
                        ,tag)))
             ,@args)))))
    (:jump-table
     (multiple-value-bind (body decls) (parse-body body nil)
       `((declaim (inline ,dispatch-name))
         (defun ,dispatch-name ,params
           ,@decls
           (case (if (%other-pointer-p ,(first params))
                     (ash (%other-pointer-widetag ,(first params)) -2)
                     0)
             ;; All widetags have to be listed so that the jump table logic doesn't
             ;; give up due to deciding that it's a waste of space. It could probably
             ;; be based on the SPACE compilation policy. However, I would imagine that
  it is almost always a win to use 4x or 5x table words as cases
             ;; given the amount of code that has to be emitted if not a table.
             ;; This table has only 2.5x as many words as relevant (non-error) cases.
             (,(loop for i below 64
                     unless (find i *specialized-array-element-type-properties*
                                  :key (lambda (x) (ash (saetp-typecode x) -2)))
                       collect i)
              (,error-name ,@params))
             ,@(loop
                   for info across *specialized-array-element-type-properties*
                   collect `(,(ash (saetp-typecode info) -2)
                             (let ((,(first params)
                                    (truly-the (simple-array ,(saetp-specifier info) (*))
                                               ,(first params))))
                               ,@body))))))))))))

(defun sb-kernel::check-array-shape (array dimensions)
  (when (let ((dimensions dimensions))
          (dotimes (i (array-rank array))
            (unless (eql (array-dimension array i) (pop dimensions))
              (return t))))
    (error "malformed :INITIAL-CONTENTS: ~S should have dimensions ~S"
           (make-array dimensions :displaced-to (%array-data array)
                                  :element-type (array-element-type array))
           (array-dimensions array)))
  array)

;;; Horrible kludge for the "static-vectors" system
  which uses an internal symbol in SB - IMPL .
(import '%vector-widetag-and-n-bits-shift 'sb-impl)

(defun make-weak-vector (length &key (initial-contents nil contents-p)
                                     (initial-element nil element-p))
  (declare (index length))
  (when (and element-p contents-p)
    (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
  ;; Explicitly compute a widetag with the weakness bit ORed in.
  (let ((type (logior (ash vector-weak-flag array-flags-position) simple-vector-widetag)))
    ;; These allocation calls are the transforms of MAKE-ARRAY for a vector with
    ;; the respective initializing keyword arg. This is badly OAOO-violating and
    ;; almost makes me want to cry, but not quite enough for me to improve it.
    (if contents-p
        (let ((contents-length (length initial-contents)))
          (if (= length contents-length)
              (replace (truly-the simple-vector
                                  (allocate-vector #+ubsan nil type length length))
                       initial-contents)
              (error "~S has ~D elements, vector length is ~D."
                     :initial-contents contents-length length)))
        (fill (truly-the simple-vector
                         (allocate-vector #+ubsan nil type length length))
  0 is the usual default , but NIL makes more sense for weak vectors
              ;; as it is the value assigned to broken hearts.
              (if element-p initial-element nil)))))

(defun weak-vector-p (x)
  (and (simple-vector-p x)
       (test-header-data-bit x (ash vector-weak-flag array-flags-data-position))))

 functions to implement arrays
 more information.

 public domain. The software is in the public domain and is
 provided with absolutely no warranty. See the COPYING and CREDITS
 files for more information.
 miscellaneous accessor functions
 These functions are only needed by the interpreter, 'cause the
 MAKE-ARRAY
 specialized types is exceedingly slow
 Do things the hard way after falling through the tagbody.
 i.e. log(2,bits-per-elt)
 but a single case involving it now.
 VECTOR-LENGTH-IN-WORDS potentially returns a machine-word-sized
 integer, so it doesn't match the primitive type restriction of
 Complain in various ways about wrong MAKE-ARRAY and ADJUST-ARRAY arguments,
 doing so would entail moving toplevel defuns around for no good reason.
 There was a comment implying that this should be TYPE-ERROR
 but I don't see that as a spec requirement.
 Add backpointer to the new data vector if it has a header.
 Remove old backpointer, if any.
 it'll be the same as the resulting array widetag only for simple vectors
 element-type might not be supplied, but widetag->element is always good
 a (SIMPLE-ARRAY * (*))
 presence of at most one :INITIAL-thing keyword was ensured above
 store the function which bears responsibility for creation of this
 array in case we need to blame it for not initializing.
 no shadow bits.
 use the LENGTH slot directly
 XXX: magic
 Leave the last word alone for base-string,
 in case the mandatory trailing null is part of a data word.
 it's non-simple or multidimensional, or both.

 This way of doing explicit checks before the vector is allocated
 is expensive, but probably worth the trouble as once we've allocated
 the vector we have no way to get rid of it anymore...
 for effect

 Allocate and possibly initialize the vector.
 but a single case involving it now.
 DATA-VECTOR-FROM-INITS returns a simple rank-1 array that has the
 initial-contents.
 really just that they're non-nil
 ok if already a list
 accessor/setter functions
 each different specialized vector type. Do dispatching by looking
 provide separate versions where bounds checking has been moved
 from the callee to the caller, since it's much cheaper to do once
 the type information is available. Finally, for each of these
 routines also provide a slow path, taken for arrays that are not
 vectors or not simple.
 FIXME: how is this not redundant with DEFINE-ARRAY-DISPATCH?
 Which is to say, why did DEFINE-ARRAY-DISPATCH decide to do
 something different instead of figuring out how to unify the ways
 code than would be generated by the more natural expression
   (let ((tag (if (%other-ptr ...) (widetag ...) 0)))
 but either way is suboptimal. As expressed, if the array-var
 is known to satisfy %other-pointer-p, then it performs a
 move-immediate-to-register which is clobbered right away
 it would produce a jump around a jump because the compiler
 is unwilling to *unconditionally* assign 0 into a register
 to begin with. It actually wants to guard an immediate load
 when it doesn't need to, as if both consequents of the IF
 have side-effects that should not happen.
 meaning we can have post-build dependences on this.
 (SAFETY 0) is ok. All calls to
 these functions are generated by
 the compiler, so argument count
 checking isn't needed. Type checking
 dispatch.
 The reasonably quick path of non-displaced complex
 arrays.
 The real slow path.
 Obviously these all coerce raw words to lispobjs
 so don't keep spewing notes about it.
 Impossibly setting an elt of an (ARRAY NIL)
 returns no value. And nobody cares.
 SPEED 1 needed to avoid the compiler
 from downgrading the type check to
 a cheaper one.
 Low-level setters return no value
 the energy to figure out to change that right now.
 (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
 definition is needed for the compiler to use in constant folding.)
 Array invalidation stashes the original dimensions here...
 SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 haven't found technical advantages or disadvantages for either
 scheme.
 miscellaneous array properties
 same as (SPECIFIER-TYPE (ARRAY-ELEMENT-TYPE ARRAY)) but more efficient
 if unsimple and
 displaced
 Note that this appears not to be a fundamental limitation.
 non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
 but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
 fill pointer frobbing stuff
 This does not try to allow for resizing (ARRAY NIL) - there's no backing storage anyway.
 However, ADJUST-ARRAY apparently thinks it can resize non-simple arrays of
 because it doesn't know not to try to copy elements.
 So unless we think that that is one of the most pressing issues that demands
 a fix, who cares how we reallocate?
 If you're manipulating such arrays, quite literally you deserve to lose.
 but a single case involving it now.
 FIXME: mark prefix of shadow bits assigned, suffix unassigned
 Copy the data
 the most common case
 transformed
 disable bounds checking
 disable bounds checking (and any fixnum test)
 ADJUST-ARRAY
 "drive-by" check of the rank
 I believe the sentence saying that this is an error pre-dates the removal
 of the restriction of calling ADJUST-ARRAY only on arrays that
 are actually adjustable. Making a new array should always work,
 so I think this may be a bug in the spec.
 "consequences are unspecified if array is adjusted to a size smaller than its fill pointer"
 super easy - just repoint ARRAY to new data
 array former contents replaced by INITIAL-CONTENTS
 simple multidimensional array.
 Because ADJUST-ARRAY has to ignore any fill-pointer when
 copying from the old data, we can't just pass ARRAY as the
 if total size is unchanged, and it was not a displaced array,
 then this array owns the data and can retain it.
 which must be less than or equal to its current length. This can
 be called on vectors without a fill pointer but it is slightly
 dangerous to do so: shrinking the size of an object accessible
 to another thread could cause it to access an out-of-bounds element.
 reads the old length or the new length. If it reads the old length,
 then the whole vector is skipped if unboxed; if it reads the new length,
 then the next object is a filler.
 Exception: for SIMPLE-VECTOR we always zeroized the unused tail,
 because the garbage collector can scan certain pages without regard
 to object boundaries. The situation we need to avoid is this:
       "old" #(...............|.....)
                              ^ page boundary
 because it doesn't know not to.

 that overallocate a temporary result. In all places where that happens,
 the discarded suffix was never used. So assuming pre-zeroed heap,
 it kind of just worked. But I don't want to assume that.
 produced no failures in the regression suite.
 We can blindly store the hidden #\null at NEW-LENGTH, but it would
 appear to be an out-of-bounds access if the length is not
 changing at all. i.e. while it's safe to always do a store,
 the length check has to be skipped.
 Now treat both the old and new lengths as if they include
 the byte that holds the implicit string terminator.
 There is no requirement to zeroize memory corresponding
 to unused array elements.
 However, it's slightly nicer if the padding word (if present) is 0.
 Only if physically shrunk as determined by PRIMITIVE-OBJECT-SIZE
 will we need to (and have adequate room to) place a filler.
 Certainly if the vector is unboxed it can't possibly matter

 but even for SIMPLE-VECTOR, it's OK, it turns out.
 Only arrays have fill-pointers, but vectors have their length
 parameter in the same place.
 BIG THREAD SAFETY NOTE

 ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
 thread unsafe. They are nonatomic, and can mess with parallel
 code using the same arrays.

 A likely seeming fix is an additional level of indirection:
 ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
 hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
 would hold everything ARRAY-HEADER now holds. This allows
 consing up a new ARRAY-INFO and replacing it atomically in
 the ARRAY-HEADER.

 %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
 one: not only is it needed extremely rarely, which makes
 any thread safety bugs involving it look like rare random
 corruption, but because it walks the chain *upwards*, which
 may violate user expectations.
 Fill in array header with the provided information, and return the array.
 ANSI sayeth (ADJUST-ARRAY dictionary entry):

   "If A is displaced to B, the consequences are unspecified if B is
   adjusted in such a way that it no longer has enough elements to
   satisfy A.

 since we're hanging on a weak pointer here, we can't signal an
 error right now: the array that we're looking at might be
 safe access to the displaced array will trap. Additionally, we
 save the original dimensions, so we can signal a more
 understandable error when the time comes.
 User visible extension
 the return value is always of the known type.
 This does the grinding work for ADJUST-ARRAY. It zaps the data
 from the OLD-DATA in an arrangement specified by the OLD-DIMS to
 is a displaced offset to be added to computed indices of OLD-DATA.
 OLD-DIMS comes from array-dimensions, which returns a fresh list
 NEW-DIMS comes from the user.
 NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
 INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
 EQ; in this case, a temporary must be used and filled
 appropriately. specified initial-element.
 would be a win...
 Kill the temporary vector to prevent garbage retention.
 When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
 already been filled with any
 Figure out the row-major-order index of an array reference from a
 list of subscripts and a list of dimensions. This is for internal
 calls only, and the subscripts and dim-list variables are assumed
 to be reversed from what the user supplied.
 some bit stuff
 it got a constant-folding-error in the FORMAT call when producing the load-time
 Bit array operations are allowed to leave arbitrary values in the
 trailing bits of the result. Examples:
   1111111111111111111111111111111111111111111111111111111111110110
   1111111111111111111111111111111111111111111111111111111111110010
 But because reading is more common than writing, it seems that a better
 technique might be to enforce an invariant that the last word contain 0
 array type dispatching
 Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
 defines the functions

 DISPATCH-FOO/SIMPLE-BASE-STRING
 DISPATCH-FOO/SIMPLE-CHARACTER-STRING
 DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
 ...

 specializer function. The array being specialized must be the
 is automatically inserted into the body of each function.

 functions. The table is padded by the function

 Finally, the DISPATCH-FOO macro is defined which does the actual

 This SUBSTITUTE call happens ** after ** all the SETFs below it.
 with 0 (it would not work if the vector held function objects).
 Then the SETFs happen, as cold-load can process %SVSET, which
 is great, because it means that hairy sequence dispatch may occur
 as early as you'd like in cold-init without regard to file order.
 However when it comes to actually executing the toplevel forms
 that were compiled into thunks of target code to invoke,
 all the known good entries must be preserved.
 All widetags have to be listed so that the jump table logic doesn't
 give up due to deciding that it's a waste of space. It could probably
 be based on the SPACE compilation policy. However, I would imagine that
 given the amount of code that has to be emitted if not a table.
 This table has only 2.5x as many words as relevant (non-error) cases.
 Horrible kludge for the "static-vectors" system
 Explicitly compute a widetag with the weakness bit ORed in.
 These allocation calls are the transforms of MAKE-ARRAY for a vector with
 the respective initializing keyword arg. This is badly OAOO-violating and
 almost makes me want to cry, but not quite enough for me to improve it.
 as it is the value assigned to broken hearts.

  This software is part of the SBCL system . See the README file for
  This software is derived from the CMU CL system , which was
  written at Carnegie Mellon University and released into the

(in-package "SB-VM")

(declaim (inline adjustable-array-p
                 array-displacement))


  compiler inlines them .
(macrolet ((def (name)
             `(progn
                (defun ,name (array)
                  (,name array))
                (defun (setf ,name) (value array)
                  (setf (,name array) value)))))
  (def %array-fill-pointer)
  (def %array-available-elements)
  (def %array-data)
  (def %array-displacement)
  (def %array-displaced-p)
  (def %array-displaced-from))

(defun %array-rank (array)
  (%array-rank array))

(defun %array-dimension (array axis)
  (%array-dimension array axis))

(defun %check-bound (array bound index)
  (declare (type index bound)
           (fixnum index))
  (%check-bound array bound index))

(defun check-bound (array bound index)
  (declare (type index bound)
           (fixnum index))
  (%check-bound array bound index)
  index)

(defun %with-array-data/fp (array start end)
  (%with-array-data-macro array start end :check-bounds t :check-fill-pointer t))

(defun %with-array-data (array start end)
  (%with-array-data-macro array start end :check-bounds t :array-header-p t))

(defun %data-vector-and-index (array index)
  (if (array-header-p array)
      (multiple-value-bind (vector index)
          (%with-array-data array index nil)
        (values vector index))
      (values (truly-the (simple-array * (*)) array) index)))


(defun %integer-vector-widetag-and-n-bits-shift (signed high)
  (let ((unsigned-table
          #.(let ((map (make-array (1+ n-word-bits))))
              (loop for saetp across
                    (reverse *specialized-array-element-type-properties*)
                    for ctype = (saetp-ctype saetp)
                    when (and (numeric-type-p ctype)
                              (eq (numeric-type-class ctype) 'integer)
                              (zerop (numeric-type-low ctype)))
                    do (fill map (cons (saetp-typecode saetp)
                                       (saetp-n-bits-shift saetp))
                             :end (1+ (integer-length (numeric-type-high ctype)))))
              map))
        (signed-table
          #.(let ((map (make-array (1+ n-word-bits))))
              (loop for saetp across
                    (reverse *specialized-array-element-type-properties*)
                    for ctype = (saetp-ctype saetp)
                    when (and (numeric-type-p ctype)
                              (eq (numeric-type-class ctype) 'integer)
                              (minusp (numeric-type-low ctype)))
                    do (fill map (cons (saetp-typecode saetp)
                                       (saetp-n-bits-shift saetp))
                             :end (+ (integer-length (numeric-type-high ctype)) 2)))
              map)))
    (cond ((> high n-word-bits)
           (values #.simple-vector-widetag
                   #.(1- (integer-length n-word-bits))))
          (signed
           (let ((x (aref signed-table high)))
             (values (car x) (cdr x))))
          (t
           (let ((x (aref unsigned-table high)))
             (values (car x) (cdr x)))))))

  This is a bit complicated , but calling subtypep over all
(defun %vector-widetag-and-n-bits-shift (type)
  (macrolet ((with-parameters ((arg-type &key intervals)
                               (&rest args) &body body)
               (let ((type-sym (gensym)))
                 `(let (,@(loop for arg in args
                                collect `(,arg '*)))
                    (declare (ignorable ,@args))
                    (when (consp type)
                      (let ((,type-sym (cdr type)))
                        (block nil
                          ,@(loop for arg in args
                                  collect
                                  `(cond ((consp ,type-sym)
                                          (let ((value (pop ,type-sym)))
                                            (if (or (eq value '*)
                                                    (typep value ',arg-type)
                                                    ,(if intervals
                                                         `(and (consp value)
                                                               (null (cdr value))
                                                               (typep (car value)
                                                                      ',arg-type))))
                                                (setf ,arg value)
                                                (ill-type))))
                                         ((null ,type-sym)
                                          (return))
                                         (t
                                          (ill-type)))))
                        (when ,type-sym
                          (ill-type))))
                    ,@body)))
             (ill-type ()
               `(go fastidiously-parse))
             (result (widetag)
               (let ((value (symbol-value widetag)))
                 `(values ,value
                          ,(saetp-n-bits-shift
                            (find value
                                  *specialized-array-element-type-properties*
                                  :key #'saetp-typecode))))))
    (flet ((integer-interval-widetag (low high)
             (if (minusp low)
                 (%integer-vector-widetag-and-n-bits-shift
                  t
                  (1+ (max (integer-length low) (integer-length high))))
                 (%integer-vector-widetag-and-n-bits-shift
                  nil
                  (max (integer-length low) (integer-length high))))))
      (tagbody
         (binding*
             ((consp (consp type))
              (type-name (if consp (car type) type))
              ((widetag n-bits-shift)
               (case type-name
                 ((t)
                  (when consp
                    (ill-type))
                  (result simple-vector-widetag))
                 ((base-char standard-char #-sb-unicode character)
                  (when consp
                    (ill-type))
                  (result simple-base-string-widetag))
                 #+sb-unicode
                 ((character extended-char)
                  (when consp
                    (ill-type))
                  (result simple-character-string-widetag))
                 (bit
                  (when consp
                    (ill-type))
                  (result simple-bit-vector-widetag))
                 (fixnum
                  (when consp
                    (ill-type))
                  (result simple-array-fixnum-widetag))
                 (unsigned-byte
                  (with-parameters ((integer 1)) (high)
                    (if (eq high '*)
                        (result simple-vector-widetag)
                        (%integer-vector-widetag-and-n-bits-shift nil high))))
                 (signed-byte
                  (with-parameters ((integer 1)) (high)
                    (if (eq high '*)
                        (result simple-vector-widetag)
                        (%integer-vector-widetag-and-n-bits-shift t high))))
                 (double-float
                  (with-parameters (double-float :intervals t) (low high)
                    (if (and (not (eq low '*))
                             (not (eq high '*))
                             (if (or (consp low) (consp high))
                                 (>= (type-bound-number low) (type-bound-number high))
                                 (> low high)))
                        (result simple-array-nil-widetag)
                        (result simple-array-double-float-widetag))))
                 (single-float
                  (with-parameters (single-float :intervals t) (low high)
                    (if (and (not (eq low '*))
                             (not (eq high '*))
                             (if (or (consp low) (consp high))
                                 (>= (type-bound-number low) (type-bound-number high))
                                 (> low high)))
                        (result simple-array-nil-widetag)
                        (result simple-array-single-float-widetag))))
                 (mod
                  (if (and (consp type)
                           (consp (cdr type))
                           (null (cddr type))
                           (typep (cadr type) '(integer 1)))
                      (%integer-vector-widetag-and-n-bits-shift
                       nil (integer-length (1- (cadr type))))
                      (ill-type)))
                 #+long-float
                 (long-float
                  (with-parameters (long-float :intervals t) (low high)
                    (if (and (not (eq low '*))
                             (not (eq high '*))
                             (if (or (consp low) (consp high))
                                 (>= (type-bound-number low) (type-bound-number high))
                                 (> low high)))
                        (result simple-array-nil-widetag)
                        (result simple-array-long-float-widetag))))
                 (integer
                  (with-parameters (integer :intervals t) (low high)
                    (let ((low (if (consp low)
                                   (1+ (car low))
                                   low))
                          (high (if (consp high)
                                    (1- (car high))
                                    high)))
                      (cond ((or (eq high '*)
                                 (eq low '*))
                             (result simple-vector-widetag))
                            ((> low high)
                             (result simple-array-nil-widetag))
                            (t
                             (integer-interval-widetag low high))))))
                 (complex
                  (with-parameters (t) (subtype)
                    (if (eq subtype '*)
                        (result simple-vector-widetag)
                        (let ((ctype (specifier-type type)))
                          (cond ((eq ctype *empty-type*)
                                 (result simple-array-nil-widetag))
                                ((union-type-p ctype)
                                 (cond ((csubtypep ctype (specifier-type '(complex double-float)))
                                        (result
                                         simple-array-complex-double-float-widetag))
                                       ((csubtypep ctype (specifier-type '(complex single-float)))
                                        (result
                                         simple-array-complex-single-float-widetag))
                                       #+long-float
                                       ((csubtypep ctype (specifier-type '(complex long-float)))
                                        (result
                                         simple-array-complex-long-float-widetag))
                                       (t
                                        (result simple-vector-widetag))))
                                (t
                                 (case (numeric-type-format ctype)
                                   (double-float
                                    (result
                                     simple-array-complex-double-float-widetag))
                                   (single-float
                                    (result
                                     simple-array-complex-single-float-widetag))
                                   #+long-float
                                   (long-float
                                    (result
                                     simple-array-complex-long-float-widetag))
                                   (t
                                    (result simple-vector-widetag)))))))))
                 ((nil)
                  (result simple-array-nil-widetag))
                 (t
                  (go fastidiously-parse)))))
           (return-from %vector-widetag-and-n-bits-shift
             (values widetag n-bits-shift)))
       fastidiously-parse)
      (let* ((ctype (type-or-nil-if-unknown type))
             (ctype (and ctype
                         (sb-kernel::replace-hairy-type ctype))))
        (typecase ctype
          (null (result simple-vector-widetag))
          (union-type
           (let ((types (union-type-types ctype)))
             (cond ((not (every #'numeric-type-p types))
                    (result simple-vector-widetag))
                   ((csubtypep ctype (specifier-type 'integer))
                    (block nil
                      (integer-interval-widetag
                       (dx-flet ((low (x)
                                      (or (numeric-type-low x)
                                          (return (result simple-vector-widetag)))))
                         (reduce #'min types :key #'low))
                       (dx-flet ((high (x)
                                       (or (numeric-type-high x)
                                           (return (result simple-vector-widetag)))))
                         (reduce #'max types :key #'high)))))
                   ((csubtypep ctype (specifier-type 'double-float))
                    (result simple-array-double-float-widetag))
                   ((csubtypep ctype (specifier-type 'single-float))
                    (result simple-array-single-float-widetag))
                   #+long-float
                   ((csubtypep ctype (specifier-type 'long-float))
                    (result simple-array-long-float-widetag))
                   ((csubtypep ctype (specifier-type 'complex-double-float))
                    (result simple-array-complex-double-float-widetag))
                   ((csubtypep ctype (specifier-type 'complex-single-float))
                    (result simple-array-complex-single-float-widetag))
                   (t
                    (result simple-vector-widetag)))))
          (intersection-type
           (let ((types (intersection-type-types ctype)))
             (loop for type in types
                   unless (hairy-type-p type)
                   return (%vector-widetag-and-n-bits-shift (type-specifier type)))))
          (character-set-type
           #-sb-unicode (result simple-base-string-widetag)
           #+sb-unicode
           (if (loop for (start . end)
                     in (character-set-type-pairs ctype)
                     always (and (< start base-char-code-limit)
                                 (< end base-char-code-limit)))
               (result simple-base-string-widetag)
               (result simple-character-string-widetag)))
          (t
           (let ((expansion (type-specifier ctype)))
             (if (equal expansion type)
                 (result simple-vector-widetag)
                 (%vector-widetag-and-n-bits-shift expansion)))))))))

(defun %complex-vector-widetag (widetag)
  (macrolet ((make-case ()
               `(case widetag
                  ,@(loop for saetp across *specialized-array-element-type-properties*
                          for complex = (saetp-complex-typecode saetp)
                          when complex
                          collect (list (saetp-typecode saetp) complex))
                  (t
                   #.complex-vector-widetag))))
    (make-case)))

(declaim (inline vector-length-in-words))
(defun vector-length-in-words (length n-bits-shift)
  (declare (type (integer 0 7) n-bits-shift))
  (let ((mask (ash (1- n-word-bits) (- n-bits-shift)))
        (shift (- n-bits-shift
                  (1- (integer-length n-word-bits)))))
    (ash (+ length mask) shift)))

  N - BITS - SHIFT is the shift amount needed to turn LENGTH into array - size - in - bits ,
(defun allocate-vector-with-widetag (#+ubsan poisoned widetag length n-bits-shift)
  (declare (type (unsigned-byte 8) widetag)
           (type index length))
   : add SAETP - N - PAD - ELEMENTS " by hand " since there is
         (full-length (+ length (if (= widetag simple-base-string-widetag) 1 0)))
  Be careful not to allocate backing storage for element type NIL .
  Both it and type BIT have N - BITS - SHIFT = 0 , so the determination
  of true size ca n't be left up to VECTOR - LENGTH - IN - WORDS .
  POSITIVE - FIXNUM for the last argument of the vector   .
         (nwords (the fixnum
                      (if (/= widetag simple-array-nil-widetag)
                          (vector-length-in-words full-length n-bits-shift)
                          0))))
  first arg to allocate - vector must be a constant
                      (allocate-vector t widetag length nwords)
                      (allocate-vector nil widetag length nwords))
    #-ubsan (allocate-vector widetag length nwords)))

(declaim (ftype (sfunction (array) (integer 128 255)) array-underlying-widetag))
(defun array-underlying-widetag (array)
  (macrolet ((generate-table ()
               (macrolet ((to-index (x) `(ash ,x -2)))
                 (let ((table (sb-xc:make-array 64 :initial-element 0
                                                :element-type '(unsigned-byte 8))))
                   (dovector (saetp *specialized-array-element-type-properties*)
                     (let* ((typecode (saetp-typecode saetp))
                            (complex-typecode (saetp-complex-typecode saetp)))
                       (setf (aref table (to-index typecode)) typecode)
                       (when complex-typecode
                         (setf (aref table (to-index complex-typecode)) typecode))))
                   (setf (aref table (to-index simple-array-widetag)) 0
                         (aref table (to-index complex-vector-widetag)) 0
                         (aref table (to-index complex-array-widetag)) 0)
                   table)))
             (to-index (x) `(ash ,x -2)))
  (named-let recurse ((x array))
    (let ((result (aref (generate-table)
                        (to-index (%other-pointer-widetag x)))))
      (if (= 0 result)
          (recurse (%array-data x))
          (truly-the (integer 128 255) result))))))

  returning the two initialization arguments needed for DATA - VECTOR - FROM - INITS .
  This is an unhygienic macro which would be a MACROLET other than for
(defmacro check-make-array-initargs (displaceable &optional element-type size)
  `(cond ,@(when displaceable
             `((displaced-to
                (when (or element-p contents-p)
                  (if (and element-p contents-p)
                      (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
                               may be specified with the :DISPLACED-TO option")
                      (error "~S may not be specified with the :DISPLACED-TO option"
                             (if element-p :initial-element :initial-contents))))
                (unless (= (array-underlying-widetag displaced-to) widetag)
  Require exact match on upgraded type ( lp#1331299 )
                  (error "Can't displace an array of type ~/sb-impl:print-type-specifier/ ~
                           into another of type ~/sb-impl:print-type-specifier/"
                         ,element-type (array-element-type displaced-to)))
                (when (< (array-total-size displaced-to)
                         (+ displaced-index-offset ,size))
                  (error "The :DISPLACED-TO array is too small.")))
               (offset-p
                (error "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))))
         ((and element-p contents-p)
          (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
         (element-p  (values :initial-element initial-element))
         (contents-p (values :initial-contents initial-contents))))
(defmacro make-array-bad-fill-pointer (actual max adjective)
  `(error "Can't supply a value for :FILL-POINTER (~S) that is larger ~
           than the~A size of the vector (~S)" ,actual ,adjective ,max))

(declaim (inline %save-displaced-array-backpointer
                 %save-displaced-new-array-backpointer))
(defun %save-displaced-array-backpointer (array data)
  (flet ((purge (pointers)
           (remove-if (lambda (value)
                        (or (not value) (eq array value)))
                      pointers
                      :key #'weak-pointer-value)))
    (let ((old-data (%array-data array)))
      (unless (eq old-data data)
        (when (array-header-p data)
          (setf (%array-displaced-from data)
                (cons (make-weak-pointer array)
                      (purge (%array-displaced-from data)))))
        (when (array-header-p old-data)
          (setf (%array-displaced-from old-data)
                (purge (%array-displaced-from old-data))))))))

(defun %save-displaced-new-array-backpointer (array data)
  (flet ((purge (pointers)
           (remove-if-not #'weak-pointer-value pointers)))
    (when (array-header-p data)
      (setf (%array-displaced-from data)
            (cons (make-weak-pointer array)
                  (purge (%array-displaced-from data)))))))

(defmacro populate-dimensions (header list-or-index rank)
  `(if (listp ,list-or-index)
       (let ((dims ,list-or-index))
         (dotimes (axis ,rank)
           (declare ((integer 0 ,array-rank-limit) axis))
           (%set-array-dimension ,header axis (pop dims))))
       (%set-array-dimension ,header 0 ,list-or-index)))

(declaim (inline rank-and-total-size-from-dims))
(defun rank-and-total-size-from-dims (dims)
  (cond ((not (listp dims)) (values 1 (the index dims)))
        ((not dims) (values 0 1))
        (t (let ((rank 1) (product (car dims)))
             (declare (array-rank rank) (index product))
             (dolist (dim (cdr dims) (values rank product))
               (setq product (* product (the index dim)))
               (incf rank))))))

(declaim (inline widetag->element-type))
(defun widetag->element-type (widetag)
  (svref #.(let ((a (make-array 32 :initial-element 0)))
             (dovector (saetp *specialized-array-element-type-properties* a)
               (let ((tag (saetp-typecode saetp)))
                 (setf (aref a (ash (- tag #x80) -2)) (saetp-specifier saetp)))))
         (- (ash widetag -2) 32)))

(defun initial-contents-error (content-length length)
  (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
                                the vector length is ~W."
         content-length length))

  Widetag is the widetag of the underlying vector ,
(defun %make-array (dimensions widetag n-bits
                    &key
                      element-type
                      (initial-element nil element-p)
                      (initial-contents nil contents-p)
                      adjustable fill-pointer
                      displaced-to
                      (displaced-index-offset 0 offset-p))
  (declare (ignore element-type))
  (binding* (((array-rank total-size) (rank-and-total-size-from-dims dimensions))
             ((initialize initial-data)
              (check-make-array-initargs t (widetag->element-type widetag) total-size))
             (simple (and (null fill-pointer)
                          (not adjustable)
                          (null displaced-to))))

    (cond ((and simple (= array-rank 1))
                  (allocate-vector-with-widetag #+ubsan (not (or element-p contents-p))
                                                widetag total-size n-bits)))
             (cond (element-p
                    (fill vector initial-element))
                   (contents-p
                    (let ((content-length (length initial-contents)))
                      (unless (= total-size content-length)
                        (initial-contents-error content-length total-size)))
                    (replace vector initial-contents))
                   #+ubsan
                   (t
                                               (vector-extra-data vector))
                    (cond ((= widetag simple-vector-widetag)
                           (fill vector (%make-lisp-obj unwritten-vector-element-marker)))
                          ((array-may-contain-random-bits-p widetag)
                           (dotimes (i (- (vector-length-in-words total-size n-bits)
                                          (if (= widetag simple-base-string-widetag) 1 0)))
                             (setf (%vector-raw-bits vector i) sb-ext:most-positive-word))))))
             vector))
          (t
           (when fill-pointer
             (unless (= array-rank 1)
               (error "Only vectors can have fill pointers."))
             (when (and (integerp fill-pointer) (> fill-pointer total-size))
               (make-array-bad-fill-pointer fill-pointer total-size "")))
           (let* ((data (or displaced-to
                            (data-vector-from-inits dimensions total-size widetag n-bits
                                                    initialize initial-data)))
                  (array (make-array-header
                          (cond ((= array-rank 1)
                                 (%complex-vector-widetag widetag))
                                (simple simple-array-widetag)
                                (t complex-array-widetag))
                          array-rank)))
             (cond (fill-pointer
                    (logior-array-flags array +array-fill-pointer-p+)
                    (setf (%array-fill-pointer array)
                          (if (eq fill-pointer t) total-size fill-pointer)))
                   (t
                    (reset-array-flags array +array-fill-pointer-p+)
                    (setf (%array-fill-pointer array) total-size)))
             (setf (%array-available-elements array) total-size)
             (setf (%array-data array) data)
             (setf (%array-displaced-from array) nil)
             (cond (displaced-to
                    (setf (%array-displacement array) (or displaced-index-offset 0))
                    (setf (%array-displaced-p array) t)
                    (%save-displaced-new-array-backpointer array data))
                   (t
                    (setf (%array-displaced-p array) nil)))
             (populate-dimensions array dimensions array-rank)
             array)))))

(defun make-array (dimensions &rest args
                   &key (element-type t)
                        initial-element initial-contents
                        adjustable
                        fill-pointer
                        displaced-to
                        displaced-index-offset)
  (declare (ignore initial-element
                   initial-contents adjustable
                   fill-pointer displaced-to displaced-index-offset))
  (declare (explicit-check))
  (multiple-value-bind (widetag shift) (%vector-widetag-and-n-bits-shift element-type)
    (apply #'%make-array dimensions widetag shift args)))

(defun make-static-vector (length &key
                           (element-type '(unsigned-byte 8))
                           (initial-contents nil contents-p)
                           (initial-element nil element-p))
  "Allocate vector of LENGTH elements in static space. Only allocation
of specialized arrays is supported."
  STEP 1 : check inputs fully
  (when (eq t (upgraded-array-element-type element-type))
    (error "Static arrays of type ~/sb-impl:print-type-specifier/ not supported."
           element-type))
  (when contents-p
    (unless (= length (length initial-contents))
      (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
              vector length is ~W."
             (length initial-contents)
             length))
    (unless (every (lambda (x) (typep x element-type)) initial-contents)
      (error ":INITIAL-CONTENTS contains elements not of type ~
               ~/sb-impl:print-type-specifier/."
             element-type)))
  (when element-p
    (unless (typep initial-element element-type)
      (error ":INITIAL-ELEMENT ~S is not of type ~
               ~/sb-impl:print-type-specifier/."
             initial-element element-type)))
  STEP 2
  (multiple-value-bind (type n-bits-shift)
      (%vector-widetag-and-n-bits-shift element-type)
    (let* ((full-length
   : add SAETP - N - PAD - ELEMENTS " by hand " since there is
             (+ length (if (= type simple-base-string-widetag) 1 0)))
           (vector
             (allocate-static-vector type length
                                     (vector-length-in-words full-length
                                                             n-bits-shift))))
      (cond (element-p
             (fill vector initial-element))
            (contents-p
             (replace vector initial-contents))
            (t
             vector)))))

#+darwin-jit
(defun make-static-code-vector (length initial-contents)
  "Allocate vector of LENGTH elements in static space. Only allocation
of specialized arrays is supported."
  (let ((vector (allocate-static-code-vector simple-array-unsigned-byte-8-widetag
                                             length
                                             (* length n-word-bytes))))
    (with-pinned-objects (initial-contents)
      (jit-memcpy (vector-sap vector) (vector-sap initial-contents) length))
    vector))

  specified array characteristics .  is only used to pass
  to FILL - DATA - VECTOR for error checking on the structure of
(defun data-vector-from-inits (dimensions total-size widetag n-bits initialize initial-data)
  (let ((data (allocate-vector-with-widetag #+ubsan (not initialize) widetag total-size n-bits)))
    (ecase initialize
     (:initial-element
      (fill (the vector data) initial-data))
     (:initial-contents
  DIMENSIONS can be supplied as a list or integer now
        (fill-data-vector data
                          (if (listp dimensions) dimensions list-of-dims)
                          initial-data)))
     ((nil)))
    data))

(defun vector (&rest objects)
  "Construct a SIMPLE-VECTOR from the given objects."
  (let ((v (make-array (length objects))))
    (do-rest-arg ((x i) objects 0 v)
      (setf (aref v i) x))))



  Dispatch to an optimized routine the data vector accessors for
  up the widetag in the array rather than with the typecases , which
  as of 1.0.5 compiles to a naive sequence of linear TYPEPs . Also
  that we call an element of an array accessed by widetag ?
(macrolet ((def (name table-name)
             `(progn
                (define-load-time-global ,table-name
                    (make-array ,(1+ widetag-mask)))
                (declaim (type (simple-array function (,(1+ widetag-mask)))
                               ,table-name))
                (defmacro ,name (array-var)
                  `(the function
  Assigning TAG to 0 initially produces slightly better
  by a zero - extending load . A peephole pass could eliminate
  the first move as effectless .   If expressed the other way ,
                     (let ((tag 0))
                       (when (%other-pointer-p ,array-var)
                         (setf tag (%other-pointer-widetag ,array-var)))
                       (svref ,',table-name tag)))))))
  (def !find-data-vector-setter %%data-vector-setters%%)
  (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
  Used by DO - VECTOR - DATA -- which in turn appears in DOSEQUENCE expansion ,
  (def %find-data-vector-reffer %%data-vector-reffers%%)
  (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))

  Like  , but more magical -- ca n't use this on host .
(defmacro sb-impl::do-vector-data ((elt vector &optional result) &body body)
  (multiple-value-bind (forms decls) (parse-body body nil)
    (with-unique-names (index vec start end ref)
      `(with-array-data ((,vec ,vector)
                         (,start)
                         (,end)
                         :check-fill-pointer t)
         (let ((,ref (%find-data-vector-reffer ,vec)))
           (declare (function ,ref))
           (do ((,index ,start (1+ ,index)))
               ((>= ,index ,end)
                (let ((,elt nil))
                  ,@(sb-impl::filter-dolist-declarations decls)
                  ,elt
                  ,result))
             (let ((,elt (funcall ,ref ,vec ,index)))
               ,@decls
               (tagbody ,@forms))))))))

(macrolet ((%ref (accessor-getter extra-params)
             `(sb-c::%funcall-no-nargs (,accessor-getter array) array index ,@extra-params))
           (define (accessor-name slow-accessor-name accessor-getter
                                  extra-params check-bounds)
             `(progn
                (defun ,accessor-name (array index ,@extra-params)
                  (declare (explicit-check))
                  (declare (optimize speed
  is done implicitly via the widetag
                                     (safety 0)))
                  (%ref ,accessor-getter ,extra-params))
                (defun ,slow-accessor-name (array index ,@extra-params)
                  (declare (optimize speed (safety 0))
                           (array array))
                  (if (not (%array-displaced-p array))
                      (let ((array (%array-data array)))
                        (%ref ,accessor-getter ,extra-params))
                      (with-array-data
                          ((array array)
                           (index (locally
                                      (declare (optimize (speed 1) (safety 1)))
                                    (,@check-bounds index)))
                           (end)
                           :force-inline t)
                        (declare (ignore end))
                        (%ref ,accessor-getter ,extra-params)))))))
  (define hairy-data-vector-ref slow-hairy-data-vector-ref
    %find-data-vector-reffer
    nil (progn))
  (define hairy-data-vector-set slow-hairy-data-vector-set
    !find-data-vector-setter
    (new-value) (progn))
  (define hairy-data-vector-ref/check-bounds
      slow-hairy-data-vector-ref/check-bounds
    !find-data-vector-reffer/check-bounds
    nil (check-bound array (%array-dimension array 0)))
  (define hairy-data-vector-set/check-bounds
      slow-hairy-data-vector-set/check-bounds
    !find-data-vector-setter/check-bounds
    (new-value) (check-bound array (%array-dimension array 0))))

(defun hairy-ref-error (array index &optional new-value)
  (declare (ignore index new-value)
           (optimize (sb-c:verify-arg-count 0)))
  (error 'type-error
         :datum array
         :expected-type 'vector))

(macrolet ((define-reffer (saetp check-form)
             (let* ((type (saetp-specifier saetp))
                    (atype `(simple-array ,type (*))))
               `(named-lambda (optimized-data-vector-ref ,type) (vector index)
                  (declare (optimize speed (safety 0))
                           (muffle-conditions compiler-note)
                           (ignorable index))
                  ,(if type
                       `(data-vector-ref (the ,atype vector)
                                         (the index
                                              (locally
                                                  (declare (optimize (safety 1)))
                                                (,@check-form index))))
                       `(data-nil-vector-ref (the ,atype vector) index)))))
           (define-setter (saetp check-form)
             (let* ((type (saetp-specifier saetp))
                    (atype `(simple-array ,type (*))))
               `(named-lambda (optimized-data-vector-set ,type) (vector index new-value)
                  (declare (optimize speed (safety 0)))
                  (declare (muffle-conditions compiler-note))
                  (data-vector-set (the ,atype vector)
                                   (locally
                                       (declare (optimize (safety 1)))
                                     (the index
                                       (,@check-form index)))
                                   (locally
                                       (declare (optimize (speed 1)
                                                          (safety 1)))
                                     (the* (,type :context 'sb-c::aref-context) new-value)))
                  new-value)))
           (define-reffers (symbol deffer check-form slow-path)
             `(progn
  FIXME /  : ca n't just FILL here , because genesis does n't
  preserve the binding , so re - initiaize as NS does n't have
                (setf ,symbol (make-array (1+ widetag-mask)
                                          :initial-element #'hairy-ref-error))
                ,@(loop for widetag in '(complex-vector-widetag
                                         complex-bit-vector-widetag
                                         #+sb-unicode complex-character-string-widetag
                                         complex-base-string-widetag
                                         simple-array-widetag
                                         complex-array-widetag)
                        collect `(setf (svref ,symbol ,widetag) ,slow-path))
                ,@(loop for saetp across *specialized-array-element-type-properties*
                        for widetag = (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)))

  DATA - VECTOR - REF is also FOLDABLE , and this ordinary function
(defun data-vector-ref (array index)
  (declare (explicit-check))
  (hairy-data-vector-ref array index))

(defun data-vector-ref-with-offset (array index offset)
  (declare (explicit-check))
  (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)
  (declare (optimize allow-non-returning-tail-call))
  (aver (array-header-p array))
  (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 t integer &optional t) nil)
                invalid-array-index-error))
(defun invalid-array-index-error (array index bound &optional axis)
  (declare (optimize allow-non-returning-tail-call))
  (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)))))

(defun %array-row-major-index (array &rest subscripts)
  (declare (truly-dynamic-extent subscripts)
           (array array))
  (let ((length (length subscripts)))
    (cond ((array-header-p array)
           (let ((rank (%array-rank array)))
             (unless (= rank length)
               (error "Wrong number of subscripts, ~W, for array of rank ~W."
                      length rank))
             (do ((axis (1- rank) (1- axis))
                  (chunk-size 1)
                  (result 0))
                 ((minusp axis) result)
               (declare (fixnum axis chunk-size result))
               (let ((index (fast-&rest-nth axis subscripts))
                     (dim (%array-dimension array axis)))
                 (unless (and (fixnump index) (< -1 index dim))
                   (invalid-array-index-error array index dim axis))
                 (setf result
                       (truly-the fixnum
                                  (+ result
                                     (truly-the fixnum (* chunk-size index))))
                       chunk-size (truly-the fixnum (* chunk-size dim)))))))
          ((/= length 1)
           (error "Wrong number of subscripts, ~W, for array of rank 1."
                  length))
          (t
           (let ((index (fast-&rest-nth 0 subscripts))
                 (length (length (the (simple-array * (*)) array))))
             (unless (and (fixnump index) (< -1 index length))
               (invalid-array-index-error array index length))
             index)))))

(defun array-in-bounds-p (array &rest subscripts)
  "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
  (declare (truly-dynamic-extent subscripts))
  (let ((length (length subscripts)))
    (cond ((array-header-p array)
           (let ((rank (%array-rank array)))
             (unless (= rank length)
               (error "Wrong number of subscripts, ~W, for array of rank ~W."
                      length rank))
             (loop for i below length
                   for s = (fast-&rest-nth i subscripts)
                   always (and (typep s '(and fixnum unsigned-byte))
                               (< s (%array-dimension array i))))))
          ((/= length 1)
           (error "Wrong number of subscripts, ~W, for array of rank 1."
                  length))
          (t
           (let ((subscript (fast-&rest-nth 0 subscripts)))
             (and (typep subscript '(and fixnum unsigned-byte))
                  (< subscript
                     (length (truly-the (simple-array * (*)) array)))))))))

(defun array-row-major-index (array &rest subscripts)
  (declare (truly-dynamic-extent subscripts))
  (apply #'%array-row-major-index array subscripts))

(defun aref (array &rest subscripts)
  "Return the element of the ARRAY specified by the SUBSCRIPTS."
  (declare (truly-dynamic-extent subscripts))
  (row-major-aref array (apply #'%array-row-major-index array subscripts)))

  ( setf aref / bit / sbit ) are implemented using setf - functions ,
  because they have to work with ( setf ( apply # ' aref array subscripts ) )
  All other setfs can be done using setf - functions too , but I
(defun (setf aref) (new-value array &rest subscripts)
  (declare (truly-dynamic-extent subscripts)
           (type array array))
  (setf (row-major-aref array (apply #'%array-row-major-index array subscripts))
        new-value))

(defun row-major-aref (array index)
  "Return the element of array corresponding to the row-major index. This is
   SETFable."
  (declare (optimize (safety 1)))
  (row-major-aref array index))

(defun %set-row-major-aref (array index new-value)
  (declare (optimize (safety 1)))
  (setf (row-major-aref array index) new-value))

(defun svref (simple-vector index)
  "Return the INDEXth element of the given Simple-Vector."
  (declare (optimize (safety 1)))
  (aref simple-vector index))

(defun %svset (simple-vector index new)
  (declare (optimize (safety 1)))
  (setf (aref simple-vector index) new))

(defun bit (bit-array &rest subscripts)
  "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
  (declare (type (array bit) bit-array)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (row-major-aref bit-array (apply #'%array-row-major-index bit-array subscripts)))

(defun (setf bit) (new-value bit-array &rest subscripts)
  (declare (type (array bit) bit-array)
           (type bit new-value)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (setf (row-major-aref bit-array
                        (apply #'%array-row-major-index bit-array subscripts))
        new-value))

(defun sbit (simple-bit-array &rest subscripts)
  "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
  (declare (type (simple-array bit) simple-bit-array)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (row-major-aref simple-bit-array
                  (apply #'%array-row-major-index simple-bit-array subscripts)))

(defun (setf sbit) (new-value bit-array &rest subscripts)
  (declare (type (simple-array bit) bit-array)
           (type bit new-value)
           (truly-dynamic-extent subscripts)
           (optimize (safety 1)))
  (setf (row-major-aref bit-array
                        (apply #'%array-row-major-index bit-array subscripts))
        new-value))


(define-load-time-global *saetp-widetag-ctype* (make-array 32 :initial-element (make-unbound-marker)))

(defun array-element-ctype (array)
  (svref *saetp-widetag-ctype*
         (- (ash (array-underlying-widetag array) -2) 32)))

(defun array-element-type (array)
  "Return the type of the elements of the array"
  (truly-the (or list symbol)
             (widetag->element-type (array-underlying-widetag array))))

(defun array-rank (array)
  "Return the number of dimensions of ARRAY."
  (%array-rank array))

(defun array-dimension (array axis-number)
  "Return the length of dimension AXIS-NUMBER of ARRAY."
  (declare (array array) (type index axis-number))
  (cond ((not (array-header-p array))
         (unless (= axis-number 0)
           (error "Vector axis is not zero: ~S" axis-number))
         (length (the (simple-array * (*)) array)))
        ((>= axis-number (%array-rank array))
         (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
                axis-number array (%array-rank array)))
        (t
         (%array-dimension array axis-number))))

(defun array-dimensions (array)
  "Return a list whose elements are the dimensions of the array"
  (declare (explicit-check))
  (cond ((array-header-p array)
         (do ((results nil (cons (%array-dimension array index) results))
              (index (1- (%array-rank array)) (1- index)))
             ((minusp index) results)))
        ((typep array 'vector)
         (list (length array)))
        (t
         (sb-c::%type-check-error/c array 'object-not-array-error nil))))

(defun array-total-size (array)
  "Return the total number of elements in the Array."
  (declare (explicit-check))
  (cond ((array-header-p array)
         (%array-available-elements array))
        ((typep array 'vector)
         (length array))
        (t
         (sb-c::%type-check-error/c array 'object-not-array-error nil))))

(defun array-displacement (array)
  "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
   options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
  (declare (type array array))
      (values (%array-data array) (%array-displacement array))
      (values nil 0)))

(defun adjustable-array-p (array)
  "Return T if and only if calling ADJUST-ARRAY on ARRAY will return
   the identical object."
  (declare (array array))
  -- CSR , 2004 - 03 - 01 .
  (not (typep array 'simple-array)))


(setf (info :function :predicate-truth-constraint 'array-has-fill-pointer-p)
      '(and vector (not simple-array)))
(defun array-has-fill-pointer-p (array)
  "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
  (array-has-fill-pointer-p array))

(defun fill-pointer-error (vector)
  (declare (optimize allow-non-returning-tail-call)
           (optimize (sb-c::verify-arg-count 0)))
  (error 'simple-type-error
         :datum vector
         :expected-type '(and vector (satisfies array-has-fill-pointer-p))
         :format-control "~S is not an array with a fill pointer."
         :format-arguments (list vector)))


(defun fill-pointer (vector)
  "Return the FILL-POINTER of the given VECTOR."
  (declare (explicit-check))
  (fill-pointer vector))

(defun %set-fill-pointer (vector new)
  (declare (explicit-check))
  (cond ((not (and (arrayp vector)
                   (array-has-fill-pointer-p vector)))
         (fill-pointer-error vector))
        (t
         (let ((max (%array-available-elements vector)))
           (when (> (the fixnum new) max)
             (error 'simple-type-error
                    :datum new
                    :expected-type (list 'integer 0 max)
                    :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)"
                    :format-arguments (list new max)))
           (setf (%array-fill-pointer vector) (truly-the index new))))))

  FIXME : It 'd probably make sense to use a MACROLET to share the
  guts of VECTOR - PUSH between VECTOR - PUSH - EXTEND . Such a macro
  should probably be based on the VECTOR - PUSH - EXTEND code ( which is
  new ca . sbcl-0.7.0 ) rather than the VECTOR - PUSH code ( which dates
  back to CMU CL ) .
(defun vector-push (new-element array)
  "Attempt to set the element of ARRAY designated by its fill pointer
   to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
   too large, NIL is returned, otherwise the index of the pushed element is
   returned."
  (declare (explicit-check))
  (let ((fill-pointer (fill-pointer array)))
    (cond ((= fill-pointer (%array-available-elements array))
           nil)
          (t
           (locally (declare (optimize (safety 0)))
             (setf (aref array fill-pointer) new-element))
           (setf (%array-fill-pointer array) (1+ fill-pointer))
           fill-pointer))))

#-system-tlabs
(defmacro reallocate-vector-with-widetag (old-vector &rest args)
  (declare (ignore old-vector))
  `(allocate-vector-with-widetag ,@args))

  element type NIL , but fails in ZAP - ARRAY - DATA - AUX . e.g. :
    ( adjust - array ( make - array ' ( 10 10 ) : element - type nil ) ' ( 20 20 ) )
  allocates a non - simple 10x10 array pointing to a ( SIMPLE - ARRAY NIL 100 )
  and then gets " An attempt to access an array of element - type NIL was made "
  FIXME : does not support # + ubsan , which is fairly bit - rotted , so ... meh .
#+system-tlabs
(defun reallocate-vector-with-widetag (old-vector widetag length n-bits-shift)
  (declare (type (unsigned-byte 8) widetag)
           (type index length))
   : add SAETP - N - PAD - ELEMENTS " by hand " since there is
  (let* ((full-length (+ length (if (= widetag simple-base-string-widetag) 1 0)))
         (nwords (the fixnum (vector-length-in-words full-length n-bits-shift))))
    (if (sb-vm::force-to-heap-p old-vector)
        (locally (declare (sb-c::tlab :system))
          (allocate-vector widetag length nwords))
        (allocate-vector widetag length nwords))))

(defun extend-vector (vector min-extension)
  (declare (optimize speed)
           (vector vector))
  (let* ((old-length (length vector))
         (min-extension (or min-extension
                            (min old-length
                                 (- array-dimension-limit old-length))))
         (new-length (the index (+ old-length
                                   (max 1 min-extension))))
         (fill-pointer (1+ old-length)))
    (declare (fixnum new-length min-extension))
    (with-array-data ((old-data vector) (old-start)
                      (old-end old-length))
      (let* ((widetag (%other-pointer-widetag old-data))
             (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag))
             (new-data
              (reallocate-vector-with-widetag old-data #+ubsan nil
                                              widetag new-length n-bits-shift)))
                     (truly-the simple-vector old-data)
                     :start2 old-start :end2 old-end)
            (let ((copier (blt-copier-for-widetag widetag)))
              (if copier
                  (funcall (truly-the function copier) old-data old-start new-data 0 old-length)
                  (replace new-data old-data :start2 old-start :end2 old-end))))
        (setf (%array-data vector) new-data
              (%array-available-elements vector) new-length
              (%array-fill-pointer vector) fill-pointer
              (%array-displacement vector) 0
              (%array-displaced-p vector) nil)
        (%set-array-dimension vector 0 new-length)
        vector))))

(defun vector-push-extend (new-element vector &optional min-extension)
  (declare (type (or null (and index (integer 1))) min-extension))
  (declare (explicit-check))
  (let* ((fill-pointer (fill-pointer vector))
         (new-fill-pointer (1+ fill-pointer)))
    (if (= fill-pointer (%array-available-elements vector))
        (extend-vector vector min-extension)
        (setf (%array-fill-pointer vector) new-fill-pointer))
    (locally (declare (optimize (safety 0)))
      (setf (aref vector fill-pointer) new-element))
    fill-pointer))

(defun vector-pop (array)
  "Decrease the fill pointer by 1 and return the element pointed to by the
  new fill pointer."
  (declare (explicit-check))
  (let ((fill-pointer (fill-pointer array)))
    (if (zerop fill-pointer)
        (error "There is nothing left to pop.")
        (locally (declare (optimize (safety 0)))
          (aref array
                (setf (%array-fill-pointer array)
                      (1- fill-pointer)))))))



(defun adjust-array (array dimensions &key
                           (element-type (array-element-type array) element-type-p)
                           (initial-element nil element-p)
                           (initial-contents nil contents-p)
                           fill-pointer
                           displaced-to (displaced-index-offset 0 offset-p))
  "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
  (when (invalid-array-p array)
    (invalid-array-error array))
  (binding*
      (((rank new-total-size) (rank-and-total-size-from-dims dimensions))
       (widetag
        (let ((widetag (array-underlying-widetag array)))
            (error "Expected ~D new dimension~:P for array, but received ~D."
                   (array-rank array) rank))
          (if (or (not element-type-p)
  Quick pass if ELEMENT - TYPE is same as the element type based on widetag
                  (equal element-type (widetag->element-type widetag))
                  (= (%vector-widetag-and-n-bits-shift element-type) widetag))
              widetag
              (error "The new element type, ~/sb-impl:print-type-specifier/, is incompatible ~
                      with old type, ~/sb-impl:print-type-specifier/."
                     element-type (array-element-type array)))))
       (new-fill-pointer
        (cond (fill-pointer
               (unless (array-has-fill-pointer-p array)
                 (if (/= rank 1)
                     (error "Only vectors can have fill pointers.")
                     (fill-pointer-error array)))
               (cond ((eq fill-pointer t) new-total-size)
                     ((<= fill-pointer new-total-size) fill-pointer)
                     (t (make-array-bad-fill-pointer fill-pointer new-total-size " new"))))
              ((array-has-fill-pointer-p array)
               (let ((old-fill-pointer (%array-fill-pointer array)))
                 (when (< new-total-size old-fill-pointer)
                   (error "can't adjust vector ~S to a size (~S) smaller than ~
                           its current fill pointer (~S)"
                          array new-total-size old-fill-pointer))
                 old-fill-pointer))))
       ((initialize initial-data)
        (check-make-array-initargs t element-type new-total-size))
       (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag)))

    (cond
       (if (adjustable-array-p array)
           (set-array-header array displaced-to new-total-size new-fill-pointer
                             displaced-index-offset dimensions t nil)
           (%make-array dimensions widetag n-bits-shift
                        :displaced-to displaced-to
                        :displaced-index-offset displaced-index-offset)))
       (let ((array-data (data-vector-from-inits dimensions new-total-size widetag n-bits-shift
                                                 initialize initial-data)))
         (cond ((adjustable-array-p array)
                (set-array-header array array-data new-total-size new-fill-pointer
                                  0 dimensions nil nil))
               ((array-header-p array)
  fill - pointer vectors satisfy ADJUSTABLE - ARRAY - P ( in SBCL , that is )
  and therefore are handled by the first stanza of the cond .
                (%make-array dimensions widetag n-bits-shift
                             :initial-contents initial-contents))
               (t
                array-data))))
      ((= rank 1)
       (let ((old-length (array-total-size array)))
  second argument of REPLACE .
         (with-array-data ((old-data array) (old-start) (old-end old-length))
           (let ((new-data
                  (if (and (= new-total-size old-length)
                           (not (and (array-header-p array) (%array-displaced-p array))))
                      old-data
                      (let ((data
                             (reallocate-vector-with-widetag old-data #+ubsan t
                                                             widetag new-total-size
                                                             n-bits-shift)))
                        (replace data old-data
                                 :start1 0 :end1 new-total-size
                                 :start2 old-start :end2 old-end)
                        (when (and element-p (> new-total-size old-length))
                          (fill data initial-element :start old-length))
                        data))))
             (if (adjustable-array-p array)
                 (set-array-header array new-data new-total-size new-fill-pointer
                                   0 dimensions nil nil)
                 new-data)))))
      (t
           (let ((old-total-size (%array-available-elements array)))
             (with-array-data ((old-data array) (old-start) (old-end old-total-size))
               (declare (ignore old-end))
               (let ((new-data (if (or (and (array-header-p array)
                                            (%array-displaced-p array))
                                       (> new-total-size old-total-size)
                                       (not (adjustable-array-p array)))
                                   (data-vector-from-inits dimensions new-total-size widetag
                                                           n-bits-shift initialize initial-data)
                                   old-data)))
                 (if (or (zerop old-total-size) (zerop new-total-size))
                     (when element-p (fill new-data initial-element))
                     (zap-array-data old-data (array-dimensions array)
                                     old-start
                                     new-data dimensions new-total-size
                                     element-type initial-element
                                     element-p))
                 (if (adjustable-array-p array)
                     (set-array-header array new-data new-total-size
                                       nil 0 dimensions nil nil)
                     (let ((new-array (make-array-header simple-array-widetag rank)))
                       (set-array-header new-array new-data new-total-size
                                         nil 0 dimensions nil t))))))))))

  Destructively alter VECTOR , changing its length to NEW - LENGTH ,
  GC should generally be fine no matter what happens , because it either
        " new " # ( .......... ) Fill| .....
  where GC reads the objects on the page just after the filler
(defmacro make-filler (n)
  `(logior (ash ,n #+64-bit 32 #-64-bit ,n-widetag-bits) filler-widetag))
(defmacro filler-nwords (header)
  `(ash ,header #+64-bit -32 #-64-bit ,(- n-widetag-bits)))

(defun %shrink-vector (vector new-length
                              &aux (old-length (length vector))
                                   (new-length* new-length))
  (declare (vector vector))
  (cond
    ((simple-vector-p vector)
  We do in fact call % SHRINK - VECTOR a lot from sequence functions
  For what it 's worth , adding this assertion prior to FILL :
    ( WHEN ( FIND 0 VECTOR : START OLD - LENGTH : TEST # ' NEQ ) ( BUG " No can do " ) )
     (when (< new-length old-length) (fill vector 0 :start new-length)))
    ((not (or (array-header-p vector) (typep vector '(simple-array nil (*)))))
      (when (simple-base-string-p vector)
        (locally (declare (optimize (sb-c:insert-array-bounds-checks 0)))
          (setf (schar vector new-length) (code-char 0)))
        (incf old-length)
        (incf new-length*))
      (let* ((n-bits-shift (aref %%simple-array-n-bits-shifts%%
                                 (%other-pointer-widetag vector)))
             (old-nwords (ceiling (ash old-length n-bits-shift) n-word-bits))
             (new-nwords (ceiling (ash new-length* n-bits-shift) n-word-bits)))
        (when (< new-nwords old-nwords)
          (with-pinned-objects (vector)
  VECTOR - SAP is only for unboxed vectors . Use the vop directly .
            (let ((data (%primitive vector-sap vector)))
              (when (oddp new-nwords)
                (setf (sap-ref-word data (ash new-nwords word-shift)) 0))
              (let* ((aligned-old (align-up old-nwords 2))
                     (aligned-new (align-up new-nwords 2)))
                (when (< aligned-new aligned-old)
                  (let ((diff (- aligned-old aligned-new)))
                    (setf (sap-ref-word data (ash aligned-new word-shift))
                          (make-filler diff)))))))))))
  (setf (%array-fill-pointer vector) new-length)
  vector)

(defun shrink-vector (vector new-length)
  (declare (vector vector))
  (cond
    ((eq (length vector) new-length)
     vector)
    ((array-has-fill-pointer-p vector)
     (setf (%array-fill-pointer vector) new-length)
     vector)
    (t (subseq vector 0 new-length))))


(defun set-array-header (array data length fill-pointer displacement dimensions
                         displacedp newp)
  (labels ((%walk-displaced-array-backpointers (array new-length)
             (dolist (p (%array-displaced-from array))
               (let ((from (weak-pointer-value p)))
                 (when (and from (eq array (%array-data from)))
                   (let ((requires (+ (%array-available-elements from)
                                      (%array-displacement from))))
                     (unless (>= new-length requires)
  garbage . Instead , we set all dimensions to zero so that next
                       (%walk-displaced-array-backpointers from 0)
                       (setf (%array-fill-pointer from) 0
                             (%array-available-elements from) 0
                             (%array-displaced-p from) (array-dimensions array))
                       (dotimes (i (%array-rank from))
                         (%set-array-dimension from i 0)))))))))
    (if newp
        (setf (%array-displaced-from array) nil)
        (%walk-displaced-array-backpointers array length))
    (when displacedp
      (%save-displaced-array-backpointer array data))
    (setf (%array-data array) data)
    (setf (%array-available-elements array) length)
    (cond (fill-pointer
           (setf (%array-fill-pointer array) fill-pointer)
           (logior-array-flags array +array-fill-pointer-p+))
          (t
           (setf (%array-fill-pointer array) length)
           (reset-array-flags array +array-fill-pointer-p+)))
    (setf (%array-displacement array) displacement)
    (populate-dimensions array dimensions (array-rank array))
    (setf (%array-displaced-p array) displacedp)
    array))

(declaim (ftype (sfunction (array) (simple-array * (*))) array-storage-vector))
(defun array-storage-vector (array)
  "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.

In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
vector. Multidimensional arrays, arrays with fill pointers, and adjustable
arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
ARRAY, which this function returns.

Important note: the underlying vector is an implementation detail. Even though
this function exposes it, changes in the implementation may cause this
function to be removed without further warning."
   : Without TRULY - THE the system is not smart enough to figure out that
  (truly-the (simple-array * (*))
             (cond ((not (array-header-p array))
                    array)
                   ((%array-displaced-p array)
                    (error "~S cannot be used with displaced arrays. Use ~S instead."
                           'array-storage-vector 'array-displacement))
                   (t
                    (%array-data array)))))


  ZAP - ARRAY - DATA for ADJUST - ARRAY

  the NEW - DATA in an arrangement specified by the NEW - DIMS . OFFSET
(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
                       element-type initial-element initial-element-p)
  (declare (list old-dims new-dims)
           (fixnum new-length))
  at least in SBCL .
  (setf old-dims (nreverse old-dims)
        new-dims (reverse new-dims))
  (cond ((eq old-data new-data)
  FIXME : transforming this TYPEP to someting a bit faster
         (unless (or (not initial-element-p)
                     (typep initial-element element-type))
           (error "~S can't be used to initialize an array of type ~
                    ~/sb-impl:print-type-specifier/."
                  initial-element element-type))
         (let ((temp (if initial-element-p
                         (make-array new-length :initial-element initial-element)
                         (make-array new-length))))
           (declare (simple-vector temp))
           (zap-array-data-aux old-data old-dims offset temp new-dims)
           (dotimes (i new-length)
             (setf (aref new-data i) (aref temp i)))
           (%shrink-vector temp 0)))
        (t
         (zap-array-data-aux old-data old-dims offset new-data new-dims))))

(defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
  (declare (fixnum offset))
  (let ((limits (mapcar (lambda (x y)
                          (declare (fixnum x y))
                          (1- (the fixnum (min x y))))
                        old-dims new-dims)))
    (macrolet ((bump-index-list (index limits)
                 `(do ((subscripts ,index (cdr subscripts))
                       (limits ,limits (cdr limits)))
                      ((null subscripts) :eof)
                    (cond ((< (the fixnum (car subscripts))
                              (the fixnum (car limits)))
                           (rplaca subscripts
                                   (1+ (the fixnum (car subscripts))))
                           (return ,index))
                          (t (rplaca subscripts 0))))))
      (do ((index (make-list (length old-dims) :initial-element 0)
                  (bump-index-list index limits)))
          ((eq index :eof))
        (setf (aref new-data (row-major-index-from-dims index new-dims))
              (aref old-data
                    (+ (the fixnum (row-major-index-from-dims index old-dims))
                       offset)))))))

(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
  (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
       (rev-dim-list rev-dim-list (cdr rev-dim-list))
       (chunk-size 1)
       (result 0))
      ((null rev-dim-list) result)
    (declare (fixnum chunk-size result))
    (setq result (+ result
                    (the fixnum (* (the fixnum (car rev-subscripts))
                                   chunk-size))))
    (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))


(defun bit-array-same-dimensions-p (array1 array2)
  (declare (type (array bit) array1 array2))
  (let ((rank (array-rank array1)))
    (and (= rank (array-rank array2))
         (if (= rank 1)
             (= (array-total-size array1)
                (array-total-size array2))
             (dotimes (index rank t)
               (when (/= (%array-dimension array1 index)
                         (%array-dimension array2 index))
                 (return nil)))))))

(defun copy-array-header (array)
  (let* ((rank (%array-rank array))
         (size (%array-available-elements array))
         (result (make-array-header simple-array-widetag
                                    rank)))
    (loop for i below rank
          do (%set-array-dimension result i
                                   (%array-dimension array i)))
  fill - pointer - p defaults to 0
    (setf (%array-displaced-from result) nil
          (%array-displaced-p result) nil
          (%array-fill-pointer result) size
          (%array-available-elements result) size)
    result))

(defun pick-result-array (result-bit-array bit-array-1)
  (case result-bit-array
    ((t) bit-array-1)
    ((nil)
     (if (vectorp bit-array-1)
         (make-array (array-total-size bit-array-1)
                     :element-type 'bit
                     :initial-element 0)
         (let ((header (copy-array-header bit-array-1)))
           (setf (%array-data header)
                 (make-array (%array-available-elements bit-array-1)
                             :element-type 'bit
                             :initial-element 0))
           header)))
    (t
     (unless (bit-array-same-dimensions-p bit-array-1
                                          result-bit-array)
       (error "~S and ~S don't have the same dimensions."
              bit-array-1 result-bit-array))
     result-bit-array)))

  This used to be a DEFMACRO , but depending on the target 's support for Unicode ,
  macro .      returns true , so then we want to know whether the
  result is a base - string which entails calling SB - KERNEL : SIMPLE - BASE - STRING - P
  which has no definition in the cross - compiler . ( We could add one of course )

  * ( format t " ~b~% " ( % vector - raw - bits ( bit - not # * 1001 ) 0 ) )
  * ( format t " ~b~% " ( % vector - raw - bits ( bit - nor # * 1001 # * 1010 ) 0 ) )
  in all unused bits so that EQUAL and SXHASH become far simpler .

(macrolet ((def-bit-array-op (name function)
  `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
     ,(format nil
              "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
               BIT-ARRAY-2,~%  putting the results in RESULT-BIT-ARRAY. ~
               If RESULT-BIT-ARRAY is T,~%  BIT-ARRAY-1 is used. If ~
               RESULT-BIT-ARRAY is NIL or omitted, a new array is~%  created. ~
               All the arrays must have the same rank and dimensions."
              (symbol-name function))
     (declare (type (array bit) bit-array-1 bit-array-2)
              (type (or (array bit) (member t nil)) result-bit-array))
     (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
       (error "~S and ~S don't have the same dimensions."
              bit-array-1 bit-array-2))
     (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
       (if (and (simple-bit-vector-p bit-array-1)
                (simple-bit-vector-p bit-array-2)
                (simple-bit-vector-p result-bit-array))
           (locally (declare (optimize (speed 3) (safety 0)))
             (,name bit-array-1 bit-array-2 result-bit-array))
           (with-array-data ((data1 bit-array-1) (start1) (end1))
             (with-array-data ((data2 bit-array-2) (start2) (end2))
               (with-array-data ((data3 result-bit-array) (start3) (end3))
                 (if (and (zerop start1)
                          (zerop start2)
                          (zerop start3)
                          (= (length data1) end1)
                          (= (length data2) end2)
                          (= (length data3) end3))
                     (locally (declare (optimize (speed 3) (safety 0)))
                       (,name data1 data2 data3))
                     (do ((index-1 start1 (1+ index-1))
                          (index-2 start2 (1+ index-2))
                          (index-3 start3 (1+ index-3)))
                         ((>= index-3 end3))
                       (declare (type index index-1 index-2 index-3))
                       (setf (sbit data3 index-3)
                             (logand (,function (sbit data1 index-1)
                                                (sbit data2 index-2))
                                     1))))
                 result-bit-array))))))))

(def-bit-array-op bit-and logand)
(def-bit-array-op bit-ior logior)
(def-bit-array-op bit-xor logxor)
(def-bit-array-op bit-eqv logeqv)
(def-bit-array-op bit-nand lognand)
(def-bit-array-op bit-nor lognor)
(def-bit-array-op bit-andc1 logandc1)
(def-bit-array-op bit-andc2 logandc2)
(def-bit-array-op bit-orc1 logorc1)
(def-bit-array-op bit-orc2 logorc2)
  end MACROLET

(defun bit-not (bit-array &optional result-bit-array)
  "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
  BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  created. Both arrays must have the same rank and dimensions."
  (declare (type (array bit) bit-array)
           (type (or (array bit) (member t nil)) result-bit-array))
  (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
    (if (and (simple-bit-vector-p bit-array)
             (simple-bit-vector-p result-bit-array))
        (locally (declare (optimize (speed 3) (safety 0)))
          (bit-not bit-array result-bit-array))
        (with-array-data ((src bit-array) (src-start) (src-end))
          (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
            (if (and (zerop src-start)
                     (zerop dst-start)
                     (= src-end (length src))
                     (= dst-end (length dst)))
                (locally (declare (optimize (speed 3) (safety 0)))
                  (bit-not src dst))
                (do ((src-index src-start (1+ src-index))
                     (dst-index dst-start (1+ dst-index)))
                    ((>= dst-index dst-end))
                  (declare (type index src-index dst-index))
                  (setf (sbit dst dst-index)
                        (logxor (sbit src src-index) 1))))
            result-bit-array)))))


  PARAMS are the function parameters in the definition of each
  first parameter in PARAMS . A type declaration for this parameter
  The dispatch table % % FOO - FUNS%% is defined and populated by these
  HAIRY - FOO - DISPATCH - ERROR , also defined by DEFINE - ARRAY - DISPATCH .
  dispatching when called . It expects arguments that match PARAMS .
(defmacro sb-impl::!define-array-dispatch (style dispatch-name params nil-array &body body)
  #-(or x86 x86-64) (setq style :call)
  (let ((table-name (symbolicate "%%" dispatch-name "-FUNS%%"))
        (error-name (symbolicate "HAIRY-" dispatch-name "-ERROR")))
    (declare (ignorable table-name))
    `(progn
       (defun ,error-name (,(first params) &rest rest)
         (declare (ignore rest))
         (error 'type-error
                :datum ,(first params)
                :expected-type '(simple-array * (*))))

       ,@(ecase style
    (:call
     `((define-load-time-global ,table-name ,(sb-xc:make-array (1+ widetag-mask)))

  DEFGLOBAL 's initial value is dumped by genesis as a vector filled
       (nsubstitute #',error-name 0 ,table-name)

       ,@(loop for info across *specialized-array-element-type-properties*
               for typecode = (saetp-typecode info)
               for specifier = (saetp-specifier info)
               for primitive-type-name = (saetp-primitive-type-name info)
               collect (let ((fun-name (symbolicate (string dispatch-name)
                                                    "/" primitive-type-name)))
                         `(progn
                            (defun ,fun-name ,params
                              (declare (type (simple-array ,specifier (*))
                                             ,(first params)))
                              ,@(if (null specifier)
                                    nil-array
                                    body))
                            (setf (svref ,table-name ,typecode) #',fun-name))))
       (defmacro ,dispatch-name (&rest args)
         (check-type (first args) symbol)
         (let ((tag (gensym "TAG")))
           `(funcall
             (truly-the function
               (let ((,tag 0))
                 (when (%other-pointer-p ,(first args))
                   (setf ,tag (%other-pointer-widetag ,(first args))))
                 (svref (truly-the (simple-vector 256) (load-time-value ,',table-name t))
                        ,tag)))
             ,@args)))))
    (:jump-table
     (multiple-value-bind (body decls) (parse-body body nil)
       `((declaim (inline ,dispatch-name))
         (defun ,dispatch-name ,params
           ,@decls
           (case (if (%other-pointer-p ,(first params))
                     (ash (%other-pointer-widetag ,(first params)) -2)
                     0)
  it is almost always a win to use 4x or 5x table words as cases
             (,(loop for i below 64
                     unless (find i *specialized-array-element-type-properties*
                                  :key (lambda (x) (ash (saetp-typecode x) -2)))
                       collect i)
              (,error-name ,@params))
             ,@(loop
                   for info across *specialized-array-element-type-properties*
                   collect `(,(ash (saetp-typecode info) -2)
                             (let ((,(first params)
                                    (truly-the (simple-array ,(saetp-specifier info) (*))
                                               ,(first params))))
                               ,@body))))))))))))

(defun sb-kernel::check-array-shape (array dimensions)
  (when (let ((dimensions dimensions))
          (dotimes (i (array-rank array))
            (unless (eql (array-dimension array i) (pop dimensions))
              (return t))))
    (error "malformed :INITIAL-CONTENTS: ~S should have dimensions ~S"
           (make-array dimensions :displaced-to (%array-data array)
                                  :element-type (array-element-type array))
           (array-dimensions array)))
  array)

  which uses an internal symbol in SB - IMPL .
(import '%vector-widetag-and-n-bits-shift 'sb-impl)

(defun make-weak-vector (length &key (initial-contents nil contents-p)
                                     (initial-element nil element-p))
  (declare (index length))
  (when (and element-p contents-p)
    (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
  (let ((type (logior (ash vector-weak-flag array-flags-position) simple-vector-widetag)))
    (if contents-p
        (let ((contents-length (length initial-contents)))
          (if (= length contents-length)
              (replace (truly-the simple-vector
                                  (allocate-vector #+ubsan nil type length length))
                       initial-contents)
              (error "~S has ~D elements, vector length is ~D."
                     :initial-contents contents-length length)))
        (fill (truly-the simple-vector
                         (allocate-vector #+ubsan nil type length length))
  0 is the usual default , but NIL makes more sense for weak vectors
              (if element-p initial-element nil)))))

(defun weak-vector-p (x)
  (and (simple-vector-p x)
       (test-header-data-bit x (ash vector-weak-flag array-flags-data-position))))
