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 (defun %integer-vector-widetag-and-n-bits (signed high)
66 #.(let ((map (make-array (1+ sb!vm:n-word-bits))))
67 (loop for saetp across
68 (reverse sb!vm:*specialized-array-element-type-properties*)
69 for ctype = (sb!vm:saetp-ctype saetp)
70 when (and (numeric-type-p ctype)
71 (eq (numeric-type-class ctype) 'integer)
72 (zerop (numeric-type-low ctype)))
73 do (fill map (cons (sb!vm:saetp-typecode saetp)
74 (sb!vm:saetp-n-bits saetp))
75 :end (1+ (integer-length (numeric-type-high ctype)))))
78 #.(let ((map (make-array (1+ sb!vm:n-word-bits))))
79 (loop for saetp across
80 (reverse sb!vm:*specialized-array-element-type-properties*)
81 for ctype = (sb!vm:saetp-ctype saetp)
82 when (and (numeric-type-p ctype)
83 (eq (numeric-type-class ctype) 'integer)
84 (minusp (numeric-type-low ctype)))
85 do (fill map (cons (sb!vm:saetp-typecode saetp)
86 (sb!vm:saetp-n-bits saetp))
87 :end (+ (integer-length (numeric-type-high ctype)) 2)))
89 (cond ((> high sb!vm:n-word-bits)
90 (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
92 (let ((x (aref signed-table high)))
93 (values (car x) (cdr x))))
95 (let ((x (aref unsigned-table high)))
96 (values (car x) (cdr x)))))))
98 ;;; This is a bit complicated, but calling subtypep over all
99 ;;; specialized types is exceedingly slow
100 (defun %vector-widetag-and-n-bits (type)
101 (macrolet ((with-parameters ((arg-type &key intervals)
102 (&rest args) &body body)
103 (let ((type-sym (gensym)))
104 `(let (,@(loop for arg in args
106 (declare (ignorable ,@args))
108 (let ((,type-sym (cdr type)))
110 ,@(loop for arg in args
112 `(cond ((consp ,type-sym)
113 (let ((value (pop ,type-sym)))
114 (if (or (eq value '*)
115 (typep value ',arg-type)
131 (let ((value (symbol-value widetag)))
135 sb!vm:*specialized-array-element-type-properties*
136 :key #'sb!vm:saetp-typecode))))))
138 (error "Invalid type specifier: ~s" type))
139 (integer-interval-widetag (low high)
141 (%integer-vector-widetag-and-n-bits
143 (1+ (max (integer-length low) (integer-length high))))
144 (%integer-vector-widetag-and-n-bits
146 (max (integer-length low) (integer-length high))))))
147 (let* ((consp (consp type))
155 (result sb!vm:simple-vector-widetag))
156 ((base-char standard-char #!-sb-unicode character)
159 (result sb!vm:simple-base-string-widetag))
161 ((character extended-char)
164 (result sb!vm:simple-character-string-widetag))
168 (result sb!vm:simple-bit-vector-widetag))
172 (result sb!vm:simple-array-fixnum-widetag))
174 (with-parameters ((integer 1)) (high)
176 (result sb!vm:simple-vector-widetag)
177 (%integer-vector-widetag-and-n-bits nil high))))
179 (with-parameters ((integer 1)) (high)
181 (result sb!vm:simple-vector-widetag)
182 (%integer-vector-widetag-and-n-bits t high))))
184 (with-parameters (double-float :intervals t) (low high)
185 (if (and (not (eq low '*))
187 (if (or (consp low) (consp high))
188 (>= (type-bound-number low) (type-bound-number high))
190 (result sb!vm:simple-array-nil-widetag)
191 (result sb!vm:simple-array-double-float-widetag))))
193 (with-parameters (single-float :intervals t) (low high)
194 (if (and (not (eq low '*))
196 (if (or (consp low) (consp high))
197 (>= (type-bound-number low) (type-bound-number high))
199 (result sb!vm:simple-array-nil-widetag)
200 (result sb!vm:simple-array-single-float-widetag))))
202 (if (and (consp type)
205 (typep (cadr type) '(integer 1)))
206 (%integer-vector-widetag-and-n-bits
207 nil (integer-length (1- (cadr type))))
211 (with-parameters (long-float :intervals t) (low high)
212 (if (and (not (eq low '*))
214 (if (or (consp low) (consp high))
215 (>= (type-bound-number low) (type-bound-number high))
217 (result sb!vm:simple-array-nil-widetag)
218 (result sb!vm:simple-array-long-float-widetag))))
220 (with-parameters (integer :intervals t) (low high)
221 (let ((low (if (consp low)
224 (high (if (consp high)
227 (cond ((or (eq high '*)
229 (result sb!vm:simple-vector-widetag))
231 (result sb!vm:simple-array-nil-widetag))
233 (integer-interval-widetag low high))))))
235 (with-parameters (t) (subtype)
237 (result sb!vm:simple-vector-widetag)
238 (let ((ctype (specifier-type type)))
239 (cond ((eq ctype *empty-type*)
240 (result sb!vm:simple-array-nil-widetag))
241 ((union-type-p ctype)
242 (cond ((csubtypep ctype (specifier-type '(complex double-float)))
244 sb!vm:simple-array-complex-double-float-widetag))
245 ((csubtypep ctype (specifier-type '(complex single-float)))
247 sb!vm:simple-array-complex-single-float-widetag))
249 ((csubtypep ctype (specifier-type '(complex long-float)))
251 sb!vm:simple-array-complex-long-float-widetag))
253 (result sb!vm:simple-vector-widetag))))
255 (case (numeric-type-format ctype)
258 sb!vm:simple-array-complex-double-float-widetag))
261 sb!vm:simple-array-complex-single-float-widetag))
265 sb!vm:simple-array-complex-long-float-widetag))
267 (result sb!vm:simple-vector-widetag)))))))))
269 (result sb!vm:simple-array-nil-widetag))
273 (handler-case (specifier-type type)
274 (parse-unknown-type ()
275 (return (result sb!vm:simple-vector-widetag))))))
276 (if (union-type-p ctype)
277 (let ((types (union-type-types ctype)))
278 (cond ((not (every #'numeric-type-p types))
279 (result sb!vm:simple-vector-widetag))
280 ((csubtypep ctype (specifier-type 'integer))
281 (integer-interval-widetag
282 (reduce #'min types :key #'numeric-type-low)
283 (reduce #'max types :key #'numeric-type-high)))
284 ((csubtypep ctype (specifier-type 'double-float))
285 (result sb!vm:simple-array-double-float-widetag))
286 ((csubtypep ctype (specifier-type 'single-float))
287 (result sb!vm:simple-array-single-float-widetag))
289 ((csubtypep ctype (specifier-type 'long-float))
290 (result sb!vm:simple-array-long-float-widetag))
292 (result sb!vm:simple-vector-widetag))))
293 (let ((expansion (type-specifier ctype)))
294 (if (equal expansion type)
295 (result sb!vm:simple-vector-widetag)
296 (%vector-widetag-and-n-bits expansion))))))))))))
298 (defun %complex-vector-widetag (widetag)
299 (macrolet ((make-case ()
301 ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
302 for complex = (sb!vm:saetp-complex-typecode saetp)
304 collect (list (sb!vm:saetp-typecode saetp) complex))
306 #.sb!vm:complex-vector-widetag))))
309 (defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask)))
310 #.(loop for info across sb!vm:*specialized-array-element-type-properties*
311 collect `(setf (aref %%simple-array-n-bits%% ,(sb!vm:saetp-typecode info))
312 ,(sb!vm:saetp-n-bits info)) into forms
313 finally (return `(progn ,@forms)))
315 (defun allocate-vector-with-widetag (widetag length &optional n-bits)
316 (declare (type (unsigned-byte 8) widetag)
318 (let ((n-bits (or n-bits (aref %%simple-array-n-bits%% widetag))))
319 (declare (type (integer 0 256) n-bits))
320 (allocate-vector widetag length
322 (* (if (or (= widetag sb!vm:simple-base-string-widetag)
325 sb!vm:simple-character-string-widetag))
329 sb!vm:n-word-bits))))
331 (defun array-underlying-widetag (array)
332 (macrolet ((make-case ()
334 ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
335 for complex = (sb!vm:saetp-complex-typecode saetp)
337 collect (list complex (sb!vm:saetp-typecode saetp)))
338 ((,sb!vm:simple-array-widetag
339 ,sb!vm:complex-vector-widetag
340 ,sb!vm:complex-array-widetag)
341 (with-array-data ((array array) (start) (end))
342 (declare (ignore start end))
346 (let ((widetag (widetag-of array)))
349 ;;; Widetag is the widetag of the underlying vector,
350 ;;; it'll be the same as the resulting array widetag only for simple vectors
351 (defun %make-array (dimensions widetag n-bits
354 (initial-element nil initial-element-p)
355 (initial-contents nil initial-contents-p)
356 adjustable fill-pointer
357 displaced-to displaced-index-offset)
358 (declare (ignore element-type))
359 (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
360 (array-rank (length (the list dimensions)))
361 (simple (and (null fill-pointer)
363 (null displaced-to))))
364 (declare (fixnum array-rank))
365 (cond ((and displaced-index-offset (null displaced-to))
366 (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
367 ((and simple (= array-rank 1))
368 ;; it's a (SIMPLE-ARRAY * (*))
369 (let* ((length (car dimensions))
370 (array (allocate-vector-with-widetag widetag length n-bits)))
371 (declare (type index length))
372 (when initial-element-p
373 (fill array initial-element))
374 (when initial-contents-p
375 (when initial-element-p
376 (error "can't specify both :INITIAL-ELEMENT and ~
378 (unless (= length (length initial-contents))
379 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
380 the vector length is ~W."
381 (length initial-contents)
383 (replace array initial-contents))
385 ((and (arrayp displaced-to)
386 (/= (array-underlying-widetag displaced-to) widetag))
387 (error "Array element type of :DISPLACED-TO array does not match specified element type"))
389 ;; it's either a complex array or a multidimensional array.
390 (let* ((total-size (reduce #'* dimensions))
391 (data (or displaced-to
392 (data-vector-from-inits
393 dimensions total-size nil widetag n-bits
394 initial-contents initial-contents-p
395 initial-element initial-element-p)))
396 (array (make-array-header
397 (cond ((= array-rank 1)
398 (%complex-vector-widetag widetag))
399 (simple sb!vm:simple-array-widetag)
400 (t sb!vm:complex-array-widetag))
403 (unless (= array-rank 1)
404 (error "Only vectors can have fill pointers."))
405 (let ((length (car dimensions)))
406 (declare (fixnum length))
407 (setf (%array-fill-pointer array)
408 (cond ((eq fill-pointer t)
411 (unless (and (fixnump fill-pointer)
413 (<= fill-pointer length))
414 ;; FIXME: should be TYPE-ERROR?
415 (error "invalid fill-pointer ~W"
418 (setf (%array-fill-pointer-p array) t))
420 (setf (%array-fill-pointer array) total-size)
421 (setf (%array-fill-pointer-p array) nil)))
422 (setf (%array-available-elements array) total-size)
423 (setf (%array-data-vector array) data)
424 (setf (%array-displaced-from array) nil)
426 (when (or initial-element-p initial-contents-p)
427 (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
428 can be specified along with :DISPLACED-TO"))
429 (let ((offset (or displaced-index-offset 0)))
430 (when (> (+ offset total-size)
431 (array-total-size displaced-to))
432 (error "~S doesn't have enough elements." displaced-to))
433 (setf (%array-displacement array) offset)
434 (setf (%array-displaced-p array) t)
435 (%save-displaced-array-backpointer array data)))
437 (setf (%array-displaced-p array) nil)))
439 (dolist (dim dimensions)
440 (setf (%array-dimension array axis) dim)
444 (defun make-array (dimensions &rest args
445 &key (element-type t)
446 initial-element initial-contents
450 displaced-index-offset)
451 (declare (ignore initial-element
452 initial-contents adjustable
453 fill-pointer displaced-to displaced-index-offset))
454 (multiple-value-bind (widetag n-bits) (%vector-widetag-and-n-bits element-type)
455 (apply #'%make-array dimensions widetag n-bits args)))
457 (defun make-static-vector (length &key
458 (element-type '(unsigned-byte 8))
459 (initial-contents nil initial-contents-p)
460 (initial-element nil initial-element-p))
461 "Allocate vector of LENGTH elements in static space. Only allocation
462 of specialized arrays is supported."
463 ;; STEP 1: check inputs fully
465 ;; This way of doing explicit checks before the vector is allocated
466 ;; is expensive, but probably worth the trouble as once we've allocated
467 ;; the vector we have no way to get rid of it anymore...
468 (when (eq t (upgraded-array-element-type element-type))
469 (error "Static arrays of type ~S not supported."
471 (when initial-contents-p
472 (when initial-element-p
473 (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
474 (unless (= length (length initial-contents))
475 (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
476 vector length is ~W."
477 (length initial-contents)
479 (unless (every (lambda (x) (typep x element-type)) initial-contents)
480 (error ":INITIAL-CONTENTS contains elements not of type ~S."
482 (when initial-element-p
483 (unless (typep initial-element element-type)
484 (error ":INITIAL-ELEMENT ~S is not of type ~S."
485 initial-element element-type)))
488 ;; Allocate and possibly initialize the vector.
489 (multiple-value-bind (type n-bits)
490 (sb!impl::%vector-widetag-and-n-bits element-type)
492 (allocate-static-vector type length
493 (ceiling (* length n-bits)
494 sb!vm:n-word-bits))))
495 (cond (initial-element-p
496 (fill vector initial-element))
498 (replace vector initial-contents))
502 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
503 ;;; specified array characteristics. Dimensions is only used to pass
504 ;;; to FILL-DATA-VECTOR for error checking on the structure of
505 ;;; initial-contents.
506 (defun data-vector-from-inits (dimensions total-size
507 element-type widetag n-bits
508 initial-contents initial-contents-p
509 initial-element initial-element-p)
510 (when initial-element-p
511 (when initial-contents-p
512 (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
513 either MAKE-ARRAY or ADJUST-ARRAY."))
514 ;; FIXME: element-type can be NIL when widetag is non-nil,
515 ;; and FILL will check the type, although the error will be not as nice.
516 ;; (cond (typep initial-element element-type)
517 ;; (error "~S cannot be used to initialize an array of type ~S."
518 ;; initial-element element-type))
520 (let ((data (if widetag
521 (allocate-vector-with-widetag widetag total-size n-bits)
522 (make-array total-size :element-type element-type))))
523 (cond (initial-element-p
524 (fill (the vector data) initial-element))
526 (fill-data-vector data dimensions initial-contents)))
529 (defun vector (&rest objects)
531 "Construct a SIMPLE-VECTOR from the given objects."
532 (coerce (the list objects) 'simple-vector))
535 ;;;; accessor/setter functions
537 ;;; Dispatch to an optimized routine the data vector accessors for
538 ;;; each different specialized vector type. Do dispatching by looking
539 ;;; up the widetag in the array rather than with the typecases, which
540 ;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
541 ;;; provide separate versions where bounds checking has been moved
542 ;;; from the callee to the caller, since it's much cheaper to do once
543 ;;; the type information is available. Finally, for each of these
544 ;;; routines also provide a slow path, taken for arrays that are not
545 ;;; vectors or not simple.
546 (macrolet ((def (name table-name)
548 (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)))
549 (defmacro ,name (array-var)
552 (when (sb!vm::%other-pointer-p ,array-var)
553 (setf tag (%other-pointer-widetag ,array-var)))
554 (svref ,',table-name tag)))))))
555 (def !find-data-vector-setter %%data-vector-setters%%)
556 (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
557 ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
558 ;; meaning we can have post-build dependences on this.
559 (def %find-data-vector-reffer %%data-vector-reffers%%)
560 (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
562 ;;; Like DOVECTOR, but more magical -- can't use this on host.
563 (defmacro do-vector-data ((elt vector &optional result) &body body)
564 (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
565 (with-unique-names (index vec start end ref)
566 `(with-array-data ((,vec ,vector)
569 :check-fill-pointer t)
570 (let ((,ref (%find-data-vector-reffer ,vec)))
571 (do ((,index ,start (1+ ,index)))
574 ,@(filter-dolist-declarations decls)
577 (let ((,elt (funcall ,ref ,vec ,index)))
579 (tagbody ,@forms))))))))
581 (macrolet ((%ref (accessor-getter extra-params)
582 `(funcall (,accessor-getter array) array index ,@extra-params))
583 (define (accessor-name slow-accessor-name accessor-getter
584 extra-params check-bounds)
586 (defun ,accessor-name (array index ,@extra-params)
587 (declare (optimize speed
588 ;; (SAFETY 0) is ok. All calls to
589 ;; these functions are generated by
590 ;; the compiler, so argument count
591 ;; checking isn't needed. Type checking
592 ;; is done implicitly via the widetag
595 (%ref ,accessor-getter ,extra-params))
596 (defun ,slow-accessor-name (array index ,@extra-params)
597 (declare (optimize speed (safety 0)))
598 (if (not (%array-displaced-p array))
599 ;; The reasonably quick path of non-displaced complex
601 (let ((array (%array-data-vector array)))
602 (%ref ,accessor-getter ,extra-params))
603 ;; The real slow path.
607 (declare (optimize (speed 1) (safety 1)))
608 (,@check-bounds index)))
611 (declare (ignore end))
612 (,accessor-name vector index ,@extra-params)))))))
613 (define hairy-data-vector-ref slow-hairy-data-vector-ref
614 %find-data-vector-reffer
616 (define hairy-data-vector-set slow-hairy-data-vector-set
617 !find-data-vector-setter
619 (define hairy-data-vector-ref/check-bounds
620 slow-hairy-data-vector-ref/check-bounds
621 !find-data-vector-reffer/check-bounds
622 nil (%check-bound array (array-dimension array 0)))
623 (define hairy-data-vector-set/check-bounds
624 slow-hairy-data-vector-set/check-bounds
625 !find-data-vector-setter/check-bounds
626 (new-value) (%check-bound array (array-dimension array 0))))
628 (defun hairy-ref-error (array index &optional new-value)
629 (declare (ignore index new-value))
632 :expected-type 'vector))
634 (macrolet ((define-reffer (saetp check-form)
635 (let* ((type (sb!vm:saetp-specifier saetp))
636 (atype `(simple-array ,type (*))))
637 `(named-lambda optimized-data-vector-ref (vector index)
638 (declare (optimize speed (safety 0)))
639 (data-vector-ref (the ,atype vector)
641 (declare (optimize (safety 1)))
643 (,@check-form index)))))))
644 (define-setter (saetp check-form)
645 (let* ((type (sb!vm:saetp-specifier saetp))
646 (atype `(simple-array ,type (*))))
647 `(named-lambda optimized-data-vector-set (vector index new-value)
648 (declare (optimize speed (safety 0)))
649 (data-vector-set (the ,atype vector)
651 (declare (optimize (safety 1)))
653 (,@check-form index)))
655 ;; SPEED 1 needed to avoid the compiler
656 ;; from downgrading the type check to
658 (declare (optimize (speed 1)
660 (the ,type new-value)))
661 ;; For specialized arrays, the return from
662 ;; data-vector-set would have to be reboxed to be a
663 ;; (Lisp) return value; instead, we use the
664 ;; already-boxed value as the return.
666 (define-reffers (symbol deffer check-form slow-path)
668 ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
669 ;; preserve the binding, so re-initiaize as NS doesn't have
670 ;; the energy to figure out to change that right now.
671 (setf ,symbol (make-array (1+ sb!vm::widetag-mask)
672 :initial-element #'hairy-ref-error))
673 ,@(loop for widetag in '(sb!vm:complex-vector-widetag
674 sb!vm:complex-vector-nil-widetag
675 sb!vm:complex-bit-vector-widetag
676 #!+sb-unicode sb!vm:complex-character-string-widetag
677 sb!vm:complex-base-string-widetag
678 sb!vm:simple-array-widetag
679 sb!vm:complex-array-widetag)
680 collect `(setf (svref ,symbol ,widetag) ,slow-path))
681 ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
682 for widetag = (sb!vm:saetp-typecode saetp)
683 collect `(setf (svref ,symbol ,widetag)
684 (,deffer ,saetp ,check-form))))))
685 (defun !hairy-data-vector-reffer-init ()
686 (define-reffers %%data-vector-reffers%% define-reffer
688 #'slow-hairy-data-vector-ref)
689 (define-reffers %%data-vector-setters%% define-setter
691 #'slow-hairy-data-vector-set)
692 (define-reffers %%data-vector-reffers/check-bounds%% define-reffer
693 (%check-bound vector (length vector))
694 #'slow-hairy-data-vector-ref/check-bounds)
695 (define-reffers %%data-vector-setters/check-bounds%% define-setter
696 (%check-bound vector (length vector))
697 #'slow-hairy-data-vector-set/check-bounds)))
699 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
700 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
701 ;;; definition is needed for the compiler to use in constant folding.)
702 (defun data-vector-ref (array index)
703 (hairy-data-vector-ref array index))
705 (defun data-vector-ref-with-offset (array index offset)
706 (hairy-data-vector-ref array (+ index offset)))
708 (defun invalid-array-p (array)
709 (and (array-header-p array)
710 (consp (%array-displaced-p array))))
712 (declaim (ftype (function (array) nil) invalid-array-error))
713 (defun invalid-array-error (array)
714 (aver (array-header-p array))
715 ;; Array invalidation stashes the original dimensions here...
716 (let ((dims (%array-displaced-p array))
717 (et (array-element-type array)))
718 (error 'invalid-array-error
723 `(vector ,et ,@dims)))))
725 (declaim (ftype (function (array integer integer &optional t) nil)
726 invalid-array-index-error))
727 (defun invalid-array-index-error (array index bound &optional axis)
728 (if (invalid-array-p array)
729 (invalid-array-error array)
730 (error 'invalid-array-index-error
734 :expected-type `(integer 0 (,bound)))))
736 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
737 (defun %array-row-major-index (array subscripts
738 &optional (invalid-index-error-p t))
739 (declare (array array)
741 (let ((rank (array-rank array)))
742 (unless (= rank (length subscripts))
743 (error "wrong number of subscripts, ~W, for array of rank ~W"
744 (length subscripts) rank))
745 (if (array-header-p array)
746 (do ((subs (nreverse subscripts) (cdr subs))
747 (axis (1- (array-rank array)) (1- axis))
751 (declare (list subs) (fixnum axis chunk-size result))
752 (let ((index (car subs))
753 (dim (%array-dimension array axis)))
754 (declare (fixnum dim))
755 (unless (and (fixnump index) (< -1 index dim))
756 (if invalid-index-error-p
757 (invalid-array-index-error array index dim axis)
758 (return-from %array-row-major-index nil)))
759 (incf result (* chunk-size (the fixnum index)))
760 (setf chunk-size (* chunk-size dim))))
761 (let ((index (first subscripts))
762 (length (length (the (simple-array * (*)) array))))
763 (unless (and (fixnump index) (< -1 index length))
764 (if invalid-index-error-p
765 (invalid-array-index-error array index length)
766 (return-from %array-row-major-index nil)))
769 (defun array-in-bounds-p (array &rest subscripts)
771 "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
772 (if (%array-row-major-index array subscripts nil)
775 (defun array-row-major-index (array &rest subscripts)
776 (declare (truly-dynamic-extent subscripts))
777 (%array-row-major-index array subscripts))
779 (defun aref (array &rest subscripts)
781 "Return the element of the ARRAY specified by the SUBSCRIPTS."
782 (declare (truly-dynamic-extent subscripts))
783 (row-major-aref array (%array-row-major-index array subscripts)))
785 ;;; (setf aref/bit/sbit) are implemented using setf-functions,
786 ;;; because they have to work with (setf (apply #'aref array subscripts))
787 ;;; All other setfs can be done using setf-functions too, but I
788 ;;; haven't found technical advantages or disatvantages for either
790 (defun (setf aref) (new-value array &rest subscripts)
791 (declare (truly-dynamic-extent subscripts)
793 (setf (row-major-aref array (%array-row-major-index array subscripts))
796 (defun row-major-aref (array index)
798 "Return the element of array corresponding to the row-major index. This is
800 (declare (optimize (safety 1)))
801 (row-major-aref array index))
803 (defun %set-row-major-aref (array index new-value)
804 (declare (optimize (safety 1)))
805 (setf (row-major-aref array index) new-value))
807 (defun svref (simple-vector index)
809 "Return the INDEXth element of the given Simple-Vector."
810 (declare (optimize (safety 1)))
811 (aref simple-vector index))
813 (defun %svset (simple-vector index new)
814 (declare (optimize (safety 1)))
815 (setf (aref simple-vector index) new))
817 (defun bit (bit-array &rest subscripts)
819 "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
820 (declare (type (array bit) bit-array)
821 (optimize (safety 1)))
822 (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
824 (defun (setf bit) (new-value bit-array &rest subscripts)
825 (declare (type (array bit) bit-array)
827 (optimize (safety 1)))
828 (setf (row-major-aref bit-array
829 (%array-row-major-index bit-array subscripts))
832 (defun sbit (simple-bit-array &rest subscripts)
834 "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
835 (declare (type (simple-array bit) simple-bit-array)
836 (optimize (safety 1)))
837 (row-major-aref simple-bit-array
838 (%array-row-major-index simple-bit-array subscripts)))
840 (defun (setf sbit) (new-value bit-array &rest subscripts)
841 (declare (type (simple-array bit) bit-array)
843 (optimize (safety 1)))
844 (setf (row-major-aref bit-array
845 (%array-row-major-index bit-array subscripts))
848 ;;;; miscellaneous array properties
850 (defun array-element-type (array)
852 "Return the type of the elements of the array"
853 (let ((widetag (widetag-of array)))
854 (macrolet ((pick-element-type (&rest stuff)
855 `(cond ,@(mapcar (lambda (stuff)
857 (let ((item (car stuff)))
866 `(= widetag ,item))))
869 #.`(pick-element-type
872 `(,(if (sb!vm:saetp-complex-typecode saetp)
873 (list (sb!vm:saetp-typecode saetp)
874 (sb!vm:saetp-complex-typecode saetp))
875 (sb!vm:saetp-typecode saetp))
876 ',(sb!vm:saetp-specifier saetp)))
877 sb!vm:*specialized-array-element-type-properties*)
878 ((sb!vm:simple-array-widetag
879 sb!vm:complex-vector-widetag
880 sb!vm:complex-array-widetag)
881 (with-array-data ((array array) (start) (end))
882 (declare (ignore start end))
883 (array-element-type array)))
885 (error 'type-error :datum array :expected-type 'array))))))
887 (defun array-rank (array)
889 "Return the number of dimensions of ARRAY."
890 (if (array-header-p array)
894 (defun array-dimension (array axis-number)
896 "Return the length of dimension AXIS-NUMBER of ARRAY."
897 (declare (array array) (type index axis-number))
898 (cond ((not (array-header-p array))
899 (unless (= axis-number 0)
900 (error "Vector axis is not zero: ~S" axis-number))
901 (length (the (simple-array * (*)) array)))
902 ((>= axis-number (%array-rank array))
903 (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
904 axis-number array (%array-rank array)))
906 (%array-dimension array axis-number))))
908 (defun array-dimensions (array)
910 "Return a list whose elements are the dimensions of the array"
911 (declare (array array))
912 (if (array-header-p array)
913 (do ((results nil (cons (array-dimension array index) results))
914 (index (1- (array-rank array)) (1- index)))
915 ((minusp index) results))
916 (list (array-dimension array 0))))
918 (defun array-total-size (array)
920 "Return the total number of elements in the Array."
921 (declare (array array))
922 (if (array-header-p array)
923 (%array-available-elements array)
924 (length (the vector array))))
926 (defun array-displacement (array)
928 "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
929 options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
930 (declare (type array array))
931 (if (and (array-header-p array) ; if unsimple and
932 (%array-displaced-p array)) ; displaced
933 (values (%array-data-vector array) (%array-displacement array))
936 (defun adjustable-array-p (array)
938 "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
939 to the argument, this happens for complex arrays."
940 (declare (array array))
941 ;; Note that this appears not to be a fundamental limitation.
942 ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
943 ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
944 ;; -- CSR, 2004-03-01.
945 (not (typep array 'simple-array)))
947 ;;;; fill pointer frobbing stuff
949 (declaim (inline array-has-fill-pointer-p))
950 (defun array-has-fill-pointer-p (array)
952 "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
953 (declare (array array))
954 (and (array-header-p array) (%array-fill-pointer-p array)))
956 (defun fill-pointer-error (vector arg)
958 (aver (array-has-fill-pointer-p vector))
959 (let ((max (%array-available-elements vector)))
960 (error 'simple-type-error
962 :expected-type (list 'integer 0 max)
963 :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)"
964 :format-arguments (list arg max))))
966 (error 'simple-type-error
968 :expected-type '(and vector (satisfies array-has-fill-pointer-p))
969 :format-control "~S is not an array with a fill pointer."
970 :format-arguments (list vector)))))
972 (declaim (inline fill-pointer))
973 (defun fill-pointer (vector)
975 "Return the FILL-POINTER of the given VECTOR."
976 (if (array-has-fill-pointer-p vector)
977 (%array-fill-pointer vector)
978 (fill-pointer-error vector nil)))
980 (defun %set-fill-pointer (vector new)
982 (fill-pointer-error vector x)))
983 (if (array-has-fill-pointer-p vector)
984 (if (> new (%array-available-elements vector))
986 (setf (%array-fill-pointer vector) new))
989 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
990 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
991 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
992 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
994 (defun vector-push (new-element array)
996 "Attempt to set the element of ARRAY designated by its fill pointer
997 to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
998 too large, NIL is returned, otherwise the index of the pushed element is
1000 (let ((fill-pointer (fill-pointer array)))
1001 (declare (fixnum fill-pointer))
1002 (cond ((= fill-pointer (%array-available-elements array))
1005 (locally (declare (optimize (safety 0)))
1006 (setf (aref array fill-pointer) new-element))
1007 (setf (%array-fill-pointer array) (1+ fill-pointer))
1010 (defun vector-push-extend (new-element vector &optional min-extension)
1011 (declare (type (or null fixnum) min-extension))
1012 (let ((fill-pointer (fill-pointer vector)))
1013 (declare (fixnum fill-pointer))
1014 (when (= fill-pointer (%array-available-elements vector))
1015 (let ((min-extension
1017 (let ((length (length vector)))
1019 (- array-dimension-limit length))))))
1020 (adjust-array vector (+ fill-pointer (max 1 min-extension)))))
1021 ;; disable bounds checking
1022 (locally (declare (optimize (safety 0)))
1023 (setf (aref vector fill-pointer) new-element))
1024 (setf (%array-fill-pointer vector) (1+ fill-pointer))
1027 (defun vector-pop (array)
1029 "Decrease the fill pointer by 1 and return the element pointed to by the
1031 (let ((fill-pointer (fill-pointer array)))
1032 (declare (fixnum fill-pointer))
1033 (if (zerop fill-pointer)
1034 (error "There is nothing left to pop.")
1035 ;; disable bounds checking (and any fixnum test)
1036 (locally (declare (optimize (safety 0)))
1038 (setf (%array-fill-pointer array)
1039 (1- fill-pointer)))))))
1044 (defun adjust-array (array dimensions &key
1045 (element-type (array-element-type array) element-type-p)
1046 (initial-element nil initial-element-p)
1047 (initial-contents nil initial-contents-p)
1049 displaced-to displaced-index-offset)
1051 "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
1052 (when (invalid-array-p array)
1053 (invalid-array-error array))
1054 (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
1055 (cond ((/= (the fixnum (length (the list dimensions)))
1056 (the fixnum (array-rank array)))
1057 (error "The number of dimensions not equal to rank of array."))
1058 ((and element-type-p
1059 (not (subtypep element-type (array-element-type array))))
1060 (error "The new element type, ~S, is incompatible with old type."
1062 ((and fill-pointer (not (array-has-fill-pointer-p array)))
1065 :expected-type '(satisfies array-has-fill-pointer-p))))
1066 (let ((array-rank (length (the list dimensions))))
1067 (declare (fixnum array-rank))
1068 (unless (= array-rank 1)
1070 (error "Only vectors can have fill pointers.")))
1071 (cond (initial-contents-p
1072 ;; array former contents replaced by INITIAL-CONTENTS
1073 (if (or initial-element-p displaced-to)
1074 (error ":INITIAL-CONTENTS may not be specified with ~
1075 the :INITIAL-ELEMENT or :DISPLACED-TO option."))
1076 (let* ((array-size (apply #'* dimensions))
1077 (array-data (data-vector-from-inits
1078 dimensions array-size element-type nil nil
1079 initial-contents initial-contents-p
1080 initial-element initial-element-p)))
1081 (if (adjustable-array-p array)
1082 (set-array-header array array-data array-size
1083 (get-new-fill-pointer array array-size
1085 0 dimensions nil nil)
1086 (if (array-header-p array)
1087 ;; simple multidimensional or single dimensional array
1088 (make-array dimensions
1089 :element-type element-type
1090 :initial-contents initial-contents)
1093 ;; We already established that no INITIAL-CONTENTS was supplied.
1094 (when initial-element
1095 (error "The :INITIAL-ELEMENT option may not be specified ~
1096 with :DISPLACED-TO."))
1097 (unless (subtypep element-type (array-element-type displaced-to))
1098 (error "can't displace an array of type ~S into another of ~
1100 element-type (array-element-type displaced-to)))
1101 (let ((displacement (or displaced-index-offset 0))
1102 (array-size (apply #'* dimensions)))
1103 (declare (fixnum displacement array-size))
1104 (if (< (the fixnum (array-total-size displaced-to))
1105 (the fixnum (+ displacement array-size)))
1106 (error "The :DISPLACED-TO array is too small."))
1107 (if (adjustable-array-p array)
1108 ;; None of the original contents appear in adjusted array.
1109 (set-array-header array displaced-to array-size
1110 (get-new-fill-pointer array array-size
1112 displacement dimensions t nil)
1113 ;; simple multidimensional or single dimensional array
1114 (make-array dimensions
1115 :element-type element-type
1116 :displaced-to displaced-to
1117 :displaced-index-offset
1118 displaced-index-offset))))
1120 (let ((old-length (array-total-size array))
1121 (new-length (car dimensions))
1123 (declare (fixnum old-length new-length))
1124 (with-array-data ((old-data array) (old-start)
1125 (old-end old-length))
1126 (cond ((or (and (array-header-p array)
1127 (%array-displaced-p array))
1128 (< old-length new-length))
1130 (data-vector-from-inits
1131 dimensions new-length element-type
1132 (widetag-of old-data) nil
1133 initial-contents initial-contents-p
1134 initial-element initial-element-p))
1135 ;; Provide :END1 to avoid full call to LENGTH
1137 (replace new-data old-data
1139 :start2 old-start :end2 old-end))
1141 (shrink-vector old-data new-length))))
1142 (if (adjustable-array-p array)
1143 (set-array-header array new-data new-length
1144 (get-new-fill-pointer array new-length
1146 0 dimensions nil nil)
1149 (let ((old-length (%array-available-elements array))
1150 (new-length (apply #'* dimensions)))
1151 (declare (fixnum old-length new-length))
1152 (with-array-data ((old-data array) (old-start)
1153 (old-end old-length))
1154 (declare (ignore old-end))
1155 (let ((new-data (if (or (and (array-header-p array)
1156 (%array-displaced-p array))
1157 (> new-length old-length))
1158 (data-vector-from-inits
1159 dimensions new-length
1161 (widetag-of old-data) nil
1163 initial-element initial-element-p)
1165 (if (or (zerop old-length) (zerop new-length))
1166 (when initial-element-p (fill new-data initial-element))
1167 (zap-array-data old-data (array-dimensions array)
1169 new-data dimensions new-length
1170 element-type initial-element
1172 (if (adjustable-array-p array)
1173 (set-array-header array new-data new-length
1174 nil 0 dimensions nil nil)
1177 sb!vm:simple-array-widetag array-rank)))
1178 (set-array-header new-array new-data new-length
1179 nil 0 dimensions nil t)))))))))))
1182 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
1183 (cond ((not fill-pointer)
1184 (when (array-has-fill-pointer-p old-array)
1185 (when (> (%array-fill-pointer old-array) new-array-size)
1186 (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
1187 smaller than its fill pointer (~S)"
1188 old-array new-array-size (fill-pointer old-array)))
1189 (%array-fill-pointer old-array)))
1190 ((not (array-has-fill-pointer-p old-array))
1191 (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
1192 in ADJUST-ARRAY unless the array (~S) was originally ~
1193 created with a fill pointer"
1196 ((numberp fill-pointer)
1197 (when (> fill-pointer new-array-size)
1198 (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
1199 than the new length of the vector (~S)"
1200 fill-pointer new-array-size))
1202 ((eq fill-pointer t)
1205 (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S"
1208 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
1209 ;;; which must be less than or equal to its current length. This can
1210 ;;; be called on vectors without a fill pointer but it is extremely
1211 ;;; dangerous to do so: shrinking the size of an object (as viewed by
1212 ;;; the gc) makes bounds checking unreliable in the face of interrupts
1213 ;;; or multi-threading. Call it only on provably local vectors.
1214 (defun %shrink-vector (vector new-length)
1215 (declare (vector vector))
1216 (unless (array-header-p vector)
1217 (macrolet ((frob (name &rest things)
1219 ((simple-array nil (*)) (error 'nil-array-accessed-error))
1220 ,@(mapcar (lambda (thing)
1221 (destructuring-bind (type-spec fill-value)
1224 (fill (truly-the ,type-spec ,name)
1226 :start new-length))))
1228 ;; Set the 'tail' of the vector to the appropriate type of zero,
1229 ;; "because in some cases we'll scavenge larger areas in one go,
1230 ;; like groups of pages that had triggered the write barrier, or
1231 ;; the whole static space" according to jsnell.
1235 `((simple-array ,(sb!vm:saetp-specifier saetp) (*))
1236 ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character)
1238 (eq (sb!vm:saetp-specifier saetp) 'base-char))
1239 *default-init-char-form*
1240 (sb!vm:saetp-initial-element-default saetp))))
1242 #'sb!vm:saetp-specifier
1243 sb!vm:*specialized-array-element-type-properties*)))))
1244 ;; Only arrays have fill-pointers, but vectors have their length
1245 ;; parameter in the same place.
1246 (setf (%array-fill-pointer vector) new-length)
1249 (defun shrink-vector (vector new-length)
1250 (declare (vector vector))
1252 ((eq (length vector) new-length)
1254 ((array-has-fill-pointer-p vector)
1255 (setf (%array-fill-pointer vector) new-length)
1257 (t (subseq vector 0 new-length))))
1259 ;;; BIG THREAD SAFETY NOTE
1261 ;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
1262 ;;; thread unsafe. They are nonatomic, and can mess with parallel
1263 ;;; code using the same arrays.
1265 ;;; A likely seeming fix is an additional level of indirection:
1266 ;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
1267 ;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
1268 ;;; would hold everything ARRAY-HEADER now holds. This allows
1269 ;;; consing up a new ARRAY-INFO and replacing it atomically in
1270 ;;; the ARRAY-HEADER.
1272 ;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
1273 ;;; one: not only is it needed extremely rarely, which makes
1274 ;;; any thread safety bugs involving it look like rare random
1275 ;;; corruption, but because it walks the chain *upwards*, which
1276 ;;; may violate user expectations.
1278 (defun %save-displaced-array-backpointer (array data)
1279 (flet ((purge (pointers)
1280 (remove-if (lambda (value)
1281 (or (not value) (eq array value)))
1283 :key #'weak-pointer-value)))
1284 ;; Add backpointer to the new data vector if it has a header.
1285 (when (array-header-p data)
1286 (setf (%array-displaced-from data)
1287 (cons (make-weak-pointer array)
1288 (purge (%array-displaced-from data)))))
1289 ;; Remove old backpointer, if any.
1290 (let ((old-data (%array-data-vector array)))
1291 (when (and (neq data old-data) (array-header-p old-data))
1292 (setf (%array-displaced-from old-data)
1293 (purge (%array-displaced-from old-data)))))))
1295 (defun %walk-displaced-array-backpointers (array new-length)
1296 (dolist (p (%array-displaced-from array))
1297 (let ((from (weak-pointer-value p)))
1298 (when (and from (eq array (%array-data-vector from)))
1299 (let ((requires (+ (%array-available-elements from)
1300 (%array-displacement from))))
1301 (unless (>= new-length requires)
1302 ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
1304 ;; "If A is displaced to B, the consequences are unspecified if B is
1305 ;; adjusted in such a way that it no longer has enough elements to
1308 ;; since we're hanging on a weak pointer here, we can't signal an
1309 ;; error right now: the array that we're looking at might be
1310 ;; garbage. Instead, we set all dimensions to zero so that next
1311 ;; safe access to the displaced array will trap. Additionally, we
1312 ;; save the original dimensions, so we can signal a more
1313 ;; understandable error when the time comes.
1314 (%walk-displaced-array-backpointers from 0)
1315 (setf (%array-fill-pointer from) 0
1316 (%array-available-elements from) 0
1317 (%array-displaced-p from) (array-dimensions array))
1318 (dotimes (i (%array-rank from))
1319 (setf (%array-dimension from i) 0))))))))
1321 ;;; Fill in array header with the provided information, and return the array.
1322 (defun set-array-header (array data length fill-pointer displacement dimensions
1325 (setf (%array-displaced-from array) nil)
1326 (%walk-displaced-array-backpointers array length))
1328 (%save-displaced-array-backpointer array data))
1329 (setf (%array-data-vector array) data)
1330 (setf (%array-available-elements array) length)
1332 (setf (%array-fill-pointer array) fill-pointer)
1333 (setf (%array-fill-pointer-p array) t))
1335 (setf (%array-fill-pointer array) length)
1336 (setf (%array-fill-pointer-p array) nil)))
1337 (setf (%array-displacement array) displacement)
1338 (if (listp dimensions)
1339 (dotimes (axis (array-rank array))
1340 (declare (type index axis))
1341 (setf (%array-dimension array axis) (pop dimensions)))
1342 (setf (%array-dimension array 0) dimensions))
1343 (setf (%array-displaced-p array) displacedp)
1346 ;;; User visible extension
1347 (declaim (ftype (function (array) (values (simple-array * (*)) &optional))
1348 array-storage-vector))
1349 (defun array-storage-vector (array)
1350 "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
1352 In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
1353 vector. Multidimensional arrays, arrays with fill pointers, and adjustable
1354 arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
1355 ARRAY, which this function returns.
1357 Important note: the underlying vector is an implementation detail. Even though
1358 this function exposes it, changes in the implementation may cause this
1359 function to be removed without further warning."
1360 ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that
1361 ;; the return value is always of the known type.
1362 (truly-the (simple-array * (*))
1363 (if (array-header-p array)
1364 (if (%array-displaced-p array)
1365 (error "~S cannot be used with displaced arrays. Use ~S instead."
1366 'array-storage-vector 'array-displacement)
1367 (%array-data-vector array))
1371 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
1373 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
1374 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
1375 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
1376 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
1377 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1378 element-type initial-element initial-element-p)
1379 (declare (list old-dims new-dims)
1380 (fixnum new-length))
1381 ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
1382 ;; at least in SBCL.
1383 ;; NEW-DIMS comes from the user.
1384 (setf old-dims (nreverse old-dims)
1385 new-dims (reverse new-dims))
1386 (cond ((eq old-data new-data)
1387 ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
1388 ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
1389 ;; EQ; in this case, a temporary must be used and filled
1390 ;; appropriately. specified initial-element.
1391 (when initial-element-p
1392 ;; FIXME: transforming this TYPEP to someting a bit faster
1393 ;; would be a win...
1394 (unless (typep initial-element element-type)
1395 (error "~S can't be used to initialize an array of type ~S."
1396 initial-element element-type)))
1397 (let ((temp (if initial-element-p
1398 (make-array new-length :initial-element initial-element)
1399 (make-array new-length))))
1400 (declare (simple-vector temp))
1401 (zap-array-data-aux old-data old-dims offset temp new-dims)
1402 (dotimes (i new-length)
1403 (setf (aref new-data i) (aref temp i)))
1404 ;; Kill the temporary vector to prevent garbage retention.
1405 (%shrink-vector temp 0)))
1407 ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
1408 ;; already been filled with any
1409 (zap-array-data-aux old-data old-dims offset new-data new-dims))))
1411 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
1412 (declare (fixnum offset))
1413 (let ((limits (mapcar (lambda (x y)
1414 (declare (fixnum x y))
1415 (1- (the fixnum (min x y))))
1416 old-dims new-dims)))
1417 (macrolet ((bump-index-list (index limits)
1418 `(do ((subscripts ,index (cdr subscripts))
1419 (limits ,limits (cdr limits)))
1420 ((null subscripts) :eof)
1421 (cond ((< (the fixnum (car subscripts))
1422 (the fixnum (car limits)))
1424 (1+ (the fixnum (car subscripts))))
1426 (t (rplaca subscripts 0))))))
1427 (do ((index (make-list (length old-dims) :initial-element 0)
1428 (bump-index-list index limits)))
1430 (setf (aref new-data (row-major-index-from-dims index new-dims))
1432 (+ (the fixnum (row-major-index-from-dims index old-dims))
1435 ;;; Figure out the row-major-order index of an array reference from a
1436 ;;; list of subscripts and a list of dimensions. This is for internal
1437 ;;; calls only, and the subscripts and dim-list variables are assumed
1438 ;;; to be reversed from what the user supplied.
1439 (defun row-major-index-from-dims (rev-subscripts rev-dim-list)
1440 (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
1441 (rev-dim-list rev-dim-list (cdr rev-dim-list))
1444 ((null rev-dim-list) result)
1445 (declare (fixnum chunk-size result))
1446 (setq result (+ result
1447 (the fixnum (* (the fixnum (car rev-subscripts))
1449 (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
1453 (defun bit-array-same-dimensions-p (array1 array2)
1454 (declare (type (array bit) array1 array2))
1455 (and (= (array-rank array1)
1456 (array-rank array2))
1457 (dotimes (index (array-rank array1) t)
1458 (when (/= (array-dimension array1 index)
1459 (array-dimension array2 index))
1462 (defun pick-result-array (result-bit-array bit-array-1)
1463 (case result-bit-array
1465 ((nil) (make-array (array-dimensions bit-array-1)
1467 :initial-element 0))
1469 (unless (bit-array-same-dimensions-p bit-array-1
1471 (error "~S and ~S don't have the same dimensions."
1472 bit-array-1 result-bit-array))
1475 (defmacro def-bit-array-op (name function)
1476 `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
1479 "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1480 BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
1481 If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
1482 RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
1483 All the arrays must have the same rank and dimensions."
1484 (symbol-name function))
1485 (declare (type (array bit) bit-array-1 bit-array-2)
1486 (type (or (array bit) (member t nil)) result-bit-array))
1487 (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
1488 (error "~S and ~S don't have the same dimensions."
1489 bit-array-1 bit-array-2))
1490 (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
1491 (if (and (simple-bit-vector-p bit-array-1)
1492 (simple-bit-vector-p bit-array-2)
1493 (simple-bit-vector-p result-bit-array))
1494 (locally (declare (optimize (speed 3) (safety 0)))
1495 (,name bit-array-1 bit-array-2 result-bit-array))
1496 (with-array-data ((data1 bit-array-1) (start1) (end1))
1497 (declare (ignore end1))
1498 (with-array-data ((data2 bit-array-2) (start2) (end2))
1499 (declare (ignore end2))
1500 (with-array-data ((data3 result-bit-array) (start3) (end3))
1501 (do ((index-1 start1 (1+ index-1))
1502 (index-2 start2 (1+ index-2))
1503 (index-3 start3 (1+ index-3)))
1504 ((>= index-3 end3) result-bit-array)
1505 (declare (type index index-1 index-2 index-3))
1506 (setf (sbit data3 index-3)
1507 (logand (,function (sbit data1 index-1)
1508 (sbit data2 index-2))
1511 (def-bit-array-op bit-and logand)
1512 (def-bit-array-op bit-ior logior)
1513 (def-bit-array-op bit-xor logxor)
1514 (def-bit-array-op bit-eqv logeqv)
1515 (def-bit-array-op bit-nand lognand)
1516 (def-bit-array-op bit-nor lognor)
1517 (def-bit-array-op bit-andc1 logandc1)
1518 (def-bit-array-op bit-andc2 logandc2)
1519 (def-bit-array-op bit-orc1 logorc1)
1520 (def-bit-array-op bit-orc2 logorc2)
1522 (defun bit-not (bit-array &optional result-bit-array)
1524 "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1525 putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1526 BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1527 created. Both arrays must have the same rank and dimensions."
1528 (declare (type (array bit) bit-array)
1529 (type (or (array bit) (member t nil)) result-bit-array))
1530 (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
1531 (if (and (simple-bit-vector-p bit-array)
1532 (simple-bit-vector-p result-bit-array))
1533 (locally (declare (optimize (speed 3) (safety 0)))
1534 (bit-not bit-array result-bit-array))
1535 (with-array-data ((src bit-array) (src-start) (src-end))
1536 (declare (ignore src-end))
1537 (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
1538 (do ((src-index src-start (1+ src-index))
1539 (dst-index dst-start (1+ dst-index)))
1540 ((>= dst-index dst-end) result-bit-array)
1541 (declare (type index src-index dst-index))
1542 (setf (sbit dst dst-index)
1543 (logxor (sbit src src-index) 1))))))))
1545 ;;;; array type dispatching
1547 ;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
1548 ;;; defines the functions
1550 ;;; DISPATCH-FOO/SIMPLE-BASE-STRING
1551 ;;; DISPATCH-FOO/SIMPLE-CHARACTER-STRING
1552 ;;; DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
1555 ;;; PARAMS are the function parameters in the definition of each
1556 ;;; specializer function. The array being specialized must be the
1557 ;;; first parameter in PARAMS. A type declaration for this parameter
1558 ;;; is automatically inserted into the body of each function.
1560 ;;; The dispatch table %%FOO-FUNS%% is defined and populated by these
1561 ;;; functions. The table is padded by the function
1562 ;;; HAIRY-FOO-DISPATCH-ERROR, also defined by DEFINE-ARRAY-DISPATCH.
1564 ;;; Finally, the DISPATCH-FOO macro is defined which does the actual
1565 ;;; dispatching when called. It expects arguments that match PARAMS.
1567 (defmacro define-array-dispatch (dispatch-name params &body body)
1568 (let ((table-name (symbolicate "%%" dispatch-name "-FUNS%%"))
1569 (error-name (symbolicate "HAIRY-" dispatch-name "-ERROR")))
1571 (eval-when (:compile-toplevel :load-toplevel :execute)
1572 (defun ,error-name (&rest args)
1575 :expected-type '(simple-array * (*)))))
1576 (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)
1577 :initial-element #',error-name))
1578 ,@(loop for info across sb!vm:*specialized-array-element-type-properties*
1579 for typecode = (sb!vm:saetp-typecode info)
1580 for specifier = (sb!vm:saetp-specifier info)
1581 for primitive-type-name = (sb!vm:saetp-primitive-type-name info)
1582 collect (let ((fun-name (symbolicate (string dispatch-name)
1583 "/" primitive-type-name)))
1585 (defun ,fun-name ,params
1586 (declare (type (simple-array ,specifier (*))
1589 (setf (svref ,table-name ,typecode) #',fun-name))))
1590 (defmacro ,dispatch-name (&rest args)
1591 (check-type (first args) symbol)
1592 (let ((tag (gensym "TAG")))
1596 (when (sb!vm::%other-pointer-p ,(first args))
1597 (setf ,tag (%other-pointer-widetag ,(first args))))
1598 (svref ,',table-name ,tag)))