X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=8c23fe31d0bc5bc878a270fd4e8e28473f1c90c3;hb=1ab1dd29f2602c87d404492e588abdf5f6abfbf2;hp=8fe9d9f1a3705ee0364eb6751f218323257ece72;hpb=2de1b72f4bec82ad5289f33a84b34fe9cb62bd0a;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 8fe9d9f..8c23fe3 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -224,6 +224,7 @@ ;; This seems silly, is there something better? '(integer 0 (0)))))) +(declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error)) (defun sequence-bounding-indices-bad-error (sequence start end) (let ((size (length sequence))) (error 'bounding-indices-bad-error @@ -232,6 +233,7 @@ (integer ,start ,size)) :object sequence))) +(declaim (ftype (function (t t t) nil) array-bounding-indices-bad-error)) (defun array-bounding-indices-bad-error (array start end) (let ((size (array-total-size array))) (error 'bounding-indices-bad-error @@ -239,6 +241,16 @@ :expected-type `(cons (integer 0 ,size) (integer ,start ,size)) :object array))) + +(declaim (ftype (function (t) nil) circular-list-error)) +(defun circular-list-error (list) + (let ((*print-circle* t)) + (error 'simple-type-error + :format-control "List is circular:~% ~S" + :format-arguments (list list) + :datum list + :type '(and list (satisfies list-length))))) + (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." @@ -487,17 +499,18 @@ (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 (rplaca pointer item)))) - (loop while pointer - do (setf pointer (cdr (rplaca pointer item))))))))) + (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) (with-array-data ((data sequence) @@ -519,22 +532,18 @@ (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))))))) + ;; DEFTRANSFORM for FILL will turn these into + ;; calls to UB*-BASH-FILL. + (etypecase data + #!+sb-unicode + ((simple-array character (*)) + (let ((item (locally (declare (optimize (safety 3))) + (the character item)))) + (fill data item :start start :end end))) + ((simple-array base-char (*)) + (let ((item (locally (declare (optimize (safety 3))) + (the base-char item)))) + (fill data item :start start :end end)))))) (defun fill (sequence item &key (start 0) end) #!+sb-doc @@ -672,7 +681,7 @@ #!+sb-doc "The target sequence is destructively modified by copying successive elements into it from the source sequence." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind ;; these things here so that legacy code gets the names it's @@ -869,6 +878,29 @@ (t (bad-sequence-type-error output-type-spec))))) +;;; Efficient out-of-line concatenate for strings. Compiler transforms +;;; CONCATENATE 'STRING &co into these. +(macrolet ((def (name element-type) + `(defun ,name (&rest sequences) + (declare (dynamic-extent sequences) + (optimize speed)) + (let* ((lengths (mapcar #'length sequences)) + (result (make-array (the integer (apply #'+ lengths)) + :element-type ',element-type)) + (start 0)) + (declare (index start)) + (dolist (seq sequences) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*)) + t) + seq + (replace result seq :start1 start)) + (incf start (the index (pop lengths)))) + result)))) + (def %concatenate-to-string character) + (def %concatenate-to-base-string base-char)) + ;;; internal frobs ;;; FIXME: These are weird. They're never called anywhere except in ;;; CONCATENATE. It seems to me that the macros ought to just @@ -960,9 +992,9 @@ (type list sequences)) (let ((result nil)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (push (apply fun args) result))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) (nreverse result))) (defun %map-to-vector (output-type-spec fun sequences) @@ -970,19 +1002,19 @@ (type list sequences)) (let ((min-len 0)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore args)) (incf min-len))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) (let ((result (make-sequence output-type-spec min-len)) (i 0)) (declare (type (simple-array * (*)) result)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (setf (aref result i) (apply fun args)) (incf i))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) result))) (defun %map-to-sequence (result-type fun sequences) @@ -990,20 +1022,20 @@ (type list sequences)) (let ((min-len 0)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore args)) (incf min-len))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences)) (let ((result (make-sequence result-type min-len))) (multiple-value-bind (state limit from-end step endp elt setelt) (sb!sequence:make-sequence-iterator result) (declare (ignore limit endp elt)) (flet ((f (&rest args) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (funcall setelt (apply fun args) result state) (setq state (funcall step result state from-end)))) - (declare (dynamic-extent #'f)) + (declare (truly-dynamic-extent #'f)) (%map-for-effect #'f sequences))) result))) @@ -1233,7 +1265,7 @@ (define-sequence-traverser reduce (function sequence &rest args &key key from-end start end (initial-value nil ivp)) (declare (type index start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((start start) (end (or end length))) (declare (type index start end)) @@ -1376,7 +1408,7 @@ "Return a sequence formed by destructively removing the specified ITEM from the given SEQUENCE." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1414,7 +1446,7 @@ "Return a sequence formed by destructively removing the elements satisfying the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1452,7 +1484,7 @@ "Return a sequence formed by destructively removing the elements not satisfying the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1601,7 +1633,7 @@ "Return a copy of SEQUENCE with elements satisfying the test (default is EQL) with ITEM removed." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1618,7 +1650,7 @@ #!+sb-doc "Return a copy of sequence with elements satisfying PREDICATE removed." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1635,7 +1667,7 @@ #!+sb-doc "Return a copy of sequence with elements not satisfying PREDICATE removed." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence @@ -1787,7 +1819,7 @@ The :TEST-NOT argument is deprecated." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (if sequence (list-remove-duplicates* sequence test test-not @@ -1860,7 +1892,7 @@ given sequence, is returned. The :TEST-NOT argument is deprecated." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (if sequence (list-delete-duplicates* sequence test test-not @@ -1980,7 +2012,7 @@ "Return a sequence of the same kind as SEQUENCE with the same elements, except that all elements equal to OLD are replaced with NEW." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (type index end)) (subst-dispatch 'normal))) @@ -1992,7 +2024,7 @@ #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying the PRED are replaced with NEW." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (fixnum start)) (let ((end (or end length)) (test predicate) @@ -2006,7 +2038,7 @@ #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying the PRED are replaced with NEW." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (fixnum start)) (let ((end (or end length)) (test predicate) @@ -2025,7 +2057,7 @@ except that all elements equal to OLD are replaced with NEW. SEQUENCE may be destructively modified." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (seq-dispatch sequence (if from-end @@ -2078,7 +2110,7 @@ except that all elements satisfying PREDICATE are replaced with NEW. SEQUENCE may be destructively modified." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (fixnum end)) (seq-dispatch sequence @@ -2120,7 +2152,7 @@ except that all elements not satisfying PREDICATE are replaced with NEW. SEQUENCE may be destructively modified." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length))) (declare (fixnum end)) (seq-dispatch sequence @@ -2178,8 +2210,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))))))))) @@ -2210,7 +2243,7 @@ (defun find (item sequence &rest args &key from-end (start 0) end key test test-not) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 0 (%find-position item sequence from-end start end @@ -2223,7 +2256,7 @@ (apply #'sb!sequence:find item sequence args))) (defun position (item sequence &rest args &key from-end (start 0) end key test test-not) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 1 (%find-position item sequence from-end start end @@ -2236,7 +2269,7 @@ (apply #'sb!sequence:position item sequence args))) (defun find-if (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 0 (%find-position-if (%coerce-callable-to-fun predicate) @@ -2249,7 +2282,7 @@ (apply #'sb!sequence:find-if predicate sequence args))) (defun position-if (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 1 (%find-position-if (%coerce-callable-to-fun predicate) @@ -2263,7 +2296,7 @@ (defun find-if-not (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 0 (%find-position-if-not (%coerce-callable-to-fun predicate) @@ -2276,7 +2309,7 @@ (apply #'sb!sequence:find-if-not predicate sequence args))) (defun position-if-not (predicate sequence &rest args &key from-end (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (seq-dispatch sequence (nth-value 1 (%find-position-if-not (%coerce-callable-to-fun predicate) @@ -2325,7 +2358,7 @@ #!+sb-doc "Return the number of elements in SEQUENCE satisfying PRED(el)." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length)) (pred (%coerce-callable-to-fun pred))) (declare (type index end)) @@ -2343,7 +2376,7 @@ #!+sb-doc "Return the number of elements in SEQUENCE not satisfying TEST(el)." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end (or end length)) (pred (%coerce-callable-to-fun pred))) (declare (type index end)) @@ -2363,7 +2396,7 @@ "Return the number of elements in SEQUENCE satisfying a test with ITEM, which defaults to EQL." (declare (fixnum start)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (when (and test-p test-not-p) ;; ANSI Common Lisp has left the behavior in this situation unspecified. ;; (CLHS 17.2.1) @@ -2471,7 +2504,7 @@ :FROM-END argument is given, then one plus the index of the rightmost position in which the sequences differ is returned." (declare (fixnum start1 start2)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let* ((end1 (or end1 length1)) (end2 (or end2 length2))) (declare (type index end1 end2)) @@ -2581,7 +2614,7 @@ (sequence1 sequence2 &rest args &key from-end test test-not start1 end1 start2 end2 key) (declare (fixnum start1 start2)) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((end1 (or end1 length1)) (end2 (or end2 length2))) (seq-dispatch sequence2