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