src/code/array.lisp

   1 ;;;; functions to implement arrays
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 #!-sb-fluid
  15 (declaim (inline adjustable-array-p
  16                  array-displacement))
  17 \f
  18 ;;;; miscellaneous accessor functions
  19
  20 ;;; These functions are only needed by the interpreter, 'cause the
  21 ;;; compiler inlines them.
  22 (macrolet ((def (name)
  23              `(progn
  24                 (defun ,name (array)
  25                   (,name array))
  26                 (defun (setf ,name) (value array)
  27                   (setf (,name array) value)))))
  28   (def %array-fill-pointer)
  29   (def %array-fill-pointer-p)
  30   (def %array-available-elements)
  31   (def %array-data-vector)
  32   (def %array-displacement)
  33   (def %array-displaced-p)
  34   (def %array-diplaced-from))
  35
  36 (defun %array-rank (array)
  37   (%array-rank array))
  38
  39 (defun %array-dimension (array axis)
  40   (%array-dimension array axis))
  41
  42 (defun %set-array-dimension (array axis value)
  43   (%set-array-dimension array axis value))
  44
  45 (defun %check-bound (array bound index)
  46   (declare (type index bound)
  47            (fixnum index))
  48   (%check-bound array bound index))
  49
  50 (defun %with-array-data/fp (array start end)
  51   (%with-array-data-macro array start end :check-bounds t :check-fill-pointer t))
  52
  53 (defun %with-array-data (array start end)
  54   (%with-array-data-macro array start end :check-bounds t :check-fill-pointer nil))
  55
  56 (defun %data-vector-and-index (array index)
  57   (if (array-header-p array)
  58       (multiple-value-bind (vector index)
  59           (%with-array-data array index nil)
  60         (values vector index))
  61       (values array index)))
  62 \f
  63 ;;;; MAKE-ARRAY
  64 (eval-when (:compile-toplevel :execute)
  65   (sb!xc:defmacro pick-vector-type (type &rest specs)
  66     `(cond ,@(mapcar (lambda (spec)
  67                        `(,(if (eq (car spec) t)
  68                               t
  69                               `(subtypep ,type ',(car spec)))
  70                          ,@(cdr spec)))
  71                      specs))))
  72
  73 ;;; These functions are used in the implementation of MAKE-ARRAY for
  74 ;;; complex arrays. There are lots of transforms to simplify
  75 ;;; MAKE-ARRAY for various easy cases, but not for all reasonable
  76 ;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
  77 ;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
  78 ;;; making this somewhat efficient, at least not doing full calls to
  79 ;;; SUBTYPEP in the easy cases.
  80 (defun %vector-widetag-and-n-bits (type)
  81   (case type
  82     ;; Pick off some easy common cases.
  83     ;;
  84     ;; (Perhaps we should make a much more exhaustive table of easy
  85     ;; common cases here. Or perhaps the effort would be better spent
  86     ;; on smarter compiler transforms which do the calculation once
  87     ;; and for all in any reasonable user programs.)
  88     ((t)
  89      (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
  90     ((base-char standard-char #!-sb-unicode character)
  91      (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
  92     #!+sb-unicode
  93     ((character)
  94      (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits))
  95     ((bit)
  96      (values #.sb!vm:simple-bit-vector-widetag 1))
  97     ;; OK, we have to wade into SUBTYPEPing after all.
  98     (t
  99      (unless *type-system-initialized*
 100        (bug "SUBTYPEP dispatch for MAKE-ARRAY before the type system is ready"))
 101      #.`(pick-vector-type type
 102          ,@(map 'list
 103                 (lambda (saetp)
 104                   `(,(sb!vm:saetp-specifier saetp)
 105                     (values ,(sb!vm:saetp-typecode saetp)
 106                             ,(sb!vm:saetp-n-bits saetp))))
 107                 sb!vm:*specialized-array-element-type-properties*)))))
 108
 109 (defun %complex-vector-widetag (type)
 110   (case type
 111     ;; Pick off some easy common cases.
 112     ((t)
 113      #.sb!vm:complex-vector-widetag)
 114     ((base-char #!-sb-unicode character)
 115      #.sb!vm:complex-base-string-widetag)
 116     #!+sb-unicode
 117     ((character)
 118      #.sb!vm:complex-character-string-widetag)
 119     ((nil)
 120      #.sb!vm:complex-vector-nil-widetag)
 121     ((bit)
 122      #.sb!vm:complex-bit-vector-widetag)
 123     ;; OK, we have to wade into SUBTYPEPing after all.
 124     (t
 125      (pick-vector-type type
 126        (nil #.sb!vm:complex-vector-nil-widetag)
 127        #!-sb-unicode
 128        (character #.sb!vm:complex-base-string-widetag)
 129        #!+sb-unicode
 130        (base-char #.sb!vm:complex-base-string-widetag)
 131        #!+sb-unicode
 132        (character #.sb!vm:complex-character-string-widetag)
 133        (bit #.sb!vm:complex-bit-vector-widetag)
 134        (t #.sb!vm:complex-vector-widetag)))))
 135
 136 (defun make-array (dimensions &key
 137                               (element-type t)
 138                               (initial-element nil initial-element-p)
 139                               (initial-contents nil initial-contents-p)
 140                               adjustable fill-pointer
 141                               displaced-to displaced-index-offset)
 142   (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
 143          (array-rank (length (the list dimensions)))
 144          (simple (and (null fill-pointer)
 145                       (not adjustable)
 146                       (null displaced-to))))
 147     (declare (fixnum array-rank))
 148     (when (and displaced-index-offset (null displaced-to))
 149       (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
 150     (when (and displaced-to
 151                (arrayp displaced-to)
 152                (not (equal (array-element-type displaced-to)
 153                            (upgraded-array-element-type element-type))))
 154       (error "Array element type of :DISPLACED-TO array does not match specified element type"))
 155     (if (and simple (= array-rank 1))
 156         ;; it's a (SIMPLE-ARRAY * (*))
 157         (multiple-value-bind (type n-bits)
 158             (%vector-widetag-and-n-bits element-type)
 159           (declare (type (unsigned-byte 8) type)
 160                    (type (integer 0 256) n-bits))
 161           (let* ((length (car dimensions))
 162                  (array (allocate-vector
 163                          type
 164                          length
 165                          (ceiling
 166                           (* (if (or (= type sb!vm:simple-base-string-widetag)
 167                                      #!+sb-unicode
 168                                      (= type
 169                                         sb!vm:simple-character-string-widetag))
 170                                  (1+ length)
 171                                  length)
 172                              n-bits)
 173                           sb!vm:n-word-bits))))
 174             (declare (type index length))
 175             (when initial-element-p
 176               (fill array initial-element))
 177             (when initial-contents-p
 178               (when initial-element-p
 179                 (error "can't specify both :INITIAL-ELEMENT and ~
 180                        :INITIAL-CONTENTS"))
 181               (unless (= length (length initial-contents))
 182                 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
 183                        the vector length is ~W."
 184                        (length initial-contents)
 185                        length))
 186               (replace array initial-contents))
 187             array))
 188         ;; it's either a complex array or a multidimensional array.
 189         (let* ((total-size (reduce #'* dimensions))
 190                (data (or displaced-to
 191                          (data-vector-from-inits
 192                           dimensions total-size element-type
 193                           initial-contents initial-contents-p
 194                           initial-element initial-element-p)))
 195                (array (make-array-header
 196                        (cond ((= array-rank 1)
 197                               (%complex-vector-widetag element-type))
 198                              (simple sb!vm:simple-array-widetag)
 199                              (t sb!vm:complex-array-widetag))
 200                        array-rank)))
 201           (cond (fill-pointer
 202                  (unless (= array-rank 1)
 203                    (error "Only vectors can have fill pointers."))
 204                  (let ((length (car dimensions)))
 205                    (declare (fixnum length))
 206                    (setf (%array-fill-pointer array)
 207                      (cond ((eq fill-pointer t)
 208                             length)
 209                            (t
 210                             (unless (and (fixnump fill-pointer)
 211                                          (>= fill-pointer 0)
 212                                          (<= fill-pointer length))
 213                               ;; FIXME: should be TYPE-ERROR?
 214                               (error "invalid fill-pointer ~W"
 215                                      fill-pointer))
 216                             fill-pointer))))
 217                  (setf (%array-fill-pointer-p array) t))
 218                 (t
 219                  (setf (%array-fill-pointer array) total-size)
 220                  (setf (%array-fill-pointer-p array) nil)))
 221           (setf (%array-available-elements array) total-size)
 222           (setf (%array-data-vector array) data)
 223           (setf (%array-displaced-from array) nil)
 224           (cond (displaced-to
 225                  (when (or initial-element-p initial-contents-p)
 226                    (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
 227                    can be specified along with :DISPLACED-TO"))
 228                  (let ((offset (or displaced-index-offset 0)))
 229                    (when (> (+ offset total-size)
 230                             (array-total-size displaced-to))
 231                      (error "~S doesn't have enough elements." displaced-to))
 232                    (setf (%array-displacement array) offset)
 233                    (setf (%array-displaced-p array) t)
 234                    (%save-displaced-array-backpointer array data)))
 235                 (t
 236                  (setf (%array-displaced-p array) nil)))
 237           (let ((axis 0))
 238             (dolist (dim dimensions)
 239               (setf (%array-dimension array axis) dim)
 240               (incf axis)))
 241           array))))
 242
 243 (defun make-static-vector (length &key
 244                            (element-type '(unsigned-byte 8))
 245                            (initial-contents nil initial-contents-p)
 246                            (initial-element nil initial-element-p))
 247   "Allocate vector of LENGTH elements in static space. Only allocation
 248 of specialized arrays is supported."
 249   ;; STEP 1: check inputs fully
 250   ;;
 251   ;; This way of doing explicit checks before the vector is allocated
 252   ;; is expensive, but probably worth the trouble as once we've allocated
 253   ;; the vector we have no way to get rid of it anymore...
 254   (when (eq t (upgraded-array-element-type element-type))
 255     (error "Static arrays of type ~S not supported."
 256            element-type))
 257   (when initial-contents-p
 258     (when initial-element-p
 259       (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
 260     (unless (= length (length initial-contents))
 261       (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
 262               vector length is ~W."
 263              (length initial-contents)
 264              length))
 265     (unless (every (lambda (x) (typep x element-type)) initial-contents)
 266       (error ":INITIAL-CONTENTS contains elements not of type ~S."
 267              element-type)))
 268   (when initial-element-p
 269     (unless (typep initial-element element-type)
 270       (error ":INITIAL-ELEMENT ~S is not of type ~S."
 271              initial-element element-type)))
 272   ;; STEP 2
 273   ;;
 274   ;; Allocate and possibly initialize the vector.
 275   (multiple-value-bind (type n-bits)
 276       (sb!impl::%vector-widetag-and-n-bits element-type)
 277     (let ((vector
 278            (allocate-static-vector type length
 279                                    (ceiling (* length n-bits)
 280                                             sb!vm:n-word-bits))))
 281       (cond (initial-element-p
 282              (fill vector initial-element))
 283             (initial-contents-p
 284              (replace vector initial-contents))
 285             (t
 286              vector)))))
 287
 288 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
 289 ;;; specified array characteristics. Dimensions is only used to pass
 290 ;;; to FILL-DATA-VECTOR for error checking on the structure of
 291 ;;; initial-contents.
 292 (defun data-vector-from-inits (dimensions total-size element-type
 293                                initial-contents initial-contents-p
 294                                initial-element initial-element-p)
 295   (when (and initial-contents-p initial-element-p)
 296     (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
 297             either MAKE-ARRAY or ADJUST-ARRAY."))
 298   (let ((data (if initial-element-p
 299                   (make-array total-size
 300                               :element-type element-type
 301                               :initial-element initial-element)
 302                   (make-array total-size
 303                               :element-type element-type))))
 304     (cond (initial-element-p
 305            (unless (simple-vector-p data)
 306              (unless (typep initial-element element-type)
 307                (error "~S cannot be used to initialize an array of type ~S."
 308                       initial-element element-type))
 309              (fill (the vector data) initial-element)))
 310           (initial-contents-p
 311            (fill-data-vector data dimensions initial-contents)))
 312     data))
 313
 314 (defun vector (&rest objects)
 315   #!+sb-doc
 316   "Construct a SIMPLE-VECTOR from the given objects."
 317   (coerce (the list objects) 'simple-vector))
 318 \f
 319
 320 ;;;; accessor/setter and subseq functions
 321
 322 ;;; Dispatch to an optimized routine the data vector accessors for
 323 ;;; each different specialized vector type. Do dispatching by looking
 324 ;;; up the widetag in the array rather than with the typecases, which
 325 ;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
 326 ;;; provide separate versions where bounds checking has been moved
 327 ;;; from the callee to the caller, since it's much cheaper to do once
 328 ;;; the type information is available. Finally, for each of these
 329 ;;; routines also provide a slow path, taken for arrays that are not
 330 ;;; vectors or not simple.
 331 ;;;
 332 ;;; Similarly for SUBSEQ, except we don't have the slow-path at all:
 333 ;;; VECTOR-SUBEQ* takes care of that.
 334 (macrolet ((def (name table-name)
 335              `(progn
 336                 (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)))
 337                 (defmacro ,name (array-var)
 338                   `(the function
 339                      (let ((tag 0))
 340                        (when (sb!vm::%other-pointer-p ,array-var)
 341                          (setf tag (%other-pointer-widetag ,array-var)))
 342                        (svref ,',table-name tag)))))))
 343   (def !find-data-vector-setter %%data-vector-setters%%)
 344   (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
 345   (def !find-data-vector-reffer %%data-vector-reffers%%)
 346   (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%)
 347   (def !find-vector-subseq-fun %%vector-subseq-funs%%))
 348
 349 (macrolet ((%ref (accessor-getter extra-params)
 350              `(funcall (,accessor-getter array) array index ,@extra-params))
 351            (define (accessor-name slow-accessor-name accessor-getter
 352                                   extra-params check-bounds)
 353              `(progn
 354                 (defun ,accessor-name (array index ,@extra-params)
 355                   (declare (optimize speed
 356                                      ;; (SAFETY 0) is ok. All calls to
 357                                      ;; these functions are generated by
 358                                      ;; the compiler, so argument count
 359                                      ;; checking isn't needed. Type checking
 360                                      ;; is done implicitly via the widetag
 361                                      ;; dispatch.
 362                                      (safety 0)))
 363                   (%ref ,accessor-getter ,extra-params))
 364                 (defun ,slow-accessor-name (array index ,@extra-params)
 365                   (declare (optimize speed (safety 0)))
 366                   (if (not (%array-displaced-p array))
 367                       ;; The reasonably quick path of non-displaced complex
 368                       ;; arrays.
 369                       (let ((array (%array-data-vector array)))
 370                         (%ref ,accessor-getter ,extra-params))
 371                       ;; The real slow path.
 372                       (with-array-data
 373                           ((vector array)
 374                            (index (locally
 375                                       (declare (optimize (speed 1) (safety 1)))
 376                                     (,@check-bounds index)))
 377                            (end)
 378                            :force-inline t)
 379                         (declare (ignore end))
 380                         (,accessor-name vector index ,@extra-params)))))))
 381   (define hairy-data-vector-ref slow-hairy-data-vector-ref
 382     !find-data-vector-reffer
 383     nil (progn))
 384   (define hairy-data-vector-set slow-hairy-data-vector-set
 385     !find-data-vector-setter
 386     (new-value) (progn))
 387   (define hairy-data-vector-ref/check-bounds
 388       slow-hairy-data-vector-ref/check-bounds
 389     !find-data-vector-reffer/check-bounds
 390     nil (%check-bound array (array-dimension array 0)))
 391   (define hairy-data-vector-set/check-bounds
 392       slow-hairy-data-vector-set/check-bounds
 393     !find-data-vector-setter/check-bounds
 394     (new-value) (%check-bound array (array-dimension array 0))))
 395
 396 (defun hairy-ref-error (array index &optional new-value)
 397   (declare (ignore index new-value))
 398   (error 'type-error
 399          :datum array
 400          :expected-type 'vector))
 401
 402 (defun hairy-subseq-error (array start end)
 403   (declare (ignore start end))
 404   (error 'type-error
 405          :datum array
 406          :expected-type '(simple-array * (*))))
 407
 408 ;;; Populate the dispatch tables.
 409 (macrolet ((def-subseq-funs ()
 410              `(progn
 411                 (set '%%vector-subseq-funs%%
 412                      (make-array (1+ sb!vm:widetag-mask)
 413                                  :initial-element #'hairy-subseq-error))
 414                 ,@(map 'list
 415                        (lambda (saetp)
 416                          (let ((name (symbolicate "SUBSEQ/"
 417                                                   (sb!vm:saetp-primitive-type-name saetp))))
 418                            `(progn
 419                               (defun ,name (vector start end)
 420                                 (declare (type (simple-array ,(sb!vm:saetp-specifier saetp) (*))
 421                                                vector)
 422                                          (index start end)
 423                                          (optimize speed (safety 0)))
 424                                 (subseq vector start end))
 425                               (setf (svref %%vector-subseq-funs%%
 426                                            ,(sb!vm:saetp-typecode saetp))
 427                                     #',name))))
 428                        sb!vm:*specialized-array-element-type-properties*))))
 429   (def-subseq-funs))
 430 (macrolet ((define-reffer (saetp check-form)
 431              (let* ((type (sb!vm:saetp-specifier saetp))
 432                     (atype `(simple-array ,type (*))))
 433                `(named-lambda optimized-data-vector-ref (vector index)
 434                   (declare (optimize speed (safety 0)))
 435                   (data-vector-ref (the ,atype vector)
 436                                    (locally
 437                                        (declare (optimize (safety 1)))
 438                                      (the index
 439                                        (,@check-form index)))))))
 440            (define-setter (saetp check-form)
 441              (let* ((type (sb!vm:saetp-specifier saetp))
 442                     (atype `(simple-array ,type (*))))
 443                `(named-lambda optimized-data-vector-set (vector index new-value)
 444                   (declare (optimize speed (safety 0)))
 445                   (data-vector-set (the ,atype vector)
 446                                    (locally
 447                                        (declare (optimize (safety 1)))
 448                                      (the index
 449                                        (,@check-form index)))
 450                                    (locally
 451                                        ;; SPEED 1 needed to avoid the compiler
 452                                        ;; from downgrading the type check to
 453                                        ;; a cheaper one.
 454                                        (declare (optimize (speed 1)
 455                                                           (safety 1)))
 456                                      (the ,type new-value)))
 457                   ;; For specialized arrays, the return from
 458                   ;; data-vector-set would have to be reboxed to be a
 459                   ;; (Lisp) return value; instead, we use the
 460                   ;; already-boxed value as the return.
 461                   new-value)))
 462            (define-reffers (symbol deffer check-form slow-path)
 463              `(progn
 464                 ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
 465                 ;; preserve the binding, so re-initiaize as NS doesn't have
 466                 ;; the energy to figure out to change that right now.
 467                 (setf ,symbol (make-array (1+ sb!vm::widetag-mask)
 468                                           :initial-element #'hairy-ref-error))
 469                 ,@(loop for widetag in '(sb!vm:complex-vector-widetag
 470                                          sb!vm:complex-vector-nil-widetag
 471                                          sb!vm:complex-bit-vector-widetag
 472                                          #!+sb-unicode sb!vm:complex-character-string-widetag
 473                                          sb!vm:complex-base-string-widetag
 474                                          sb!vm:simple-array-widetag
 475                                          sb!vm:complex-array-widetag)
 476                         collect `(setf (svref ,symbol ,widetag) ,slow-path))
 477                 ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
 478                         for widetag = (sb!vm:saetp-typecode saetp)
 479                         collect `(setf (svref ,symbol ,widetag)
 480                                        (,deffer ,saetp ,check-form))))))
 481   (defun !hairy-data-vector-reffer-init ()
 482     (define-reffers %%data-vector-reffers%% define-reffer
 483       (progn)
 484       #'slow-hairy-data-vector-ref)
 485     (define-reffers %%data-vector-setters%% define-setter
 486       (progn)
 487       #'slow-hairy-data-vector-set)
 488     (define-reffers %%data-vector-reffers/check-bounds%% define-reffer
 489       (%check-bound vector (length vector))
 490       #'slow-hairy-data-vector-ref/check-bounds)
 491     (define-reffers %%data-vector-setters/check-bounds%% define-setter
 492       (%check-bound vector (length vector))
 493       #'slow-hairy-data-vector-set/check-bounds)))
 494
 495 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
 496 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
 497 ;;; definition is needed for the compiler to use in constant folding.)
 498 (defun data-vector-ref (array index)
 499   (hairy-data-vector-ref array index))
 500
 501 (defun data-vector-ref-with-offset (array index offset)
 502   (hairy-data-vector-ref array (+ index offset)))
 503
 504 (defun invalid-array-p (array)
 505   (and (array-header-p array)
 506        (consp (%array-displaced-p array))))
 507
 508 (declaim (ftype (function (array) nil) invalid-array-error))
 509 (defun invalid-array-error (array)
 510   (aver (array-header-p array))
 511   ;; Array invalidation stashes the original dimensions here...
 512   (let ((dims (%array-displaced-p array))
 513         (et (array-element-type array)))
 514     (error 'invalid-array-error
 515            :datum array
 516            :expected-type
 517            (if (cdr dims)
 518                `(array ,et ,dims)
 519                `(vector ,et ,@dims)))))
 520
 521 (declaim (ftype (function (array integer integer &optional t) nil)
 522                 invalid-array-index-error))
 523 (defun invalid-array-index-error (array index bound &optional axis)
 524   (if (invalid-array-p array)
 525       (invalid-array-error array)
 526       (error 'invalid-array-index-error
 527              :array array
 528              :axis axis
 529              :datum index
 530              :expected-type `(integer 0 (,bound)))))
 531
 532 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 533 (defun %array-row-major-index (array subscripts
 534                                      &optional (invalid-index-error-p t))
 535   (declare (array array)
 536            (list subscripts))
 537   (let ((rank (array-rank array)))
 538     (unless (= rank (length subscripts))
 539       (error "wrong number of subscripts, ~W, for array of rank ~W"
 540              (length subscripts) rank))
 541     (if (array-header-p array)
 542         (do ((subs (nreverse subscripts) (cdr subs))
 543              (axis (1- (array-rank array)) (1- axis))
 544              (chunk-size 1)
 545              (result 0))
 546             ((null subs) result)
 547           (declare (list subs) (fixnum axis chunk-size result))
 548           (let ((index (car subs))
 549                 (dim (%array-dimension array axis)))
 550             (declare (fixnum dim))
 551             (unless (and (fixnump index) (< -1 index dim))
 552               (if invalid-index-error-p
 553                   (invalid-array-index-error array index dim axis)
 554                   (return-from %array-row-major-index nil)))
 555             (incf result (* chunk-size (the fixnum index)))
 556             (setf chunk-size (* chunk-size dim))))
 557         (let ((index (first subscripts))
 558               (length (length (the (simple-array * (*)) array))))
 559           (unless (and (fixnump index) (< -1 index length))
 560             (if invalid-index-error-p
 561                 (invalid-array-index-error array index length)
 562                 (return-from %array-row-major-index nil)))
 563           index))))
 564
 565 (defun array-in-bounds-p (array &rest subscripts)
 566   #!+sb-doc
 567   "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
 568   (if (%array-row-major-index array subscripts nil)
 569       t))
 570
 571 (defun array-row-major-index (array &rest subscripts)
 572   (declare (truly-dynamic-extent subscripts))
 573   (%array-row-major-index array subscripts))
 574
 575 (defun aref (array &rest subscripts)
 576   #!+sb-doc
 577   "Return the element of the ARRAY specified by the SUBSCRIPTS."
 578   (declare (truly-dynamic-extent subscripts))
 579   (row-major-aref array (%array-row-major-index array subscripts)))
 580
 581 (defun %aset (array &rest stuff)
 582   (declare (truly-dynamic-extent stuff))
 583   (let ((subscripts (butlast stuff))
 584         (new-value (car (last stuff))))
 585     (setf (row-major-aref array (%array-row-major-index array subscripts))
 586           new-value)))
 587
 588 ;;; FIXME: What's supposed to happen with functions
 589 ;;; like AREF when we (DEFUN (SETF FOO) ..) when
 590 ;;; DEFSETF FOO is also defined? It seems as though the logical
 591 ;;; thing to do would be to nuke the macro definition for (SETF FOO)
 592 ;;; and replace it with the (SETF FOO) function, issuing a warning,
 593 ;;; just as for ordinary functions
 594 ;;;  * (LISP-IMPLEMENTATION-VERSION)
 595 ;;;  "18a+ release x86-linux 2.4.7 6 November 1998 cvs"
 596 ;;;  * (DEFMACRO ZOO (X) `(+ ,X ,X))
 597 ;;;  ZOO
 598 ;;;  * (DEFUN ZOO (X) (* 3 X))
 599 ;;;  Warning: ZOO previously defined as a macro.
 600 ;;;  ZOO
 601 ;;; But that doesn't seem to be what happens in CMU CL.
 602 ;;;
 603 ;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS
 604 ;;; 5.1.2.5) requires implementations to support
 605 ;;;   (SETF (APPLY #'AREF ...) ...)
 606 ;;; [and also #'BIT and #'SBIT].  Yes, this is terrifying, and it's
 607 ;;; also terrifying that this sequence of definitions causes it to
 608 ;;; work.
 609 ;;;
 610 ;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
 611 ;;; has a setf expansion and/or a setf function defined.
 612
 613 #!-sb-fluid (declaim (inline (setf aref)))
 614 (defun (setf aref) (new-value array &rest subscripts)
 615   (declare (truly-dynamic-extent subscripts))
 616   (declare (type array array))
 617   (setf (row-major-aref array (%array-row-major-index array subscripts))
 618         new-value))
 619
 620 (defun row-major-aref (array index)
 621   #!+sb-doc
 622   "Return the element of array corressponding to the row-major index. This is
 623    SETF'able."
 624   (declare (optimize (safety 1)))
 625   (row-major-aref array index))
 626
 627 (defun %set-row-major-aref (array index new-value)
 628   (declare (optimize (safety 1)))
 629   (setf (row-major-aref array index) new-value))
 630
 631 (defun svref (simple-vector index)
 632   #!+sb-doc
 633   "Return the INDEX'th element of the given Simple-Vector."
 634   (declare (optimize (safety 1)))
 635   (aref simple-vector index))
 636
 637 (defun %svset (simple-vector index new)
 638   (declare (optimize (safety 1)))
 639   (setf (aref simple-vector index) new))
 640
 641 (defun bit (bit-array &rest subscripts)
 642   #!+sb-doc
 643   "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
 644   (declare (type (array bit) bit-array) (optimize (safety 1)))
 645   (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
 646
 647 (defun %bitset (bit-array &rest stuff)
 648   (declare (type (array bit) bit-array) (optimize (safety 1)))
 649   (let ((subscripts (butlast stuff))
 650         (new-value (car (last stuff))))
 651     (setf (row-major-aref bit-array
 652                           (%array-row-major-index bit-array subscripts))
 653           new-value)))
 654
 655 #!-sb-fluid (declaim (inline (setf bit)))
 656 (defun (setf bit) (new-value bit-array &rest subscripts)
 657   (declare (type (array bit) bit-array) (optimize (safety 1)))
 658   (setf (row-major-aref bit-array
 659                         (%array-row-major-index bit-array subscripts))
 660         new-value))
 661
 662 (defun sbit (simple-bit-array &rest subscripts)
 663   #!+sb-doc
 664   "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
 665   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
 666   (row-major-aref simple-bit-array
 667                   (%array-row-major-index simple-bit-array subscripts)))
 668
 669 ;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER,
 670 ;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names.
 671 ;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names?
 672 ;;; -- WHN 19990911
 673 (defun %sbitset (simple-bit-array &rest stuff)
 674   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
 675   (let ((subscripts (butlast stuff))
 676         (new-value (car (last stuff))))
 677     (setf (row-major-aref simple-bit-array
 678                           (%array-row-major-index simple-bit-array subscripts))
 679           new-value)))
 680
 681 #!-sb-fluid (declaim (inline (setf sbit)))
 682 (defun (setf sbit) (new-value bit-array &rest subscripts)
 683   (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
 684   (setf (row-major-aref bit-array
 685                         (%array-row-major-index bit-array subscripts))
 686         new-value))
 687 \f
 688 ;;;; miscellaneous array properties
 689
 690 (defun array-element-type (array)
 691   #!+sb-doc
 692   "Return the type of the elements of the array"
 693   (let ((widetag (widetag-of array)))
 694     (macrolet ((pick-element-type (&rest stuff)
 695                  `(cond ,@(mapcar (lambda (stuff)
 696                                     (cons
 697                                      (let ((item (car stuff)))
 698                                        (cond ((eq item t)
 699                                               t)
 700                                              ((listp item)
 701                                               (cons 'or
 702                                                     (mapcar (lambda (x)
 703                                                               `(= widetag ,x))
 704                                                             item)))
 705                                              (t
 706                                               `(= widetag ,item))))
 707                                      (cdr stuff)))
 708                                   stuff))))
 709       #.`(pick-element-type
 710           ,@(map 'list
 711                  (lambda (saetp)
 712                    `(,(if (sb!vm:saetp-complex-typecode saetp)
 713                           (list (sb!vm:saetp-typecode saetp)
 714                                 (sb!vm:saetp-complex-typecode saetp))
 715                           (sb!vm:saetp-typecode saetp))
 716                      ',(sb!vm:saetp-specifier saetp)))
 717                  sb!vm:*specialized-array-element-type-properties*)
 718           ((sb!vm:simple-array-widetag
 719             sb!vm:complex-vector-widetag
 720             sb!vm:complex-array-widetag)
 721            (with-array-data ((array array) (start) (end))
 722              (declare (ignore start end))
 723              (array-element-type array)))
 724           (t
 725            (error 'type-error :datum array :expected-type 'array))))))
 726
 727 (defun array-rank (array)
 728   #!+sb-doc
 729   "Return the number of dimensions of ARRAY."
 730   (if (array-header-p array)
 731       (%array-rank array)
 732       1))
 733
 734 (defun array-dimension (array axis-number)
 735   #!+sb-doc
 736   "Return the length of dimension AXIS-NUMBER of ARRAY."
 737   (declare (array array) (type index axis-number))
 738   (cond ((not (array-header-p array))
 739          (unless (= axis-number 0)
 740            (error "Vector axis is not zero: ~S" axis-number))
 741          (length (the (simple-array * (*)) array)))
 742         ((>= axis-number (%array-rank array))
 743          (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
 744                 axis-number array (%array-rank array)))
 745         (t
 746          (%array-dimension array axis-number))))
 747
 748 (defun array-dimensions (array)
 749   #!+sb-doc
 750   "Return a list whose elements are the dimensions of the array"
 751   (declare (array array))
 752   (if (array-header-p array)
 753       (do ((results nil (cons (array-dimension array index) results))
 754            (index (1- (array-rank array)) (1- index)))
 755           ((minusp index) results))
 756       (list (array-dimension array 0))))
 757
 758 (defun array-total-size (array)
 759   #!+sb-doc
 760   "Return the total number of elements in the Array."
 761   (declare (array array))
 762   (if (array-header-p array)
 763       (%array-available-elements array)
 764       (length (the vector array))))
 765
 766 (defun array-displacement (array)
 767   #!+sb-doc
 768   "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
 769    options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
 770   (declare (type array array))
 771   (if (and (array-header-p array) ; if unsimple and
 772            (%array-displaced-p array)) ; displaced
 773       (values (%array-data-vector array) (%array-displacement array))
 774       (values nil 0)))
 775
 776 (defun adjustable-array-p (array)
 777   #!+sb-doc
 778   "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
 779    to the argument, this happens for complex arrays."
 780   (declare (array array))
 781   ;; Note that this appears not to be a fundamental limitation.
 782   ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
 783   ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
 784   ;; -- CSR, 2004-03-01.
 785   (not (typep array 'simple-array)))
 786 \f
 787 ;;;; fill pointer frobbing stuff
 788
 789 (declaim (inline array-has-fill-pointer-p))
 790 (defun array-has-fill-pointer-p (array)
 791   #!+sb-doc
 792   "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
 793   (declare (array array))
 794   (and (array-header-p array) (%array-fill-pointer-p array)))
 795
 796 (defun fill-pointer-error (vector arg)
 797   (cond (arg
 798          (aver (array-has-fill-pointer-p vector))
 799          (let ((max (%array-available-elements vector)))
 800            (error 'simple-type-error
 801                   :datum arg
 802                   :expected-type (list 'integer 0 max)
 803                   :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)"
 804                   :format-arguments (list arg max))))
 805         (t
 806          (error 'simple-type-error
 807                 :datum vector
 808                 :expected-type '(and vector (satisfies array-has-fill-pointer-p))
 809                 :format-control "~S is not an array with a fill pointer."
 810                 :format-arguments (list vector)))))
 811
 812 (declaim (inline fill-pointer))
 813 (defun fill-pointer (vector)
 814   #!+sb-doc
 815   "Return the FILL-POINTER of the given VECTOR."
 816   (if (array-has-fill-pointer-p vector)
 817       (%array-fill-pointer vector)
 818       (fill-pointer-error vector nil)))
 819
 820 (defun %set-fill-pointer (vector new)
 821   (flet ((oops (x)
 822            (fill-pointer-error vector x)))
 823     (if (array-has-fill-pointer-p vector)
 824         (if (> new (%array-available-elements vector))
 825             (oops new)
 826             (setf (%array-fill-pointer vector) new))
 827         (oops nil))))
 828
 829 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
 830 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
 831 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
 832 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
 833 ;;; back to CMU CL).
 834 (defun vector-push (new-el array)
 835   #!+sb-doc
 836   "Attempt to set the element of ARRAY designated by its fill pointer
 837    to NEW-EL, and increment the fill pointer by one. If the fill pointer is
 838    too large, NIL is returned, otherwise the index of the pushed element is
 839    returned."
 840   (let ((fill-pointer (fill-pointer array)))
 841     (declare (fixnum fill-pointer))
 842     (cond ((= fill-pointer (%array-available-elements array))
 843            nil)
 844           (t
 845            (locally (declare (optimize (safety 0)))
 846              (setf (aref array fill-pointer) new-el))
 847            (setf (%array-fill-pointer array) (1+ fill-pointer))
 848            fill-pointer))))
 849
 850 (defun vector-push-extend (new-element
 851                            vector
 852                            &optional
 853                            (min-extension
 854                             (let ((length (length vector)))
 855                               (min (1+ length)
 856                                    (- array-dimension-limit length)))))
 857   (declare (fixnum min-extension))
 858   (let ((fill-pointer (fill-pointer vector)))
 859     (declare (fixnum fill-pointer))
 860     (when (= fill-pointer (%array-available-elements vector))
 861       (adjust-array vector (+ fill-pointer (max 1 min-extension))))
 862     ;; disable bounds checking
 863     (locally (declare (optimize (safety 0)))
 864       (setf (aref vector fill-pointer) new-element))
 865     (setf (%array-fill-pointer vector) (1+ fill-pointer))
 866     fill-pointer))
 867
 868 (defun vector-pop (array)
 869   #!+sb-doc
 870   "Decrease the fill pointer by 1 and return the element pointed to by the
 871   new fill pointer."
 872   (let ((fill-pointer (fill-pointer array)))
 873     (declare (fixnum fill-pointer))
 874     (if (zerop fill-pointer)
 875         (error "There is nothing left to pop.")
 876         ;; disable bounds checking (and any fixnum test)
 877         (locally (declare (optimize (safety 0)))
 878           (aref array
 879                 (setf (%array-fill-pointer array)
 880                       (1- fill-pointer)))))))
 881
 882 \f
 883 ;;;; ADJUST-ARRAY
 884
 885 (defun adjust-array (array dimensions &key
 886                            (element-type (array-element-type array))
 887                            (initial-element nil initial-element-p)
 888                            (initial-contents nil initial-contents-p)
 889                            fill-pointer
 890                            displaced-to displaced-index-offset)
 891   #!+sb-doc
 892   "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
 893   (when (invalid-array-p array)
 894     (invalid-array-error array))
 895   (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
 896     (cond ((/= (the fixnum (length (the list dimensions)))
 897                (the fixnum (array-rank array)))
 898            (error "The number of dimensions not equal to rank of array."))
 899           ((not (subtypep element-type (array-element-type array)))
 900            (error "The new element type, ~S, is incompatible with old type."
 901                   element-type))
 902           ((and fill-pointer (not (array-has-fill-pointer-p array)))
 903            (error 'type-error
 904                   :datum array
 905                   :expected-type '(satisfies array-has-fill-pointer-p))))
 906     (let ((array-rank (length (the list dimensions))))
 907       (declare (fixnum array-rank))
 908       (unless (= array-rank 1)
 909         (when fill-pointer
 910           (error "Only vectors can have fill pointers.")))
 911       (cond (initial-contents-p
 912              ;; array former contents replaced by INITIAL-CONTENTS
 913              (if (or initial-element-p displaced-to)
 914                  (error "INITIAL-CONTENTS may not be specified with ~
 915                          the :INITIAL-ELEMENT or :DISPLACED-TO option."))
 916              (let* ((array-size (apply #'* dimensions))
 917                     (array-data (data-vector-from-inits
 918                                  dimensions array-size element-type
 919                                  initial-contents initial-contents-p
 920                                  initial-element initial-element-p)))
 921                (if (adjustable-array-p array)
 922                    (set-array-header array array-data array-size
 923                                  (get-new-fill-pointer array array-size
 924                                                        fill-pointer)
 925                                  0 dimensions nil nil)
 926                    (if (array-header-p array)
 927                        ;; simple multidimensional or single dimensional array
 928                        (make-array dimensions
 929                                    :element-type element-type
 930                                    :initial-contents initial-contents)
 931                        array-data))))
 932             (displaced-to
 933              ;; We already established that no INITIAL-CONTENTS was supplied.
 934              (when initial-element
 935                (error "The :INITIAL-ELEMENT option may not be specified ~
 936                        with :DISPLACED-TO."))
 937              (unless (subtypep element-type (array-element-type displaced-to))
 938                (error "can't displace an array of type ~S into another of ~
 939                        type ~S"
 940                       element-type (array-element-type displaced-to)))
 941              (let ((displacement (or displaced-index-offset 0))
 942                    (array-size (apply #'* dimensions)))
 943                (declare (fixnum displacement array-size))
 944                (if (< (the fixnum (array-total-size displaced-to))
 945                       (the fixnum (+ displacement array-size)))
 946                    (error "The :DISPLACED-TO array is too small."))
 947                (if (adjustable-array-p array)
 948                    ;; None of the original contents appear in adjusted array.
 949                    (set-array-header array displaced-to array-size
 950                                      (get-new-fill-pointer array array-size
 951                                                            fill-pointer)
 952                                      displacement dimensions t nil)
 953                    ;; simple multidimensional or single dimensional array
 954                    (make-array dimensions
 955                                :element-type element-type
 956                                :displaced-to displaced-to
 957                                :displaced-index-offset
 958                                displaced-index-offset))))
 959             ((= array-rank 1)
 960              (let ((old-length (array-total-size array))
 961                    (new-length (car dimensions))
 962                    new-data)
 963                (declare (fixnum old-length new-length))
 964                (with-array-data ((old-data array) (old-start)
 965                                  (old-end old-length))
 966                  (cond ((or (and (array-header-p array)
 967                                  (%array-displaced-p array))
 968                             (< old-length new-length))
 969                         (setf new-data
 970                               (data-vector-from-inits
 971                                dimensions new-length element-type
 972                                initial-contents initial-contents-p
 973                                initial-element initial-element-p))
 974                         (replace new-data old-data
 975                                  :start2 old-start :end2 old-end))
 976                        (t (setf new-data
 977                                 (shrink-vector old-data new-length))))
 978                  (if (adjustable-array-p array)
 979                      (set-array-header array new-data new-length
 980                                        (get-new-fill-pointer array new-length
 981                                                              fill-pointer)
 982                                        0 dimensions nil nil)
 983                      new-data))))
 984             (t
 985              (let ((old-length (%array-available-elements array))
 986                    (new-length (apply #'* dimensions)))
 987                (declare (fixnum old-length new-length))
 988                (with-array-data ((old-data array) (old-start)
 989                                  (old-end old-length))
 990                  (declare (ignore old-end))
 991                  (let ((new-data (if (or (and (array-header-p array)
 992                                               (%array-displaced-p array))
 993                                          (> new-length old-length))
 994                                      (data-vector-from-inits
 995                                       dimensions new-length
 996                                       element-type () nil
 997                                       initial-element initial-element-p)
 998                                      old-data)))
 999                    (if (or (zerop old-length) (zerop new-length))
1000                        (when initial-element-p (fill new-data initial-element))
1001                        (zap-array-data old-data (array-dimensions array)
1002                                        old-start
1003                                        new-data dimensions new-length
1004                                        element-type initial-element
1005                                        initial-element-p))
1006                    (if (adjustable-array-p array)
1007                        (set-array-header array new-data new-length
1008                                          nil 0 dimensions nil nil)
1009                        (let ((new-array
1010                               (make-array-header
1011                                sb!vm:simple-array-widetag array-rank)))
1012                          (set-array-header new-array new-data new-length
1013                                            nil 0 dimensions nil t)))))))))))
1014
1015
1016 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
1017   (cond ((not fill-pointer)
1018          (when (array-has-fill-pointer-p old-array)
1019            (when (> (%array-fill-pointer old-array) new-array-size)
1020              (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
1021                      smaller than its fill pointer (~S)"
1022                     old-array new-array-size (fill-pointer old-array)))
1023            (%array-fill-pointer old-array)))
1024         ((not (array-has-fill-pointer-p old-array))
1025          (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
1026                  in ADJUST-ARRAY unless the array (~S) was originally ~
1027                  created with a fill pointer"
1028                 fill-pointer
1029                 old-array))
1030         ((numberp fill-pointer)
1031          (when (> fill-pointer new-array-size)
1032            (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
1033                    than the new length of the vector (~S)"
1034                   fill-pointer new-array-size))
1035          fill-pointer)
1036         ((eq fill-pointer t)
1037          new-array-size)
1038         (t
1039          (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
1040                 fill-pointer))))
1041
1042 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
1043 ;;; which must be less than or equal to its current length. This can
1044 ;;; be called on vectors without a fill pointer but it is extremely
1045 ;;; dangerous to do so: shrinking the size of an object (as viewed by
1046 ;;; the gc) makes bounds checking unreliable in the face of interrupts
1047 ;;; or multi-threading. Call it only on provably local vectors.
1048 (defun %shrink-vector (vector new-length)
1049   (declare (vector vector))
1050   (unless (array-header-p vector)
1051     (macrolet ((frob (name &rest things)
1052                  `(etypecase ,name
1053                     ((simple-array nil (*)) (error 'nil-array-accessed-error))
1054                     ,@(mapcar (lambda (thing)
1055                                 (destructuring-bind (type-spec fill-value)
1056                                     thing
1057                                   `(,type-spec
1058                                     (fill (truly-the ,type-spec ,name)
1059                                           ,fill-value
1060                                           :start new-length))))
1061                               things))))
1062       ;; Set the 'tail' of the vector to the appropriate type of zero,
1063       ;; "because in some cases we'll scavenge larger areas in one go,
1064       ;; like groups of pages that had triggered the write barrier, or
1065       ;; the whole static space" according to jsnell.
1066       #.`(frob vector
1067           ,@(map 'list
1068                  (lambda (saetp)
1069                    `((simple-array ,(sb!vm:saetp-specifier saetp) (*))
1070                      ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character)
1071                               #!+sb-unicode
1072                               (eq (sb!vm:saetp-specifier saetp) 'base-char))
1073                           *default-init-char-form*
1074                           (sb!vm:saetp-initial-element-default saetp))))
1075                  (remove-if-not
1076                   #'sb!vm:saetp-specifier
1077                   sb!vm:*specialized-array-element-type-properties*)))))
1078   ;; Only arrays have fill-pointers, but vectors have their length
1079   ;; parameter in the same place.
1080   (setf (%array-fill-pointer vector) new-length)
1081   vector)
1082
1083 (defun shrink-vector (vector new-length)
1084   (declare (vector vector))
1085   (cond
1086     ((eq (length vector) new-length)
1087      vector)
1088     ((array-has-fill-pointer-p vector)
1089      (setf (%array-fill-pointer vector) new-length)
1090      vector)
1091     (t (subseq vector 0 new-length))))
1092
1093 ;;; BIG THREAD SAFETY NOTE
1094 ;;;
1095 ;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
1096 ;;; thread unsafe. They are nonatomic, and can mess with parallel
1097 ;;; code using the same arrays.
1098 ;;;
1099 ;;; A likely seeming fix is an additional level of indirection:
1100 ;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
1101 ;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
1102 ;;; would hold everything ARRAY-HEADER now holds. This allows
1103 ;;; consing up a new ARRAY-INFO and replacing it atomically in
1104 ;;; the ARRAY-HEADER.
1105 ;;;
1106 ;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
1107 ;;; one: not only is it needed extremely rarely, which makes
1108 ;;; any thread safety bugs involving it look like rare random
1109 ;;; corruption, but because it walks the chain *upwards*, which
1110 ;;; may violate user expectations.
1111
1112 (defun %save-displaced-array-backpointer (array data)
1113   (flet ((purge (pointers)
1114            (remove-if (lambda (value)
1115                         (or (not value) (eq array value)))
1116                       pointers
1117                       :key #'weak-pointer-value)))
1118     ;; Add backpointer to the new data vector if it has a header.
1119     (when (array-header-p data)
1120       (setf (%array-displaced-from data)
1121             (cons (make-weak-pointer array)
1122                   (purge (%array-displaced-from data)))))
1123     ;; Remove old backpointer, if any.
1124     (let ((old-data (%array-data-vector array)))
1125       (when (and (neq data old-data) (array-header-p old-data))
1126         (setf (%array-displaced-from old-data)
1127               (purge (%array-displaced-from old-data)))))))
1128
1129 (defun %walk-displaced-array-backpointers (array new-length)
1130   (dolist (p (%array-displaced-from array))
1131     (let ((from (weak-pointer-value p)))
1132       (when (and from (eq array (%array-data-vector from)))
1133         (let ((requires (+ (%array-available-elements from)
1134                            (%array-displacement from))))
1135           (unless (>= new-length requires)
1136             ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
1137             ;;
1138             ;;   "If A is displaced to B, the consequences are unspecified if B is
1139             ;;   adjusted in such a way that it no longer has enough elements to
1140             ;;   satisfy A.
1141             ;;
1142             ;; since we're hanging on a weak pointer here, we can't signal an
1143             ;; error right now: the array that we're looking at might be
1144             ;; garbage. Instead, we set all dimensions to zero so that next
1145             ;; safe access to the displaced array will trap. Additionally, we
1146             ;; save the original dimensions, so we can signal a more
1147             ;; understandable error when the time comes.
1148             (%walk-displaced-array-backpointers from 0)
1149             (setf (%array-fill-pointer from) 0
1150                   (%array-available-elements from) 0
1151                   (%array-displaced-p from) (array-dimensions array))
1152             (dotimes (i (%array-rank from))
1153               (setf (%array-dimension from i) 0))))))))
1154
1155 ;;; Fill in array header with the provided information, and return the array.
1156 (defun set-array-header (array data length fill-pointer displacement dimensions
1157                          displacedp newp)
1158   (if newp
1159       (setf (%array-displaced-from array) nil)
1160       (%walk-displaced-array-backpointers array length))
1161   (when displacedp
1162     (%save-displaced-array-backpointer array data))
1163   (setf (%array-data-vector array) data)
1164   (setf (%array-available-elements array) length)
1165   (cond (fill-pointer
1166          (setf (%array-fill-pointer array) fill-pointer)
1167          (setf (%array-fill-pointer-p array) t))
1168         (t
1169          (setf (%array-fill-pointer array) length)
1170          (setf (%array-fill-pointer-p array) nil)))
1171   (setf (%array-displacement array) displacement)
1172   (if (listp dimensions)
1173       (dotimes (axis (array-rank array))
1174         (declare (type index axis))
1175         (setf (%array-dimension array axis) (pop dimensions)))
1176       (setf (%array-dimension array 0) dimensions))
1177   (setf (%array-displaced-p array) displacedp)
1178   array)
1179
1180 ;;; User visible extension
1181 (declaim (ftype (function (array) (values (simple-array * (*)) &optional))
1182                 array-storage-vector))
1183 (defun array-storage-vector (array)
1184   "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
1185
1186 In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
1187 vector. Multidimensional arrays, arrays with fill pointers, and adjustable
1188 arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
1189 ARRAY, which this function returns.
1190
1191 Important note: the underlying vector is an implementation detail. Even though
1192 this function exposes it, changes in the implementation may cause this
1193 function to be removed without further warning."
1194   ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that
1195   ;; the return value is always of the known type.
1196   (truly-the (simple-array * (*))
1197              (if (array-header-p array)
1198                  (if (%array-displaced-p array)
1199                      (error "~S cannot be used with displaced arrays. Use ~S instead."
1200                             'array-storage-vector 'array-displacement)
1201                      (%array-data-vector array))
1202                  array)))
1203 \f
1204
1205 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
1206
1207 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
1208 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
1209 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
1210 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
1211 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1212                        element-type initial-element initial-element-p)
1213   (declare (list old-dims new-dims)
1214            (fixnum new-length))
1215   ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
1216   ;; at least in SBCL.
1217   ;; NEW-DIMS comes from the user.
1218   (setf old-dims (nreverse old-dims)
1219         new-dims (reverse new-dims))
1220   (cond ((eq old-data new-data)
1221          ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
1222          ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
1223          ;; EQ; in this case, a temporary must be used and filled
1224          ;; appropriately. specified initial-element.
1225          (when initial-element-p
1226            ;; FIXME: transforming this TYPEP to someting a bit faster
1227            ;; would be a win...
1228            (unless (typep initial-element element-type)
1229              (error "~S can't be used to initialize an array of type ~S."
1230                     initial-element element-type)))
1231          (let ((temp (if initial-element-p
1232                          (make-array new-length :initial-element initial-element)
1233                          (make-array new-length))))
1234            (declare (simple-vector temp))
1235            (zap-array-data-aux old-data old-dims offset temp new-dims)
1236            (dotimes (i new-length)
1237              (setf (aref new-data i) (aref temp i)))
1238            ;; Kill the temporary vector to prevent garbage retention.
1239            (%shrink-vector temp 0)))
1240         (t
1241          ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
1242          ;; already been filled with any
1243          (zap-array-data-aux old-data old-dims offset new-data new-dims))))
1244
1245 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
1246   (declare (fixnum offset))
1247   (let ((limits (mapcar (lambda (x y)
1248                           (declare (fixnum x y))
1249                           (1- (the fixnum (min x y))))
1250                         old-dims new-dims)))
1251     (macrolet ((bump-index-list (index limits)
1252                  `(do ((subscripts ,index (cdr subscripts))
1253                        (limits ,limits (cdr limits)))
1254                       ((null subscripts) :eof)
1255                     (cond ((< (the fixnum (car subscripts))
1256                               (the fixnum (car limits)))
1257                            (rplaca subscripts
1258                                    (1+ (the fixnum (car subscripts))))
1259                            (return ,index))
1260                           (t (rplaca subscripts 0))))))
1261       (do ((index (make-list (length old-dims) :initial-element 0)
1262                   (bump-index-list index limits)))
1263           ((eq index :eof))
1264         (setf (aref new-data (row-major-index-from-dims index new-dims))
1265               (aref old-data
1266                     (+ (the fixnum (row-major-index-from-dims index old-dims))
1267                        offset)))))))
1268
1269 ;;; Figure out the row-major-order index of an array reference from a
1270 ;;; list of subscripts and a list of dimensions. This is for internal
1271 ;;; calls only, and the subscripts and dim-list variables are assumed
1272 ;;; to be reversed from what the user supplied.
1273 (defun row-major-index-from-dims (rev-subscripts rev-dim-list)
1274   (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
1275        (rev-dim-list rev-dim-list (cdr rev-dim-list))
1276        (chunk-size 1)
1277        (result 0))
1278       ((null rev-dim-list) result)
1279     (declare (fixnum chunk-size result))
1280     (setq result (+ result
1281                     (the fixnum (* (the fixnum (car rev-subscripts))
1282                                    chunk-size))))
1283     (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
1284 \f
1285 ;;;; some bit stuff
1286
1287 (defun bit-array-same-dimensions-p (array1 array2)
1288   (declare (type (array bit) array1 array2))
1289   (and (= (array-rank array1)
1290           (array-rank array2))
1291        (dotimes (index (array-rank array1) t)
1292          (when (/= (array-dimension array1 index)
1293                    (array-dimension array2 index))
1294            (return nil)))))
1295
1296 (defun pick-result-array (result-bit-array bit-array-1)
1297   (case result-bit-array
1298     ((t) bit-array-1)
1299     ((nil) (make-array (array-dimensions bit-array-1)
1300                        :element-type 'bit
1301                        :initial-element 0))
1302     (t
1303      (unless (bit-array-same-dimensions-p bit-array-1
1304                                           result-bit-array)
1305        (error "~S and ~S don't have the same dimensions."
1306               bit-array-1 result-bit-array))
1307      result-bit-array)))
1308
1309 (defmacro def-bit-array-op (name function)
1310   `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
1311      #!+sb-doc
1312      ,(format nil
1313               "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1314                BIT-ARRAY-2,~%  putting the results in RESULT-BIT-ARRAY. ~
1315                If RESULT-BIT-ARRAY is T,~%  BIT-ARRAY-1 is used. If ~
1316                RESULT-BIT-ARRAY is NIL or omitted, a new array is~%  created. ~
1317                All the arrays must have the same rank and dimensions."
1318               (symbol-name function))
1319      (declare (type (array bit) bit-array-1 bit-array-2)
1320               (type (or (array bit) (member t nil)) result-bit-array))
1321      (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
1322        (error "~S and ~S don't have the same dimensions."
1323               bit-array-1 bit-array-2))
1324      (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
1325        (if (and (simple-bit-vector-p bit-array-1)
1326                 (simple-bit-vector-p bit-array-2)
1327                 (simple-bit-vector-p result-bit-array))
1328            (locally (declare (optimize (speed 3) (safety 0)))
1329              (,name bit-array-1 bit-array-2 result-bit-array))
1330            (with-array-data ((data1 bit-array-1) (start1) (end1))
1331              (declare (ignore end1))
1332              (with-array-data ((data2 bit-array-2) (start2) (end2))
1333                (declare (ignore end2))
1334                (with-array-data ((data3 result-bit-array) (start3) (end3))
1335                  (do ((index-1 start1 (1+ index-1))
1336                       (index-2 start2 (1+ index-2))
1337                       (index-3 start3 (1+ index-3)))
1338                      ((>= index-3 end3) result-bit-array)
1339                    (declare (type index index-1 index-2 index-3))
1340                    (setf (sbit data3 index-3)
1341                          (logand (,function (sbit data1 index-1)
1342                                             (sbit data2 index-2))
1343                                  1))))))))))
1344
1345 (def-bit-array-op bit-and logand)
1346 (def-bit-array-op bit-ior logior)
1347 (def-bit-array-op bit-xor logxor)
1348 (def-bit-array-op bit-eqv logeqv)
1349 (def-bit-array-op bit-nand lognand)
1350 (def-bit-array-op bit-nor lognor)
1351 (def-bit-array-op bit-andc1 logandc1)
1352 (def-bit-array-op bit-andc2 logandc2)
1353 (def-bit-array-op bit-orc1 logorc1)
1354 (def-bit-array-op bit-orc2 logorc2)
1355
1356 (defun bit-not (bit-array &optional result-bit-array)
1357   #!+sb-doc
1358   "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1359   putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1360   BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1361   created. Both arrays must have the same rank and dimensions."
1362   (declare (type (array bit) bit-array)
1363            (type (or (array bit) (member t nil)) result-bit-array))
1364   (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
1365     (if (and (simple-bit-vector-p bit-array)
1366              (simple-bit-vector-p result-bit-array))
1367         (locally (declare (optimize (speed 3) (safety 0)))
1368           (bit-not bit-array result-bit-array))
1369         (with-array-data ((src bit-array) (src-start) (src-end))
1370           (declare (ignore src-end))
1371           (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
1372             (do ((src-index src-start (1+ src-index))
1373                  (dst-index dst-start (1+ dst-index)))
1374                 ((>= dst-index dst-end) result-bit-array)
1375               (declare (type index src-index dst-index))
1376               (setf (sbit dst dst-index)
1377                     (logxor (sbit src src-index) 1))))))))