\f
;;;; utilities
+(defun %check-generic-sequence-bounds (seq start end)
+ (let ((length (sb!sequence:length seq)))
+ (if (<= 0 start (or end length) length)
+ (or end length)
+ (sequence-bounding-indices-bad-error seq start end))))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *sequence-keyword-info*
nil
(if (<= 0 ,start ,length)
,start
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
index)
`(,end
nil
;; FIXME: defend against non-number non-NIL
;; stuff?
,end
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
(or null index)))))
'((start end length sequence)
(start1 end1 length1 sequence1)
;; This seems silly, is there something better?
'(integer 0 (0))))))
-(defun signal-bounding-indices-bad-error (sequence start end)
- (let ((length (length sequence)))
+(defun sequence-bounding-indices-bad-error (sequence start end)
+ (let ((size (length sequence)))
(error 'bounding-indices-bad-error
:datum (cons start end)
- :expected-type `(cons (integer 0 ,length)
- (or null (integer ,start ,length)))
+ :expected-type `(cons (integer 0 ,size)
+ (integer ,start ,size))
:object sequence)))
+
+(defun array-bounding-indices-bad-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)))
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
;;;; so we worry about dealing with END being supplied or defaulting
;;;; to NIL at this level.
-(defun vector-subseq* (sequence start &optional end)
+(defun string-subseq* (sequence start end)
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :force-inline t
+ :check-fill-pointer t)
+ (declare (optimize (speed 3) (safety 0)))
+ (string-dispatch ((simple-array character (*))
+ (simple-array base-char (*))
+ (vector nil))
+ data
+ (subseq data start end))))
+
+(defun vector-subseq* (sequence start end)
(declare (type vector sequence))
- (declare (type index start))
- (declare (type (or null index) end))
- (when (null end)
- (setf end (length sequence)))
- (unless (<= 0 start end (length sequence))
- (signal-bounding-indices-bad-error sequence start end))
- (do ((old-index start (1+ old-index))
- (new-index 0 (1+ new-index))
- (copy (%make-sequence-like sequence (- end start))))
- ((= old-index end) copy)
- (declare (fixnum old-index new-index))
- (setf (aref copy new-index)
- (aref sequence old-index))))
-
-(defun list-subseq* (sequence start &optional end)
- (declare (type list sequence))
- ;; the INDEX declaration isn't actually mandatory, but it's true for
- ;; all practical purposes.
- (declare (type index start))
- (declare (type (or null index) end))
- (do ((list sequence (cdr list))
- (index 0 (1+ index))
- (result nil))
- (nil)
- (cond
- ((null list) (if (or (and end (> end index))
- (< index start))
- (signal-bounding-indices-bad-error sequence start end)
- (return (nreverse result))))
- ((< index start) nil)
- ((and end (= index end)) (return (nreverse result)))
- (t (push (car list) result)))))
+ (declare (type index start)
+ (type (or null index) end))
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :check-fill-pointer t
+ :force-inline t)
+ (let* ((copy (%make-sequence-like sequence (- end start)))
+ (setter (!find-data-vector-setter copy))
+ (reffer (!find-data-vector-reffer data)))
+ (declare (optimize (speed 3) (safety 0)))
+ (do ((old-index start (1+ old-index))
+ (new-index 0 (1+ new-index)))
+ ((= old-index end) copy)
+ (declare (index old-index new-index))
+ (funcall setter copy new-index
+ (funcall reffer data old-index))))))
+
+(defun list-subseq* (sequence start end)
+ (declare (type list sequence)
+ (type unsigned-byte start)
+ (type (or null unsigned-byte) end))
+ (flet ((oops ()
+ (sequence-bounding-indices-bad-error sequence start end)))
+ (let ((pointer sequence))
+ (unless (zerop start)
+ ;; If START > 0 the list cannot be empty. So CDR down to
+ ;; it START-1 times, check that we still have something, then
+ ;; CDR the final time.
+ ;;
+ ;; If START was zero, the list may be empty if END is NIL or
+ ;; also zero.
+ (when (> start 1)
+ (setf pointer (nthcdr (1- start) pointer)))
+ (if pointer
+ (pop pointer)
+ (oops)))
+ (if end
+ (let ((n (- end start)))
+ (declare (integer n))
+ (when (minusp n)
+ (oops))
+ (when (plusp n)
+ (let* ((head (list nil))
+ (tail head))
+ (macrolet ((pop-one ()
+ `(let ((tmp (list (pop pointer))))
+ (setf (cdr tail) tmp
+ tail tmp))))
+ ;; Bignum case
+ (loop until (fixnump n)
+ do (pop-one)
+ (decf n))
+ ;; Fixnum case, but leave last element, so we should
+ ;; still have something left in the sequence.
+ (let ((m (1- n)))
+ (declare (fixnum m))
+ (loop repeat m
+ do (pop-one)))
+ (unless pointer
+ (oops))
+ ;; OK, pop the last one.
+ (pop-one)
+ (cdr head)))))
+ (loop while pointer
+ collect (pop pointer))))))
(defun subseq (sequence start &optional end)
#!+sb-doc
\f
;;;; COPY-SEQ
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-copy-seq (sequence)
- `(let ((length (length (the vector ,sequence))))
- (declare (fixnum length))
- (do ((index 0 (1+ index))
- (copy (%make-sequence-like ,sequence length)))
- ((= index length) copy)
- (declare (fixnum index))
- (setf (aref copy index) (aref ,sequence index)))))
-
-(sb!xc:defmacro list-copy-seq (list)
- `(if (atom ,list) '()
- (let ((result (cons (car ,list) '()) ))
- (do ((x (cdr ,list) (cdr x))
- (splice result
- (cdr (rplacd splice (cons (car x) '() ))) ))
- ((atom x) (unless (null x)
- (rplacd splice x))
- result)))))
-
-) ; EVAL-WHEN
-
(defun copy-seq (sequence)
#!+sb-doc "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
(seq-dispatch sequence
(list-copy-seq* sequence)
- (vector-copy-seq* sequence)
+ (vector-subseq* sequence 0 nil)
(sb!sequence:copy-seq sequence)))
-;;; internal frobs
-
(defun list-copy-seq* (sequence)
- (list-copy-seq sequence))
-
-(defun vector-copy-seq* (sequence)
- (declare (type vector sequence))
- (vector-copy-seq sequence))
+ (!copy-list-macro sequence :check-proper-list t))
\f
;;;; FILL
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-fill (sequence item start end)
- `(do ((index ,start (1+ index)))
- ((= index (the fixnum ,end)) ,sequence)
- (declare (fixnum index))
- (setf (aref ,sequence index) ,item)))
-
-(sb!xc:defmacro list-fill (sequence item start end)
- `(do ((current (nthcdr ,start ,sequence) (cdr current))
- (index ,start (1+ index)))
- ((or (atom current) (and end (= index (the fixnum ,end))))
- sequence)
- (declare (fixnum index))
- (rplaca current ,item)))
-
-) ; EVAL-WHEN
-
-;;; The support routines for FILL are used by compiler transforms, so we
-;;; worry about dealing with END being supplied or defaulting to NIL
-;;; at this level.
-
(defun list-fill* (sequence item start end)
- (declare (list sequence))
- (list-fill sequence item start end))
+ (declare (type list sequence)
+ (type unsigned-byte start)
+ (type (or null unsigned-byte) end))
+ (flet ((oops ()
+ (sequence-bounding-indices-bad-error sequence start end)))
+ (let ((pointer sequence))
+ (unless (zerop start)
+ ;; If START > 0 the list cannot be empty. So CDR down to it
+ ;; START-1 times, check that we still have something, then CDR
+ ;; the final time.
+ ;;
+ ;; If START was zero, the list may be empty if END is NIL or
+ ;; also zero.
+ (unless (= start 1)
+ (setf pointer (nthcdr (1- start) pointer)))
+ (if pointer
+ (pop pointer)
+ (oops)))
+ (if end
+ (let ((n (- end start)))
+ (declare (integer n))
+ (when (minusp n)
+ (oops))
+ (when (plusp n)
+ (loop repeat n
+ do (setf pointer (cdr (rplaca pointer item))))))
+ (loop while pointer
+ do (setf pointer (cdr (rplaca pointer item)))))))
+ sequence)
(defun vector-fill* (sequence item start end)
- (declare (vector sequence))
- (when (null end) (setq end (length sequence)))
- (vector-fill sequence item start end))
-
-(define-sequence-traverser fill (sequence item &rest args &key start end)
- #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :force-inline t
+ :check-fill-pointer t)
+ (let ((setter (!find-data-vector-setter data)))
+ (declare (optimize (speed 3) (safety 0)))
+ (do ((index start (1+ index)))
+ ((= index end) sequence)
+ (declare (index index))
+ (funcall setter data index item)))))
+
+(defun string-fill* (sequence item start end)
+ (declare (string sequence))
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :force-inline t
+ :check-fill-pointer t)
+ (macrolet ((frob ()
+ `(locally (declare (optimize (safety 0) (speed 3)))
+ (do ((i start (1+ i)))
+ ((= i end) sequence)
+ (declare (index i))
+ (setf (aref data i) item)))))
+ (etypecase data
+ #!+sb-unicode
+ ((simple-array character (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the character item))))
+ (frob)))
+ ((simple-array base-char (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the base-char item))))
+ (frob)))))))
+
+(defun fill (sequence item &key (start 0) end)
+ #!+sb-doc
+ "Replace the specified elements of SEQUENCE with ITEM."
(seq-dispatch sequence
- (list-fill* sequence item start end)
- (vector-fill* sequence item start end)
- (apply #'sb!sequence:fill sequence item args)))
+ (list-fill* sequence item start end)
+ (vector-fill* sequence item start end)
+ (sb!sequence:fill sequence item
+ :start start
+ :end (%check-generic-sequence-bounds sequence start end))))
\f
;;;; REPLACE
(frob sequence-arg from-end)
(with-array-data ((sequence sequence-arg :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds
- sequence-arg start end)))
+ (end end)
+ :check-fill-pointer t)
(multiple-value-bind (f p)
(macrolet ((frob2 () '(if from-end
(frob sequence t)
(frob sequence nil))))
(typecase sequence
- (simple-vector (frob2))
- (simple-base-string (frob2))
+ #!+sb-unicode
+ ((simple-array character (*)) (frob2))
+ ((simple-array base-char (*)) (frob2))
(t (vector*-frob sequence))))
(declare (type (or index null) p))
(values f (and p (the index (- p offset)))))))))
projects / sbcl.git / blobdiff