X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=8c23fe31d0bc5bc878a270fd4e8e28473f1c90c3;hb=1ab1dd29f2602c87d404492e588abdf5f6abfbf2;hp=8099663476616b5e645926b4512550b3c1d6484b;hpb=a682f4c392bc874a6a898632889319ebdd8821fc;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 8099663..8c23fe3 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,33 @@ ;; This seems silly, is there something better? '(integer 0 (0)))))) -(defun signal-bounding-indices-bad-error (sequence start end) - (let ((length (length sequence))) +(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 :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))) + +(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 + :datum (cons start end) + :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." @@ -352,40 +376,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 +469,91 @@ ;;;; 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) + ;; 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 + "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 @@ -603,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 @@ -800,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 @@ -891,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) @@ -901,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) @@ -921,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))) @@ -1164,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)) @@ -1307,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 @@ -1345,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 @@ -1383,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 @@ -1532,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 @@ -1549,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 @@ -1566,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 @@ -1682,20 +1783,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))) @@ -1716,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 @@ -1770,9 +1873,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 @@ -1783,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 @@ -1903,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))) @@ -1915,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) @@ -1929,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) @@ -1948,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 @@ -2001,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 @@ -2043,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 @@ -2094,15 +2203,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))))))))) @@ -2133,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 @@ -2146,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 @@ -2159,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) @@ -2172,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) @@ -2186,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) @@ -2199,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) @@ -2248,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)) @@ -2266,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)) @@ -2286,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) @@ -2394,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)) @@ -2504,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 @@ -2512,17 +2622,9 @@ (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)))))))) - -;;; originally in array.lisp; probably best to put it back there and -;;; make DOSEQUENCE and SEQ-DISPATCH be in early-seq.lisp. +;;; 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. (defun fill-data-vector (vector dimensions initial-contents) (let ((index 0)) (labels ((frob (axis dims contents) @@ -2541,4 +2643,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))))