'(let ((length (length vector)))
(if (<= 0 start (or end length) length)
(or end length)
- (sb!impl::signal-bounding-indices-bad-error vector start end)))))
+ (sequence-bounding-indices-bad-error vector start end)))))
(defun specialized-list-seek-function-name (function-name key-functions)
(or (find-symbol (with-output-to-string (s)
(rplacd splice (cdr x))))
(t (setq splice x)))))
-(deftransform fill ((seq item &key (start 0) (end (length seq)))
- (vector t &key (:start t) (:end index))
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (list t &key (:start t) (:end t)))
+ '(list-fill* seq item start end))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (vector t &key (:start t) (:end t))
*
- :policy (> speed space))
- "open code"
- (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
- (values
- `(with-array-data ((data seq)
- (start start)
- (end end)
- :check-fill-pointer t)
- (declare (type (simple-array ,element-type 1) data))
- (declare (type fixnum start end))
- (do ((i start (1+ i)))
- ((= i end) seq)
- (declare (type index i))
- ;; WITH-ARRAY-DATA did our range checks once and for all, so
- ;; it'd be wasteful to check again on every AREF...
- (declare (optimize (safety 0)))
- (setf (aref data i) item)))
- ;; ... though we still need to check that the new element can fit
- ;; into the vector in safe code. -- CSR, 2002-07-05
- `((declare (type ,element-type item))))))
+ :node node)
+ (let ((type (lvar-type seq))
+ (element-type (type-specifier (extract-upgraded-element-type seq))))
+ (cond ((and (neq '* element-type) (policy node (> speed space)))
+ (values
+ `(with-array-data ((data seq)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (declare (type (simple-array ,element-type 1) data))
+ (declare (type index start end))
+ ;; WITH-ARRAY-DATA did our range checks once and for all, so
+ ;; it'd be wasteful to check again on every AREF...
+ (declare (optimize (safety 0) (speed 3)))
+ (do ((i start (1+ i)))
+ ((= i end) seq)
+ (declare (type index i))
+ (setf (aref data i) item)))
+ ;; ... though we still need to check that the new element can fit
+ ;; into the vector in safe code. -- CSR, 2002-07-05
+ `((declare (type ,element-type item)))))
+ ((csubtypep type (specifier-type 'string))
+ '(string-fill* seq item start end))
+ (t
+ '(vector-fill* seq item start end)))))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ ((and sequence (not vector) (not list)) t &key (:start t) (:end t)))
+ `(sb!sequence:fill seq item
+ :start start
+ :end (%check-generic-sequence-bounds seq start end)))
\f
;;;; utilities
,(unless (policy node (= safety 0))
`(progn
(unless (<= 0 start1 end1 len1)
- (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1))
+ (sequence-bounding-indices-bad-error seq1 start1 end1))
(unless (<= 0 start2 end2 len2)
- (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2))))
+ (sequence-bounding-indices-bad-error seq2 start2 end2))))
,',(cond
((and saetp (valid-bit-bash-saetp-p saetp))
(let* ((n-element-bits (sb!vm:saetp-n-bits saetp))
(type (integer 0 #.sb!xc:array-dimension-limit) j i))
(setf (aref ,dst (1- j)) (aref ,src (1- i))))))
+;;; SUBSEQ, COPY-SEQ
+
(deftransform subseq ((seq start &optional end)
- ((or (simple-unboxed-array (*)) simple-vector) t &optional t)
- * :node node)
- (let ((array-type (lvar-type seq)))
- (unless (array-type-p array-type)
- (give-up-ir1-transform))
- (let ((element-type (type-specifier (array-type-specialized-element-type array-type))))
- `(let* ((length (length seq))
- (end (or end length)))
- ,(unless (policy node (= safety 0))
- '(progn
- (unless (<= 0 start end length)
- (sb!impl::signal-bounding-indices-bad-error seq start end))))
- (let* ((size (- end start))
- (result (make-array size :element-type ',element-type)))
- ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
- (lvar-value start)
- 'start)
- 'result 0 'size element-type)
- result)))))
+ (vector t &optional t)
+ *
+ :node node)
+ (let ((type (lvar-type seq)))
+ (cond
+ ((and (array-type-p type)
+ (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+ (let ((element-type (type-specifier (array-type-specialized-element-type type))))
+ `(let* ((length (length seq))
+ (end (or end length)))
+ ,(unless (policy node (zerop insert-array-bounds-checks))
+ '(progn
+ (unless (<= 0 start end length)
+ (sequence-bounding-indices-bad-error seq start end))))
+ (let* ((size (- end start))
+ (result (make-array size :element-type ',element-type)))
+ ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
+ (lvar-value start)
+ 'start)
+ 'result 0 'size element-type)
+ result))))
+ ((csubtypep type (specifier-type 'string))
+ '(string-subseq* seq start end))
+ (t
+ '(vector-subseq* seq start end)))))
(deftransform subseq ((seq start &optional end)
(list t &optional t))
`(list-subseq* seq start end))
-(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *)
- (let ((array-type (lvar-type seq)))
- (unless (array-type-p array-type)
- (give-up-ir1-transform))
- (let ((element-type (type-specifier (array-type-specialized-element-type array-type))))
- `(let* ((length (length seq))
- (result (make-array length :element-type ',element-type)))
- ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
- result))))
+(deftransform subseq ((seq start &optional end)
+ ((and sequence (not vector) (not list)) t &optional t))
+ '(sb!sequence:subseq seq start end))
+
+(deftransform copy-seq ((seq) (vector))
+ (let ((type (lvar-type seq)))
+ (cond ((and (array-type-p type)
+ (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+ (let ((element-type (type-specifier (array-type-specialized-element-type type))))
+ `(let* ((length (length seq))
+ (result (make-array length :element-type ',element-type)))
+ ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
+ result)))
+ ((csubtypep type (specifier-type 'string))
+ '(string-subseq* seq 0 nil))
+ (t
+ '(vector-subseq* seq 0 nil)))))
+
+(deftransform copy-seq ((seq) (list))
+ '(list-copy-seq* seq))
+
+(deftransform copy-seq ((seq) ((and sequence (not vector) (not list))))
+ '(sb!sequence:copy-seq seq))
;;; FIXME: it really should be possible to take advantage of the
;;; macros used in code/seq.lisp here to avoid duplication of code,
(check-bounds-p (policy node (plusp insert-array-bounds-checks))))
`(block search
(flet ((oops (vector start end)
- (bounding-index-error vector start end)))
+ (sequence-bounding-indices-bad-error vector start end)))
(let* ((len1 (length pattern))
(len2 (length text))
(end1 (or end1 len1))
(declare (type index index))
(dolist (i sequence
(if (and end (> end index))
- (sb!impl::signal-bounding-indices-bad-error
+ (sequence-bounding-indices-bad-error
sequence start end)
(values find position)))
(let ((key-i (funcall key i)))
(effective-find-position-key key))))))
(define-find-position-if-not find-if-not 0)
(define-find-position-if-not position-if-not 1))
+
+(macrolet ((define-trimmer-transform (fun-name leftp rightp)
+ `(deftransform ,fun-name ((char-bag string)
+ (t simple-string))
+ (let ((find-expr
+ (if (constant-lvar-p char-bag)
+ ;; If the bag is constant, use MEMBER
+ ;; instead of FIND, since we have a
+ ;; deftransform for MEMBER that can
+ ;; open-code all of the comparisons when
+ ;; the list is constant. -- JES, 2007-12-10
+ `(not (member (schar string index)
+ ',(coerce (lvar-value char-bag) 'list)
+ :test #'char=))
+ '(not (find (schar string index) char-bag :test #'char=)))))
+ `(flet ((char-not-in-bag (index)
+ ,find-expr))
+ (let* ((end (length string))
+ (left-end (if ,',leftp
+ (do ((index 0 (1+ index)))
+ ((or (= index (the fixnum end))
+ (char-not-in-bag index))
+ index)
+ (declare (fixnum index)))
+ 0))
+ (right-end (if ,',rightp
+ (do ((index (1- end) (1- index)))
+ ((or (< index left-end)
+ (char-not-in-bag index))
+ (1+ index))
+ (declare (fixnum index)))
+ end)))
+ (if (and (eql left-end 0)
+ (eql right-end (length string)))
+ string
+ (subseq string left-end right-end))))))))
+ (define-trimmer-transform string-left-trim t nil)
+ (define-trimmer-transform string-right-trim nil t)
+ (define-trimmer-transform string-trim t t))
+
projects / sbcl.git / blobdiff