X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fseq.lisp;h=7cf17f4c983212b785b4783ef17ecf3e21871b87;hb=672b2f6cb751566526c7f3bb3de6b7d8424760e2;hp=eba8389974c32f60bbc17d8cbee12ad401ae6379;hpb=b86daba1860b622636d9e8f655a3f96de4d86801;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index eba8389..7cf17f4 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* @@ -358,21 +364,38 @@ ;;;; 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)) - (sequence-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)))) + (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) @@ -434,84 +457,95 @@ ;;;; 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))))))) + 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)))) ;;;; REPLACE @@ -2145,8 +2179,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)))))))))