(defun %data-vector-and-index (array index)
(if (array-header-p array)
- (%with-array-data array index nil)
+ (multiple-value-bind (vector index)
+ (%with-array-data array index nil)
+ (values vector index))
(values array index)))
;;; It'd waste space to expand copies of error handling in every
(bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
\f
;;;; MAKE-ARRAY
-(defun upgraded-array-element-type (spec &optional environment)
- #!+sb-doc
- "Return the element type that will actually be used to implement an array
- with the specifier :ELEMENT-TYPE Spec."
- (declare (ignore environment))
- (if (unknown-type-p (specifier-type spec))
- (error "undefined type: ~S" spec)
- (type-specifier (array-type-specialized-element-type
- (specifier-type `(array ,spec))))))
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro pick-vector-type (type &rest specs)
`(cond ,@(mapcar (lambda (spec)
;; and for all in any reasonable user programs.)
((t)
(values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
- ((character base-char standard-char)
- (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits))
+ ((base-char standard-char character)
+ (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
((bit)
(values #.sb!vm:simple-bit-vector-widetag 1))
;; OK, we have to wade into SUBTYPEPing after all.
(t
- ;; FIXME: The data here are redundant with
- ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
- (pick-vector-type type
- (nil (values #.sb!vm:simple-array-nil-widetag 0))
- (base-char (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits))
- (bit (values #.sb!vm:simple-bit-vector-widetag 1))
- ((unsigned-byte 2)
- (values #.sb!vm:simple-array-unsigned-byte-2-widetag 2))
- ((unsigned-byte 4)
- (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4))
- ((unsigned-byte 8)
- (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8))
- ((unsigned-byte 16)
- (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16))
- ((unsigned-byte 32)
- (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32))
- ((signed-byte 8)
- (values #.sb!vm:simple-array-signed-byte-8-widetag 8))
- ((signed-byte 16)
- (values #.sb!vm:simple-array-signed-byte-16-widetag 16))
- ((signed-byte 30)
- (values #.sb!vm:simple-array-signed-byte-30-widetag 32))
- ((signed-byte 32)
- (values #.sb!vm:simple-array-signed-byte-32-widetag 32))
- (single-float (values #.sb!vm:simple-array-single-float-widetag 32))
- (double-float (values #.sb!vm:simple-array-double-float-widetag 64))
- #!+long-float
- (long-float
- (values #.sb!vm:simple-array-long-float-widetag
- #!+x86 96 #!+sparc 128))
- ((complex single-float)
- (values #.sb!vm:simple-array-complex-single-float-widetag 64))
- ((complex double-float)
- (values #.sb!vm:simple-array-complex-double-float-widetag 128))
- #!+long-float
- ((complex long-float)
- (values #.sb!vm:simple-array-complex-long-float-widetag
- #!+x86 192
- #!+sparc 256))
- (t (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))))))
+ #.`(pick-vector-type type
+ ,@(map 'list
+ (lambda (saetp)
+ `(,(sb!vm:saetp-specifier saetp)
+ (values ,(sb!vm:saetp-typecode saetp)
+ ,(sb!vm:saetp-n-bits saetp))))
+ sb!vm:*specialized-array-element-type-properties*)))))
+
(defun %complex-vector-widetag (type)
(case type
;; Pick off some easy common cases.
((t)
#.sb!vm:complex-vector-widetag)
- ((character base-char)
- #.sb!vm:complex-string-widetag)
+ ((base-char character)
+ #.sb!vm:complex-base-string-widetag)
+ ((nil)
+ #.sb!vm:complex-vector-nil-widetag)
((bit)
#.sb!vm:complex-bit-vector-widetag)
;; OK, we have to wade into SUBTYPEPing after all.
(t
(pick-vector-type type
- (base-char #.sb!vm:complex-string-widetag)
+ (nil #.sb!vm:complex-vector-nil-widetag)
+ (character #.sb!vm:complex-base-string-widetag)
(bit #.sb!vm:complex-bit-vector-widetag)
(t #.sb!vm:complex-vector-widetag)))))
(defun make-array (dimensions &key
(element-type t)
(initial-element nil initial-element-p)
- initial-contents adjustable fill-pointer
+ (initial-contents nil initial-contents-p)
+ adjustable fill-pointer
displaced-to displaced-index-offset)
(let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
(array-rank (length (the list dimensions)))
(array (allocate-vector
type
length
- (ceiling (* (if (= type sb!vm:simple-string-widetag)
+ (ceiling (* (if (= type sb!vm:simple-base-string-widetag)
(1+ length)
length)
n-bits)
(declare (type index length))
(when initial-element-p
(fill array initial-element))
- (when initial-contents
- (when initial-element
- (error "can't specify both :INITIAL-ELEMENT and ~
- :INITIAL-CONTENTS"))
- (unless (= length (length initial-contents))
- (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
- the vector length is ~W."
- (length initial-contents)
- length))
+ (when initial-contents-p
+ (when initial-element-p
+ (error "can't specify both :INITIAL-ELEMENT and ~
+ :INITIAL-CONTENTS"))
+ (unless (= length (length initial-contents))
+ (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
+ the vector length is ~W."
+ (length initial-contents)
+ length))
(replace array initial-contents))
array))
;; it's either a complex array or a multidimensional array.
(data (or displaced-to
(data-vector-from-inits
dimensions total-size element-type
- initial-contents initial-element initial-element-p)))
+ initial-contents initial-contents-p
+ initial-element initial-element-p)))
(array (make-array-header
(cond ((= array-rank 1)
(%complex-vector-widetag element-type))
(setf (%array-available-elements array) total-size)
(setf (%array-data-vector array) data)
(cond (displaced-to
- (when (or initial-element-p initial-contents)
+ (when (or initial-element-p initial-contents-p)
(error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
- can be specified along with :DISPLACED-TO"))
+ can be specified along with :DISPLACED-TO"))
(let ((offset (or displaced-index-offset 0)))
(when (> (+ offset total-size)
(array-total-size displaced-to))
(setf (%array-dimension array axis) dim)
(incf axis)))
array))))
-
+
;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
;;; specified array characteristics. Dimensions is only used to pass
;;; to FILL-DATA-VECTOR for error checking on the structure of
;;; initial-contents.
(defun data-vector-from-inits (dimensions total-size element-type
- initial-contents initial-element
- initial-element-p)
- (when (and initial-contents initial-element-p)
+ initial-contents initial-contents-p
+ initial-element initial-element-p)
+ (when (and initial-contents-p initial-element-p)
(error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
- either MAKE-ARRAY or ADJUST-ARRAY."))
+ either MAKE-ARRAY or ADJUST-ARRAY."))
(let ((data (if initial-element-p
(make-array total-size
:element-type element-type
(error "~S cannot be used to initialize an array of type ~S."
initial-element element-type))
(fill (the vector data) initial-element)))
- (initial-contents
+ (initial-contents-p
(fill-data-vector data dimensions initial-contents)))
data))
(incf index))
(t
(unless (typep contents 'sequence)
- (error "malformed :INITIAL-CONTENTS: ~S is not a ~
- sequence, but ~W more layer~:P needed."
+ (error "malformed :INITIAL-CONTENTS: ~S is not a ~
+ sequence, but ~W more layer~:P needed."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
- (error "malformed :INITIAL-CONTENTS: Dimension of ~
- axis ~W is ~W, but ~S is ~W long."
+ (error "malformed :INITIAL-CONTENTS: Dimension of ~
+ axis ~W is ~W, but ~S is ~W long."
axis (car dims) contents (length contents)))
(if (listp contents)
(dolist (content contents)
(coerce (the list objects) 'simple-vector))
\f
;;;; accessor/setter functions
-
-(eval-when (:compile-toplevel :execute)
- (defparameter *specialized-array-element-types*
- '(t
- character
- bit
- (unsigned-byte 2)
- (unsigned-byte 4)
- (unsigned-byte 8)
- (unsigned-byte 16)
- (unsigned-byte 32)
- (signed-byte 8)
- (signed-byte 16)
- (signed-byte 30)
- (signed-byte 32)
- single-float
- double-float
- #!+long-float long-float
- (complex single-float)
- (complex double-float)
- #!+long-float (complex long-float)
- nil)))
-
(defun hairy-data-vector-ref (array index)
(with-array-data ((vector array) (index index) (end))
(declare (ignore end))
(etypecase vector .
- #.(mapcar (lambda (type)
- (let ((atype `(simple-array ,type (*))))
- `(,atype
- (data-vector-ref (the ,atype vector)
- index))))
- *specialized-array-element-types*))))
+ #.(map 'list
+ (lambda (saetp)
+ (let* ((type (sb!vm:saetp-specifier saetp))
+ (atype `(simple-array ,type (*))))
+ `(,atype
+ (data-vector-ref (the ,atype vector) index))))
+ (sort
+ (copy-seq
+ sb!vm:*specialized-array-element-type-properties*)
+ #'> :key #'sb!vm:saetp-importance)))))
;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
(with-array-data ((vector array) (index index) (end))
(declare (ignore end))
(etypecase vector .
- #.(mapcar (lambda (type)
- (let ((atype `(simple-array ,type (*))))
- `(,atype
- (data-vector-set (the ,atype vector)
- index
- (the ,type
- new-value))
- ;; For specialized arrays, the return
- ;; from data-vector-set would have to
- ;; be reboxed to be a (Lisp) return
- ;; value; instead, we use the
- ;; already-boxed value as the return.
- new-value)))
- *specialized-array-element-types*))))
+ #.(map 'list
+ (lambda (saetp)
+ (let* ((type (sb!vm:saetp-specifier saetp))
+ (atype `(simple-array ,type (*))))
+ `(,atype
+ (data-vector-set (the ,atype vector) index
+ (the ,type new-value))
+ ;; For specialized arrays, the return from
+ ;; data-vector-set would have to be
+ ;; reboxed to be a (Lisp) return value;
+ ;; instead, we use the already-boxed value
+ ;; as the return.
+ new-value)))
+ (sort
+ (copy-seq
+ sb!vm:*specialized-array-element-type-properties*)
+ #'> :key #'sb!vm:saetp-importance)))))
(defun %array-row-major-index (array subscripts
&optional (invalid-index-error-p t))
(let ((index (car subs))
(dim (%array-dimension array axis)))
(declare (fixnum dim))
- (unless (< -1 index dim)
+ (unless (and (fixnump index) (< -1 index dim))
(if invalid-index-error-p
(error 'simple-type-error
:format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
(setf chunk-size (* chunk-size dim))))
(let ((index (first subscripts))
(length (length (the (simple-array * (*)) array))))
- (unless (< -1 index length)
+ (unless (and (fixnump index) (< -1 index length))
(if invalid-index-error-p
;; FIXME: perhaps this should share a format-string
;; with INVALID-ARRAY-INDEX-ERROR or
(defun array-in-bounds-p (array &rest subscripts)
#!+sb-doc
- "Return T if the Subscipts are in bounds for the Array, Nil otherwise."
+ "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
(if (%array-row-major-index array subscripts nil)
t))
(defun aref (array &rest subscripts)
#!+sb-doc
- "Return the element of the Array specified by the Subscripts."
+ "Return the element of the ARRAY specified by the SUBSCRIPTS."
(row-major-aref array (%array-row-major-index array subscripts)))
(defun %aset (array &rest stuff)
`(= widetag ,item))))
(cdr stuff)))
stuff))))
- ;; FIXME: The data here are redundant with
- ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
- (pick-element-type
- (sb!vm:simple-array-nil-widetag nil)
- ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char)
- ((sb!vm:simple-bit-vector-widetag
- sb!vm:complex-bit-vector-widetag) 'bit)
- (sb!vm:simple-vector-widetag t)
- (sb!vm:simple-array-unsigned-byte-2-widetag '(unsigned-byte 2))
- (sb!vm:simple-array-unsigned-byte-4-widetag '(unsigned-byte 4))
- (sb!vm:simple-array-unsigned-byte-8-widetag '(unsigned-byte 8))
- (sb!vm:simple-array-unsigned-byte-16-widetag '(unsigned-byte 16))
- (sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32))
- (sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8))
- (sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16))
- (sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30))
- (sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32))
- (sb!vm:simple-array-single-float-widetag 'single-float)
- (sb!vm:simple-array-double-float-widetag 'double-float)
- #!+long-float
- (sb!vm:simple-array-long-float-widetag 'long-float)
- (sb!vm:simple-array-complex-single-float-widetag
- '(complex single-float))
- (sb!vm:simple-array-complex-double-float-widetag
- '(complex double-float))
- #!+long-float
- (sb!vm:simple-array-complex-long-float-widetag '(complex long-float))
- ((sb!vm:simple-array-widetag
- sb!vm:complex-vector-widetag
- sb!vm:complex-array-widetag)
- (with-array-data ((array array) (start) (end))
- (declare (ignore start end))
- (array-element-type array)))
- (t
- (error 'type-error :datum array :expected-type 'array))))))
+ #.`(pick-element-type
+ ,@(map 'list
+ (lambda (saetp)
+ `(,(if (sb!vm:saetp-complex-typecode saetp)
+ (list (sb!vm:saetp-typecode saetp)
+ (sb!vm:saetp-complex-typecode saetp))
+ (sb!vm:saetp-typecode saetp))
+ ',(sb!vm:saetp-specifier saetp)))
+ sb!vm:*specialized-array-element-type-properties*)
+ ((sb!vm:simple-array-widetag
+ sb!vm:complex-vector-widetag
+ sb!vm:complex-array-widetag)
+ (with-array-data ((array array) (start) (end))
+ (declare (ignore start end))
+ (array-element-type array)))
+ (t
+ (error 'type-error :datum array :expected-type 'array))))))
(defun array-rank (array)
#!+sb-doc
(error "Axis number ~W is too big; ~S only has ~D dimension~:P."
axis-number array (%array-rank array)))
(t
- (%array-dimension array axis-number))))
+ ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
+ ;;
+ ;; "If A is displaced to B, the consequences are
+ ;; unspecified if B is adjusted in such a way that it no
+ ;; longer has enough elements to satisfy A.
+ ;;
+ ;; In situations where this matters we should be doing a
+ ;; bounds-check, which in turn uses ARRAY-DIMENSION -- so
+ ;; this seems like a good place to signal an error.
+ (multiple-value-bind (target offset) (array-displacement array)
+ (when (and target
+ (> (array-total-size array)
+ (- (array-total-size target) offset)))
+ (error 'displaced-to-array-too-small-error
+ :format-control "~@<The displaced-to array is too small. ~S ~
+ elements after offset required, ~S available.~:@>"
+ :format-arguments (list (array-total-size array)
+ (- (array-total-size target) offset))))
+ (%array-dimension array axis-number)))))
(defun array-dimensions (array)
#!+sb-doc
"Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
to the argument, this happens for complex arrays."
(declare (array array))
+ ;; Note that this appears not to be a fundamental limitation.
+ ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
+ ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
+ ;; -- CSR, 2004-03-01.
(not (typep array 'simple-array)))
\f
;;;; fill pointer frobbing stuff
(declare (fixnum fill-pointer))
(when (= fill-pointer (%array-available-elements vector))
(adjust-array vector (+ fill-pointer extension)))
- (setf (aref vector fill-pointer) new-element)
+ ;; disable bounds checking
+ (locally (declare (optimize (safety 0)))
+ (setf (aref vector fill-pointer) new-element))
(setf (%array-fill-pointer vector) (1+ fill-pointer))
fill-pointer))
(declare (fixnum fill-pointer))
(if (zerop fill-pointer)
(error "There is nothing left to pop.")
- (aref array
- (setf (%array-fill-pointer array)
- (1- fill-pointer))))))
+ ;; disable bounds checking (and any fixnum test)
+ (locally (declare (optimize (safety 0)))
+ (aref array
+ (setf (%array-fill-pointer array)
+ (1- fill-pointer)))))))
+
\f
;;;; ADJUST-ARRAY
(defun adjust-array (array dimensions &key
(element-type (array-element-type array))
(initial-element nil initial-element-p)
- initial-contents fill-pointer
+ (initial-contents nil initial-contents-p)
+ fill-pointer
displaced-to displaced-index-offset)
#!+sb-doc
"Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
element-type)))
(let ((array-rank (length (the list dimensions))))
(declare (fixnum array-rank))
- (when (and fill-pointer (> array-rank 1))
- (error "Multidimensional arrays can't have fill pointers."))
- (cond (initial-contents
+ (unless (= array-rank 1)
+ (when fill-pointer
+ (error "Only vectors can have fill pointers.")))
+ (cond (initial-contents-p
;; array former contents replaced by INITIAL-CONTENTS
(if (or initial-element-p displaced-to)
- (error "INITIAL-CONTENTS may not be specified with ~
- the :INITIAL-ELEMENT or :DISPLACED-TO option."))
+ (error "INITIAL-CONTENTS may not be specified with ~
+ the :INITIAL-ELEMENT or :DISPLACED-TO option."))
(let* ((array-size (apply #'* dimensions))
(array-data (data-vector-from-inits
dimensions array-size element-type
- initial-contents initial-element
- initial-element-p)))
+ initial-contents initial-contents-p
+ initial-element initial-element-p)))
(if (adjustable-array-p array)
(set-array-header array array-data array-size
(get-new-fill-pointer array array-size
(displaced-to
;; We already established that no INITIAL-CONTENTS was supplied.
(when initial-element
- (error "The :INITIAL-ELEMENT option may not be specified ~
- with :DISPLACED-TO."))
- (unless (subtypep element-type (array-element-type displaced-to))
- (error "can't displace an array of type ~S into another of ~
- type ~S"
+ (error "The :INITIAL-ELEMENT option may not be specified ~
+ with :DISPLACED-TO."))
+ (unless (subtypep element-type (array-element-type displaced-to))
+ (error "can't displace an array of type ~S into another of ~
+ type ~S"
element-type (array-element-type displaced-to)))
(let ((displacement (or displaced-index-offset 0))
(array-size (apply #'* dimensions)))
(setf new-data
(data-vector-from-inits
dimensions new-length element-type
- initial-contents initial-element
- initial-element-p))
+ initial-contents initial-contents-p
+ initial-element initial-element-p))
(replace new-data old-data
:start2 old-start :end2 old-end))
(t (setf new-data
(> new-length old-length))
(data-vector-from-inits
dimensions new-length
- element-type () initial-element
- initial-element-p)
+ element-type () nil
+ initial-element initial-element-p)
old-data)))
(if (or (zerop old-length) (zerop new-length))
(when initial-element-p (fill new-data initial-element))
new-data dimensions new-length
element-type initial-element
initial-element-p))
- (set-array-header array new-data new-length
- new-length 0 dimensions nil)))))))))
+ (if (adjustable-array-p array)
+ (set-array-header array new-data new-length
+ new-length 0 dimensions nil)
+ (let ((new-array
+ (make-array-header
+ sb!vm:simple-array-widetag array-rank)))
+ (set-array-header new-array new-data new-length
+ new-length 0 dimensions nil)))))))))))
+
(defun get-new-fill-pointer (old-array new-array-size fill-pointer)
(cond ((not fill-pointer)
(when (array-has-fill-pointer-p old-array)
(when (> (%array-fill-pointer old-array) new-array-size)
(error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
- smaller than its fill pointer (~S)"
+ smaller than its fill pointer (~S)"
old-array new-array-size (fill-pointer old-array)))
(%array-fill-pointer old-array)))
((not (array-has-fill-pointer-p old-array))
(error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
- in ADJUST-ARRAY unless the array (~S) was originally ~
- created with a fill pointer"
+ in ADJUST-ARRAY unless the array (~S) was originally ~
+ created with a fill pointer"
fill-pointer
old-array))
((numberp fill-pointer)
(when (> fill-pointer new-array-size)
(error "can't supply a value for :FILL-POINTER (~S) that is larger ~
- than the new length of the vector (~S)"
+ than the new length of the vector (~S)"
fill-pointer new-array-size))
fill-pointer)
((eq fill-pointer t)
(unless (array-header-p vector)
(macrolet ((frob (name &rest things)
`(etypecase ,name
- ((simple-array nil (*)) (error 'cell-error
- :name 'nil-array-element))
+ ((simple-array nil (*)) (error 'nil-array-accessed-error))
,@(mapcar (lambda (thing)
(destructuring-bind (type-spec fill-value)
thing
,fill-value
:start new-length))))
things))))
- ;; FIXME: The associations between vector types and initial
- ;; values here are redundant with
- ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
- (frob vector
- (simple-vector 0)
- (simple-base-string #.*default-init-char-form*)
- (simple-bit-vector 0)
- ((simple-array (unsigned-byte 2) (*)) 0)
- ((simple-array (unsigned-byte 4) (*)) 0)
- ((simple-array (unsigned-byte 8) (*)) 0)
- ((simple-array (unsigned-byte 16) (*)) 0)
- ((simple-array (unsigned-byte 32) (*)) 0)
- ((simple-array (signed-byte 8) (*)) 0)
- ((simple-array (signed-byte 16) (*)) 0)
- ((simple-array (signed-byte 30) (*)) 0)
- ((simple-array (signed-byte 32) (*)) 0)
- ((simple-array single-float (*)) (coerce 0 'single-float))
- ((simple-array double-float (*)) (coerce 0 'double-float))
- #!+long-float
- ((simple-array long-float (*)) (coerce 0 'long-float))
- ((simple-array (complex single-float) (*))
- (coerce 0 '(complex single-float)))
- ((simple-array (complex double-float) (*))
- (coerce 0 '(complex double-float)))
- #!+long-float
- ((simple-array (complex long-float) (*))
- (coerce 0 '(complex long-float))))))
+ #.`(frob vector
+ ,@(map 'list
+ (lambda (saetp)
+ `((simple-array ,(sb!vm:saetp-specifier saetp) (*))
+ ,(if (eq (sb!vm:saetp-specifier saetp) 'character)
+ *default-init-char-form*
+ (sb!vm:saetp-initial-element-default saetp))))
+ (remove-if-not
+ #'sb!vm:saetp-specifier
+ sb!vm:*specialized-array-element-type-properties*)))))
;; Only arrays have fill-pointers, but vectors have their length
;; parameter in the same place.
(setf (%array-fill-pointer vector) new-length)
(macrolet ((bump-index-list (index limits)
`(do ((subscripts ,index (cdr subscripts))
(limits ,limits (cdr limits)))
- ((null subscripts) nil)
+ ((null subscripts) :eof)
(cond ((< (the fixnum (car subscripts))
(the fixnum (car limits)))
(rplaca subscripts
(t (rplaca subscripts 0))))))
(do ((index (make-list (length old-dims) :initial-element 0)
(bump-index-list index limits)))
- ((null index))
+ ((eq index :eof))
(setf (aref new-data (row-major-index-from-dims index new-dims))
(aref old-data
(+ (the fixnum (row-major-index-from-dims index old-dims))
(defmacro def-bit-array-op (name function)
`(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
+ #!+sb-doc
,(format nil
"Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
- BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
- If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
- RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
- All the arrays must have the same rank and dimensions."
+ BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
+ If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
+ RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
+ All the arrays must have the same rank and dimensions."
(symbol-name function))
(declare (type (array bit) bit-array-1 bit-array-2)
(type (or (array bit) (member t nil)) result-bit-array))
projects / sbcl.git / blobdiff