X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fseq.lisp;h=7cf17f4c983212b785b4783ef17ecf3e21871b87;hb=5423b2e0f7e7643001ed3ef2f66681c0114a72a6;hp=6ff9ebc5a3a3bcdd46661e6fd982abe7e8e9d6b9;hpb=0cb75ba42eb24fc8fbc24806d932322cb4741ffe;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 6ff9ebc..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* @@ -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,40 +364,87 @@ ;;;; 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 @@ -398,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 @@ -1682,20 +1752,22 @@ (do ((elt)) ((= index end)) (setq elt (aref vector index)) - ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT - ;; arguments simultaneously is a little fragile, since ANSI says - ;; we can't depend on it, so we need to remember to keep that - ;; extension in our implementation. It'd probably be better to - ;; rewrite this to avoid passing both (as - ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18). (unless (or (and from-end - (position (apply-key key elt) result - :start start :end jndex - :test test :test-not test-not :key key)) + (if test-not + (position (apply-key key elt) result + :start start :end jndex + :test-not test-not :key key) + (position (apply-key key elt) result + :start start :end jndex + :test test :key key))) (and (not from-end) - (position (apply-key key elt) vector - :start (1+ index) :end end - :test test :test-not test-not :key key))) + (if test-not + (position (apply-key key elt) vector + :start (1+ index) :end end + :test-not test-not :key key) + (position (apply-key key elt) vector + :start (1+ index) :end end + :test test :key key)))) (setf (aref result jndex) elt) (setq jndex (1+ jndex))) (setq index (1+ index))) @@ -1770,9 +1842,15 @@ (setf (aref vector jndex) (aref vector index)))) (declare (fixnum index jndex)) (setf (aref vector jndex) (aref vector index)) - (unless (position (apply-key key (aref vector index)) vector :key key - :start (if from-end start (1+ index)) :test test - :end (if from-end jndex end) :test-not test-not) + (unless (if test-not + (position (apply-key key (aref vector index)) vector :key key + :start (if from-end start (1+ index)) + :end (if from-end jndex end) + :test-not test-not) + (position (apply-key key (aref vector index)) vector :key key + :start (if from-end start (1+ index)) + :end (if from-end jndex end) + :test test)) (setq jndex (1+ jndex))))) (define-sequence-traverser delete-duplicates @@ -2094,15 +2172,16 @@ (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))))))))) @@ -2512,15 +2591,6 @@ (vector-search sequence2 sequence1) (apply #'sb!sequence:search sequence1 sequence2 args)))) -(sb!xc:defmacro string-dispatch ((&rest types) var &body body) - (let ((fun (gensym "STRING-DISPATCH-FUN-"))) - `(flet ((,fun (,var) - ,@body)) - (declare (inline ,fun)) - (etypecase ,var - ,@(loop for type in types - collect `(,type (,fun (the ,type ,var)))))))) - ;;; FIXME: this was originally in array.lisp; it might be better to ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in ;;; a new early-seq.lisp file. @@ -2542,4 +2612,4 @@ axis (car dims) contents (length contents))) (sb!sequence:dosequence (content contents) (frob (1+ axis) (cdr dims) content)))))) - (frob 0 dimensions initial-contents)))) \ No newline at end of file + (frob 0 dimensions initial-contents))))