1 ;;;; functions to implement arrays
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
15 (declaim (inline adjustable-array-p
18 ;;;; miscellaneous accessor functions
20 ;;; These functions are only needed by the interpreter, 'cause the
21 ;;; compiler inlines them.
22 (macrolet ((def (name)
26 (defun (setf ,name) (value array)
27 (setf (,name array) value)))))
28 (def %array-fill-pointer)
29 (def %array-fill-pointer-p)
30 (def %array-available-elements)
31 (def %array-data-vector)
32 (def %array-displacement)
33 (def %array-displaced-p)
34 (def %array-diplaced-from))
36 (defun %array-rank (array)
39 (defun %array-dimension (array axis)
40 (%array-dimension array axis))
42 (defun %set-array-dimension (array axis value)
43 (%set-array-dimension array axis value))
45 (defun %check-bound (array bound index)
46 (declare (type index bound)
48 (%check-bound array bound index))
50 (defun %with-array-data/fp (array start end)
51 (%with-array-data-macro array start end :check-bounds t :check-fill-pointer t))
53 (defun %with-array-data (array start end)
54 (%with-array-data-macro array start end :check-bounds t :check-fill-pointer nil))
56 (defun %data-vector-and-index (array index)
57 (if (array-header-p array)
58 (multiple-value-bind (vector index)
59 (%with-array-data array index nil)
60 (values vector index))
61 (values array index)))
64 (eval-when (:compile-toplevel :execute)
65 (sb!xc:defmacro pick-vector-type (type &rest specs)
66 `(cond ,@(mapcar (lambda (spec)
67 `(,(if (eq (car spec) t)
69 `(subtypep ,type ',(car spec)))
73 ;;; These functions are used in the implementation of MAKE-ARRAY for
74 ;;; complex arrays. There are lots of transforms to simplify
75 ;;; MAKE-ARRAY for various easy cases, but not for all reasonable
76 ;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
77 ;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
78 ;;; making this somewhat efficient, at least not doing full calls to
79 ;;; SUBTYPEP in the easy cases.
80 (defun %vector-widetag-and-n-bits (type)
82 ;; Pick off some easy common cases.
84 ;; (Perhaps we should make a much more exhaustive table of easy
85 ;; common cases here. Or perhaps the effort would be better spent
86 ;; on smarter compiler transforms which do the calculation once
87 ;; and for all in any reasonable user programs.)
89 (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
90 ((base-char standard-char #!-sb-unicode character)
91 (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
94 (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits))
96 (values #.sb!vm:simple-bit-vector-widetag 1))
97 ;; OK, we have to wade into SUBTYPEPing after all.
99 (unless *type-system-initialized*
100 (bug "SUBTYPEP dispatch for MAKE-ARRAY before the type system is ready"))
101 #.`(pick-vector-type type
104 `(,(sb!vm:saetp-specifier saetp)
105 (values ,(sb!vm:saetp-typecode saetp)
106 ,(sb!vm:saetp-n-bits saetp))))
107 sb!vm:*specialized-array-element-type-properties*)))))
109 (defun %complex-vector-widetag (type)
111 ;; Pick off some easy common cases.
113 #.sb!vm:complex-vector-widetag)
114 ((base-char #!-sb-unicode character)
115 #.sb!vm:complex-base-string-widetag)
118 #.sb!vm:complex-character-string-widetag)
120 #.sb!vm:complex-vector-nil-widetag)
122 #.sb!vm:complex-bit-vector-widetag)
123 ;; OK, we have to wade into SUBTYPEPing after all.
125 (pick-vector-type type
126 (nil #.sb!vm:complex-vector-nil-widetag)
128 (character #.sb!vm:complex-base-string-widetag)
130 (base-char #.sb!vm:complex-base-string-widetag)
132 (character #.sb!vm:complex-character-string-widetag)
133 (bit #.sb!vm:complex-bit-vector-widetag)
134 (t #.sb!vm:complex-vector-widetag)))))
136 (defun make-array (dimensions &key
138 (initial-element nil initial-element-p)
139 (initial-contents nil initial-contents-p)
140 adjustable fill-pointer
141 displaced-to displaced-index-offset)
142 (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
143 (array-rank (length (the list dimensions)))
144 (simple (and (null fill-pointer)
146 (null displaced-to))))
147 (declare (fixnum array-rank))
148 (when (and displaced-index-offset (null displaced-to))
149 (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
150 (when (and displaced-to
151 (arrayp displaced-to)
152 (not (equal (array-element-type displaced-to)
153 (upgraded-array-element-type element-type))))
154 (error "Array element type of :DISPLACED-TO array does not match specified element type"))
155 (if (and simple (= array-rank 1))
156 ;; it's a (SIMPLE-ARRAY * (*))
157 (multiple-value-bind (type n-bits)
158 (%vector-widetag-and-n-bits element-type)
159 (declare (type (unsigned-byte 8) type)
160 (type (integer 0 256) n-bits))
161 (let* ((length (car dimensions))
162 (array (allocate-vector
166 (* (if (or (= type sb!vm:simple-base-string-widetag)
169 sb!vm:simple-character-string-widetag))
173 sb!vm:n-word-bits))))
174 (declare (type index length))
175 (when initial-element-p
176 (fill array initial-element))
177 (when initial-contents-p
178 (when initial-element-p
179 (error "can't specify both :INITIAL-ELEMENT and ~
181 (unless (= length (length initial-contents))
182 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
183 the vector length is ~W."
184 (length initial-contents)
186 (replace array initial-contents))
188 ;; it's either a complex array or a multidimensional array.
189 (let* ((total-size (reduce #'* dimensions))
190 (data (or displaced-to
191 (data-vector-from-inits
192 dimensions total-size element-type
193 initial-contents initial-contents-p
194 initial-element initial-element-p)))
195 (array (make-array-header
196 (cond ((= array-rank 1)
197 (%complex-vector-widetag element-type))
198 (simple sb!vm:simple-array-widetag)
199 (t sb!vm:complex-array-widetag))
202 (unless (= array-rank 1)
203 (error "Only vectors can have fill pointers."))
204 (let ((length (car dimensions)))
205 (declare (fixnum length))
206 (setf (%array-fill-pointer array)
207 (cond ((eq fill-pointer t)
210 (unless (and (fixnump fill-pointer)
212 (<= fill-pointer length))
213 ;; FIXME: should be TYPE-ERROR?
214 (error "invalid fill-pointer ~W"
217 (setf (%array-fill-pointer-p array) t))
219 (setf (%array-fill-pointer array) total-size)
220 (setf (%array-fill-pointer-p array) nil)))
221 (setf (%array-available-elements array) total-size)
222 (setf (%array-data-vector array) data)
223 (setf (%array-displaced-from array) nil)
225 (when (or initial-element-p initial-contents-p)
226 (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
227 can be specified along with :DISPLACED-TO"))
228 (let ((offset (or displaced-index-offset 0)))
229 (when (> (+ offset total-size)
230 (array-total-size displaced-to))
231 (error "~S doesn't have enough elements." displaced-to))
232 (setf (%array-displacement array) offset)
233 (setf (%array-displaced-p array) t)
234 (%save-displaced-array-backpointer array data)))
236 (setf (%array-displaced-p array) nil)))
238 (dolist (dim dimensions)
239 (setf (%array-dimension array axis) dim)
243 (defun make-static-vector (length &key
244 (element-type '(unsigned-byte 8))
245 (initial-contents nil initial-contents-p)
246 (initial-element nil initial-element-p))
247 "Allocate vector of LENGTH elements in static space. Only allocation
248 of specialized arrays is supported."
249 ;; STEP 1: check inputs fully
251 ;; This way of doing explicit checks before the vector is allocated
252 ;; is expensive, but probably worth the trouble as once we've allocated
253 ;; the vector we have no way to get rid of it anymore...
254 (when (eq t (upgraded-array-element-type element-type))
255 (error "Static arrays of type ~S not supported."
257 (when initial-contents-p
258 (when initial-element-p
259 (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
260 (unless (= length (length initial-contents))
261 (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
262 vector length is ~W."
263 (length initial-contents)
265 (unless (every (lambda (x) (typep x element-type)) initial-contents)
266 (error ":INITIAL-CONTENTS contains elements not of type ~S."
268 (when initial-element-p
269 (unless (typep initial-element element-type)
270 (error ":INITIAL-ELEMENT ~S is not of type ~S."
271 initial-element element-type)))
274 ;; Allocate and possibly initialize the vector.
275 (multiple-value-bind (type n-bits)
276 (sb!impl::%vector-widetag-and-n-bits element-type)
278 (allocate-static-vector type length
279 (ceiling (* length n-bits)
280 sb!vm:n-word-bits))))
281 (cond (initial-element-p
282 (fill vector initial-element))
284 (replace vector initial-contents))
288 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
289 ;;; specified array characteristics. Dimensions is only used to pass
290 ;;; to FILL-DATA-VECTOR for error checking on the structure of
291 ;;; initial-contents.
292 (defun data-vector-from-inits (dimensions total-size element-type
293 initial-contents initial-contents-p
294 initial-element initial-element-p)
295 (when (and initial-contents-p initial-element-p)
296 (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
297 either MAKE-ARRAY or ADJUST-ARRAY."))
298 (let ((data (if initial-element-p
299 (make-array total-size
300 :element-type element-type
301 :initial-element initial-element)
302 (make-array total-size
303 :element-type element-type))))
304 (cond (initial-element-p
305 (unless (simple-vector-p data)
306 (unless (typep initial-element element-type)
307 (error "~S cannot be used to initialize an array of type ~S."
308 initial-element element-type))
309 (fill (the vector data) initial-element)))
311 (fill-data-vector data dimensions initial-contents)))
314 (defun vector (&rest objects)
316 "Construct a SIMPLE-VECTOR from the given objects."
317 (coerce (the list objects) 'simple-vector))
320 ;;;; accessor/setter and subseq functions
322 ;;; Dispatch to an optimized routine the data vector accessors for
323 ;;; each different specialized vector type. Do dispatching by looking
324 ;;; up the widetag in the array rather than with the typecases, which
325 ;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
326 ;;; provide separate versions where bounds checking has been moved
327 ;;; from the callee to the caller, since it's much cheaper to do once
328 ;;; the type information is available. Finally, for each of these
329 ;;; routines also provide a slow path, taken for arrays that are not
330 ;;; vectors or not simple.
332 ;;; Similarly for SUBSEQ, except we don't have the slow-path at all:
333 ;;; VECTOR-SUBEQ* takes care of that.
334 (macrolet ((def (name table-name)
336 (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)))
337 (defmacro ,name (array-var)
340 (when (sb!vm::%other-pointer-p ,array-var)
341 (setf tag (%other-pointer-widetag ,array-var)))
342 (svref ,',table-name tag)))))))
343 (def !find-data-vector-setter %%data-vector-setters%%)
344 (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
345 (def !find-data-vector-reffer %%data-vector-reffers%%)
346 (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%)
347 (def !find-vector-subseq-fun %%vector-subseq-funs%%))
349 (macrolet ((%ref (accessor-getter extra-params)
350 `(funcall (,accessor-getter array) array index ,@extra-params))
351 (define (accessor-name slow-accessor-name accessor-getter
352 extra-params check-bounds)
354 (defun ,accessor-name (array index ,@extra-params)
355 (declare (optimize speed
356 ;; (SAFETY 0) is ok. All calls to
357 ;; these functions are generated by
358 ;; the compiler, so argument count
359 ;; checking isn't needed. Type checking
360 ;; is done implicitly via the widetag
363 (%ref ,accessor-getter ,extra-params))
364 (defun ,slow-accessor-name (array index ,@extra-params)
365 (declare (optimize speed (safety 0)))
366 (if (not (%array-displaced-p array))
367 ;; The reasonably quick path of non-displaced complex
369 (let ((array (%array-data-vector array)))
370 (%ref ,accessor-getter ,extra-params))
371 ;; The real slow path.
375 (declare (optimize (speed 1) (safety 1)))
376 (,@check-bounds index)))
379 (declare (ignore end))
380 (,accessor-name vector index ,@extra-params)))))))
381 (define hairy-data-vector-ref slow-hairy-data-vector-ref
382 !find-data-vector-reffer
384 (define hairy-data-vector-set slow-hairy-data-vector-set
385 !find-data-vector-setter
387 (define hairy-data-vector-ref/check-bounds
388 slow-hairy-data-vector-ref/check-bounds
389 !find-data-vector-reffer/check-bounds
390 nil (%check-bound array (array-dimension array 0)))
391 (define hairy-data-vector-set/check-bounds
392 slow-hairy-data-vector-set/check-bounds
393 !find-data-vector-setter/check-bounds
394 (new-value) (%check-bound array (array-dimension array 0))))
396 (defun hairy-ref-error (array index &optional new-value)
397 (declare (ignore index new-value))
400 :expected-type 'vector))
402 (defun hairy-subseq-error (array start end)
403 (declare (ignore start end))
406 :expected-type '(simple-array * (*))))
408 ;;; Populate the dispatch tables.
409 (macrolet ((def-subseq-funs ()
411 (set '%%vector-subseq-funs%%
412 (make-array (1+ sb!vm:widetag-mask)
413 :initial-element #'hairy-subseq-error))
416 (let ((name (symbolicate "SUBSEQ/"
417 (sb!vm:saetp-primitive-type-name saetp))))
419 (defun ,name (vector start end)
420 (declare (type (simple-array ,(sb!vm:saetp-specifier saetp) (*))
423 (optimize speed (safety 0)))
424 (subseq vector start end))
425 (setf (svref %%vector-subseq-funs%%
426 ,(sb!vm:saetp-typecode saetp))
428 sb!vm:*specialized-array-element-type-properties*))))
430 (macrolet ((define-reffer (saetp check-form)
431 (let* ((type (sb!vm:saetp-specifier saetp))
432 (atype `(simple-array ,type (*))))
433 `(named-lambda optimized-data-vector-ref (vector index)
434 (declare (optimize speed (safety 0)))
435 (data-vector-ref (the ,atype vector)
437 (declare (optimize (safety 1)))
439 (,@check-form index)))))))
440 (define-setter (saetp check-form)
441 (let* ((type (sb!vm:saetp-specifier saetp))
442 (atype `(simple-array ,type (*))))
443 `(named-lambda optimized-data-vector-set (vector index new-value)
444 (declare (optimize speed (safety 0)))
445 (data-vector-set (the ,atype vector)
447 (declare (optimize (safety 1)))
449 (,@check-form index)))
451 ;; SPEED 1 needed to avoid the compiler
452 ;; from downgrading the type check to
454 (declare (optimize (speed 1)
456 (the ,type new-value)))
457 ;; For specialized arrays, the return from
458 ;; data-vector-set would have to be reboxed to be a
459 ;; (Lisp) return value; instead, we use the
460 ;; already-boxed value as the return.
462 (define-reffers (symbol deffer check-form slow-path)
464 ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
465 ;; preserve the binding, so re-initiaize as NS doesn't have
466 ;; the energy to figure out to change that right now.
467 (setf ,symbol (make-array (1+ sb!vm::widetag-mask)
468 :initial-element #'hairy-ref-error))
469 ,@(loop for widetag in '(sb!vm:complex-vector-widetag
470 sb!vm:complex-vector-nil-widetag
471 sb!vm:complex-bit-vector-widetag
472 #!+sb-unicode sb!vm:complex-character-string-widetag
473 sb!vm:complex-base-string-widetag
474 sb!vm:simple-array-widetag
475 sb!vm:complex-array-widetag)
476 collect `(setf (svref ,symbol ,widetag) ,slow-path))
477 ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
478 for widetag = (sb!vm:saetp-typecode saetp)
479 collect `(setf (svref ,symbol ,widetag)
480 (,deffer ,saetp ,check-form))))))
481 (defun !hairy-data-vector-reffer-init ()
482 (define-reffers %%data-vector-reffers%% define-reffer
484 #'slow-hairy-data-vector-ref)
485 (define-reffers %%data-vector-setters%% define-setter
487 #'slow-hairy-data-vector-set)
488 (define-reffers %%data-vector-reffers/check-bounds%% define-reffer
489 (%check-bound vector (length vector))
490 #'slow-hairy-data-vector-ref/check-bounds)
491 (define-reffers %%data-vector-setters/check-bounds%% define-setter
492 (%check-bound vector (length vector))
493 #'slow-hairy-data-vector-set/check-bounds)))
495 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
496 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
497 ;;; definition is needed for the compiler to use in constant folding.)
498 (defun data-vector-ref (array index)
499 (hairy-data-vector-ref array index))
501 (defun data-vector-ref-with-offset (array index offset)
502 (hairy-data-vector-ref array (+ index offset)))
504 (defun invalid-array-p (array)
505 (and (array-header-p array)
506 (consp (%array-displaced-p array))))
508 (declaim (ftype (function (array) nil) invalid-array-error))
509 (defun invalid-array-error (array)
510 (aver (array-header-p array))
511 ;; Array invalidation stashes the original dimensions here...
512 (let ((dims (%array-displaced-p array))
513 (et (array-element-type array)))
514 (error 'invalid-array-error
519 `(vector ,et ,@dims)))))
521 (declaim (ftype (function (array integer integer &optional t) nil)
522 invalid-array-index-error))
523 (defun invalid-array-index-error (array index bound &optional axis)
524 (if (invalid-array-p array)
525 (invalid-array-error array)
526 (error 'invalid-array-index-error
530 :expected-type `(integer 0 (,bound)))))
532 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
533 (defun %array-row-major-index (array subscripts
534 &optional (invalid-index-error-p t))
535 (declare (array array)
537 (let ((rank (array-rank array)))
538 (unless (= rank (length subscripts))
539 (error "wrong number of subscripts, ~W, for array of rank ~W"
540 (length subscripts) rank))
541 (if (array-header-p array)
542 (do ((subs (nreverse subscripts) (cdr subs))
543 (axis (1- (array-rank array)) (1- axis))
547 (declare (list subs) (fixnum axis chunk-size result))
548 (let ((index (car subs))
549 (dim (%array-dimension array axis)))
550 (declare (fixnum dim))
551 (unless (and (fixnump index) (< -1 index dim))
552 (if invalid-index-error-p
553 (invalid-array-index-error array index dim axis)
554 (return-from %array-row-major-index nil)))
555 (incf result (* chunk-size (the fixnum index)))
556 (setf chunk-size (* chunk-size dim))))
557 (let ((index (first subscripts))
558 (length (length (the (simple-array * (*)) array))))
559 (unless (and (fixnump index) (< -1 index length))
560 (if invalid-index-error-p
561 (invalid-array-index-error array index length)
562 (return-from %array-row-major-index nil)))
565 (defun array-in-bounds-p (array &rest subscripts)
567 "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
568 (if (%array-row-major-index array subscripts nil)
571 (defun array-row-major-index (array &rest subscripts)
572 (declare (truly-dynamic-extent subscripts))
573 (%array-row-major-index array subscripts))
575 (defun aref (array &rest subscripts)
577 "Return the element of the ARRAY specified by the SUBSCRIPTS."
578 (declare (truly-dynamic-extent subscripts))
579 (row-major-aref array (%array-row-major-index array subscripts)))
581 (defun %aset (array &rest stuff)
582 (declare (truly-dynamic-extent stuff))
583 (let ((subscripts (butlast stuff))
584 (new-value (car (last stuff))))
585 (setf (row-major-aref array (%array-row-major-index array subscripts))
588 ;;; FIXME: What's supposed to happen with functions
589 ;;; like AREF when we (DEFUN (SETF FOO) ..) when
590 ;;; DEFSETF FOO is also defined? It seems as though the logical
591 ;;; thing to do would be to nuke the macro definition for (SETF FOO)
592 ;;; and replace it with the (SETF FOO) function, issuing a warning,
593 ;;; just as for ordinary functions
594 ;;; * (LISP-IMPLEMENTATION-VERSION)
595 ;;; "18a+ release x86-linux 2.4.7 6 November 1998 cvs"
596 ;;; * (DEFMACRO ZOO (X) `(+ ,X ,X))
598 ;;; * (DEFUN ZOO (X) (* 3 X))
599 ;;; Warning: ZOO previously defined as a macro.
601 ;;; But that doesn't seem to be what happens in CMU CL.
603 ;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS
604 ;;; 5.1.2.5) requires implementations to support
605 ;;; (SETF (APPLY #'AREF ...) ...)
606 ;;; [and also #'BIT and #'SBIT]. Yes, this is terrifying, and it's
607 ;;; also terrifying that this sequence of definitions causes it to
610 ;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
611 ;;; has a setf expansion and/or a setf function defined.
613 #!-sb-fluid (declaim (inline (setf aref)))
614 (defun (setf aref) (new-value array &rest subscripts)
615 (declare (truly-dynamic-extent subscripts))
616 (declare (type array array))
617 (setf (row-major-aref array (%array-row-major-index array subscripts))
620 (defun row-major-aref (array index)
622 "Return the element of array corressponding to the row-major index. This is
624 (declare (optimize (safety 1)))
625 (row-major-aref array index))
627 (defun %set-row-major-aref (array index new-value)
628 (declare (optimize (safety 1)))
629 (setf (row-major-aref array index) new-value))
631 (defun svref (simple-vector index)
633 "Return the INDEX'th element of the given Simple-Vector."
634 (declare (optimize (safety 1)))
635 (aref simple-vector index))
637 (defun %svset (simple-vector index new)
638 (declare (optimize (safety 1)))
639 (setf (aref simple-vector index) new))
641 (defun bit (bit-array &rest subscripts)
643 "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
644 (declare (type (array bit) bit-array) (optimize (safety 1)))
645 (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
647 (defun %bitset (bit-array &rest stuff)
648 (declare (type (array bit) bit-array) (optimize (safety 1)))
649 (let ((subscripts (butlast stuff))
650 (new-value (car (last stuff))))
651 (setf (row-major-aref bit-array
652 (%array-row-major-index bit-array subscripts))
655 #!-sb-fluid (declaim (inline (setf bit)))
656 (defun (setf bit) (new-value bit-array &rest subscripts)
657 (declare (type (array bit) bit-array) (optimize (safety 1)))
658 (setf (row-major-aref bit-array
659 (%array-row-major-index bit-array subscripts))
662 (defun sbit (simple-bit-array &rest subscripts)
664 "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
665 (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
666 (row-major-aref simple-bit-array
667 (%array-row-major-index simple-bit-array subscripts)))
669 ;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER,
670 ;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names.
671 ;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names?
673 (defun %sbitset (simple-bit-array &rest stuff)
674 (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
675 (let ((subscripts (butlast stuff))
676 (new-value (car (last stuff))))
677 (setf (row-major-aref simple-bit-array
678 (%array-row-major-index simple-bit-array subscripts))
681 #!-sb-fluid (declaim (inline (setf sbit)))
682 (defun (setf sbit) (new-value bit-array &rest subscripts)
683 (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
684 (setf (row-major-aref bit-array
685 (%array-row-major-index bit-array subscripts))
688 ;;;; miscellaneous array properties
690 (defun array-element-type (array)
692 "Return the type of the elements of the array"
693 (let ((widetag (widetag-of array)))
694 (macrolet ((pick-element-type (&rest stuff)
695 `(cond ,@(mapcar (lambda (stuff)
697 (let ((item (car stuff)))
706 `(= widetag ,item))))
709 #.`(pick-element-type
712 `(,(if (sb!vm:saetp-complex-typecode saetp)
713 (list (sb!vm:saetp-typecode saetp)
714 (sb!vm:saetp-complex-typecode saetp))
715 (sb!vm:saetp-typecode saetp))
716 ',(sb!vm:saetp-specifier saetp)))
717 sb!vm:*specialized-array-element-type-properties*)
718 ((sb!vm:simple-array-widetag
719 sb!vm:complex-vector-widetag
720 sb!vm:complex-array-widetag)
721 (with-array-data ((array array) (start) (end))
722 (declare (ignore start end))
723 (array-element-type array)))
725 (error 'type-error :datum array :expected-type 'array))))))
727 (defun array-rank (array)
729 "Return the number of dimensions of ARRAY."
730 (if (array-header-p array)
734 (defun array-dimension (array axis-number)
736 "Return the length of dimension AXIS-NUMBER of ARRAY."
737 (declare (array array) (type index axis-number))
738 (cond ((not (array-header-p array))
739 (unless (= axis-number 0)
740 (error "Vector axis is not zero: ~S" axis-number))
741 (length (the (simple-array * (*)) array)))
742 ((>= axis-number (%array-rank array))
743 (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
744 axis-number array (%array-rank array)))
746 (%array-dimension array axis-number))))
748 (defun array-dimensions (array)
750 "Return a list whose elements are the dimensions of the array"
751 (declare (array array))
752 (if (array-header-p array)
753 (do ((results nil (cons (array-dimension array index) results))
754 (index (1- (array-rank array)) (1- index)))
755 ((minusp index) results))
756 (list (array-dimension array 0))))
758 (defun array-total-size (array)
760 "Return the total number of elements in the Array."
761 (declare (array array))
762 (if (array-header-p array)
763 (%array-available-elements array)
764 (length (the vector array))))
766 (defun array-displacement (array)
768 "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
769 options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
770 (declare (type array array))
771 (if (and (array-header-p array) ; if unsimple and
772 (%array-displaced-p array)) ; displaced
773 (values (%array-data-vector array) (%array-displacement array))
776 (defun adjustable-array-p (array)
778 "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
779 to the argument, this happens for complex arrays."
780 (declare (array array))
781 ;; Note that this appears not to be a fundamental limitation.
782 ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
783 ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
784 ;; -- CSR, 2004-03-01.
785 (not (typep array 'simple-array)))
787 ;;;; fill pointer frobbing stuff
789 (declaim (inline array-has-fill-pointer-p))
790 (defun array-has-fill-pointer-p (array)
792 "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
793 (declare (array array))
794 (and (array-header-p array) (%array-fill-pointer-p array)))
796 (defun fill-pointer-error (vector arg)
798 (aver (array-has-fill-pointer-p vector))
799 (let ((max (%array-available-elements vector)))
800 (error 'simple-type-error
802 :expected-type (list 'integer 0 max)
803 :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)"
804 :format-arguments (list arg max))))
806 (error 'simple-type-error
808 :expected-type '(and vector (satisfies array-has-fill-pointer-p))
809 :format-control "~S is not an array with a fill pointer."
810 :format-arguments (list vector)))))
812 (declaim (inline fill-pointer))
813 (defun fill-pointer (vector)
815 "Return the FILL-POINTER of the given VECTOR."
816 (if (array-has-fill-pointer-p vector)
817 (%array-fill-pointer vector)
818 (fill-pointer-error vector nil)))
820 (defun %set-fill-pointer (vector new)
822 (fill-pointer-error vector x)))
823 (if (array-has-fill-pointer-p vector)
824 (if (> new (%array-available-elements vector))
826 (setf (%array-fill-pointer vector) new))
829 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
830 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
831 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
832 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
834 (defun vector-push (new-el array)
836 "Attempt to set the element of ARRAY designated by its fill pointer
837 to NEW-EL, and increment the fill pointer by one. If the fill pointer is
838 too large, NIL is returned, otherwise the index of the pushed element is
840 (let ((fill-pointer (fill-pointer array)))
841 (declare (fixnum fill-pointer))
842 (cond ((= fill-pointer (%array-available-elements array))
845 (locally (declare (optimize (safety 0)))
846 (setf (aref array fill-pointer) new-el))
847 (setf (%array-fill-pointer array) (1+ fill-pointer))
850 (defun vector-push-extend (new-element
854 (let ((length (length vector)))
856 (- array-dimension-limit length)))))
857 (declare (fixnum min-extension))
858 (let ((fill-pointer (fill-pointer vector)))
859 (declare (fixnum fill-pointer))
860 (when (= fill-pointer (%array-available-elements vector))
861 (adjust-array vector (+ fill-pointer (max 1 min-extension))))
862 ;; disable bounds checking
863 (locally (declare (optimize (safety 0)))
864 (setf (aref vector fill-pointer) new-element))
865 (setf (%array-fill-pointer vector) (1+ fill-pointer))
868 (defun vector-pop (array)
870 "Decrease the fill pointer by 1 and return the element pointed to by the
872 (let ((fill-pointer (fill-pointer array)))
873 (declare (fixnum fill-pointer))
874 (if (zerop fill-pointer)
875 (error "There is nothing left to pop.")
876 ;; disable bounds checking (and any fixnum test)
877 (locally (declare (optimize (safety 0)))
879 (setf (%array-fill-pointer array)
880 (1- fill-pointer)))))))
885 (defun adjust-array (array dimensions &key
886 (element-type (array-element-type array))
887 (initial-element nil initial-element-p)
888 (initial-contents nil initial-contents-p)
890 displaced-to displaced-index-offset)
892 "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
893 (when (invalid-array-p array)
894 (invalid-array-error array))
895 (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
896 (cond ((/= (the fixnum (length (the list dimensions)))
897 (the fixnum (array-rank array)))
898 (error "The number of dimensions not equal to rank of array."))
899 ((not (subtypep element-type (array-element-type array)))
900 (error "The new element type, ~S, is incompatible with old type."
902 ((and fill-pointer (not (array-has-fill-pointer-p array)))
905 :expected-type '(satisfies array-has-fill-pointer-p))))
906 (let ((array-rank (length (the list dimensions))))
907 (declare (fixnum array-rank))
908 (unless (= array-rank 1)
910 (error "Only vectors can have fill pointers.")))
911 (cond (initial-contents-p
912 ;; array former contents replaced by INITIAL-CONTENTS
913 (if (or initial-element-p displaced-to)
914 (error "INITIAL-CONTENTS may not be specified with ~
915 the :INITIAL-ELEMENT or :DISPLACED-TO option."))
916 (let* ((array-size (apply #'* dimensions))
917 (array-data (data-vector-from-inits
918 dimensions array-size element-type
919 initial-contents initial-contents-p
920 initial-element initial-element-p)))
921 (if (adjustable-array-p array)
922 (set-array-header array array-data array-size
923 (get-new-fill-pointer array array-size
925 0 dimensions nil nil)
926 (if (array-header-p array)
927 ;; simple multidimensional or single dimensional array
928 (make-array dimensions
929 :element-type element-type
930 :initial-contents initial-contents)
933 ;; We already established that no INITIAL-CONTENTS was supplied.
934 (when initial-element
935 (error "The :INITIAL-ELEMENT option may not be specified ~
936 with :DISPLACED-TO."))
937 (unless (subtypep element-type (array-element-type displaced-to))
938 (error "can't displace an array of type ~S into another of ~
940 element-type (array-element-type displaced-to)))
941 (let ((displacement (or displaced-index-offset 0))
942 (array-size (apply #'* dimensions)))
943 (declare (fixnum displacement array-size))
944 (if (< (the fixnum (array-total-size displaced-to))
945 (the fixnum (+ displacement array-size)))
946 (error "The :DISPLACED-TO array is too small."))
947 (if (adjustable-array-p array)
948 ;; None of the original contents appear in adjusted array.
949 (set-array-header array displaced-to array-size
950 (get-new-fill-pointer array array-size
952 displacement dimensions t nil)
953 ;; simple multidimensional or single dimensional array
954 (make-array dimensions
955 :element-type element-type
956 :displaced-to displaced-to
957 :displaced-index-offset
958 displaced-index-offset))))
960 (let ((old-length (array-total-size array))
961 (new-length (car dimensions))
963 (declare (fixnum old-length new-length))
964 (with-array-data ((old-data array) (old-start)
965 (old-end old-length))
966 (cond ((or (and (array-header-p array)
967 (%array-displaced-p array))
968 (< old-length new-length))
970 (data-vector-from-inits
971 dimensions new-length element-type
972 initial-contents initial-contents-p
973 initial-element initial-element-p))
974 (replace new-data old-data
975 :start2 old-start :end2 old-end))
977 (shrink-vector old-data new-length))))
978 (if (adjustable-array-p array)
979 (set-array-header array new-data new-length
980 (get-new-fill-pointer array new-length
982 0 dimensions nil nil)
985 (let ((old-length (%array-available-elements array))
986 (new-length (apply #'* dimensions)))
987 (declare (fixnum old-length new-length))
988 (with-array-data ((old-data array) (old-start)
989 (old-end old-length))
990 (declare (ignore old-end))
991 (let ((new-data (if (or (and (array-header-p array)
992 (%array-displaced-p array))
993 (> new-length old-length))
994 (data-vector-from-inits
995 dimensions new-length
997 initial-element initial-element-p)
999 (if (or (zerop old-length) (zerop new-length))
1000 (when initial-element-p (fill new-data initial-element))
1001 (zap-array-data old-data (array-dimensions array)
1003 new-data dimensions new-length
1004 element-type initial-element
1006 (if (adjustable-array-p array)
1007 (set-array-header array new-data new-length
1008 nil 0 dimensions nil nil)
1011 sb!vm:simple-array-widetag array-rank)))
1012 (set-array-header new-array new-data new-length
1013 nil 0 dimensions nil t)))))))))))
1016 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
1017 (cond ((not fill-pointer)
1018 (when (array-has-fill-pointer-p old-array)
1019 (when (> (%array-fill-pointer old-array) new-array-size)
1020 (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
1021 smaller than its fill pointer (~S)"
1022 old-array new-array-size (fill-pointer old-array)))
1023 (%array-fill-pointer old-array)))
1024 ((not (array-has-fill-pointer-p old-array))
1025 (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
1026 in ADJUST-ARRAY unless the array (~S) was originally ~
1027 created with a fill pointer"
1030 ((numberp fill-pointer)
1031 (when (> fill-pointer new-array-size)
1032 (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
1033 than the new length of the vector (~S)"
1034 fill-pointer new-array-size))
1036 ((eq fill-pointer t)
1039 (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
1042 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
1043 ;;; which must be less than or equal to its current length. This can
1044 ;;; be called on vectors without a fill pointer but it is extremely
1045 ;;; dangerous to do so: shrinking the size of an object (as viewed by
1046 ;;; the gc) makes bounds checking unreliable in the face of interrupts
1047 ;;; or multi-threading. Call it only on provably local vectors.
1048 (defun %shrink-vector (vector new-length)
1049 (declare (vector vector))
1050 (unless (array-header-p vector)
1051 (macrolet ((frob (name &rest things)
1053 ((simple-array nil (*)) (error 'nil-array-accessed-error))
1054 ,@(mapcar (lambda (thing)
1055 (destructuring-bind (type-spec fill-value)
1058 (fill (truly-the ,type-spec ,name)
1060 :start new-length))))
1062 ;; Set the 'tail' of the vector to the appropriate type of zero,
1063 ;; "because in some cases we'll scavenge larger areas in one go,
1064 ;; like groups of pages that had triggered the write barrier, or
1065 ;; the whole static space" according to jsnell.
1069 `((simple-array ,(sb!vm:saetp-specifier saetp) (*))
1070 ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character)
1072 (eq (sb!vm:saetp-specifier saetp) 'base-char))
1073 *default-init-char-form*
1074 (sb!vm:saetp-initial-element-default saetp))))
1076 #'sb!vm:saetp-specifier
1077 sb!vm:*specialized-array-element-type-properties*)))))
1078 ;; Only arrays have fill-pointers, but vectors have their length
1079 ;; parameter in the same place.
1080 (setf (%array-fill-pointer vector) new-length)
1083 (defun shrink-vector (vector new-length)
1084 (declare (vector vector))
1086 ((eq (length vector) new-length)
1088 ((array-has-fill-pointer-p vector)
1089 (setf (%array-fill-pointer vector) new-length)
1091 (t (subseq vector 0 new-length))))
1093 ;;; BIG THREAD SAFETY NOTE
1095 ;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
1096 ;;; thread unsafe. They are nonatomic, and can mess with parallel
1097 ;;; code using the same arrays.
1099 ;;; A likely seeming fix is an additional level of indirection:
1100 ;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
1101 ;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
1102 ;;; would hold everything ARRAY-HEADER now holds. This allows
1103 ;;; consing up a new ARRAY-INFO and replacing it atomically in
1104 ;;; the ARRAY-HEADER.
1106 ;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
1107 ;;; one: not only is it needed extremely rarely, which makes
1108 ;;; any thread safety bugs involving it look like rare random
1109 ;;; corruption, but because it walks the chain *upwards*, which
1110 ;;; may violate user expectations.
1112 (defun %save-displaced-array-backpointer (array data)
1113 (flet ((purge (pointers)
1114 (remove-if (lambda (value)
1115 (or (not value) (eq array value)))
1117 :key #'weak-pointer-value)))
1118 ;; Add backpointer to the new data vector if it has a header.
1119 (when (array-header-p data)
1120 (setf (%array-displaced-from data)
1121 (cons (make-weak-pointer array)
1122 (purge (%array-displaced-from data)))))
1123 ;; Remove old backpointer, if any.
1124 (let ((old-data (%array-data-vector array)))
1125 (when (and (neq data old-data) (array-header-p old-data))
1126 (setf (%array-displaced-from old-data)
1127 (purge (%array-displaced-from old-data)))))))
1129 (defun %walk-displaced-array-backpointers (array new-length)
1130 (dolist (p (%array-displaced-from array))
1131 (let ((from (weak-pointer-value p)))
1132 (when (and from (eq array (%array-data-vector from)))
1133 (let ((requires (+ (%array-available-elements from)
1134 (%array-displacement from))))
1135 (unless (>= new-length requires)
1136 ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
1138 ;; "If A is displaced to B, the consequences are unspecified if B is
1139 ;; adjusted in such a way that it no longer has enough elements to
1142 ;; since we're hanging on a weak pointer here, we can't signal an
1143 ;; error right now: the array that we're looking at might be
1144 ;; garbage. Instead, we set all dimensions to zero so that next
1145 ;; safe access to the displaced array will trap. Additionally, we
1146 ;; save the original dimensions, so we can signal a more
1147 ;; understandable error when the time comes.
1148 (%walk-displaced-array-backpointers from 0)
1149 (setf (%array-fill-pointer from) 0
1150 (%array-available-elements from) 0
1151 (%array-displaced-p from) (array-dimensions array))
1152 (dotimes (i (%array-rank from))
1153 (setf (%array-dimension from i) 0))))))))
1155 ;;; Fill in array header with the provided information, and return the array.
1156 (defun set-array-header (array data length fill-pointer displacement dimensions
1159 (setf (%array-displaced-from array) nil)
1160 (%walk-displaced-array-backpointers array length))
1162 (%save-displaced-array-backpointer array data))
1163 (setf (%array-data-vector array) data)
1164 (setf (%array-available-elements array) length)
1166 (setf (%array-fill-pointer array) fill-pointer)
1167 (setf (%array-fill-pointer-p array) t))
1169 (setf (%array-fill-pointer array) length)
1170 (setf (%array-fill-pointer-p array) nil)))
1171 (setf (%array-displacement array) displacement)
1172 (if (listp dimensions)
1173 (dotimes (axis (array-rank array))
1174 (declare (type index axis))
1175 (setf (%array-dimension array axis) (pop dimensions)))
1176 (setf (%array-dimension array 0) dimensions))
1177 (setf (%array-displaced-p array) displacedp)
1180 ;;; User visible extension
1181 (declaim (ftype (function (array) (values (simple-array * (*)) &optional))
1182 array-storage-vector))
1183 (defun array-storage-vector (array)
1184 "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
1186 In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
1187 vector. Multidimensional arrays, arrays with fill pointers, and adjustable
1188 arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
1189 ARRAY, which this function returns.
1191 Important note: the underlying vector is an implementation detail. Even though
1192 this function exposes it, changes in the implementation may cause this
1193 function to be removed without further warning."
1194 ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that
1195 ;; the return value is always of the known type.
1196 (truly-the (simple-array * (*))
1197 (if (array-header-p array)
1198 (if (%array-displaced-p array)
1199 (error "~S cannot be used with displaced arrays. Use ~S instead."
1200 'array-storage-vector 'array-displacement)
1201 (%array-data-vector array))
1205 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
1207 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
1208 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
1209 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
1210 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
1211 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1212 element-type initial-element initial-element-p)
1213 (declare (list old-dims new-dims)
1214 (fixnum new-length))
1215 ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
1216 ;; at least in SBCL.
1217 ;; NEW-DIMS comes from the user.
1218 (setf old-dims (nreverse old-dims)
1219 new-dims (reverse new-dims))
1220 (cond ((eq old-data new-data)
1221 ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
1222 ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
1223 ;; EQ; in this case, a temporary must be used and filled
1224 ;; appropriately. specified initial-element.
1225 (when initial-element-p
1226 ;; FIXME: transforming this TYPEP to someting a bit faster
1227 ;; would be a win...
1228 (unless (typep initial-element element-type)
1229 (error "~S can't be used to initialize an array of type ~S."
1230 initial-element element-type)))
1231 (let ((temp (if initial-element-p
1232 (make-array new-length :initial-element initial-element)
1233 (make-array new-length))))
1234 (declare (simple-vector temp))
1235 (zap-array-data-aux old-data old-dims offset temp new-dims)
1236 (dotimes (i new-length)
1237 (setf (aref new-data i) (aref temp i)))
1238 ;; Kill the temporary vector to prevent garbage retention.
1239 (%shrink-vector temp 0)))
1241 ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
1242 ;; already been filled with any
1243 (zap-array-data-aux old-data old-dims offset new-data new-dims))))
1245 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
1246 (declare (fixnum offset))
1247 (let ((limits (mapcar (lambda (x y)
1248 (declare (fixnum x y))
1249 (1- (the fixnum (min x y))))
1250 old-dims new-dims)))
1251 (macrolet ((bump-index-list (index limits)
1252 `(do ((subscripts ,index (cdr subscripts))
1253 (limits ,limits (cdr limits)))
1254 ((null subscripts) :eof)
1255 (cond ((< (the fixnum (car subscripts))
1256 (the fixnum (car limits)))
1258 (1+ (the fixnum (car subscripts))))
1260 (t (rplaca subscripts 0))))))
1261 (do ((index (make-list (length old-dims) :initial-element 0)
1262 (bump-index-list index limits)))
1264 (setf (aref new-data (row-major-index-from-dims index new-dims))
1266 (+ (the fixnum (row-major-index-from-dims index old-dims))
1269 ;;; Figure out the row-major-order index of an array reference from a
1270 ;;; list of subscripts and a list of dimensions. This is for internal
1271 ;;; calls only, and the subscripts and dim-list variables are assumed
1272 ;;; to be reversed from what the user supplied.
1273 (defun row-major-index-from-dims (rev-subscripts rev-dim-list)
1274 (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
1275 (rev-dim-list rev-dim-list (cdr rev-dim-list))
1278 ((null rev-dim-list) result)
1279 (declare (fixnum chunk-size result))
1280 (setq result (+ result
1281 (the fixnum (* (the fixnum (car rev-subscripts))
1283 (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
1287 (defun bit-array-same-dimensions-p (array1 array2)
1288 (declare (type (array bit) array1 array2))
1289 (and (= (array-rank array1)
1290 (array-rank array2))
1291 (dotimes (index (array-rank array1) t)
1292 (when (/= (array-dimension array1 index)
1293 (array-dimension array2 index))
1296 (defun pick-result-array (result-bit-array bit-array-1)
1297 (case result-bit-array
1299 ((nil) (make-array (array-dimensions bit-array-1)
1301 :initial-element 0))
1303 (unless (bit-array-same-dimensions-p bit-array-1
1305 (error "~S and ~S don't have the same dimensions."
1306 bit-array-1 result-bit-array))
1309 (defmacro def-bit-array-op (name function)
1310 `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
1313 "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1314 BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
1315 If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
1316 RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
1317 All the arrays must have the same rank and dimensions."
1318 (symbol-name function))
1319 (declare (type (array bit) bit-array-1 bit-array-2)
1320 (type (or (array bit) (member t nil)) result-bit-array))
1321 (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
1322 (error "~S and ~S don't have the same dimensions."
1323 bit-array-1 bit-array-2))
1324 (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
1325 (if (and (simple-bit-vector-p bit-array-1)
1326 (simple-bit-vector-p bit-array-2)
1327 (simple-bit-vector-p result-bit-array))
1328 (locally (declare (optimize (speed 3) (safety 0)))
1329 (,name bit-array-1 bit-array-2 result-bit-array))
1330 (with-array-data ((data1 bit-array-1) (start1) (end1))
1331 (declare (ignore end1))
1332 (with-array-data ((data2 bit-array-2) (start2) (end2))
1333 (declare (ignore end2))
1334 (with-array-data ((data3 result-bit-array) (start3) (end3))
1335 (do ((index-1 start1 (1+ index-1))
1336 (index-2 start2 (1+ index-2))
1337 (index-3 start3 (1+ index-3)))
1338 ((>= index-3 end3) result-bit-array)
1339 (declare (type index index-1 index-2 index-3))
1340 (setf (sbit data3 index-3)
1341 (logand (,function (sbit data1 index-1)
1342 (sbit data2 index-2))
1345 (def-bit-array-op bit-and logand)
1346 (def-bit-array-op bit-ior logior)
1347 (def-bit-array-op bit-xor logxor)
1348 (def-bit-array-op bit-eqv logeqv)
1349 (def-bit-array-op bit-nand lognand)
1350 (def-bit-array-op bit-nor lognor)
1351 (def-bit-array-op bit-andc1 logandc1)
1352 (def-bit-array-op bit-andc2 logandc2)
1353 (def-bit-array-op bit-orc1 logorc1)
1354 (def-bit-array-op bit-orc2 logorc2)
1356 (defun bit-not (bit-array &optional result-bit-array)
1358 "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1359 putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1360 BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1361 created. Both arrays must have the same rank and dimensions."
1362 (declare (type (array bit) bit-array)
1363 (type (or (array bit) (member t nil)) result-bit-array))
1364 (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
1365 (if (and (simple-bit-vector-p bit-array)
1366 (simple-bit-vector-p result-bit-array))
1367 (locally (declare (optimize (speed 3) (safety 0)))
1368 (bit-not bit-array result-bit-array))
1369 (with-array-data ((src bit-array) (src-start) (src-end))
1370 (declare (ignore src-end))
1371 (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
1372 (do ((src-index src-start (1+ src-index))
1373 (dst-index dst-start (1+ dst-index)))
1374 ((>= dst-index dst-end) result-bit-array)
1375 (declare (type index src-index dst-index))
1376 (setf (sbit dst dst-index)
1377 (logxor (sbit src src-index) 1))))))))