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 fill-pointer array-has-fill-pointer-p 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-frob (name)
  23              `(progn
  24                 (defun ,name (array)
  25                   (,name array))
  26                 (defun (setf ,name) (value array)
  27                   (setf (,name array) value)))))
  28   (def-frob %array-fill-pointer)
  29   (def-frob %array-fill-pointer-p)
  30   (def-frob %array-available-elements)
  31   (def-frob %array-data-vector)
  32   (def-frob %array-displacement)
  33   (def-frob %array-displaced-p))
  34
  35 (defun %array-rank (array)
  36   (%array-rank array))
  37
  38 (defun %array-dimension (array axis)
  39   (%array-dimension array axis))
  40
  41 (defun %set-array-dimension (array axis value)
  42   (%set-array-dimension array axis value))
  43
  44 (defun %check-bound (array bound index)
  45   (declare (type index bound)
  46            (fixnum index))
  47   (%check-bound array bound index))
  48
  49 (defun %with-array-data (array start end)
  50   (%with-array-data-macro array start end :fail-inline? t))
  51
  52 ;;; It'd waste space to expand copies of error handling in every
  53 ;;; inline %WITH-ARRAY-DATA, so we have them call this function
  54 ;;; instead. This is just a wrapper which is known never to return.
  55 (defun failed-%with-array-data (array start end)
  56   (declare (notinline %with-array-data))
  57   (%with-array-data array start end)
  58   (error "internal error: shouldn't be here with valid parameters"))
  59 \f
  60 ;;;; MAKE-ARRAY
  61
  62 (eval-when (:compile-toplevel :execute)
  63   (sb!xc:defmacro pick-vector-type (type &rest specs)
  64     `(cond ,@(mapcar #'(lambda (spec)
  65                          `(,(if (eq (car spec) t)
  66                               t
  67                               `(subtypep ,type ',(car spec)))
  68                            ,@(cdr spec)))
  69                      specs))))
  70
  71 ;;; These functions are used in the implementation of MAKE-ARRAY for
  72 ;;; complex arrays. There are lots of transforms to simplify
  73 ;;; MAKE-ARRAY for various easy cases, but not for all reasonable
  74 ;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
  75 ;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
  76 ;;; making this somewhat efficient, at least not doing full calls to
  77 ;;; SUBTYPEP in the easy cases.
  78 (defun %vector-type-code (type)
  79   (case type
  80     ;; Pick off some easy common cases.
  81     ;;
  82     ;; (Perhaps we should make a much more exhaustive table of easy
  83     ;; common cases here. Or perhaps the effort would be better spent
  84     ;; on smarter compiler transforms which do the calculation once
  85     ;; and for all in any reasonable user programs.)
  86     ((t)
  87      (values #.sb!vm:simple-vector-widetag #.sb!vm:word-bits))
  88     ((character base-char standard-char)
  89      (values #.sb!vm:simple-string-widetag #.sb!vm:byte-bits))
  90     ((bit)
  91      (values #.sb!vm:simple-bit-vector-widetag 1))
  92     ;; OK, we have to wade into SUBTYPEPing after all.
  93     (t
  94      ;; FIXME: The data here are redundant with
  95      ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
  96      (pick-vector-type type
  97        (base-char (values #.sb!vm:simple-string-widetag #.sb!vm:byte-bits))
  98        (bit (values #.sb!vm:simple-bit-vector-widetag 1))
  99        ((unsigned-byte 2)
 100         (values #.sb!vm:simple-array-unsigned-byte-2-widetag 2))
 101        ((unsigned-byte 4)
 102         (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4))
 103        ((unsigned-byte 8)
 104         (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8))
 105        ((unsigned-byte 16)
 106         (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16))
 107        ((unsigned-byte 32)
 108         (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32))
 109        ((signed-byte 8)
 110         (values #.sb!vm:simple-array-signed-byte-8-widetag 8))
 111        ((signed-byte 16)
 112         (values #.sb!vm:simple-array-signed-byte-16-widetag 16))
 113        ((signed-byte 30)
 114         (values #.sb!vm:simple-array-signed-byte-30-widetag 32))
 115        ((signed-byte 32)
 116         (values #.sb!vm:simple-array-signed-byte-32-widetag 32))
 117        (single-float (values #.sb!vm:simple-array-single-float-widetag 32))
 118        (double-float (values #.sb!vm:simple-array-double-float-widetag 64))
 119        #!+long-float
 120        (long-float
 121         (values #.sb!vm:simple-array-long-float-widetag
 122                 #!+x86 96 #!+sparc 128))
 123        ((complex single-float)
 124         (values #.sb!vm:simple-array-complex-single-float-widetag 64))
 125        ((complex double-float)
 126         (values #.sb!vm:simple-array-complex-double-float-widetag 128))
 127        #!+long-float
 128        ((complex long-float)
 129         (values #.sb!vm:simple-array-complex-long-float-widetag
 130                 #!+x86 192
 131                 #!+sparc 256))
 132        (t (values #.sb!vm:simple-vector-widetag #.sb!vm:word-bits))))))
 133 (defun %complex-vector-type-code (type)
 134   (case type
 135     ;; Pick off some easy common cases.
 136     ((t)
 137      #.sb!vm:complex-vector-widetag)
 138     ((character base-char)
 139      #.sb!vm:complex-string-widetag)
 140     ((bit)
 141      #.sb!vm:complex-bit-vector-widetag)
 142     ;; OK, we have to wade into SUBTYPEPing after all.
 143     (t
 144      (pick-vector-type type
 145        (base-char #.sb!vm:complex-string-widetag)
 146        (bit #.sb!vm:complex-bit-vector-widetag)
 147        (t #.sb!vm:complex-vector-widetag)))))
 148
 149 (defun make-array (dimensions &key
 150                               (element-type t)
 151                               (initial-element nil initial-element-p)
 152                               initial-contents adjustable fill-pointer
 153                               displaced-to displaced-index-offset)
 154   (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
 155          (array-rank (length (the list dimensions)))
 156          (simple (and (null fill-pointer)
 157                       (not adjustable)
 158                       (null displaced-to))))
 159     (declare (fixnum array-rank))
 160     (when (and displaced-index-offset (null displaced-to))
 161       (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
 162     (if (and simple (= array-rank 1))
 163         ;; Its a (simple-array * (*))
 164         (multiple-value-bind (type bits) (%vector-type-code element-type)
 165           (declare (type (unsigned-byte 8) type)
 166                    (type (integer 1 256) bits))
 167           (let* ((length (car dimensions))
 168                  (array (allocate-vector
 169                          type
 170                          length
 171                          (ceiling (* (if (= type sb!vm:simple-string-widetag)
 172                                          (1+ length)
 173                                          length)
 174                                      bits)
 175                                   sb!vm:word-bits))))
 176             (declare (type index length))
 177             (when initial-element-p
 178               (fill array initial-element))
 179             (when initial-contents
 180               (when initial-element
 181                 (error "can't specify both :INITIAL-ELEMENT and ~
 182                 :INITIAL-CONTENTS"))
 183               (unless (= length (length initial-contents))
 184                 (error "There are ~D elements in the :INITIAL-CONTENTS, but ~
 185                        the vector length is ~D."
 186                        (length initial-contents)
 187                        length))
 188               (replace array initial-contents))
 189             array))
 190         ;; It's either a complex array or a multidimensional array.
 191         (let* ((total-size (reduce #'* dimensions))
 192                (data (or displaced-to
 193                          (data-vector-from-inits
 194                           dimensions total-size element-type
 195                           initial-contents initial-element initial-element-p)))
 196                (array (make-array-header
 197                        (cond ((= array-rank 1)
 198                               (%complex-vector-type-code element-type))
 199                              (simple sb!vm:simple-array-widetag)
 200                              (t sb!vm:complex-array-widetag))
 201                        array-rank)))
 202           (cond (fill-pointer
 203                  (unless (= array-rank 1)
 204                    (error "Only vectors can have fill pointers."))
 205                  (let ((length (car dimensions)))
 206                    (declare (fixnum length))
 207                    (setf (%array-fill-pointer array)
 208                      (cond ((eq fill-pointer t)
 209                             length)
 210                            (t
 211                             (unless (and (fixnump fill-pointer)
 212                                          (>= fill-pointer 0)
 213                                          (<= fill-pointer length))
 214                                     (error "invalid fill-pointer ~D"
 215                                            fill-pointer))
 216                             fill-pointer))))
 217                  (setf (%array-fill-pointer-p array) t))
 218                 (t
 219                  (setf (%array-fill-pointer array) total-size)
 220                  (setf (%array-fill-pointer-p array) nil)))
 221           (setf (%array-available-elements array) total-size)
 222           (setf (%array-data-vector array) data)
 223           (cond (displaced-to
 224                  (when (or initial-element-p initial-contents)
 225                    (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
 226                    can be specified along with :DISPLACED-TO"))
 227                  (let ((offset (or displaced-index-offset 0)))
 228                    (when (> (+ offset total-size)
 229                             (array-total-size displaced-to))
 230                      (error "~S doesn't have enough elements." displaced-to))
 231                    (setf (%array-displacement array) offset)
 232                    (setf (%array-displaced-p array) t)))
 233                 (t
 234                  (setf (%array-displaced-p array) nil)))
 235           (let ((axis 0))
 236             (dolist (dim dimensions)
 237               (setf (%array-dimension array axis) dim)
 238               (incf axis)))
 239           array))))
 240
 241 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
 242 ;;; specified array characteristics. Dimensions is only used to pass
 243 ;;; to FILL-DATA-VECTOR for error checking on the structure of
 244 ;;; initial-contents.
 245 (defun data-vector-from-inits (dimensions total-size element-type
 246                                initial-contents initial-element
 247                                initial-element-p)
 248   (when (and initial-contents initial-element-p)
 249     (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
 250             either MAKE-ARRAY or ADJUST-ARRAY."))
 251   (let ((data (if initial-element-p
 252                   (make-array total-size
 253                               :element-type element-type
 254                               :initial-element initial-element)
 255                   (make-array total-size
 256                               :element-type element-type))))
 257     (cond (initial-element-p
 258            (unless (simple-vector-p data)
 259              (unless (typep initial-element element-type)
 260                (error "~S cannot be used to initialize an array of type ~S."
 261                       initial-element element-type))
 262              (fill (the vector data) initial-element)))
 263           (initial-contents
 264            (fill-data-vector data dimensions initial-contents)))
 265     data))
 266
 267 (defun fill-data-vector (vector dimensions initial-contents)
 268   (let ((index 0))
 269     (labels ((frob (axis dims contents)
 270                (cond ((null dims)
 271                       (setf (aref vector index) contents)
 272                       (incf index))
 273                      (t
 274                       (unless (typep contents 'sequence)
 275                         (error "malformed :INITIAL-CONTENTS: ~S is not a ~
 276                                 sequence, but ~D more layer~:P needed."
 277                                contents
 278                                (- (length dimensions) axis)))
 279                       (unless (= (length contents) (car dims))
 280                         (error "malformed :INITIAL-CONTENTS: Dimension of ~
 281                                 axis ~D is ~D, but ~S is ~D long."
 282                                axis (car dims) contents (length contents)))
 283                       (if (listp contents)
 284                           (dolist (content contents)
 285                             (frob (1+ axis) (cdr dims) content))
 286                           (dotimes (i (length contents))
 287                             (frob (1+ axis) (cdr dims) (aref contents i))))))))
 288       (frob 0 dimensions initial-contents))))
 289
 290 (defun vector (&rest objects)
 291   #!+sb-doc
 292   "Construct a SIMPLE-VECTOR from the given objects."
 293   (coerce (the list objects) 'simple-vector))
 294 \f
 295 ;;;; accessor/setter functions
 296
 297 (eval-when (:compile-toplevel :execute)
 298   (defparameter *specialized-array-element-types*
 299     '(t
 300       character
 301       bit
 302       (unsigned-byte 2)
 303       (unsigned-byte 4)
 304       (unsigned-byte 8)
 305       (unsigned-byte 16)
 306       (unsigned-byte 32)
 307       (signed-byte 8)
 308       (signed-byte 16)
 309       (signed-byte 30)
 310       (signed-byte 32)
 311       single-float
 312       double-float
 313       #!+long-float long-float
 314       (complex single-float)
 315       (complex double-float)
 316       #!+long-float (complex long-float))))
 317
 318 (defun hairy-data-vector-ref (array index)
 319   (with-array-data ((vector array) (index index) (end))
 320     (declare (ignore end) (optimize (safety 3)))
 321     (etypecase vector .
 322                #.(mapcar (lambda (type)
 323                            (let ((atype `(simple-array ,type (*))))
 324                              `(,atype
 325                                (data-vector-ref (the ,atype vector)
 326                                                 index))))
 327                          *specialized-array-element-types*))))
 328
 329 (defun hairy-data-vector-set (array index new-value)
 330   (with-array-data ((vector array) (index index) (end))
 331     (declare (ignore end) (optimize (safety 3)))
 332     (etypecase vector .
 333                #.(mapcar (lambda (type)
 334                            (let ((atype `(simple-array ,type (*))))
 335                              `(,atype
 336                                (data-vector-set (the ,atype vector)
 337                                                 index
 338                                                 (the ,type
 339                                                   new-value)))))
 340                          *specialized-array-element-types*))))
 341
 342 (defun %array-row-major-index (array subscripts
 343                                      &optional (invalid-index-error-p t))
 344   (declare (array array)
 345            (list subscripts))
 346   (let ((rank (array-rank array)))
 347     (unless (= rank (length subscripts))
 348       (error "wrong number of subscripts, ~D, for array of rank ~D"
 349              (length subscripts) rank))
 350     (if (array-header-p array)
 351         (do ((subs (nreverse subscripts) (cdr subs))
 352              (axis (1- (array-rank array)) (1- axis))
 353              (chunk-size 1)
 354              (result 0))
 355             ((null subs) result)
 356           (declare (list subs) (fixnum axis chunk-size result))
 357           (let ((index (car subs))
 358                 (dim (%array-dimension array axis)))
 359             (declare (fixnum index dim))
 360             (unless (< -1 index dim)
 361               (if invalid-index-error-p
 362                   (error "invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
 363                          index axis array)
 364                   (return-from %array-row-major-index nil)))
 365             (incf result (* chunk-size index))
 366             (setf chunk-size (* chunk-size dim))))
 367         (let ((index (first subscripts)))
 368           (unless (< -1 index (length (the (simple-array * (*)) array)))
 369             (if invalid-index-error-p
 370                 (error "invalid index ~D in ~S" index array)
 371                 (return-from %array-row-major-index nil)))
 372           index))))
 373
 374 (defun array-in-bounds-p (array &rest subscripts)
 375   #!+sb-doc
 376   "Return T if the Subscipts are in bounds for the Array, Nil otherwise."
 377   (if (%array-row-major-index array subscripts nil)
 378       t))
 379
 380 (defun array-row-major-index (array &rest subscripts)
 381   (%array-row-major-index array subscripts))
 382
 383 (defun aref (array &rest subscripts)
 384   #!+sb-doc
 385   "Return the element of the Array specified by the Subscripts."
 386   (row-major-aref array (%array-row-major-index array subscripts)))
 387
 388 (defun %aset (array &rest stuff)
 389   (let ((subscripts (butlast stuff))
 390         (new-value (car (last stuff))))
 391     (setf (row-major-aref array (%array-row-major-index array subscripts))
 392           new-value)))
 393
 394 ;;; FIXME: What's supposed to happen with functions
 395 ;;; like AREF when we (DEFUN (SETF FOO) ..) when
 396 ;;; DEFSETF FOO is also defined? It seems as though the logical
 397 ;;; thing to do would be to nuke the macro definition for (SETF FOO)
 398 ;;; and replace it with the (SETF FOO) function, issuing a warning,
 399 ;;; just as for ordinary functions
 400 ;;;  * (LISP-IMPLEMENTATION-VERSION)
 401 ;;;  "18a+ release x86-linux 2.4.7 6 November 1998 cvs"
 402 ;;;  * (DEFMACRO ZOO (X) `(+ ,X ,X))
 403 ;;;  ZOO
 404 ;;;  * (DEFUN ZOO (X) (* 3 X))
 405 ;;;  Warning: ZOO previously defined as a macro.
 406 ;;;  ZOO
 407 ;;; But that doesn't seem to be what happens in CMU CL.
 408 ;;;
 409 ;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
 410 ;;; has a setf expansion and/or a setf function defined.
 411
 412 #!-sb-fluid (declaim (inline (setf aref)))
 413 (defun (setf aref) (new-value array &rest subscripts)
 414   (declare (type array array))
 415   (setf (row-major-aref array (%array-row-major-index array subscripts))
 416         new-value))
 417
 418 (defun row-major-aref (array index)
 419   #!+sb-doc
 420   "Return the element of array corressponding to the row-major index. This is
 421    SETF'able."
 422   (declare (optimize (safety 1)))
 423   (row-major-aref array index))
 424
 425 (defun %set-row-major-aref (array index new-value)
 426   (declare (optimize (safety 1)))
 427   (setf (row-major-aref array index) new-value))
 428
 429 (defun svref (simple-vector index)
 430   #!+sb-doc
 431   "Return the INDEX'th element of the given Simple-Vector."
 432   (declare (optimize (safety 1)))
 433   (aref simple-vector index))
 434
 435 (defun %svset (simple-vector index new)
 436   (declare (optimize (safety 1)))
 437   (setf (aref simple-vector index) new))
 438
 439 (defun bit (bit-array &rest subscripts)
 440   #!+sb-doc
 441   "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
 442   (declare (type (array bit) bit-array) (optimize (safety 1)))
 443   (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
 444
 445 (defun %bitset (bit-array &rest stuff)
 446   (declare (type (array bit) bit-array) (optimize (safety 1)))
 447   (let ((subscripts (butlast stuff))
 448         (new-value (car (last stuff))))
 449     (setf (row-major-aref bit-array
 450                           (%array-row-major-index bit-array subscripts))
 451           new-value)))
 452
 453 #!-sb-fluid (declaim (inline (setf bit)))
 454 (defun (setf bit) (new-value bit-array &rest subscripts)
 455   (declare (type (array bit) bit-array) (optimize (safety 1)))
 456   (setf (row-major-aref bit-array
 457                         (%array-row-major-index bit-array subscripts))
 458         new-value))
 459
 460 (defun sbit (simple-bit-array &rest subscripts)
 461   #!+sb-doc
 462   "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
 463   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
 464   (row-major-aref simple-bit-array
 465                   (%array-row-major-index simple-bit-array subscripts)))
 466
 467 ;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER,
 468 ;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names.
 469 ;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names?
 470 ;;; -- WHN 19990911
 471 (defun %sbitset (simple-bit-array &rest stuff)
 472   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
 473   (let ((subscripts (butlast stuff))
 474         (new-value (car (last stuff))))
 475     (setf (row-major-aref simple-bit-array
 476                           (%array-row-major-index simple-bit-array subscripts))
 477           new-value)))
 478
 479 #!-sb-fluid (declaim (inline (setf sbit)))
 480 (defun (setf sbit) (new-value bit-array &rest subscripts)
 481   (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
 482   (setf (row-major-aref bit-array
 483                         (%array-row-major-index bit-array subscripts))
 484         new-value))
 485 \f
 486 ;;;; miscellaneous array properties
 487
 488 (defun array-element-type (array)
 489   #!+sb-doc
 490   "Return the type of the elements of the array"
 491   (let ((type (get-type array)))
 492     (macrolet ((pick-element-type (&rest stuff)
 493                  `(cond ,@(mapcar #'(lambda (stuff)
 494                                       (cons
 495                                        (let ((item (car stuff)))
 496                                          (cond ((eq item t)
 497                                                 t)
 498                                                ((listp item)
 499                                                 (cons 'or
 500                                                       (mapcar #'(lambda (x)
 501                                                                   `(= type ,x))
 502                                                               item)))
 503                                                (t
 504                                                 `(= type ,item))))
 505                                        (cdr stuff)))
 506                                                    stuff))))
 507       ;; FIXME: The data here are redundant with
 508       ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
 509       (pick-element-type
 510        ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char)
 511        ((sb!vm:simple-bit-vector-widetag
 512          sb!vm:complex-bit-vector-widetag) 'bit)
 513        (sb!vm:simple-vector-widetag t)
 514        (sb!vm:simple-array-unsigned-byte-2-widetag '(unsigned-byte 2))
 515        (sb!vm:simple-array-unsigned-byte-4-widetag '(unsigned-byte 4))
 516        (sb!vm:simple-array-unsigned-byte-8-widetag '(unsigned-byte 8))
 517        (sb!vm:simple-array-unsigned-byte-16-widetag '(unsigned-byte 16))
 518        (sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32))
 519        (sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8))
 520        (sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16))
 521        (sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30))
 522        (sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32))
 523        (sb!vm:simple-array-single-float-widetag 'single-float)
 524        (sb!vm:simple-array-double-float-widetag 'double-float)
 525        #!+long-float
 526        (sb!vm:simple-array-long-float-widetag 'long-float)
 527        (sb!vm:simple-array-complex-single-float-widetag
 528         '(complex single-float))
 529        (sb!vm:simple-array-complex-double-float-widetag
 530         '(complex double-float))
 531        #!+long-float
 532        (sb!vm:simple-array-complex-long-float-widetag '(complex long-float))
 533        ((sb!vm:simple-array-widetag
 534          sb!vm:complex-vector-widetag
 535          sb!vm:complex-array-widetag)
 536         (with-array-data ((array array) (start) (end))
 537           (declare (ignore start end))
 538           (array-element-type array)))
 539        (t
 540         (error "~S is not an array." array))))))
 541
 542 (defun array-rank (array)
 543   #!+sb-doc
 544   "Return the number of dimensions of ARRAY."
 545   (if (array-header-p array)
 546       (%array-rank array)
 547       1))
 548
 549 (defun array-dimension (array axis-number)
 550   #!+sb-doc
 551   "Return the length of dimension AXIS-NUMBER of ARRAY."
 552   (declare (array array) (type index axis-number))
 553   (cond ((not (array-header-p array))
 554          (unless (= axis-number 0)
 555            (error "Vector axis is not zero: ~S" axis-number))
 556          (length (the (simple-array * (*)) array)))
 557         ((>= axis-number (%array-rank array))
 558          (error "~D is too big; ~S only has ~D dimension~:P."
 559                 axis-number array (%array-rank array)))
 560         (t
 561          (%array-dimension array axis-number))))
 562
 563 (defun array-dimensions (array)
 564   #!+sb-doc
 565   "Return a list whose elements are the dimensions of the array"
 566   (declare (array array))
 567   (if (array-header-p array)
 568       (do ((results nil (cons (array-dimension array index) results))
 569            (index (1- (array-rank array)) (1- index)))
 570           ((minusp index) results))
 571       (list (array-dimension array 0))))
 572
 573 (defun array-total-size (array)
 574   #!+sb-doc
 575   "Return the total number of elements in the Array."
 576   (declare (array array))
 577   (if (array-header-p array)
 578       (%array-available-elements array)
 579       (length (the vector array))))
 580
 581 (defun array-displacement (array)
 582   #!+sb-doc
 583   "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
 584    options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
 585   (declare (type array array))
 586   (if (and (array-header-p array) ; if unsimple and
 587            (%array-displaced-p array)) ; displaced
 588       (values (%array-data-vector array) (%array-displacement array))
 589       (values nil 0)))
 590
 591 (defun adjustable-array-p (array)
 592   #!+sb-doc
 593   "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
 594    to the argument, this happens for complex arrays."
 595   (declare (array array))
 596   (not (typep array 'simple-array)))
 597 \f
 598 ;;;; fill pointer frobbing stuff
 599
 600 (defun array-has-fill-pointer-p (array)
 601   #!+sb-doc
 602   "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
 603   (declare (array array))
 604   (and (array-header-p array) (%array-fill-pointer-p array)))
 605
 606 (defun fill-pointer (vector)
 607   #!+sb-doc
 608   "Return the FILL-POINTER of the given VECTOR."
 609   (declare (vector vector))
 610   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
 611       (%array-fill-pointer vector)
 612       (error 'simple-type-error
 613              :datum vector
 614              :expected-type '(and vector (satisfies array-has-fill-pointer-p))
 615              :format-control "~S is not an array with a fill pointer."
 616              :format-arguments (list vector))))
 617
 618 (defun %set-fill-pointer (vector new)
 619   (declare (vector vector) (fixnum new))
 620   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
 621       (if (> new (%array-available-elements vector))
 622         (error
 623          "The new fill pointer, ~S, is larger than the length of the vector."
 624          new)
 625         (setf (%array-fill-pointer vector) new))
 626       (error 'simple-type-error
 627              :datum vector
 628              :expected-type '(and vector (satisfies array-has-fill-pointer-p))
 629              :format-control "~S is not an array with a fill pointer."
 630              :format-arguments (list vector))))
 631
 632 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
 633 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
 634 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
 635 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
 636 ;;; back to CMU CL).
 637 (defun vector-push (new-el array)
 638   #!+sb-doc
 639   "Attempt to set the element of ARRAY designated by its fill pointer
 640    to NEW-EL, and increment the fill pointer by one. If the fill pointer is
 641    too large, NIL is returned, otherwise the index of the pushed element is
 642    returned."
 643   (declare (vector array))
 644   (let ((fill-pointer (fill-pointer array)))
 645     (declare (fixnum fill-pointer))
 646     (cond ((= fill-pointer (%array-available-elements array))
 647            nil)
 648           (t
 649            (setf (aref array fill-pointer) new-el)
 650            (setf (%array-fill-pointer array) (1+ fill-pointer))
 651            fill-pointer))))
 652
 653 (defun vector-push-extend (new-element
 654                            vector
 655                            &optional
 656                            (extension (1+ (length vector))))
 657   (declare (vector vector) (fixnum extension))
 658   (let ((fill-pointer (fill-pointer vector)))
 659     (declare (fixnum fill-pointer))
 660     (when (= fill-pointer (%array-available-elements vector))
 661       (adjust-array vector (+ fill-pointer extension)))
 662     (setf (aref vector fill-pointer) new-element)
 663     (setf (%array-fill-pointer vector) (1+ fill-pointer))
 664     fill-pointer))
 665
 666 (defun vector-pop (array)
 667   #!+sb-doc
 668   "Decrease the fill pointer by 1 and return the element pointed to by the
 669   new fill pointer."
 670   (declare (vector array))
 671   (let ((fill-pointer (fill-pointer array)))
 672     (declare (fixnum fill-pointer))
 673     (if (zerop fill-pointer)
 674         (error "There is nothing left to pop.")
 675         (aref array
 676               (setf (%array-fill-pointer array)
 677                     (1- fill-pointer))))))
 678 \f
 679 ;;;; ADJUST-ARRAY
 680
 681 (defun adjust-array (array dimensions &key
 682                            (element-type (array-element-type array))
 683                            (initial-element nil initial-element-p)
 684                            initial-contents fill-pointer
 685                            displaced-to displaced-index-offset)
 686   #!+sb-doc
 687   "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
 688   (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
 689     (cond ((/= (the fixnum (length (the list dimensions)))
 690                (the fixnum (array-rank array)))
 691            (error "The number of dimensions not equal to rank of array."))
 692           ((not (subtypep element-type (array-element-type array)))
 693            (error "The new element type, ~S, is incompatible with old type."
 694                   element-type)))
 695     (let ((array-rank (length (the list dimensions))))
 696       (declare (fixnum array-rank))
 697       (when (and fill-pointer (> array-rank 1))
 698         (error "Multidimensional arrays can't have fill pointers."))
 699       (cond (initial-contents
 700              ;; array former contents replaced by INITIAL-CONTENTS
 701              (if (or initial-element-p displaced-to)
 702                  (error "INITIAL-CONTENTS may not be specified with ~
 703                  the :INITIAL-ELEMENT or :DISPLACED-TO option."))
 704              (let* ((array-size (apply #'* dimensions))
 705                     (array-data (data-vector-from-inits
 706                                  dimensions array-size element-type
 707                                  initial-contents initial-element
 708                                  initial-element-p)))
 709                (if (adjustable-array-p array)
 710                    (set-array-header array array-data array-size
 711                                  (get-new-fill-pointer array array-size
 712                                                        fill-pointer)
 713                                  0 dimensions nil)
 714                    (if (array-header-p array)
 715                        ;; simple multidimensional or single dimensional array
 716                        (make-array dimensions
 717                                    :element-type element-type
 718                                    :initial-contents initial-contents)
 719                        array-data))))
 720             (displaced-to
 721              ;; We already established that no INITIAL-CONTENTS was supplied.
 722              (when initial-element
 723                (error "The :INITIAL-ELEMENT option may not be specified ~
 724                       with :DISPLACED-TO."))
 725              (unless (subtypep element-type (array-element-type displaced-to))
 726                (error "can't displace an array of type ~S into another of ~
 727                        type ~S"
 728                       element-type (array-element-type displaced-to)))
 729              (let ((displacement (or displaced-index-offset 0))
 730                    (array-size (apply #'* dimensions)))
 731                (declare (fixnum displacement array-size))
 732                (if (< (the fixnum (array-total-size displaced-to))
 733                       (the fixnum (+ displacement array-size)))
 734                    (error "The :DISPLACED-TO array is too small."))
 735                (if (adjustable-array-p array)
 736                    ;; None of the original contents appear in adjusted array.
 737                    (set-array-header array displaced-to array-size
 738                                      (get-new-fill-pointer array array-size
 739                                                            fill-pointer)
 740                                      displacement dimensions t)
 741                    ;; simple multidimensional or single dimensional array
 742                    (make-array dimensions
 743                                :element-type element-type
 744                                :displaced-to displaced-to
 745                                :displaced-index-offset
 746                                displaced-index-offset))))
 747             ((= array-rank 1)
 748              (let ((old-length (array-total-size array))
 749                    (new-length (car dimensions))
 750                    new-data)
 751                (declare (fixnum old-length new-length))
 752                (with-array-data ((old-data array) (old-start)
 753                                  (old-end old-length))
 754                  (cond ((or (%array-displaced-p array)
 755                             (< old-length new-length))
 756                         (setf new-data
 757                               (data-vector-from-inits
 758                                dimensions new-length element-type
 759                                initial-contents initial-element
 760                                initial-element-p))
 761                         (replace new-data old-data
 762                                  :start2 old-start :end2 old-end))
 763                        (t (setf new-data
 764                                 (shrink-vector old-data new-length))))
 765                  (if (adjustable-array-p array)
 766                      (set-array-header array new-data new-length
 767                                        (get-new-fill-pointer array new-length
 768                                                              fill-pointer)
 769                                        0 dimensions nil)
 770                      new-data))))
 771             (t
 772              (let ((old-length (%array-available-elements array))
 773                    (new-length (apply #'* dimensions)))
 774                (declare (fixnum old-length new-length))
 775                (with-array-data ((old-data array) (old-start)
 776                                  (old-end old-length))
 777                  (declare (ignore old-end))
 778                  (let ((new-data (if (or (%array-displaced-p array)
 779                                          (> new-length old-length))
 780                                      (data-vector-from-inits
 781                                       dimensions new-length
 782                                       element-type () initial-element
 783                                       initial-element-p)
 784                                      old-data)))
 785                    (if (or (zerop old-length) (zerop new-length))
 786                        (when initial-element-p (fill new-data initial-element))
 787                        (zap-array-data old-data (array-dimensions array)
 788                                        old-start
 789                                        new-data dimensions new-length
 790                                        element-type initial-element
 791                                        initial-element-p))
 792                    (set-array-header array new-data new-length
 793                                      new-length 0 dimensions nil)))))))))
 794
 795 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
 796   (cond ((not fill-pointer)
 797          (when (array-has-fill-pointer-p old-array)
 798            (when (> (%array-fill-pointer old-array) new-array-size)
 799              (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
 800                     smaller than its fill pointer (~S)"
 801                     old-array new-array-size (fill-pointer old-array)))
 802            (%array-fill-pointer old-array)))
 803         ((not (array-has-fill-pointer-p old-array))
 804          (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
 805                 in ADJUST-ARRAY unless the array (~S) was originally ~
 806                 created with a fill pointer"
 807                 fill-pointer
 808                 old-array))
 809         ((numberp fill-pointer)
 810          (when (> fill-pointer new-array-size)
 811            (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
 812                   than the new length of the vector (~S)"
 813                   fill-pointer new-array-size))
 814          fill-pointer)
 815         ((eq fill-pointer t)
 816          new-array-size)
 817         (t
 818          (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
 819                 fill-pointer))))
 820
 821 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
 822 ;;; which must be less than or equal to its current length.
 823 (defun shrink-vector (vector new-length)
 824   (declare (vector vector))
 825   (unless (array-header-p vector)
 826     (macrolet ((frob (name &rest things)
 827                  `(etypecase ,name
 828                     ,@(mapcar (lambda (thing)
 829                                 (destructuring-bind (type-spec fill-value)
 830                                     thing
 831                                   `(,type-spec
 832                                     (fill (truly-the ,type-spec ,name)
 833                                           ,fill-value
 834                                           :start new-length))))
 835                               things))))
 836       ;; FIXME: The associations between vector types and initial
 837       ;; values here are redundant with
 838       ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
 839       (frob vector
 840         (simple-vector 0)
 841         (simple-base-string #.*default-init-char-form*)
 842         (simple-bit-vector 0)
 843         ((simple-array (unsigned-byte 2) (*)) 0)
 844         ((simple-array (unsigned-byte 4) (*)) 0)
 845         ((simple-array (unsigned-byte 8) (*)) 0)
 846         ((simple-array (unsigned-byte 16) (*)) 0)
 847         ((simple-array (unsigned-byte 32) (*)) 0)
 848         ((simple-array (signed-byte 8) (*)) 0)
 849         ((simple-array (signed-byte 16) (*)) 0)
 850         ((simple-array (signed-byte 30) (*)) 0)
 851         ((simple-array (signed-byte 32) (*)) 0)
 852         ((simple-array single-float (*)) (coerce 0 'single-float))
 853         ((simple-array double-float (*)) (coerce 0 'double-float))
 854         #!+long-float
 855         ((simple-array long-float (*)) (coerce 0 'long-float))
 856         ((simple-array (complex single-float) (*))
 857          (coerce 0 '(complex single-float)))
 858         ((simple-array (complex double-float) (*))
 859          (coerce 0 '(complex double-float)))
 860         #!+long-float
 861         ((simple-array (complex long-float) (*))
 862          (coerce 0 '(complex long-float))))))
 863   ;; Only arrays have fill-pointers, but vectors have their length
 864   ;; parameter in the same place.
 865   (setf (%array-fill-pointer vector) new-length)
 866   vector)
 867
 868 ;;; Fill in array header with the provided information, and return the array.
 869 (defun set-array-header (array data length fill-pointer displacement dimensions
 870                          &optional displacedp)
 871   (setf (%array-data-vector array) data)
 872   (setf (%array-available-elements array) length)
 873   (cond (fill-pointer
 874          (setf (%array-fill-pointer array) fill-pointer)
 875          (setf (%array-fill-pointer-p array) t))
 876         (t
 877          (setf (%array-fill-pointer array) length)
 878          (setf (%array-fill-pointer-p array) nil)))
 879   (setf (%array-displacement array) displacement)
 880   (if (listp dimensions)
 881       (dotimes (axis (array-rank array))
 882         (declare (type index axis))
 883         (setf (%array-dimension array axis) (pop dimensions)))
 884       (setf (%array-dimension array 0) dimensions))
 885   (setf (%array-displaced-p array) displacedp)
 886   array)
 887 \f
 888 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
 889
 890 ;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
 891 ;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice.
 892 (defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
 893
 894 (defun zap-array-data-temp (length element-type initial-element
 895                             initial-element-p)
 896   (declare (fixnum length))
 897   (when (> length (the fixnum (length *zap-array-data-temp*)))
 898     (setf *zap-array-data-temp*
 899           (make-array length :initial-element t)))
 900   (when initial-element-p
 901     (unless (typep initial-element element-type)
 902       (error "~S can't be used to initialize an array of type ~S."
 903              initial-element element-type))
 904     (fill (the simple-vector *zap-array-data-temp*) initial-element
 905           :end length))
 906   *zap-array-data-temp*)
 907
 908 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
 909 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
 910 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
 911 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
 912 ;;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and INITIAL-ELEMENT-P
 913 ;;; are used when OLD-DATA and NEW-DATA are EQ; in this case, a
 914 ;;; temporary must be used and filled appropriately. When OLD-DATA and
 915 ;;; NEW-DATA are not EQ, NEW-DATA has already been filled with any
 916 ;;; specified initial-element.
 917 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
 918                        element-type initial-element initial-element-p)
 919   (declare (list old-dims new-dims))
 920   (setq old-dims (nreverse old-dims))
 921   (setq new-dims (reverse new-dims))
 922   (if (eq old-data new-data)
 923       (let ((temp (zap-array-data-temp new-length element-type
 924                                        initial-element initial-element-p)))
 925         (zap-array-data-aux old-data old-dims offset temp new-dims)
 926         (dotimes (i new-length) (setf (aref new-data i) (aref temp i))))
 927       (zap-array-data-aux old-data old-dims offset new-data new-dims)))
 928
 929 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
 930   (declare (fixnum offset))
 931   (let ((limits (mapcar #'(lambda (x y)
 932                             (declare (fixnum x y))
 933                             (1- (the fixnum (min x y))))
 934                         old-dims new-dims)))
 935     (macrolet ((bump-index-list (index limits)
 936                  `(do ((subscripts ,index (cdr subscripts))
 937                        (limits ,limits (cdr limits)))
 938                       ((null subscripts) nil)
 939                     (cond ((< (the fixnum (car subscripts))
 940                               (the fixnum (car limits)))
 941                            (rplaca subscripts
 942                                    (1+ (the fixnum (car subscripts))))
 943                            (return ,index))
 944                           (t (rplaca subscripts 0))))))
 945       (do ((index (make-list (length old-dims) :initial-element 0)
 946                   (bump-index-list index limits)))
 947           ((null index))
 948         (setf (aref new-data (row-major-index-from-dims index new-dims))
 949               (aref old-data
 950                     (+ (the fixnum (row-major-index-from-dims index old-dims))
 951                        offset)))))))
 952
 953 ;;; Figure out the row-major-order index of an array reference from a
 954 ;;; list of subscripts and a list of dimensions. This is for internal
 955 ;;; calls only, and the subscripts and dim-list variables are assumed
 956 ;;; to be reversed from what the user supplied.
 957 (defun row-major-index-from-dims (rev-subscripts rev-dim-list)
 958   (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
 959        (rev-dim-list rev-dim-list (cdr rev-dim-list))
 960        (chunk-size 1)
 961        (result 0))
 962       ((null rev-dim-list) result)
 963     (declare (fixnum chunk-size result))
 964     (setq result (+ result
 965                     (the fixnum (* (the fixnum (car rev-subscripts))
 966                                    chunk-size))))
 967     (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
 968 \f
 969 ;;;; some bit stuff
 970
 971 (defun bit-array-same-dimensions-p (array1 array2)
 972   (declare (type (array bit) array1 array2))
 973   (and (= (array-rank array1)
 974           (array-rank array2))
 975        (dotimes (index (array-rank array1) t)
 976          (when (/= (array-dimension array1 index)
 977                    (array-dimension array2 index))
 978            (return nil)))))
 979
 980 (defun pick-result-array (result-bit-array bit-array-1)
 981   (case result-bit-array
 982     ((t) bit-array-1)
 983     ((nil) (make-array (array-dimensions bit-array-1)
 984                        :element-type 'bit
 985                        :initial-element 0))
 986     (t
 987      (unless (bit-array-same-dimensions-p bit-array-1
 988                                           result-bit-array)
 989        (error "~S and ~S don't have the same dimensions."
 990               bit-array-1 result-bit-array))
 991      result-bit-array)))
 992
 993 (defmacro def-bit-array-op (name function)
 994   `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
 995      ,(format nil
 996               "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
 997               BIT-ARRAY-2,~%  putting the results in RESULT-BIT-ARRAY. ~
 998               If RESULT-BIT-ARRAY is T,~%  BIT-ARRAY-1 is used. If ~
 999               RESULT-BIT-ARRAY is NIL or omitted, a new array is~%  created. ~
1000               All the arrays must have the same rank and dimensions."
1001               (symbol-name function))
1002      (declare (type (array bit) bit-array-1 bit-array-2)
1003               (type (or (array bit) (member t nil)) result-bit-array))
1004      (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
1005        (error "~S and ~S don't have the same dimensions."
1006               bit-array-1 bit-array-2))
1007      (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
1008        (if (and (simple-bit-vector-p bit-array-1)
1009                 (simple-bit-vector-p bit-array-2)
1010                 (simple-bit-vector-p result-bit-array))
1011            (locally (declare (optimize (speed 3) (safety 0)))
1012              (,name bit-array-1 bit-array-2 result-bit-array))
1013            (with-array-data ((data1 bit-array-1) (start1) (end1))
1014              (declare (ignore end1))
1015              (with-array-data ((data2 bit-array-2) (start2) (end2))
1016                (declare (ignore end2))
1017                (with-array-data ((data3 result-bit-array) (start3) (end3))
1018                  (do ((index-1 start1 (1+ index-1))
1019                       (index-2 start2 (1+ index-2))
1020                       (index-3 start3 (1+ index-3)))
1021                      ((>= index-3 end3) result-bit-array)
1022                    (declare (type index index-1 index-2 index-3))
1023                    (setf (sbit data3 index-3)
1024                          (logand (,function (sbit data1 index-1)
1025                                             (sbit data2 index-2))
1026                                  1))))))))))
1027
1028 (def-bit-array-op bit-and logand)
1029 (def-bit-array-op bit-ior logior)
1030 (def-bit-array-op bit-xor logxor)
1031 (def-bit-array-op bit-eqv logeqv)
1032 (def-bit-array-op bit-nand lognand)
1033 (def-bit-array-op bit-nor lognor)
1034 (def-bit-array-op bit-andc1 logandc1)
1035 (def-bit-array-op bit-andc2 logandc2)
1036 (def-bit-array-op bit-orc1 logorc1)
1037 (def-bit-array-op bit-orc2 logorc2)
1038
1039 (defun bit-not (bit-array &optional result-bit-array)
1040   #!+sb-doc
1041   "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1042   putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1043   BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1044   created. Both arrays must have the same rank and dimensions."
1045   (declare (type (array bit) bit-array)
1046            (type (or (array bit) (member t nil)) result-bit-array))
1047   (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
1048     (if (and (simple-bit-vector-p bit-array)
1049              (simple-bit-vector-p result-bit-array))
1050         (locally (declare (optimize (speed 3) (safety 0)))
1051           (bit-not bit-array result-bit-array))
1052         (with-array-data ((src bit-array) (src-start) (src-end))
1053           (declare (ignore src-end))
1054           (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
1055             (do ((src-index src-start (1+ src-index))
1056                  (dst-index dst-start (1+ dst-index)))
1057                 ((>= dst-index dst-end) result-bit-array)
1058               (declare (type index src-index dst-index))
1059               (setf (sbit dst dst-index)
1060                     (logxor (sbit src src-index) 1))))))))