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