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