\f
;;;; WITH-ARRAY-DATA
-(defun bounding-index-error (array start end)
- (let ((size (array-total-size array)))
- (error 'bounding-indices-bad-error
- :datum (cons start end)
- :expected-type `(cons (integer 0 ,size)
- (integer ,start ,size))
- :object array)))
-
-(defun bounding-index-error/fp (array start end)
- (let ((size (length array)))
- (error 'bounding-indices-bad-error
- :datum (cons start end)
- :expected-type `(cons (integer 0 ,size)
- (integer ,start ,size))
- :object array)))
-
;;; This checks to see whether the array is simple and the start and
;;; end are in bounds. If so, it proceeds with those values.
;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
(once-only ((n-array array)
(n-svalue `(the index ,svalue))
(n-evalue `(the (or index null) ,evalue)))
- (let ((check-bounds (policy env (= 0 insert-array-bounds-checks))))
+ (let ((check-bounds (policy env (plusp insert-array-bounds-checks))))
`(multiple-value-bind (,data-var
,start-var
,end-var
`(array-total-size ,n-array)))
(n-end `(or ,n-evalue ,n-len)))
(if check-bounds
- `(values ,n-array ,n-svalue ,n-end 0)
- `(if (<= ,n-svalue ,n-end ,n-len)
+ `(if (<= 0 ,n-svalue ,n-end ,n-len)
(values ,n-array ,n-svalue ,n-end 0)
,(if check-fill-pointer
- `(bounding-index-error/fp ,n-array ,n-svalue ,n-evalue)
- `(bounding-index-error ,n-array ,n-svalue ,n-evalue))))))
+ `(sequence-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)
+ `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)))
+ `(values ,n-array ,n-svalue ,n-end 0))))
,(if force-inline
`(%with-array-data-macro ,n-array ,n-svalue ,n-evalue
:check-bounds ,check-bounds
,@(when check-bounds
`((unless (<= ,start ,defaulted-end ,size)
,(if check-fill-pointer
- `(bounding-index-error/fp ,array ,start ,end)
- `(bounding-index-error ,array ,start ,end)))))
+ `(sequence-bounding-indices-bad-error ,array ,start ,end)
+ `(array-bounding-indices-bad-error ,array ,start ,end)))))
(do ((,data ,array (%array-data-vector ,data))
(,cumulative-offset 0
(+ ,cumulative-offset
(defun transform-%with-array-data/muble (array node check-fill-pointer)
(let ((element-type (upgraded-element-type-specifier-or-give-up array))
- (type (lvar-type array)))
+ (type (lvar-type array))
+ (check-bounds (policy node (plusp insert-array-bounds-checks))))
(if (and (array-type-p type)
+ (not (array-type-complexp type))
(listp (array-type-dimensions type))
(not (null (cdr (array-type-dimensions type)))))
;; If it's a simple multidimensional array, then just return
;; users to use WITH-ARRAY-DATA and we may use it ourselves at
;; some point in the future for optimized libraries or
;; similar.
- ;;
- ;; FIXME: The return values here don't seem sane, and
- ;; bounds-checks are elided!
- `(let ((data (truly-the (simple-array ,element-type (*))
- (%array-data-vector array))))
- (values data 0 (length data) 0))
+ (if check-bounds
+ `(let* ((data (truly-the (simple-array ,element-type (*))
+ (%array-data-vector array)))
+ (len (length data))
+ (real-end (or end len)))
+ (unless (<= 0 start data-end lend)
+ (sequence-bounding-indices-bad-error array start end))
+ (values data 0 real-end 0))
+ `(let ((data (truly-the (simple-array ,element-type (*))
+ (%array-data-vector array))))
+ (values data 0 (or end (length data)) 0)))
`(%with-array-data-macro array start end
:check-fill-pointer ,check-fill-pointer
- :check-bounds ,(policy node (< 0 insert-array-bounds-checks))
+ :check-bounds ,check-bounds
:element-type ,element-type))))
;; It might very well be reasonable to allow general ARRAY here, I
;; without bloating the code. If we already know the type of the array
;; with sufficient precision, skip directly to DATA-VECTOR-REF.
(deftransform aref ((array index) (t t) * :node node)
- (let ((type (lvar-type array)))
- (cond ((and (array-type-p type)
- (null (array-type-complexp type))
- (not (eql (extract-upgraded-element-type array)
- *wild-type*))
- (eql (length (array-type-dimensions type)) 1))
- `(data-vector-ref array (%check-bound array
- (array-dimension array 0)
- index)))
- ((policy node (zerop insert-array-bounds-checks))
- `(hairy-data-vector-ref array index))
- (t
- `(hairy-data-vector-ref/check-bounds array index)))))
+ (let* ((type (lvar-type array))
+ (element-ctype (extract-upgraded-element-type array)))
+ (cond
+ ((and (array-type-p type)
+ (null (array-type-complexp type))
+ (not (eql element-ctype *wild-type*))
+ (eql (length (array-type-dimensions type)) 1))
+ (let* ((declared-element-ctype (extract-declared-element-type array))
+ (bare-form
+ `(data-vector-ref array
+ (%check-bound array (array-dimension array 0) index))))
+ (if (type= declared-element-ctype element-ctype)
+ bare-form
+ `(the ,(type-specifier declared-element-ctype) ,bare-form))))
+ ((policy node (zerop insert-array-bounds-checks))
+ `(hairy-data-vector-ref array index))
+ (t `(hairy-data-vector-ref/check-bounds array index)))))
(deftransform %aset ((array index new-value) (t t t) * :node node)
(if (policy node (zerop insert-array-bounds-checks))
projects / sbcl.git / blobdiff