X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=b49f616ae61fd6f7cdd6f4a9cbb3757a16ce0a7b;hb=2e002dae2f9a3c64f147ca651751ed833806ad5e;hp=c5c6bd84aeb0978febbcc21f7569285184a1bb08;hpb=26265f96389d737bf2e1e4c787ea8943ae499944;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index c5c6bd8..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* @@ -41,8 +47,7 @@ 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 @@ -55,8 +60,7 @@ ;; 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) @@ -220,13 +224,21 @@ ;; 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))) (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." @@ -352,28 +364,45 @@ ;;;; 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)))) + (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 () - (signal-bounding-indices-bad-error sequence start end))) + (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 @@ -428,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)) - -(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 @@ -2139,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)))))))))