X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fseq.lisp;h=b49f616ae61fd6f7cdd6f4a9cbb3757a16ce0a7b;hb=2e002dae2f9a3c64f147ca651751ed833806ad5e;hp=a5173aa1b77039f712916de0e7cdbb66446ec304;hpb=0152c2971917eed5117f5d6b53653bd8424b6b1f;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index a5173aa..b49f616 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -20,6 +20,12 @@ ;;;; 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* @@ -380,14 +386,16 @@ (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) @@ -449,84 +457,94 @@ ;;;; 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)) ;;;; 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)))))))) (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)))) ;;;; REPLACE @@ -2160,8 +2178,9 @@ (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)))))))))