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