\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*
(end end)
:check-fill-pointer t
:force-inline t)
- (let ((copy (%make-sequence-like sequence (- end start))))
+ (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))
- (setf (aref copy new-index)
- (aref data old-index))))))
+ (funcall setter copy new-index
+ (funcall reffer data old-index))))))
(defun list-subseq* (sequence start end)
(declare (type list sequence)
\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))
+ (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)))))
-(define-sequence-traverser fill (sequence item &rest args &key start end)
- #!+sb-doc "Replace the specified elements of SEQUENCE with 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 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