,@(cdr spec)))
specs))))
+(defun %integer-vector-widetag-and-n-bits (signed high)
+ (let ((unsigned-table
+ #.(let ((map (make-array (1+ sb!vm:n-word-bits))))
+ (loop for saetp across
+ (reverse sb!vm:*specialized-array-element-type-properties*)
+ for ctype = (sb!vm:saetp-ctype saetp)
+ when (and (numeric-type-p ctype)
+ (eq (numeric-type-class ctype) 'integer)
+ (zerop (numeric-type-low ctype)))
+ do (fill map (cons (sb!vm:saetp-typecode saetp)
+ (sb!vm:saetp-n-bits saetp))
+ :end (1+ (integer-length (numeric-type-high ctype)))))
+ map))
+ (signed-table
+ #.(let ((map (make-array (1+ sb!vm:n-word-bits))))
+ (loop for saetp across
+ (reverse sb!vm:*specialized-array-element-type-properties*)
+ for ctype = (sb!vm:saetp-ctype saetp)
+ when (and (numeric-type-p ctype)
+ (eq (numeric-type-class ctype) 'integer)
+ (minusp (numeric-type-low ctype)))
+ do (fill map (cons (sb!vm:saetp-typecode saetp)
+ (sb!vm:saetp-n-bits saetp))
+ :end (+ (integer-length (numeric-type-high ctype)) 2)))
+ map)))
+ (cond ((> high sb!vm:n-word-bits)
+ (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
+ (signed
+ (let ((x (aref signed-table high)))
+ (values (car x) (cdr x))))
+ (t
+ (let ((x (aref unsigned-table high)))
+ (values (car x) (cdr x)))))))
+
;;; These functions are used in the implementation of MAKE-ARRAY for
;;; complex arrays. There are lots of transforms to simplify
;;; MAKE-ARRAY for various easy cases, but not for all reasonable
;;; cases, so e.g. as of sbcl-0.6.6 we still make full calls to
-;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to
-;;; making this somewhat efficient, at least not doing full calls to
-;;; SUBTYPEP in the easy cases.
+;;; MAKE-ARRAY for any non-simple array.
(defun %vector-widetag-and-n-bits (type)
- (case type
- ;; Pick off some easy common cases.
- ;;
- ;; (Perhaps we should make a much more exhaustive table of easy
- ;; common cases here. Or perhaps the effort would be better spent
- ;; on smarter compiler transforms which do the calculation once
- ;; and for all in any reasonable user programs.)
- ((t)
- (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
- ((base-char standard-char #!-sb-unicode character)
- (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
- #!+sb-unicode
- ((character)
- (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits))
- ((bit)
- (values #.sb!vm:simple-bit-vector-widetag 1))
- ;; OK, we have to wade into SUBTYPEPing after all.
- (t
- (unless *type-system-initialized*
- (bug "SUBTYPEP dispatch for MAKE-ARRAY before the type system is ready"))
- #.`(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)
- ((base-char #!-sb-unicode character)
- #.sb!vm:complex-base-string-widetag)
- #!+sb-unicode
- ((character)
- #.sb!vm:complex-character-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
- (nil #.sb!vm:complex-vector-nil-widetag)
- #!-sb-unicode
- (character #.sb!vm:complex-base-string-widetag)
- #!+sb-unicode
- (base-char #.sb!vm:complex-base-string-widetag)
- #!+sb-unicode
- (character #.sb!vm:complex-character-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 nil initial-contents-p)
- adjustable fill-pointer
- displaced-to displaced-index-offset)
+ (flet ((ill-type ()
+ (error "Invalid type specifier: ~s" type)))
+ (macrolet ((with-parameters ((arg-type &key (min-length 0))
+ (&rest args) &body body)
+ (let ((type-sym (gensym)))
+ `(let (,@(loop for arg in args
+ collect `(,arg '*)))
+ (declare (ignorable ,@args))
+ (when ,(if (plusp min-length)
+ t
+ '(consp type))
+ (let ((,type-sym (cdr type)))
+ (unless (proper-list-of-length-p ,type-sym ,min-length ,(length args))
+ (ill-type))
+ (block nil
+ ,@(loop for arg in args
+ for i from 0
+ collect
+ `(if ,type-sym
+ (let ((value (pop ,type-sym)))
+ (if (or ,(if (>= i min-length)
+ `(eq value '*))
+ (typep value ',arg-type))
+ (setf ,arg value)
+ (ill-type)))
+ (return))))))
+ ,@body)))
+ (result (widetag)
+ (let ((value (symbol-value widetag)))
+ `(values ,value
+ ,(sb!vm:saetp-n-bits
+ (find value
+ sb!vm:*specialized-array-element-type-properties*
+ :key #'sb!vm:saetp-typecode))))))
+ (let* ((consp (consp type))
+ (type-name (if consp
+ (car type)
+ type)))
+ (case type-name
+ ((t)
+ (when consp
+ (ill-type))
+ (result sb!vm:simple-vector-widetag))
+ ((base-char standard-char #!-sb-unicode character)
+ (when consp
+ (ill-type))
+ (result sb!vm:simple-base-string-widetag))
+ #!+sb-unicode
+ (character
+ (when consp
+ (ill-type))
+ (result sb!vm:simple-character-string-widetag))
+ (bit
+ (when consp
+ (ill-type))
+ (result sb!vm:simple-bit-vector-widetag))
+ (fixnum
+ (when consp
+ (ill-type))
+ (result sb!vm:simple-array-fixnum-widetag))
+ (unsigned-byte
+ (with-parameters ((integer 1)) (high)
+ (if (eq high '*)
+ (result sb!vm:simple-vector-widetag)
+ (%integer-vector-widetag-and-n-bits nil high))))
+ (signed-byte
+ (with-parameters ((integer 1)) (high)
+ (if (eq high '*)
+ (result sb!vm:simple-vector-widetag)
+ (%integer-vector-widetag-and-n-bits t high))))
+ (double-float
+ (with-parameters (double-float) (low high)
+ (if (and (not (eq low '*))
+ (not (eq high '*))
+ (> low high))
+ (result sb!vm:simple-array-nil-widetag)
+ (result sb!vm:simple-array-double-float-widetag))))
+ (single-float
+ (with-parameters (single-float) (low high)
+ (if (and (not (eq low '*))
+ (not (eq high '*))
+ (> low high))
+ (result sb!vm:simple-array-nil-widetag)
+ (result sb!vm:simple-array-single-float-widetag))))
+ (mod
+ (with-parameters ((integer 1) :min-length 1) (n)
+ (%integer-vector-widetag-and-n-bits nil (integer-length (1- n)))))
+ #!+long-float
+ (long-float
+ (with-parameters (long-float) (low high)
+ (if (and (not (eq low '*))
+ (not (eq high '*))
+ (> low high))
+ (result sb!vm:simple-array-nil-widetag)
+ (result sb!vm:simple-array-long-float-widetag))))
+ (integer
+ (with-parameters (integer) (low high)
+ (cond ((or (eq high '*)
+ (eq low '*))
+ (result sb!vm:simple-vector-widetag))
+ ((> low high)
+ (result sb!vm:simple-array-nil-widetag))
+ (t
+ (if (minusp low)
+ (%integer-vector-widetag-and-n-bits
+ t
+ (1+ (max (integer-length low) (integer-length high))))
+ (%integer-vector-widetag-and-n-bits
+ nil
+ (max (integer-length low) (integer-length high))))))))
+ (complex
+ (with-parameters (t) (subtype)
+ (if (eq type '*)
+ (result sb!vm:simple-vector-widetag)
+ (let ((ctype (specifier-type type)))
+ (if (eq ctype *empty-type*)
+ (result sb!vm:simple-array-nil-widetag)
+ (case (numeric-type-format ctype)
+ (double-float
+ (result
+ sb!vm:simple-array-complex-double-float-widetag))
+ (single-float
+ (result
+ sb!vm:simple-array-complex-single-float-widetag))
+ #!+long-float
+ (long-float
+ (result
+ sb!vm:simple-array-complex-long-float-widetag))
+ (t
+ (result sb!vm:simple-vector-widetag))))))))
+ ((nil)
+ (result sb!vm:simple-array-nil-widetag))
+ (t
+ (block nil
+ (let ((expansion
+ (type-specifier
+ (handler-case (specifier-type type)
+ (parse-unknown-type ()
+ (return (result sb!vm:simple-vector-widetag)))))))
+ (if (equal expansion type)
+ (result sb!vm:simple-vector-widetag)
+ (%vector-widetag-and-n-bits expansion))))))))))
+
+(defun %complex-vector-widetag (widetag)
+ (macrolet ((make-case ()
+ `(case widetag
+ ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ for complex = (sb!vm:saetp-complex-typecode saetp)
+ when complex
+ collect (list (sb!vm:saetp-typecode saetp) complex))
+ (t
+ #.sb!vm:complex-vector-widetag))))
+ (make-case)))
+
+(defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask)))
+#.(loop for info across sb!vm:*specialized-array-element-type-properties*
+ collect `(setf (aref %%simple-array-n-bits%% ,(sb!vm:saetp-typecode info))
+ ,(sb!vm:saetp-n-bits info)) into forms
+ finally (return `(progn ,@forms)))
+
+(defun allocate-vector-with-widetag (widetag length &optional n-bits)
+ (declare (type (unsigned-byte 8) widetag)
+ (type index length))
+ (let ((n-bits (or n-bits (aref %%simple-array-n-bits%% widetag))))
+ (declare (type (integer 0 256) n-bits))
+ (allocate-vector widetag length
+ (ceiling
+ (* (if (or (= widetag sb!vm:simple-base-string-widetag)
+ #!+sb-unicode
+ (= widetag
+ sb!vm:simple-character-string-widetag))
+ (1+ length)
+ length)
+ n-bits)
+ sb!vm:n-word-bits))))
+
+(defun array-underlying-widetag (array)
+ (macrolet ((make-case ()
+ `(case widetag
+ ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ for complex = (sb!vm:saetp-complex-typecode saetp)
+ when complex
+ collect (list complex (sb!vm:saetp-typecode saetp)))
+ ((,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))
+ (widetag-of array)))
+ (t
+ widetag))))
+ (let ((widetag (widetag-of array)))
+ (make-case))))
+
+;;; Widetag is the widetag of the underlying vector,
+;;; it'll be the same as the resulting array widetag only for simple vectors
+(defun %make-array (dimensions widetag n-bits
+ &key
+ element-type
+ (initial-element nil initial-element-p)
+ (initial-contents nil initial-contents-p)
+ adjustable fill-pointer
+ displaced-to displaced-index-offset)
+ (declare (ignore element-type))
(let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
(array-rank (length (the list dimensions)))
(simple (and (null fill-pointer)
(not adjustable)
(null displaced-to))))
(declare (fixnum array-rank))
- (when (and displaced-index-offset (null displaced-to))
- (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
- (when (and displaced-to
- (arrayp displaced-to)
- (not (equal (array-element-type displaced-to)
- (upgraded-array-element-type element-type))))
- (error "Array element type of :DISPLACED-TO array does not match specified element type"))
- (if (and simple (= array-rank 1))
- ;; it's a (SIMPLE-ARRAY * (*))
- (multiple-value-bind (type n-bits)
- (%vector-widetag-and-n-bits element-type)
- (declare (type (unsigned-byte 8) type)
- (type (integer 0 256) n-bits))
- (let* ((length (car dimensions))
- (array (allocate-vector
- type
- length
- (ceiling
- (* (if (or (= type sb!vm:simple-base-string-widetag)
- #!+sb-unicode
- (= type
- sb!vm:simple-character-string-widetag))
- (1+ length)
- length)
- n-bits)
- sb!vm:n-word-bits))))
- (declare (type index length))
- (when initial-element-p
- (fill array initial-element))
- (when initial-contents-p
- (when initial-element-p
- (error "can't specify both :INITIAL-ELEMENT and ~
+ (cond ((and displaced-index-offset (null displaced-to))
+ (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
+ ((and simple (= array-rank 1))
+ ;; it's a (SIMPLE-ARRAY * (*))
+ (let* ((length (car dimensions))
+ (array (allocate-vector-with-widetag widetag length n-bits)))
+ (declare (type index length))
+ (when initial-element-p
+ (fill array initial-element))
+ (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 ~
+ (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.
- (let* ((total-size (reduce #'* dimensions))
- (data (or displaced-to
- (data-vector-from-inits
- dimensions total-size element-type
- initial-contents initial-contents-p
- initial-element initial-element-p)))
- (array (make-array-header
- (cond ((= array-rank 1)
- (%complex-vector-widetag element-type))
- (simple sb!vm:simple-array-widetag)
- (t sb!vm:complex-array-widetag))
- array-rank)))
- (cond (fill-pointer
- (unless (= array-rank 1)
- (error "Only vectors can have fill pointers."))
- (let ((length (car dimensions)))
- (declare (fixnum length))
- (setf (%array-fill-pointer array)
- (cond ((eq fill-pointer t)
- length)
- (t
- (unless (and (fixnump fill-pointer)
- (>= fill-pointer 0)
- (<= fill-pointer length))
- ;; FIXME: should be TYPE-ERROR?
- (error "invalid fill-pointer ~W"
- fill-pointer))
- fill-pointer))))
- (setf (%array-fill-pointer-p array) t))
- (t
- (setf (%array-fill-pointer array) total-size)
- (setf (%array-fill-pointer-p array) nil)))
- (setf (%array-available-elements array) total-size)
- (setf (%array-data-vector array) data)
- (setf (%array-displaced-from array) nil)
- (cond (displaced-to
- (when (or initial-element-p initial-contents-p)
- (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
+ (length initial-contents)
+ length))
+ (replace array initial-contents))
+ array))
+ ((and (arrayp displaced-to)
+ (/= (array-underlying-widetag displaced-to) widetag))
+ (error "Array element type of :DISPLACED-TO array does not match specified element type"))
+ (t
+ ;; it's either a complex array or a multidimensional array.
+ (let* ((total-size (reduce #'* dimensions))
+ (data (or displaced-to
+ (data-vector-from-inits
+ dimensions total-size nil widetag n-bits
+ initial-contents initial-contents-p
+ initial-element initial-element-p)))
+ (array (make-array-header
+ (cond ((= array-rank 1)
+ (%complex-vector-widetag widetag))
+ (simple sb!vm:simple-array-widetag)
+ (t sb!vm:complex-array-widetag))
+ array-rank)))
+ (cond (fill-pointer
+ (unless (= array-rank 1)
+ (error "Only vectors can have fill pointers."))
+ (let ((length (car dimensions)))
+ (declare (fixnum length))
+ (setf (%array-fill-pointer array)
+ (cond ((eq fill-pointer t)
+ length)
+ (t
+ (unless (and (fixnump fill-pointer)
+ (>= fill-pointer 0)
+ (<= fill-pointer length))
+ ;; FIXME: should be TYPE-ERROR?
+ (error "invalid fill-pointer ~W"
+ fill-pointer))
+ fill-pointer))))
+ (setf (%array-fill-pointer-p array) t))
+ (t
+ (setf (%array-fill-pointer array) total-size)
+ (setf (%array-fill-pointer-p array) nil)))
+ (setf (%array-available-elements array) total-size)
+ (setf (%array-data-vector array) data)
+ (setf (%array-displaced-from array) nil)
+ (cond (displaced-to
+ (when (or initial-element-p initial-contents-p)
+ (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
can be specified along with :DISPLACED-TO"))
- (let ((offset (or displaced-index-offset 0)))
- (when (> (+ offset total-size)
- (array-total-size displaced-to))
- (error "~S doesn't have enough elements." displaced-to))
- (setf (%array-displacement array) offset)
- (setf (%array-displaced-p array) t)
- (%save-displaced-array-backpointer array data)))
- (t
- (setf (%array-displaced-p array) nil)))
- (let ((axis 0))
- (dolist (dim dimensions)
- (setf (%array-dimension array axis) dim)
- (incf axis)))
- array))))
+ (let ((offset (or displaced-index-offset 0)))
+ (when (> (+ offset total-size)
+ (array-total-size displaced-to))
+ (error "~S doesn't have enough elements." displaced-to))
+ (setf (%array-displacement array) offset)
+ (setf (%array-displaced-p array) t)
+ (%save-displaced-array-backpointer array data)))
+ (t
+ (setf (%array-displaced-p array) nil)))
+ (let ((axis 0))
+ (dolist (dim dimensions)
+ (setf (%array-dimension array axis) dim)
+ (incf axis)))
+ array)))))
+
+(defun make-array (dimensions &rest args
+ &key (element-type t)
+ initial-element initial-contents
+ adjustable
+ fill-pointer
+ displaced-to
+ displaced-index-offset)
+ (declare (ignore initial-element
+ initial-contents adjustable
+ fill-pointer displaced-to displaced-index-offset))
+ (multiple-value-bind (widetag n-bits) (%vector-widetag-and-n-bits element-type)
+ (apply #'%make-array dimensions widetag n-bits args)))
(defun make-static-vector (length &key
(element-type '(unsigned-byte 8))
;;; 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
+(defun data-vector-from-inits (dimensions total-size
+ element-type widetag n-bits
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
+ (when initial-element-p
+ (when initial-contents-p
+ (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
either MAKE-ARRAY or ADJUST-ARRAY."))
- (let ((data (if initial-element-p
- (make-array total-size
- :element-type element-type
- :initial-element initial-element)
- (make-array total-size
- :element-type element-type))))
+ ;; FIXME: element-type can be NIL when widetag is non-nil,
+ ;; and FILL will check the type, although the error will be not as nice.
+ ;; (cond (typep initial-element element-type)
+ ;; (error "~S cannot be used to initialize an array of type ~S."
+ ;; initial-element element-type))
+ )
+ (let ((data (if widetag
+ (allocate-vector-with-widetag widetag total-size n-bits)
+ (make-array total-size :element-type element-type))))
(cond (initial-element-p
- (unless (simple-vector-p data)
- (unless (typep initial-element element-type)
- (error "~S cannot be used to initialize an array of type ~S."
- initial-element element-type))
- (fill (the vector data) initial-element)))
+ (fill (the vector data) initial-element))
(initial-contents-p
(fill-data-vector data dimensions initial-contents)))
data))
(svref ,',table-name tag)))))))
(def !find-data-vector-setter %%data-vector-setters%%)
(def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
- (def !find-data-vector-reffer %%data-vector-reffers%%)
+ ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
+ ;; meaning we can have post-build dependences on this.
+ (def %find-data-vector-reffer %%data-vector-reffers%%)
(def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
+;;; Like DOVECTOR, but more magical -- can't use this on host.
+(defmacro do-vector-data ((elt vector &optional result) &body body)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (with-unique-names (index vec start end ref)
+ `(with-array-data ((,vec ,vector)
+ (,start)
+ (,end)
+ :check-fill-pointer t)
+ (let ((,ref (%find-data-vector-reffer ,vec)))
+ (do ((,index ,start (1+ ,index)))
+ ((>= ,index ,end)
+ (let ((,elt nil))
+ ,@(filter-dolist-declarations decls)
+ ,elt
+ ,result))
+ (let ((,elt (funcall ,ref ,vec ,index)))
+ ,@decls
+ (tagbody ,@forms))))))))
+
(macrolet ((%ref (accessor-getter extra-params)
`(funcall (,accessor-getter array) array index ,@extra-params))
(define (accessor-name slow-accessor-name accessor-getter
(declare (ignore end))
(,accessor-name vector index ,@extra-params)))))))
(define hairy-data-vector-ref slow-hairy-data-vector-ref
- !find-data-vector-reffer
+ %find-data-vector-reffer
nil (progn))
(define hairy-data-vector-set slow-hairy-data-vector-set
!find-data-vector-setter
(declare (truly-dynamic-extent subscripts))
(row-major-aref array (%array-row-major-index array subscripts)))
-(defun %aset (array &rest stuff)
- (declare (truly-dynamic-extent stuff))
- (let ((subscripts (butlast stuff))
- (new-value (car (last stuff))))
- (setf (row-major-aref array (%array-row-major-index array subscripts))
- new-value)))
-
-;;; FIXME: What's supposed to happen with functions
-;;; like AREF when we (DEFUN (SETF FOO) ..) when
-;;; DEFSETF FOO is also defined? It seems as though the logical
-;;; thing to do would be to nuke the macro definition for (SETF FOO)
-;;; and replace it with the (SETF FOO) function, issuing a warning,
-;;; just as for ordinary functions
-;;; * (LISP-IMPLEMENTATION-VERSION)
-;;; "18a+ release x86-linux 2.4.7 6 November 1998 cvs"
-;;; * (DEFMACRO ZOO (X) `(+ ,X ,X))
-;;; ZOO
-;;; * (DEFUN ZOO (X) (* 3 X))
-;;; Warning: ZOO previously defined as a macro.
-;;; ZOO
-;;; But that doesn't seem to be what happens in CMU CL.
-;;;
-;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS
-;;; 5.1.2.5) requires implementations to support
-;;; (SETF (APPLY #'AREF ...) ...)
-;;; [and also #'BIT and #'SBIT]. Yes, this is terrifying, and it's
-;;; also terrifying that this sequence of definitions causes it to
-;;; work.
-;;;
-;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
-;;; has a setf expansion and/or a setf function defined.
-
-#!-sb-fluid (declaim (inline (setf aref)))
+;;; (setf aref/bit/sbit) are implemented using setf-functions,
+;;; because they have to work with (setf (apply #'aref array subscripts))
+;;; All other setfs can be done using setf-functions too, but I
+;;; haven't found technical advantages or disatvantages for either
+;;; scheme.
(defun (setf aref) (new-value array &rest subscripts)
- (declare (truly-dynamic-extent subscripts))
- (declare (type array array))
+ (declare (truly-dynamic-extent subscripts)
+ (type array array))
(setf (row-major-aref array (%array-row-major-index array subscripts))
new-value))
(defun row-major-aref (array index)
#!+sb-doc
- "Return the element of array corressponding to the row-major index. This is
- SETF'able."
+ "Return the element of array corresponding to the row-major index. This is
+ SETFable."
(declare (optimize (safety 1)))
(row-major-aref array index))
(defun svref (simple-vector index)
#!+sb-doc
- "Return the INDEX'th element of the given Simple-Vector."
+ "Return the INDEXth element of the given Simple-Vector."
(declare (optimize (safety 1)))
(aref simple-vector index))
(defun bit (bit-array &rest subscripts)
#!+sb-doc
"Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
- (declare (type (array bit) bit-array) (optimize (safety 1)))
+ (declare (type (array bit) bit-array)
+ (optimize (safety 1)))
(row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
-(defun %bitset (bit-array &rest stuff)
- (declare (type (array bit) bit-array) (optimize (safety 1)))
- (let ((subscripts (butlast stuff))
- (new-value (car (last stuff))))
- (setf (row-major-aref bit-array
- (%array-row-major-index bit-array subscripts))
- new-value)))
-
-#!-sb-fluid (declaim (inline (setf bit)))
(defun (setf bit) (new-value bit-array &rest subscripts)
- (declare (type (array bit) bit-array) (optimize (safety 1)))
+ (declare (type (array bit) bit-array)
+ (type bit new-value)
+ (optimize (safety 1)))
(setf (row-major-aref bit-array
(%array-row-major-index bit-array subscripts))
new-value))
(defun sbit (simple-bit-array &rest subscripts)
#!+sb-doc
"Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
- (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
+ (declare (type (simple-array bit) simple-bit-array)
+ (optimize (safety 1)))
(row-major-aref simple-bit-array
(%array-row-major-index simple-bit-array subscripts)))
-;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER,
-;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names.
-;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names?
-;;; -- WHN 19990911
-(defun %sbitset (simple-bit-array &rest stuff)
- (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
- (let ((subscripts (butlast stuff))
- (new-value (car (last stuff))))
- (setf (row-major-aref simple-bit-array
- (%array-row-major-index simple-bit-array subscripts))
- new-value)))
-
-#!-sb-fluid (declaim (inline (setf sbit)))
(defun (setf sbit) (new-value bit-array &rest subscripts)
- (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
+ (declare (type (simple-array bit) bit-array)
+ (type bit new-value)
+ (optimize (safety 1)))
(setf (row-major-aref bit-array
(%array-row-major-index bit-array subscripts))
new-value))
;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
;;; back to CMU CL).
-(defun vector-push (new-el array)
+(defun vector-push (new-element array)
#!+sb-doc
"Attempt to set the element of ARRAY designated by its fill pointer
- to NEW-EL, and increment the fill pointer by one. If the fill pointer is
+ to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
too large, NIL is returned, otherwise the index of the pushed element is
returned."
(let ((fill-pointer (fill-pointer array)))
nil)
(t
(locally (declare (optimize (safety 0)))
- (setf (aref array fill-pointer) new-el))
+ (setf (aref array fill-pointer) new-element))
(setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))))
-(defun vector-push-extend (new-element
- vector
- &optional
- (min-extension
- (let ((length (length vector)))
- (min (1+ length)
- (- array-dimension-limit length)))))
- (declare (fixnum min-extension))
+(defun vector-push-extend (new-element vector &optional min-extension)
+ (declare (type (or null fixnum) min-extension))
(let ((fill-pointer (fill-pointer vector)))
(declare (fixnum fill-pointer))
(when (= fill-pointer (%array-available-elements vector))
- (adjust-array vector (+ fill-pointer (max 1 min-extension))))
+ (let ((min-extension
+ (or min-extension
+ (let ((length (length vector)))
+ (min (1+ length)
+ (- array-dimension-limit length))))))
+ (adjust-array vector (+ fill-pointer (max 1 min-extension)))))
;; disable bounds checking
(locally (declare (optimize (safety 0)))
(setf (aref vector fill-pointer) new-element))
;;;; ADJUST-ARRAY
(defun adjust-array (array dimensions &key
- (element-type (array-element-type array))
+ (element-type (array-element-type array) element-type-p)
(initial-element nil initial-element-p)
(initial-contents nil initial-contents-p)
fill-pointer
(cond ((/= (the fixnum (length (the list dimensions)))
(the fixnum (array-rank array)))
(error "The number of dimensions not equal to rank of array."))
- ((not (subtypep element-type (array-element-type array)))
+ ((and element-type-p
+ (not (subtypep element-type (array-element-type array))))
(error "The new element type, ~S, is incompatible with old type."
element-type))
((and fill-pointer (not (array-has-fill-pointer-p array)))
(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 ~
+ (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
+ dimensions array-size element-type nil nil
initial-contents initial-contents-p
initial-element initial-element-p)))
(if (adjustable-array-p array)
(setf new-data
(data-vector-from-inits
dimensions new-length element-type
+ (widetag-of old-data) nil
initial-contents initial-contents-p
initial-element initial-element-p))
+ ;; Provide :END1 to avoid full call to LENGTH
+ ;; inside REPLACE.
(replace new-data old-data
+ :end1 new-length
:start2 old-start :end2 old-end))
(t (setf new-data
(shrink-vector old-data new-length))))
(> new-length old-length))
(data-vector-from-inits
dimensions new-length
- element-type () nil
+ element-type
+ (widetag-of old-data) nil
+ () nil
initial-element initial-element-p)
old-data)))
(if (or (zerop old-length) (zerop new-length))
projects / sbcl.git / blobdiff