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/fp (array start end)
  50   (%with-array-data-macro array start end :check-bounds t :check-fill-pointer t))
  51
  52 (defun %with-array-data (array start end)
  53   (%with-array-data-macro array start end :check-bounds t :check-fill-pointer nil))
  54
  55 (defun %data-vector-and-index (array index)
  56   (if (array-header-p array)
  57       (multiple-value-bind (vector index)
  58           (%with-array-data array index nil)
  59         (values vector index))
  60       (values array index)))
  61 \f
  62 ;;;; MAKE-ARRAY
  63 (eval-when (:compile-toplevel :execute)
  64   (sb!xc:defmacro pick-vector-type (type &rest specs)
  65     `(cond ,@(mapcar (lambda (spec)
  66                        `(,(if (eq (car spec) t)
  67                               t
  68                               `(subtypep ,type ',(car spec)))
  69                          ,@(cdr spec)))
  70                      specs))))
  71
  72 ;;; These functions are used in the implementation of MAKE-ARRAY for
  73 ;;; complex arrays. There are lots of transforms to simplify
  74 ;;; MAKE-ARRAY for various easy cases, but not for all reasonable
  75 ;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
  76 ;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
  77 ;;; making this somewhat efficient, at least not doing full calls to
  78 ;;; SUBTYPEP in the easy cases.
  79 (defun %vector-widetag-and-n-bits (type)
  80   (case type
  81     ;; Pick off some easy common cases.
  82     ;;
  83     ;; (Perhaps we should make a much more exhaustive table of easy
  84     ;; common cases here. Or perhaps the effort would be better spent
  85     ;; on smarter compiler transforms which do the calculation once
  86     ;; and for all in any reasonable user programs.)
  87     ((t)
  88      (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
  89     ((base-char standard-char #!-sb-unicode character)
  90      (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
  91     #!+sb-unicode
  92     ((character)
  93      (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits))
  94     ((bit)
  95      (values #.sb!vm:simple-bit-vector-widetag 1))
  96     ;; OK, we have to wade into SUBTYPEPing after all.
  97     (t
  98      #.`(pick-vector-type type
  99          ,@(map 'list
 100                 (lambda (saetp)
 101                   `(,(sb!vm:saetp-specifier saetp)
 102                     (values ,(sb!vm:saetp-typecode saetp)
 103                             ,(sb!vm:saetp-n-bits saetp))))
 104                 sb!vm:*specialized-array-element-type-properties*)))))
 105
 106 (defun %complex-vector-widetag (type)
 107   (case type
 108     ;; Pick off some easy common cases.
 109     ((t)
 110      #.sb!vm:complex-vector-widetag)
 111     ((base-char #!-sb-unicode character)
 112      #.sb!vm:complex-base-string-widetag)
 113     #!+sb-unicode
 114     ((character)
 115      #.sb!vm:complex-character-string-widetag)
 116     ((nil)
 117      #.sb!vm:complex-vector-nil-widetag)
 118     ((bit)
 119      #.sb!vm:complex-bit-vector-widetag)
 120     ;; OK, we have to wade into SUBTYPEPing after all.
 121     (t
 122      (pick-vector-type type
 123        (nil #.sb!vm:complex-vector-nil-widetag)
 124        #!-sb-unicode
 125        (character #.sb!vm:complex-base-string-widetag)
 126        #!+sb-unicode
 127        (base-char #.sb!vm:complex-base-string-widetag)
 128        #!+sb-unicode
 129        (character #.sb!vm:complex-character-string-widetag)
 130        (bit #.sb!vm:complex-bit-vector-widetag)
 131        (t #.sb!vm:complex-vector-widetag)))))
 132
 133 (defun make-array (dimensions &key
 134                               (element-type t)
 135                               (initial-element nil initial-element-p)
 136                               (initial-contents nil initial-contents-p)
 137                               adjustable fill-pointer
 138                               displaced-to displaced-index-offset)
 139   (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
 140          (array-rank (length (the list dimensions)))
 141          (simple (and (null fill-pointer)
 142                       (not adjustable)
 143                       (null displaced-to))))
 144     (declare (fixnum array-rank))
 145     (when (and displaced-index-offset (null displaced-to))
 146       (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
 147     (when (and displaced-to
 148                (arrayp displaced-to)
 149                (not (equal (array-element-type displaced-to)
 150                            (upgraded-array-element-type element-type))))
 151       (error "Array element type of :DISPLACED-TO array does not match specified element type"))
 152     (if (and simple (= array-rank 1))
 153         ;; it's a (SIMPLE-ARRAY * (*))
 154         (multiple-value-bind (type n-bits)
 155             (%vector-widetag-and-n-bits element-type)
 156           (declare (type (unsigned-byte 8) type)
 157                    (type (integer 0 256) n-bits))
 158           (let* ((length (car dimensions))
 159                  (array (allocate-vector
 160                          type
 161                          length
 162                          (ceiling
 163                           (* (if (or (= type sb!vm:simple-base-string-widetag)
 164                                      #!+sb-unicode
 165                                      (= type
 166                                         sb!vm:simple-character-string-widetag))
 167                                  (1+ length)
 168                                  length)
 169                              n-bits)
 170                           sb!vm:n-word-bits))))
 171             (declare (type index length))
 172             (when initial-element-p
 173               (fill array initial-element))
 174             (when initial-contents-p
 175               (when initial-element-p
 176                 (error "can't specify both :INITIAL-ELEMENT and ~
 177                        :INITIAL-CONTENTS"))
 178               (unless (= length (length initial-contents))
 179                 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
 180                        the vector length is ~W."
 181                        (length initial-contents)
 182                        length))
 183               (replace array initial-contents))
 184             array))
 185         ;; it's either a complex array or a multidimensional array.
 186         (let* ((total-size (reduce #'* dimensions))
 187                (data (or displaced-to
 188                          (data-vector-from-inits
 189                           dimensions total-size element-type
 190                           initial-contents initial-contents-p
 191                           initial-element initial-element-p)))
 192                (array (make-array-header
 193                        (cond ((= array-rank 1)
 194                               (%complex-vector-widetag element-type))
 195                              (simple sb!vm:simple-array-widetag)
 196                              (t sb!vm:complex-array-widetag))
 197                        array-rank)))
 198           (cond (fill-pointer
 199                  (unless (= array-rank 1)
 200                    (error "Only vectors can have fill pointers."))
 201                  (let ((length (car dimensions)))
 202                    (declare (fixnum length))
 203                    (setf (%array-fill-pointer array)
 204                      (cond ((eq fill-pointer t)
 205                             length)
 206                            (t
 207                             (unless (and (fixnump fill-pointer)
 208                                          (>= fill-pointer 0)
 209                                          (<= fill-pointer length))
 210                               ;; FIXME: should be TYPE-ERROR?
 211                               (error "invalid fill-pointer ~W"
 212                                      fill-pointer))
 213                             fill-pointer))))
 214                  (setf (%array-fill-pointer-p array) t))
 215                 (t
 216                  (setf (%array-fill-pointer array) total-size)
 217                  (setf (%array-fill-pointer-p array) nil)))
 218           (setf (%array-available-elements array) total-size)
 219           (setf (%array-data-vector array) data)
 220           (cond (displaced-to
 221                  (when (or initial-element-p initial-contents-p)
 222                    (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
 223                    can be specified along with :DISPLACED-TO"))
 224                  (let ((offset (or displaced-index-offset 0)))
 225                    (when (> (+ offset total-size)
 226                             (array-total-size displaced-to))
 227                      (error "~S doesn't have enough elements." displaced-to))
 228                    (setf (%array-displacement array) offset)
 229                    (setf (%array-displaced-p array) t)))
 230                 (t
 231                  (setf (%array-displaced-p array) nil)))
 232           (let ((axis 0))
 233             (dolist (dim dimensions)
 234               (setf (%array-dimension array axis) dim)
 235               (incf axis)))
 236           array))))
 237
 238 (defun make-static-vector (length &key
 239                            (element-type '(unsigned-byte 8))
 240                            (initial-contents nil initial-contents-p)
 241                            (initial-element nil initial-element-p))
 242   "Allocate vector of LENGTH elements in static space. Only allocation
 243 of specialized arrays is supported."
 244   ;; STEP 1: check inputs fully
 245   ;;
 246   ;; This way of doing explicit checks before the vector is allocated
 247   ;; is expensive, but probably worth the trouble as once we've allocated
 248   ;; the vector we have no way to get rid of it anymore...
 249   (when (eq t (upgraded-array-element-type element-type))
 250     (error "Static arrays of type ~S not supported."
 251            element-type))
 252   (when initial-contents-p
 253     (when initial-element-p
 254       (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
 255     (unless (= length (length initial-contents))
 256       (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
 257               vector length is ~W."
 258              (length initial-contents)
 259              length))
 260     (unless (every (lambda (x) (typep x element-type)) initial-contents)
 261       (error ":INITIAL-CONTENTS contains elements not of type ~S."
 262              element-type)))
 263   (when initial-element-p
 264     (unless (typep initial-element element-type)
 265       (error ":INITIAL-ELEMENT ~S is not of type ~S."
 266              initial-element element-type)))
 267   ;; STEP 2
 268   ;;
 269   ;; Allocate and possibly initialize the vector.
 270   (multiple-value-bind (type n-bits)
 271       (sb!impl::%vector-widetag-and-n-bits element-type)
 272     (let ((vector
 273            (allocate-static-vector type length
 274                                    (ceiling (* length n-bits)
 275                                             sb!vm:n-word-bits))))
 276       (cond (initial-element-p
 277              (fill vector initial-element))
 278             (initial-contents-p
 279              (replace vector initial-contents))
 280             (t
 281              vector)))))
 282
 283 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
 284 ;;; specified array characteristics. Dimensions is only used to pass
 285 ;;; to FILL-DATA-VECTOR for error checking on the structure of
 286 ;;; initial-contents.
 287 (defun data-vector-from-inits (dimensions total-size element-type
 288                                initial-contents initial-contents-p
 289                                initial-element initial-element-p)
 290   (when (and initial-contents-p initial-element-p)
 291     (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
 292             either MAKE-ARRAY or ADJUST-ARRAY."))
 293   (let ((data (if initial-element-p
 294                   (make-array total-size
 295                               :element-type element-type
 296                               :initial-element initial-element)
 297                   (make-array total-size
 298                               :element-type element-type))))
 299     (cond (initial-element-p
 300            (unless (simple-vector-p data)
 301              (unless (typep initial-element element-type)
 302                (error "~S cannot be used to initialize an array of type ~S."
 303                       initial-element element-type))
 304              (fill (the vector data) initial-element)))
 305           (initial-contents-p
 306            (fill-data-vector data dimensions initial-contents)))
 307     data))
 308
 309 (defun vector (&rest objects)
 310   #!+sb-doc
 311   "Construct a SIMPLE-VECTOR from the given objects."
 312   (coerce (the list objects) 'simple-vector))
 313 \f
 314
 315 ;;;; accessor/setter functions
 316
 317 ;;; Dispatch to an optimized routine the data vector accessors for
 318 ;;; each different specialized vector type. Do dispatching by looking
 319 ;;; up the widetag in the array rather than with the typecases, which
 320 ;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
 321 ;;; provide separate versions where bounds checking has been moved
 322 ;;; from the callee to the caller, since it's much cheaper to do once
 323 ;;; the type information is available. Finally, for each of these
 324 ;;; routines also provide a slow path, taken for arrays that are not
 325 ;;; vectors or not simple.
 326 (macrolet ((%define (table-name extra-params)
 327              `(funcall
 328                (the function
 329                  (let ((tag 0)
 330                        (offset
 331                         #.(ecase sb!c:*backend-byte-order*
 332                             (:little-endian
 333                              (- sb!vm:other-pointer-lowtag))
 334                             (:big-endian
 335                              (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
 336                    ;; WIDETAG-OF needs extra code to handle
 337                    ;; LIST and FUNCTION lowtags. We're only
 338                    ;; dispatching on other pointers, so let's
 339                    ;; do the lowtag extraction manually.
 340                    (when (sb!vm::%other-pointer-p array)
 341                      (setf tag
 342                            (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address array))
 343                                              offset)))
 344                    ;; SYMBOL-GLOBAL-VALUE is a performance hack
 345                    ;; for threaded builds.
 346                    (svref (sb!vm::symbol-global-value ',table-name) tag)))
 347                array index ,@extra-params))
 348            (define (accessor-name slow-accessor-name table-name extra-params
 349                                   check-bounds)
 350                `(progn
 351                  (defvar ,table-name)
 352                  (defun ,accessor-name (array index ,@extra-params)
 353                    (declare (optimize speed
 354                                       ;; (SAFETY 0) is ok. All calls to
 355                                       ;; these functions are generated by
 356                                       ;; the compiler, so argument count
 357                                       ;; checking isn't needed. Type checking
 358                                       ;; is done implicitly via the widetag
 359                                       ;; dispatch.
 360                                       (safety 0)))
 361                    (%define ,table-name ,extra-params))
 362                  (defun ,slow-accessor-name (array index ,@extra-params)
 363                    (declare (optimize speed (safety 0)))
 364                    (if (not (%array-displaced-p array))
 365                        ;; The reasonably quick path of non-displaced complex
 366                        ;; arrays.
 367                        (let ((array (%array-data-vector array)))
 368                          (%define ,table-name ,extra-params))
 369                        ;; The real slow path.
 370                        (with-array-data
 371                            ((vector array)
 372                             (index (locally
 373                                        (declare (optimize (speed 1) (safety 1)))
 374                                      (,@check-bounds index)))
 375                             (end)
 376                             :force-inline t)
 377                          (declare (ignore end))
 378                          (,accessor-name vector index ,@extra-params)))))))
 379   (define hairy-data-vector-ref slow-hairy-data-vector-ref
 380     *data-vector-reffers* nil (progn))
 381   (define hairy-data-vector-set slow-hairy-data-vector-set
 382     *data-vector-setters* (new-value) (progn))
 383   (define hairy-data-vector-ref/check-bounds
 384       slow-hairy-data-vector-ref/check-bounds
 385     *data-vector-reffers/check-bounds* nil
 386     (%check-bound array (array-dimension array 0)))
 387   (define hairy-data-vector-set/check-bounds
 388       slow-hairy-data-vector-set/check-bounds
 389     *data-vector-setters/check-bounds* (new-value)
 390     (%check-bound array (array-dimension array 0))))
 391
 392 (defun hairy-ref-error (array index &optional new-value)
 393   (declare (ignore index new-value))
 394   (error 'type-error
 395          :datum array
 396          :expected-type 'vector))
 397
 398 ;;; Populate the dispatch tables.
 399 (macrolet ((define-reffer (saetp check-form)
 400              (let* ((type (sb!vm:saetp-specifier saetp))
 401                     (atype `(simple-array ,type (*))))
 402                `(named-lambda optimized-data-vector-ref (vector index)
 403                   (declare (optimize speed (safety 0)))
 404                   (data-vector-ref (the ,atype vector)
 405                                    (locally
 406                                        (declare (optimize (safety 1)))
 407                                      (the index
 408                                        (,@check-form index)))))))
 409            (define-setter (saetp check-form)
 410              (let* ((type (sb!vm:saetp-specifier saetp))
 411                     (atype `(simple-array ,type (*))))
 412                `(named-lambda optimized-data-vector-set (vector index new-value)
 413                   (declare (optimize speed (safety 0)))
 414                   (data-vector-set (the ,atype vector)
 415                                    (locally
 416                                        (declare (optimize (safety 1)))
 417                                      (the index
 418                                        (,@check-form index)))
 419                                    (locally
 420                                        ;; SPEED 1 needed to avoid the compiler
 421                                        ;; from downgrading the type check to
 422                                        ;; a cheaper one.
 423                                        (declare (optimize (speed 1)
 424                                                           (safety 1)))
 425                                      (the ,type new-value)))
 426                   ;; For specialized arrays, the return from
 427                   ;; data-vector-set would have to be reboxed to be a
 428                   ;; (Lisp) return value; instead, we use the
 429                   ;; already-boxed value as the return.
 430                   new-value)))
 431            (define-reffers (symbol deffer check-form slow-path)
 432              `(progn
 433                 (setf ,symbol (make-array sb!vm::widetag-mask
 434                                           :initial-element #'hairy-ref-error))
 435                 ,@(loop for widetag in '(sb!vm:complex-vector-widetag
 436                                          sb!vm:complex-vector-nil-widetag
 437                                          sb!vm:complex-bit-vector-widetag
 438                                          #!+sb-unicode sb!vm:complex-character-string-widetag
 439                                          sb!vm:complex-base-string-widetag
 440                                          sb!vm:simple-array-widetag
 441                                          sb!vm:complex-array-widetag)
 442                         collect `(setf (svref ,symbol ,widetag) ,slow-path))
 443                 ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
 444                         for widetag = (sb!vm:saetp-typecode saetp)
 445                         collect `(setf (svref ,symbol ,widetag)
 446                                        (,deffer ,saetp ,check-form))))))
 447   (defun !hairy-data-vector-reffer-init ()
 448     (define-reffers *data-vector-reffers* define-reffer
 449       (progn)
 450       #'slow-hairy-data-vector-ref)
 451     (define-reffers *data-vector-setters* define-setter
 452       (progn)
 453       #'slow-hairy-data-vector-set)
 454     (define-reffers *data-vector-reffers/check-bounds* define-reffer
 455       (%check-bound vector (length vector))
 456       #'slow-hairy-data-vector-ref/check-bounds)
 457     (define-reffers *data-vector-setters/check-bounds* define-setter
 458       (%check-bound vector (length vector))
 459       #'slow-hairy-data-vector-set/check-bounds)))
 460
 461 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
 462 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
 463 ;;; definition is needed for the compiler to use in constant folding.)
 464 (defun data-vector-ref (array index)
 465   (hairy-data-vector-ref array index))
 466
 467 (defun data-vector-ref-with-offset (array index offset)
 468   (hairy-data-vector-ref array (+ index offset)))
 469
 470 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 471 (defun %array-row-major-index (array subscripts
 472                                      &optional (invalid-index-error-p t))
 473   (declare (array array)
 474            (list subscripts))
 475   (let ((rank (array-rank array)))
 476     (unless (= rank (length subscripts))
 477       (error "wrong number of subscripts, ~W, for array of rank ~W"
 478              (length subscripts) rank))
 479     (if (array-header-p array)
 480         (do ((subs (nreverse subscripts) (cdr subs))
 481              (axis (1- (array-rank array)) (1- axis))
 482              (chunk-size 1)
 483              (result 0))
 484             ((null subs) result)
 485           (declare (list subs) (fixnum axis chunk-size result))
 486           (let ((index (car subs))
 487                 (dim (%array-dimension array axis)))
 488             (declare (fixnum dim))
 489             (unless (and (fixnump index) (< -1 index dim))
 490               (if invalid-index-error-p
 491                   (error 'simple-type-error
 492                          :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
 493                          :format-arguments (list index axis array)
 494                          :datum index
 495                          :expected-type `(integer 0 (,dim)))
 496                   (return-from %array-row-major-index nil)))
 497             (incf result (* chunk-size (the fixnum index)))
 498             (setf chunk-size (* chunk-size dim))))
 499         (let ((index (first subscripts))
 500               (length (length (the (simple-array * (*)) array))))
 501           (unless (and (fixnump index) (< -1 index length))
 502             (if invalid-index-error-p
 503                 ;; FIXME: perhaps this should share a format-string
 504                 ;; with INVALID-ARRAY-INDEX-ERROR or
 505                 ;; INDEX-TOO-LARGE-ERROR?
 506                 (error 'simple-type-error
 507                        :format-control "invalid index ~W in ~S"
 508                        :format-arguments (list index array)
 509                        :datum index
 510                        :expected-type `(integer 0 (,length)))
 511                 (return-from %array-row-major-index nil)))
 512           index))))
 513
 514 (defun array-in-bounds-p (array &rest subscripts)
 515   #!+sb-doc
 516   "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
 517   (if (%array-row-major-index array subscripts nil)
 518       t))
 519
 520 (defun array-row-major-index (array &rest subscripts)
 521   (declare (dynamic-extent subscripts))
 522   (%array-row-major-index array subscripts))
 523
 524 (defun aref (array &rest subscripts)
 525   #!+sb-doc
 526   "Return the element of the ARRAY specified by the SUBSCRIPTS."
 527   (declare (dynamic-extent subscripts))
 528   (row-major-aref array (%array-row-major-index array subscripts)))
 529
 530 (defun %aset (array &rest stuff)
 531   (declare (dynamic-extent stuff))
 532   (let ((subscripts (butlast stuff))
 533         (new-value (car (last stuff))))
 534     (setf (row-major-aref array (%array-row-major-index array subscripts))
 535           new-value)))
 536
 537 ;;; FIXME: What's supposed to happen with functions
 538 ;;; like AREF when we (DEFUN (SETF FOO) ..) when
 539 ;;; DEFSETF FOO is also defined? It seems as though the logical
 540 ;;; thing to do would be to nuke the macro definition for (SETF FOO)
 541 ;;; and replace it with the (SETF FOO) function, issuing a warning,
 542 ;;; just as for ordinary functions
 543 ;;;  * (LISP-IMPLEMENTATION-VERSION)
 544 ;;;  "18a+ release x86-linux 2.4.7 6 November 1998 cvs"
 545 ;;;  * (DEFMACRO ZOO (X) `(+ ,X ,X))
 546 ;;;  ZOO
 547 ;;;  * (DEFUN ZOO (X) (* 3 X))
 548 ;;;  Warning: ZOO previously defined as a macro.
 549 ;;;  ZOO
 550 ;;; But that doesn't seem to be what happens in CMU CL.
 551 ;;;
 552 ;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS
 553 ;;; 5.1.2.5) requires implementations to support
 554 ;;;   (SETF (APPLY #'AREF ...) ...)
 555 ;;; [and also #'BIT and #'SBIT].  Yes, this is terrifying, and it's
 556 ;;; also terrifying that this sequence of definitions causes it to
 557 ;;; work.
 558 ;;;
 559 ;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
 560 ;;; has a setf expansion and/or a setf function defined.
 561
 562 #!-sb-fluid (declaim (inline (setf aref)))
 563 (defun (setf aref) (new-value array &rest subscripts)
 564   (declare (dynamic-extent subscripts))
 565   (declare (type array array))
 566   (setf (row-major-aref array (%array-row-major-index array subscripts))
 567         new-value))
 568
 569 (defun row-major-aref (array index)
 570   #!+sb-doc
 571   "Return the element of array corressponding to the row-major index. This is
 572    SETF'able."
 573   (declare (optimize (safety 1)))
 574   (row-major-aref array index))
 575
 576 (defun %set-row-major-aref (array index new-value)
 577   (declare (optimize (safety 1)))
 578   (setf (row-major-aref array index) new-value))
 579
 580 (defun svref (simple-vector index)
 581   #!+sb-doc
 582   "Return the INDEX'th element of the given Simple-Vector."
 583   (declare (optimize (safety 1)))
 584   (aref simple-vector index))
 585
 586 (defun %svset (simple-vector index new)
 587   (declare (optimize (safety 1)))
 588   (setf (aref simple-vector index) new))
 589
 590 (defun bit (bit-array &rest subscripts)
 591   #!+sb-doc
 592   "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
 593   (declare (type (array bit) bit-array) (optimize (safety 1)))
 594   (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
 595
 596 (defun %bitset (bit-array &rest stuff)
 597   (declare (type (array bit) bit-array) (optimize (safety 1)))
 598   (let ((subscripts (butlast stuff))
 599         (new-value (car (last stuff))))
 600     (setf (row-major-aref bit-array
 601                           (%array-row-major-index bit-array subscripts))
 602           new-value)))
 603
 604 #!-sb-fluid (declaim (inline (setf bit)))
 605 (defun (setf bit) (new-value bit-array &rest subscripts)
 606   (declare (type (array bit) bit-array) (optimize (safety 1)))
 607   (setf (row-major-aref bit-array
 608                         (%array-row-major-index bit-array subscripts))
 609         new-value))
 610
 611 (defun sbit (simple-bit-array &rest subscripts)
 612   #!+sb-doc
 613   "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
 614   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
 615   (row-major-aref simple-bit-array
 616                   (%array-row-major-index simple-bit-array subscripts)))
 617
 618 ;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER,
 619 ;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names.
 620 ;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names?
 621 ;;; -- WHN 19990911
 622 (defun %sbitset (simple-bit-array &rest stuff)
 623   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
 624   (let ((subscripts (butlast stuff))
 625         (new-value (car (last stuff))))
 626     (setf (row-major-aref simple-bit-array
 627                           (%array-row-major-index simple-bit-array subscripts))
 628           new-value)))
 629
 630 #!-sb-fluid (declaim (inline (setf sbit)))
 631 (defun (setf sbit) (new-value bit-array &rest subscripts)
 632   (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
 633   (setf (row-major-aref bit-array
 634                         (%array-row-major-index bit-array subscripts))
 635         new-value))
 636 \f
 637 ;;;; miscellaneous array properties
 638
 639 (defun array-element-type (array)
 640   #!+sb-doc
 641   "Return the type of the elements of the array"
 642   (let ((widetag (widetag-of array)))
 643     (macrolet ((pick-element-type (&rest stuff)
 644                  `(cond ,@(mapcar (lambda (stuff)
 645                                     (cons
 646                                      (let ((item (car stuff)))
 647                                        (cond ((eq item t)
 648                                               t)
 649                                              ((listp item)
 650                                               (cons 'or
 651                                                     (mapcar (lambda (x)
 652                                                               `(= widetag ,x))
 653                                                             item)))
 654                                              (t
 655                                               `(= widetag ,item))))
 656                                      (cdr stuff)))
 657                                   stuff))))
 658       #.`(pick-element-type
 659           ,@(map 'list
 660                  (lambda (saetp)
 661                    `(,(if (sb!vm:saetp-complex-typecode saetp)
 662                           (list (sb!vm:saetp-typecode saetp)
 663                                 (sb!vm:saetp-complex-typecode saetp))
 664                           (sb!vm:saetp-typecode saetp))
 665                      ',(sb!vm:saetp-specifier saetp)))
 666                  sb!vm:*specialized-array-element-type-properties*)
 667           ((sb!vm:simple-array-widetag
 668             sb!vm:complex-vector-widetag
 669             sb!vm:complex-array-widetag)
 670            (with-array-data ((array array) (start) (end))
 671              (declare (ignore start end))
 672              (array-element-type array)))
 673           (t
 674            (error 'type-error :datum array :expected-type 'array))))))
 675
 676 (defun array-rank (array)
 677   #!+sb-doc
 678   "Return the number of dimensions of ARRAY."
 679   (if (array-header-p array)
 680       (%array-rank array)
 681       1))
 682
 683 (defun array-dimension (array axis-number)
 684   #!+sb-doc
 685   "Return the length of dimension AXIS-NUMBER of ARRAY."
 686   (declare (array array) (type index axis-number))
 687   (cond ((not (array-header-p array))
 688          (unless (= axis-number 0)
 689            (error "Vector axis is not zero: ~S" axis-number))
 690          (length (the (simple-array * (*)) array)))
 691         ((>= axis-number (%array-rank array))
 692          (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
 693                 axis-number array (%array-rank array)))
 694         (t
 695          ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
 696          ;;
 697          ;;   "If A is displaced to B, the consequences are
 698          ;;   unspecified if B is adjusted in such a way that it no
 699          ;;   longer has enough elements to satisfy A.
 700          ;;
 701          ;; In situations where this matters we should be doing a
 702          ;; bounds-check, which in turn uses ARRAY-DIMENSION -- so
 703          ;; this seems like a good place to signal an error.
 704          (multiple-value-bind (target offset) (array-displacement array)
 705            (when (and target
 706                       (> (array-total-size array)
 707                          (- (array-total-size target) offset)))
 708                (error 'displaced-to-array-too-small-error
 709                       :format-control "~@<The displaced-to array is too small. ~S ~
 710                                       elements after offset required, ~S available.~:@>"
 711                       :format-arguments (list (array-total-size array)
 712                                               (- (array-total-size target) offset))))
 713            (%array-dimension array axis-number)))))
 714
 715 (defun array-dimensions (array)
 716   #!+sb-doc
 717   "Return a list whose elements are the dimensions of the array"
 718   (declare (array array))
 719   (if (array-header-p array)
 720       (do ((results nil (cons (array-dimension array index) results))
 721            (index (1- (array-rank array)) (1- index)))
 722           ((minusp index) results))
 723       (list (array-dimension array 0))))
 724
 725 (defun array-total-size (array)
 726   #!+sb-doc
 727   "Return the total number of elements in the Array."
 728   (declare (array array))
 729   (if (array-header-p array)
 730       (%array-available-elements array)
 731       (length (the vector array))))
 732
 733 (defun array-displacement (array)
 734   #!+sb-doc
 735   "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
 736    options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
 737   (declare (type array array))
 738   (if (and (array-header-p array) ; if unsimple and
 739            (%array-displaced-p array)) ; displaced
 740       (values (%array-data-vector array) (%array-displacement array))
 741       (values nil 0)))
 742
 743 (defun adjustable-array-p (array)
 744   #!+sb-doc
 745   "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
 746    to the argument, this happens for complex arrays."
 747   (declare (array array))
 748   ;; Note that this appears not to be a fundamental limitation.
 749   ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
 750   ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
 751   ;; -- CSR, 2004-03-01.
 752   (not (typep array 'simple-array)))
 753 \f
 754 ;;;; fill pointer frobbing stuff
 755
 756 (defun array-has-fill-pointer-p (array)
 757   #!+sb-doc
 758   "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
 759   (declare (array array))
 760   (and (array-header-p array) (%array-fill-pointer-p array)))
 761
 762 (defun fill-pointer (vector)
 763   #!+sb-doc
 764   "Return the FILL-POINTER of the given VECTOR."
 765   (declare (vector vector))
 766   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
 767       (%array-fill-pointer vector)
 768       (error 'simple-type-error
 769              :datum vector
 770              :expected-type '(and vector (satisfies array-has-fill-pointer-p))
 771              :format-control "~S is not an array with a fill pointer."
 772              :format-arguments (list vector))))
 773
 774 (defun %set-fill-pointer (vector new)
 775   (declare (vector vector) (fixnum new))
 776   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
 777       (if (> new (%array-available-elements vector))
 778         (error
 779          "The new fill pointer, ~S, is larger than the length of the vector."
 780          new)
 781         (setf (%array-fill-pointer vector) new))
 782       (error 'simple-type-error
 783              :datum vector
 784              :expected-type '(and vector (satisfies array-has-fill-pointer-p))
 785              :format-control "~S is not an array with a fill pointer."
 786              :format-arguments (list vector))))
 787
 788 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
 789 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
 790 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
 791 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
 792 ;;; back to CMU CL).
 793 (defun vector-push (new-el array)
 794   #!+sb-doc
 795   "Attempt to set the element of ARRAY designated by its fill pointer
 796    to NEW-EL, and increment the fill pointer by one. If the fill pointer is
 797    too large, NIL is returned, otherwise the index of the pushed element is
 798    returned."
 799   (declare (vector array))
 800   (let ((fill-pointer (fill-pointer array)))
 801     (declare (fixnum fill-pointer))
 802     (cond ((= fill-pointer (%array-available-elements array))
 803            nil)
 804           (t
 805            (setf (aref array fill-pointer) new-el)
 806            (setf (%array-fill-pointer array) (1+ fill-pointer))
 807            fill-pointer))))
 808
 809 (defun vector-push-extend (new-element
 810                            vector
 811                            &optional
 812                            (extension (1+ (length vector))))
 813   (declare (vector vector) (fixnum extension))
 814   (let ((fill-pointer (fill-pointer vector)))
 815     (declare (fixnum fill-pointer))
 816     (when (= fill-pointer (%array-available-elements vector))
 817       (adjust-array vector (+ fill-pointer extension)))
 818     ;; disable bounds checking
 819     (locally (declare (optimize (safety 0)))
 820       (setf (aref vector fill-pointer) new-element))
 821     (setf (%array-fill-pointer vector) (1+ fill-pointer))
 822     fill-pointer))
 823
 824 (defun vector-pop (array)
 825   #!+sb-doc
 826   "Decrease the fill pointer by 1 and return the element pointed to by the
 827   new fill pointer."
 828   (declare (vector array))
 829   (let ((fill-pointer (fill-pointer array)))
 830     (declare (fixnum fill-pointer))
 831     (if (zerop fill-pointer)
 832         (error "There is nothing left to pop.")
 833         ;; disable bounds checking (and any fixnum test)
 834         (locally (declare (optimize (safety 0)))
 835           (aref array
 836                 (setf (%array-fill-pointer array)
 837                       (1- fill-pointer)))))))
 838
 839 \f
 840 ;;;; ADJUST-ARRAY
 841
 842 (defun adjust-array (array dimensions &key
 843                            (element-type (array-element-type array))
 844                            (initial-element nil initial-element-p)
 845                            (initial-contents nil initial-contents-p)
 846                            fill-pointer
 847                            displaced-to displaced-index-offset)
 848   #!+sb-doc
 849   "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
 850   (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
 851     (cond ((/= (the fixnum (length (the list dimensions)))
 852                (the fixnum (array-rank array)))
 853            (error "The number of dimensions not equal to rank of array."))
 854           ((not (subtypep element-type (array-element-type array)))
 855            (error "The new element type, ~S, is incompatible with old type."
 856                   element-type))
 857           ((and fill-pointer (not (array-has-fill-pointer-p array)))
 858            (error 'type-error
 859                   :datum array
 860                   :expected-type '(satisfies array-has-fill-pointer-p))))
 861     (let ((array-rank (length (the list dimensions))))
 862       (declare (fixnum array-rank))
 863       (unless (= array-rank 1)
 864         (when fill-pointer
 865           (error "Only vectors can have fill pointers.")))
 866       (cond (initial-contents-p
 867              ;; array former contents replaced by INITIAL-CONTENTS
 868              (if (or initial-element-p displaced-to)
 869                  (error "INITIAL-CONTENTS may not be specified with ~
 870                          the :INITIAL-ELEMENT or :DISPLACED-TO option."))
 871              (let* ((array-size (apply #'* dimensions))
 872                     (array-data (data-vector-from-inits
 873                                  dimensions array-size element-type
 874                                  initial-contents initial-contents-p
 875                                  initial-element initial-element-p)))
 876                (if (adjustable-array-p array)
 877                    (set-array-header array array-data array-size
 878                                  (get-new-fill-pointer array array-size
 879                                                        fill-pointer)
 880                                  0 dimensions nil)
 881                    (if (array-header-p array)
 882                        ;; simple multidimensional or single dimensional array
 883                        (make-array dimensions
 884                                    :element-type element-type
 885                                    :initial-contents initial-contents)
 886                        array-data))))
 887             (displaced-to
 888              ;; We already established that no INITIAL-CONTENTS was supplied.
 889              (when initial-element
 890                (error "The :INITIAL-ELEMENT option may not be specified ~
 891                        with :DISPLACED-TO."))
 892              (unless (subtypep element-type (array-element-type displaced-to))
 893                (error "can't displace an array of type ~S into another of ~
 894                        type ~S"
 895                       element-type (array-element-type displaced-to)))
 896              (let ((displacement (or displaced-index-offset 0))
 897                    (array-size (apply #'* dimensions)))
 898                (declare (fixnum displacement array-size))
 899                (if (< (the fixnum (array-total-size displaced-to))
 900                       (the fixnum (+ displacement array-size)))
 901                    (error "The :DISPLACED-TO array is too small."))
 902                (if (adjustable-array-p array)
 903                    ;; None of the original contents appear in adjusted array.
 904                    (set-array-header array displaced-to array-size
 905                                      (get-new-fill-pointer array array-size
 906                                                            fill-pointer)
 907                                      displacement dimensions t)
 908                    ;; simple multidimensional or single dimensional array
 909                    (make-array dimensions
 910                                :element-type element-type
 911                                :displaced-to displaced-to
 912                                :displaced-index-offset
 913                                displaced-index-offset))))
 914             ((= array-rank 1)
 915              (let ((old-length (array-total-size array))
 916                    (new-length (car dimensions))
 917                    new-data)
 918                (declare (fixnum old-length new-length))
 919                (with-array-data ((old-data array) (old-start)
 920                                  (old-end old-length))
 921                  (cond ((or (and (array-header-p array)
 922                                  (%array-displaced-p array))
 923                             (< old-length new-length))
 924                         (setf new-data
 925                               (data-vector-from-inits
 926                                dimensions new-length element-type
 927                                initial-contents initial-contents-p
 928                                initial-element initial-element-p))
 929                         (replace new-data old-data
 930                                  :start2 old-start :end2 old-end))
 931                        (t (setf new-data
 932                                 (shrink-vector old-data new-length))))
 933                  (if (adjustable-array-p array)
 934                      (set-array-header array new-data new-length
 935                                        (get-new-fill-pointer array new-length
 936                                                              fill-pointer)
 937                                        0 dimensions nil)
 938                      new-data))))
 939             (t
 940              (let ((old-length (%array-available-elements array))
 941                    (new-length (apply #'* dimensions)))
 942                (declare (fixnum old-length new-length))
 943                (with-array-data ((old-data array) (old-start)
 944                                  (old-end old-length))
 945                  (declare (ignore old-end))
 946                  (let ((new-data (if (or (and (array-header-p array)
 947                                               (%array-displaced-p array))
 948                                          (> new-length old-length))
 949                                      (data-vector-from-inits
 950                                       dimensions new-length
 951                                       element-type () nil
 952                                       initial-element initial-element-p)
 953                                      old-data)))
 954                    (if (or (zerop old-length) (zerop new-length))
 955                        (when initial-element-p (fill new-data initial-element))
 956                        (zap-array-data old-data (array-dimensions array)
 957                                        old-start
 958                                        new-data dimensions new-length
 959                                        element-type initial-element
 960                                        initial-element-p))
 961                    (if (adjustable-array-p array)
 962                        (set-array-header array new-data new-length
 963                                          new-length 0 dimensions nil)
 964                        (let ((new-array
 965                               (make-array-header
 966                                sb!vm:simple-array-widetag array-rank)))
 967                          (set-array-header new-array new-data new-length
 968                                            new-length 0 dimensions nil)))))))))))
 969
 970
 971 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
 972   (cond ((not fill-pointer)
 973          (when (array-has-fill-pointer-p old-array)
 974            (when (> (%array-fill-pointer old-array) new-array-size)
 975              (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
 976                      smaller than its fill pointer (~S)"
 977                     old-array new-array-size (fill-pointer old-array)))
 978            (%array-fill-pointer old-array)))
 979         ((not (array-has-fill-pointer-p old-array))
 980          (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
 981                  in ADJUST-ARRAY unless the array (~S) was originally ~
 982                  created with a fill pointer"
 983                 fill-pointer
 984                 old-array))
 985         ((numberp fill-pointer)
 986          (when (> fill-pointer new-array-size)
 987            (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
 988                    than the new length of the vector (~S)"
 989                   fill-pointer new-array-size))
 990          fill-pointer)
 991         ((eq fill-pointer t)
 992          new-array-size)
 993         (t
 994          (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
 995                 fill-pointer))))
 996
 997 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
 998 ;;; which must be less than or equal to its current length. This can
 999 ;;; be called on vectors without a fill pointer but it is extremely
1000 ;;; dangerous to do so: shrinking the size of an object (as viewed by
1001 ;;; the gc) makes bounds checking unreliable in the face of interrupts
1002 ;;; or multi-threading. Call it only on provably local vectors.
1003 (defun %shrink-vector (vector new-length)
1004   (declare (vector vector))
1005   (unless (array-header-p vector)
1006     (macrolet ((frob (name &rest things)
1007                  `(etypecase ,name
1008                     ((simple-array nil (*)) (error 'nil-array-accessed-error))
1009                     ,@(mapcar (lambda (thing)
1010                                 (destructuring-bind (type-spec fill-value)
1011                                     thing
1012                                   `(,type-spec
1013                                     (fill (truly-the ,type-spec ,name)
1014                                           ,fill-value
1015                                           :start new-length))))
1016                               things))))
1017       ;; Set the 'tail' of the vector to the appropriate type of zero,
1018       ;; "because in some cases we'll scavenge larger areas in one go,
1019       ;; like groups of pages that had triggered the write barrier, or
1020       ;; the whole static space" according to jsnell.
1021       #.`(frob vector
1022           ,@(map 'list
1023                  (lambda (saetp)
1024                    `((simple-array ,(sb!vm:saetp-specifier saetp) (*))
1025                      ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character)
1026                               #!+sb-unicode
1027                               (eq (sb!vm:saetp-specifier saetp) 'base-char))
1028                           *default-init-char-form*
1029                           (sb!vm:saetp-initial-element-default saetp))))
1030                  (remove-if-not
1031                   #'sb!vm:saetp-specifier
1032                   sb!vm:*specialized-array-element-type-properties*)))))
1033   ;; Only arrays have fill-pointers, but vectors have their length
1034   ;; parameter in the same place.
1035   (setf (%array-fill-pointer vector) new-length)
1036   vector)
1037
1038 (defun shrink-vector (vector new-length)
1039   (declare (vector vector))
1040   (cond
1041     ((eq (length vector) new-length)
1042      vector)
1043     ((array-has-fill-pointer-p vector)
1044      (setf (%array-fill-pointer vector) new-length)
1045      vector)
1046     (t (subseq vector 0 new-length))))
1047
1048 ;;; Fill in array header with the provided information, and return the array.
1049 (defun set-array-header (array data length fill-pointer displacement dimensions
1050                          &optional displacedp)
1051   (setf (%array-data-vector array) data)
1052   (setf (%array-available-elements array) length)
1053   (cond (fill-pointer
1054          (setf (%array-fill-pointer array) fill-pointer)
1055          (setf (%array-fill-pointer-p array) t))
1056         (t
1057          (setf (%array-fill-pointer array) length)
1058          (setf (%array-fill-pointer-p array) nil)))
1059   (setf (%array-displacement array) displacement)
1060   (if (listp dimensions)
1061       (dotimes (axis (array-rank array))
1062         (declare (type index axis))
1063         (setf (%array-dimension array axis) (pop dimensions)))
1064       (setf (%array-dimension array 0) dimensions))
1065   (setf (%array-displaced-p array) displacedp)
1066   array)
1067 \f
1068 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
1069
1070 ;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
1071 ;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice. This is rebound
1072 ;;; to length zero array in each new thread.
1073 ;;;
1074 ;;; DX is probably a bad idea, because a with a big array it would
1075 ;;; be fairly easy to blow the stack.
1076 (defvar *zap-array-data-temp* (vector))
1077 (declaim (simple-vector *zap-array-data-temp*))
1078
1079 (defun zap-array-data-temp (length initial-element initial-element-p)
1080   (declare (fixnum length))
1081   (let ((tmp *zap-array-data-temp*))
1082     (declare (simple-vector tmp))
1083     (cond ((> length (length tmp))
1084            (setf *zap-array-data-temp*
1085                  (if initial-element-p
1086                      (make-array length :initial-element initial-element)
1087                      (make-array length))))
1088           (initial-element-p
1089            (fill tmp initial-element :end length))
1090           (t
1091            tmp))))
1092
1093 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
1094 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
1095 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
1096 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
1097 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1098                        element-type initial-element initial-element-p)
1099   (declare (list old-dims new-dims))
1100   ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
1101   ;; at least in SBCL.
1102   ;; NEW-DIMS comes from the user.
1103   (setf old-dims (nreverse old-dims)
1104         new-dims (reverse new-dims))
1105   (cond ((eq old-data new-data)
1106          ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
1107          ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
1108          ;; EQ; in this case, a temporary must be used and filled
1109          ;; appropriately. specified initial-element.
1110          (when initial-element-p
1111            ;; FIXME: transforming this TYPEP to someting a bit faster
1112            ;; would be a win...
1113            (unless (typep initial-element element-type)
1114              (error "~S can't be used to initialize an array of type ~S."
1115                     initial-element element-type)))
1116          (without-interrupts
1117            ;; Need to disable interrupts while using the temp-vector.
1118            ;; An interrupt handler that also happened to call
1119            ;; ADJUST-ARRAY could otherwise stomp on our data here.
1120            (let ((temp (zap-array-data-temp new-length
1121                                             initial-element initial-element-p)))
1122              (declare (simple-vector temp))
1123              (zap-array-data-aux old-data old-dims offset temp new-dims)
1124              (dotimes (i new-length)
1125                (setf (aref new-data i) (aref temp i)
1126                      ;; zero out any garbage right away
1127                      (aref temp i) 0)))))
1128         (t
1129          ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
1130          ;; already been filled with any
1131          (zap-array-data-aux old-data old-dims offset new-data new-dims))))
1132
1133 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
1134   (declare (fixnum offset))
1135   (let ((limits (mapcar (lambda (x y)
1136                           (declare (fixnum x y))
1137                           (1- (the fixnum (min x y))))
1138                         old-dims new-dims)))
1139     (macrolet ((bump-index-list (index limits)
1140                  `(do ((subscripts ,index (cdr subscripts))
1141                        (limits ,limits (cdr limits)))
1142                       ((null subscripts) :eof)
1143                     (cond ((< (the fixnum (car subscripts))
1144                               (the fixnum (car limits)))
1145                            (rplaca subscripts
1146                                    (1+ (the fixnum (car subscripts))))
1147                            (return ,index))
1148                           (t (rplaca subscripts 0))))))
1149       (do ((index (make-list (length old-dims) :initial-element 0)
1150                   (bump-index-list index limits)))
1151           ((eq index :eof))
1152         (setf (aref new-data (row-major-index-from-dims index new-dims))
1153               (aref old-data
1154                     (+ (the fixnum (row-major-index-from-dims index old-dims))
1155                        offset)))))))
1156
1157 ;;; Figure out the row-major-order index of an array reference from a
1158 ;;; list of subscripts and a list of dimensions. This is for internal
1159 ;;; calls only, and the subscripts and dim-list variables are assumed
1160 ;;; to be reversed from what the user supplied.
1161 (defun row-major-index-from-dims (rev-subscripts rev-dim-list)
1162   (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
1163        (rev-dim-list rev-dim-list (cdr rev-dim-list))
1164        (chunk-size 1)
1165        (result 0))
1166       ((null rev-dim-list) result)
1167     (declare (fixnum chunk-size result))
1168     (setq result (+ result
1169                     (the fixnum (* (the fixnum (car rev-subscripts))
1170                                    chunk-size))))
1171     (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
1172 \f
1173 ;;;; some bit stuff
1174
1175 (defun bit-array-same-dimensions-p (array1 array2)
1176   (declare (type (array bit) array1 array2))
1177   (and (= (array-rank array1)
1178           (array-rank array2))
1179        (dotimes (index (array-rank array1) t)
1180          (when (/= (array-dimension array1 index)
1181                    (array-dimension array2 index))
1182            (return nil)))))
1183
1184 (defun pick-result-array (result-bit-array bit-array-1)
1185   (case result-bit-array
1186     ((t) bit-array-1)
1187     ((nil) (make-array (array-dimensions bit-array-1)
1188                        :element-type 'bit
1189                        :initial-element 0))
1190     (t
1191      (unless (bit-array-same-dimensions-p bit-array-1
1192                                           result-bit-array)
1193        (error "~S and ~S don't have the same dimensions."
1194               bit-array-1 result-bit-array))
1195      result-bit-array)))
1196
1197 (defmacro def-bit-array-op (name function)
1198   `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
1199      #!+sb-doc
1200      ,(format nil
1201               "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1202                BIT-ARRAY-2,~%  putting the results in RESULT-BIT-ARRAY. ~
1203                If RESULT-BIT-ARRAY is T,~%  BIT-ARRAY-1 is used. If ~
1204                RESULT-BIT-ARRAY is NIL or omitted, a new array is~%  created. ~
1205                All the arrays must have the same rank and dimensions."
1206               (symbol-name function))
1207      (declare (type (array bit) bit-array-1 bit-array-2)
1208               (type (or (array bit) (member t nil)) result-bit-array))
1209      (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
1210        (error "~S and ~S don't have the same dimensions."
1211               bit-array-1 bit-array-2))
1212      (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
1213        (if (and (simple-bit-vector-p bit-array-1)
1214                 (simple-bit-vector-p bit-array-2)
1215                 (simple-bit-vector-p result-bit-array))
1216            (locally (declare (optimize (speed 3) (safety 0)))
1217              (,name bit-array-1 bit-array-2 result-bit-array))
1218            (with-array-data ((data1 bit-array-1) (start1) (end1))
1219              (declare (ignore end1))
1220              (with-array-data ((data2 bit-array-2) (start2) (end2))
1221                (declare (ignore end2))
1222                (with-array-data ((data3 result-bit-array) (start3) (end3))
1223                  (do ((index-1 start1 (1+ index-1))
1224                       (index-2 start2 (1+ index-2))
1225                       (index-3 start3 (1+ index-3)))
1226                      ((>= index-3 end3) result-bit-array)
1227                    (declare (type index index-1 index-2 index-3))
1228                    (setf (sbit data3 index-3)
1229                          (logand (,function (sbit data1 index-1)
1230                                             (sbit data2 index-2))
1231                                  1))))))))))
1232
1233 (def-bit-array-op bit-and logand)
1234 (def-bit-array-op bit-ior logior)
1235 (def-bit-array-op bit-xor logxor)
1236 (def-bit-array-op bit-eqv logeqv)
1237 (def-bit-array-op bit-nand lognand)
1238 (def-bit-array-op bit-nor lognor)
1239 (def-bit-array-op bit-andc1 logandc1)
1240 (def-bit-array-op bit-andc2 logandc2)
1241 (def-bit-array-op bit-orc1 logorc1)
1242 (def-bit-array-op bit-orc2 logorc2)
1243
1244 (defun bit-not (bit-array &optional result-bit-array)
1245   #!+sb-doc
1246   "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1247   putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1248   BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1249   created. Both arrays must have the same rank and dimensions."
1250   (declare (type (array bit) bit-array)
1251            (type (or (array bit) (member t nil)) result-bit-array))
1252   (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
1253     (if (and (simple-bit-vector-p bit-array)
1254              (simple-bit-vector-p result-bit-array))
1255         (locally (declare (optimize (speed 3) (safety 0)))
1256           (bit-not bit-array result-bit-array))
1257         (with-array-data ((src bit-array) (src-start) (src-end))
1258           (declare (ignore src-end))
1259           (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
1260             (do ((src-index src-start (1+ src-index))
1261                  (dst-index dst-start (1+ dst-index)))
1262                 ((>= dst-index dst-end) result-bit-array)
1263               (declare (type index src-index dst-index))
1264               (setf (sbit dst dst-index)
1265                     (logxor (sbit src src-index) 1))))))))