X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=e6abb669a501b328967e4ef6aeae976752911e7d;hb=441dfe5655f1ec3ee96e7b17b7cb1c7a4a906117;hp=d3e88e086ccb94dad0e0e916adf13941d6bf3243;hpb=fb2d28ba0ccab2afb9e68b4de722ba2179bcea8e;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index d3e88e0..e6abb66 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -39,29 +39,34 @@ 0 (1- most-positive-fixnum)))) (mod #.sb!xc:most-positive-fixnum)) + ;; Entries for {start,end}{,1,2} ,@(mapcan (lambda (names) (destructuring-bind (start end length sequence) names (list `(,start 0 nil - (if (<= 0 ,start ,length) + ;; Only evaluate LENGTH (which may be expensive) + ;; if START is non-NIL. + (if (or (zerop ,start) (<= 0 ,start ,length)) ,start (sequence-bounding-indices-bad-error ,sequence ,start ,end)) index) - `(,end - nil - nil - (if (or (null ,end) (<= ,start ,end ,length)) - ;; Defaulting of NIL is done inside the - ;; bodies, for ease of sharing with compiler - ;; transforms. - ;; - ;; FIXME: defend against non-number non-NIL - ;; stuff? - ,end - (sequence-bounding-indices-bad-error ,sequence ,start ,end)) - (or null index))))) + `(,end + nil + nil + ;; Only evaluate LENGTH (which may be expensive) + ;; if END is non-NIL. + (if (or (null ,end) (<= ,start ,end ,length)) + ;; Defaulting of NIL is done inside the + ;; bodies, for ease of sharing with compiler + ;; transforms. + ;; + ;; FIXME: defend against non-number non-NIL + ;; stuff? + ,end + (sequence-bounding-indices-bad-error ,sequence ,start ,end)) + (or null index))))) '((start end length sequence) (start1 end1 length1 sequence1) (start2 end2 length2 sequence2))) @@ -76,44 +81,52 @@ (test-not nil nil (and test-not (%coerce-callable-to-fun test-not)) - (or null function)) - )) + (or null function)))) (sb!xc:defmacro define-sequence-traverser (name args &body body) (multiple-value-bind (body declarations docstring) (parse-body body :doc-string-allowed t) - (collect ((new-args) (new-declarations) (adjustments)) + (collect ((new-args) + (new-declarations) + ;; Things which are definitely used in any code path. + (rebindings/eager) + ;; Things which may be used/are only used in certain + ;; code paths (e.g. length). + (rebindings/lazy)) (dolist (arg args) (case arg ;; FIXME: make this robust. And clean. - ((sequence) - (new-args arg) - (adjustments '(length (length sequence))) - (new-declarations '(type index length))) - ((sequence1) - (new-args arg) - (adjustments '(length1 (length sequence1))) - (new-declarations '(type index length1))) - ((sequence2) - (new-args arg) - (adjustments '(length2 (length sequence2))) - (new-declarations '(type index length2))) + ((sequence sequence1 sequence2) + (let* ((length-var (ecase arg + (sequence 'length) + (sequence1 'length1) + (sequence2 'length2))) + (cache-var (symbolicate length-var '#:-cache))) + (new-args arg) + (rebindings/eager `(,cache-var nil)) + (rebindings/lazy + `(,length-var (truly-the + index + (or ,cache-var (setf ,cache-var (length ,arg)))))))) ((function predicate) (new-args arg) - (adjustments `(,arg (%coerce-callable-to-fun ,arg)))) - (t (let ((info (cdr (assoc arg *sequence-keyword-info*)))) - (cond (info - (destructuring-bind (default supplied-p adjuster type) info - (new-args `(,arg ,default ,@(when supplied-p (list supplied-p)))) - (adjustments `(,arg ,adjuster)) - (new-declarations `(type ,type ,arg)))) - (t (new-args arg))))))) + (rebindings/eager `(,arg (%coerce-callable-to-fun ,arg)))) + (t + (let ((info (cdr (assoc arg *sequence-keyword-info*)))) + (cond (info + (destructuring-bind (default supplied-p adjuster type) info + (new-args `(,arg ,default ,@(when supplied-p (list supplied-p)))) + (rebindings/eager `(,arg ,adjuster)) + (new-declarations `(type ,type ,arg)))) + (t (new-args arg))))))) `(defun ,name ,(new-args) ,@(when docstring (list docstring)) ,@declarations - (let* (,@(adjustments)) - (declare ,@(new-declarations)) - ,@body))))) + (symbol-macrolet (,@(rebindings/lazy)) + (let* (,@(rebindings/eager)) + (declare ,@(new-declarations)) + ,@body + )))))) ;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE. ;;; @@ -202,6 +215,7 @@ "Vector length (~W) doesn't match declared length (~W)." :format-arguments (list actual-length declared-length)))) vector) + (defun sequence-of-checked-length-given-type (sequence result-type) (let ((ctype (specifier-type result-type))) (if (not (array-type-p ctype)) @@ -252,6 +266,16 @@ :type '(and list (satisfies list-length))))) + +(defun emptyp (sequence) + #!+sb-doc + "Returns T if SEQUENCE is an empty sequence and NIL + otherwise. Signals an error if SEQUENCE is not a sequence." + (seq-dispatch sequence + (null sequence) + (zerop (length sequence)) + (sb!sequence:emptyp sequence))) + (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." (seq-dispatch sequence @@ -301,16 +325,17 @@ (typecase expanded-type (atom (cond ((eq expanded-type 'string) '(vector character)) - ((eq expanded-type 'simple-string) '(simple-array character (*))) + ((eq expanded-type 'simple-string) + '(simple-array character (*))) (t type))) (cons (cond - ((eq (car expanded-type) 'string) `(vector character ,@(cdr expanded-type))) + ((eq (car expanded-type) 'string) + `(vector character ,@(cdr expanded-type))) ((eq (car expanded-type) 'simple-string) `(simple-array character ,(if (cdr expanded-type) (cdr expanded-type) '(*)))) - (t type))) - (t type))) + (t type))))) (type (specifier-type adjusted-type))) (cond ((csubtypep type (specifier-type 'list)) (cond @@ -373,6 +398,12 @@ ;;;; SUBSEQ ;;;; + +(define-array-dispatch vector-subseq-dispatch (array start end) + (declare (optimize speed (safety 0))) + (declare (type index start end)) + (subseq array start end)) + ;;;; The support routines for SUBSEQ are used by compiler transforms, ;;;; so we worry about dealing with END being supplied or defaulting ;;;; to NIL at this level. @@ -387,7 +418,7 @@ (end end) :check-fill-pointer t :force-inline t) - (funcall (!find-vector-subseq-fun data) data start end))) + (vector-subseq-dispatch data start end))) (defun list-subseq* (sequence start end) (declare (type list sequence) @@ -659,8 +690,13 @@ (define-sequence-traverser replace (sequence1 sequence2 &rest args &key start1 end1 start2 end2) #!+sb-doc - "The target sequence is destructively modified by copying successive - elements into it from the source sequence." + "Destructively modifies SEQUENCE1 by copying successive elements +into it from the SEQUENCE2. + +Elements are copied to the subseqeuence bounded by START1 and END1, +from the subsequence bounded by START2 and END2. If these subsequences +are not of the same length, then the shorter length determines how +many elements are copied." (declare (truly-dynamic-extent args)) (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind @@ -762,24 +798,27 @@ ;;;; CONCATENATE -(defmacro sb!sequence:dosequence ((e sequence &optional return) &body body) +(defmacro sb!sequence:dosequence ((element sequence &optional return) &body body) + #!+sb-doc + "Executes BODY with ELEMENT subsequently bound to each element of + SEQUENCE, then returns RETURN." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (let ((s sequence) (sequence (gensym "SEQUENCE"))) `(block nil (let ((,sequence ,s)) (seq-dispatch ,sequence - (dolist (,e ,sequence ,return) ,@body) - (dovector (,e ,sequence ,return) ,@body) + (dolist (,element ,sequence ,return) ,@body) + (do-vector-data (,element ,sequence ,return) ,@body) (multiple-value-bind (state limit from-end step endp elt) (sb!sequence:make-sequence-iterator ,sequence) (do ((state state (funcall step ,sequence state from-end))) ((funcall endp ,sequence state limit from-end) - (let ((,e nil)) + (let ((,element nil)) ,@(filter-dolist-declarations decls) - ,e + ,element ,return)) - (let ((,e (funcall elt ,sequence state))) + (let ((,element (funcall elt ,sequence state))) ,@decls (tagbody ,@forms)))))))))) @@ -825,14 +864,10 @@ ((eq type *empty-type*) (bad-sequence-type-error nil)) ((type= type (specifier-type 'null)) - (if (every (lambda (x) (or (null x) - (and (vectorp x) (= (length x) 0)))) - sequences) - 'nil - (sequence-type-length-mismatch-error - type - ;; FIXME: circular list issues. - (reduce #'+ sequences :key #'length)))) + (unless (every #'emptyp sequences) + (sequence-type-length-mismatch-error + type (reduce #'+ sequences :key #'length))) ; FIXME: circular list issues. + '()) ((cons-type-p type) (multiple-value-bind (min exactp) (sb!kernel::cons-type-length-info type) @@ -876,7 +911,7 @@ (def %concatenate-to-string character) (def %concatenate-to-base-string base-char)) -;;;; MAP and MAP-INTO +;;;; MAP ;;; helper functions to handle arity-1 subcases of MAP (declaim (ftype (function (function sequence) list) %map-list-arity-1)) @@ -1040,34 +1075,79 @@ first-sequence more-sequences)) -;;; KLUDGE: MAP has been rewritten substantially since the fork from -;;; CMU CL in order to give reasonable performance, but this -;;; implementation of MAP-INTO still has the same problems as the old -;;; MAP code. Ideally, MAP-INTO should be rewritten to be efficient in -;;; the same way that the corresponding cases of MAP have been -;;; rewritten. Instead of doing it now, though, it's easier to wait -;;; until we have DYNAMIC-EXTENT, at which time it should become -;;; extremely easy to define a reasonably efficient MAP-INTO in terms -;;; of (MAP NIL ..). -- WHN 20000920 +;;;; MAP-INTO + +(defmacro map-into-lambda (sequences params &body body) + (check-type sequences symbol) + `(flet ((f ,params ,@body)) + (declare (truly-dynamic-extent #'f)) + ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a different animal, + ;; hence the awkward flip between MAP and LOOP. + (if ,sequences + (apply #'map nil #'f ,sequences) + (loop (f))))) + +(define-array-dispatch vector-map-into (data start end fun sequences) + (declare (optimize speed (safety 0)) + (type index start end) + (type function fun) + (type list sequences)) + (let ((index start)) + (declare (type index index)) + (block mapping + (map-into-lambda sequences (&rest args) + (declare (truly-dynamic-extent args)) + (when (eql index end) + (return-from mapping)) + (setf (aref data index) (apply fun args)) + (incf index))) + index)) + +;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid +;;; computing the length of the result sequence since we can detect +;;; the end during mapping (if MAP even gets that far). +;;; +;;; For each result type, define a mapping function which is +;;; responsible for replacing RESULT-SEQUENCE elements and for +;;; terminating itself if the end of RESULT-SEQUENCE is reached. +;;; The mapping function is defined with MAP-INTO-LAMBDA. +;;; +;;; MAP-INTO-LAMBDAs are optimized since they are the inner loops. +;;; Because we are manually doing bounds checking with known types, +;;; safety is turned off for vectors and lists but kept for generic +;;; sequences. (defun map-into (result-sequence function &rest sequences) - (let* ((fp-result - (and (arrayp result-sequence) - (array-has-fill-pointer-p result-sequence))) - (len (apply #'min - (if fp-result - (array-dimension result-sequence 0) - (length result-sequence)) - (mapcar #'length sequences)))) - - (when fp-result - (setf (fill-pointer result-sequence) len)) - - (let ((really-fun (%coerce-callable-to-fun function))) - (dotimes (index len) - (setf (elt result-sequence index) - (apply really-fun - (mapcar (lambda (seq) (elt seq index)) - sequences)))))) + (let ((really-fun (%coerce-callable-to-fun function))) + (etypecase result-sequence + (vector + (with-array-data ((data result-sequence) (start) (end) + ;; MAP-INTO ignores fill pointer when mapping + :check-fill-pointer nil) + (let ((new-end (vector-map-into data start end really-fun sequences))) + (when (array-has-fill-pointer-p result-sequence) + (setf (fill-pointer result-sequence) (- new-end start)))))) + (list + (let ((node result-sequence)) + (declare (type list node)) + (map-into-lambda sequences (&rest args) + (declare (truly-dynamic-extent args) + (optimize speed (safety 0))) + (when (null node) + (return-from map-into result-sequence)) + (setf (car node) (apply really-fun args)) + (setf node (cdr node))))) + (sequence + (multiple-value-bind (iter limit from-end) + (sb!sequence:make-sequence-iterator result-sequence) + (map-into-lambda sequences (&rest args) + (declare (truly-dynamic-extent args) (optimize speed)) + (when (sb!sequence:iterator-endp result-sequence + iter limit from-end) + (return-from map-into result-sequence)) + (setf (sb!sequence:iterator-element result-sequence iter) + (apply really-fun args)) + (setf iter (sb!sequence:iterator-step result-sequence + iter from-end))))))) result-sequence) ;;;; quantifiers @@ -1127,17 +1207,20 @@ ;; from the old seq.lisp into target-seq.lisp. (define-compiler-macro ,name (pred first-seq &rest more-seqs) (let ((elements (make-gensym-list (1+ (length more-seqs)))) - (blockname (gensym "BLOCK"))) + (blockname (sb!xc:gensym "BLOCK")) + (wrapper (sb!xc:gensym "WRAPPER"))) (once-only ((pred pred)) `(block ,blockname - (map nil - (lambda (,@elements) - (let ((pred-value (funcall ,pred ,@elements))) - (,',found-test pred-value - (return-from ,blockname - ,',found-result)))) - ,first-seq - ,@more-seqs) + (flet ((,wrapper (,@elements) + (declare (optimize (sb!c::check-tag-existence 0))) + (let ((pred-value (funcall ,pred ,@elements))) + (,',found-test pred-value + (return-from ,blockname + ,',found-result))))) + (declare (inline ,wrapper) + (dynamic-extent #',wrapper)) + (map nil #',wrapper ,first-seq + ,@more-seqs)) ,',unfound-result))))))) (defquantifier some when pred-value :unfound-result nil :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then @@ -1228,19 +1311,20 @@ (define-sequence-traverser reduce (function sequence &rest args &key key from-end start end (initial-value nil ivp)) - (declare (type index start)) - (declare (truly-dynamic-extent args)) - (let ((start start) - (end (or end length))) - (declare (type index start end)) - (seq-dispatch sequence + (declare (type index start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if (= end start) (if ivp initial-value (funcall function)) (if from-end (list-reduce-from-end function sequence key start end initial-value ivp) (list-reduce function sequence key start end - initial-value ivp))) + initial-value ivp)))) + (let ((end (or end length))) + (declare (type index end)) (if (= end start) (if ivp initial-value (funcall function)) (if from-end @@ -1255,8 +1339,8 @@ (setq initial-value (apply-key key (aref sequence start))) (setq start (1+ start))) (mumble-reduce function sequence key start end - initial-value aref)))) - (apply #'sb!sequence:reduce function sequence args)))) + initial-value aref))))) + (apply #'sb!sequence:reduce function sequence args))) ;;;; DELETE @@ -1371,18 +1455,20 @@ #!+sb-doc "Return a sequence formed by destructively removing the specified ITEM from the given SEQUENCE." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (type index end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end (normal-list-delete-from-end) - (normal-list-delete)) + (normal-list-delete))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (normal-mumble-delete-from-end) - (normal-mumble-delete)) - (apply #'sb!sequence:delete item sequence args)))) + (normal-mumble-delete))) + (apply #'sb!sequence:delete item sequence args))) (eval-when (:compile-toplevel :execute) @@ -1409,18 +1495,20 @@ #!+sb-doc "Return a sequence formed by destructively removing the elements satisfying the specified PREDICATE from the given SEQUENCE." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (type index end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-list-delete-from-end) - (if-list-delete)) + (if-list-delete))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-mumble-delete-from-end) - (if-mumble-delete)) - (apply #'sb!sequence:delete-if predicate sequence args)))) + (if-mumble-delete))) + (apply #'sb!sequence:delete-if predicate sequence args))) (eval-when (:compile-toplevel :execute) @@ -1447,18 +1535,20 @@ #!+sb-doc "Return a sequence formed by destructively removing the elements not satisfying the specified PREDICATE from the given SEQUENCE." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (type index end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-not-list-delete-from-end) - (if-not-list-delete)) + (if-not-list-delete))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-not-mumble-delete-from-end) - (if-not-mumble-delete)) - (apply #'sb!sequence:delete-if-not predicate sequence args)))) + (if-not-mumble-delete))) + (apply #'sb!sequence:delete-if-not predicate sequence args))) ;;;; REMOVE @@ -1596,52 +1686,58 @@ #!+sb-doc "Return a copy of SEQUENCE with elements satisfying the test (default is EQL) with ITEM removed." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (type index end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end (normal-list-remove-from-end) - (normal-list-remove)) + (normal-list-remove))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (normal-mumble-remove-from-end) - (normal-mumble-remove)) - (apply #'sb!sequence:remove item sequence args)))) + (normal-mumble-remove))) + (apply #'sb!sequence:remove item sequence args))) (define-sequence-traverser remove-if (predicate sequence &rest args &key from-end start end count key) #!+sb-doc "Return a copy of sequence with elements satisfying PREDICATE removed." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (type index end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-list-remove-from-end) - (if-list-remove)) + (if-list-remove))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-mumble-remove-from-end) - (if-mumble-remove)) - (apply #'sb!sequence:remove-if predicate sequence args)))) + (if-mumble-remove))) + (apply #'sb!sequence:remove-if predicate sequence args))) (define-sequence-traverser remove-if-not (predicate sequence &rest args &key from-end start end count key) #!+sb-doc "Return a copy of sequence with elements not satisfying PREDICATE removed." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (type index end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-not-list-remove-from-end) - (if-not-list-remove)) + (if-not-list-remove))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (if-not-mumble-remove-from-end) - (if-not-mumble-remove)) - (apply #'sb!sequence:remove-if-not predicate sequence args)))) + (if-not-mumble-remove))) + (apply #'sb!sequence:remove-if-not predicate sequence args))) ;;;; REMOVE-DUPLICATES @@ -1782,8 +1878,8 @@ sequence is returned. The :TEST-NOT argument is deprecated." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) + (declare (fixnum start) + (truly-dynamic-extent args)) (seq-dispatch sequence (if sequence (list-remove-duplicates* sequence test test-not @@ -1858,9 +1954,9 @@ The :TEST-NOT argument is deprecated." (declare (truly-dynamic-extent args)) (seq-dispatch sequence - (if sequence - (list-delete-duplicates* sequence test test-not - key from-end start end)) + (when sequence + (list-delete-duplicates* sequence test test-not + key from-end start end)) (vector-delete-duplicates* sequence test test-not key from-end start end) (apply #'sb!sequence:delete-duplicates sequence args))) @@ -1940,25 +2036,31 @@ (sb!xc:defmacro subst-dispatch (pred) `(seq-dispatch sequence - (if from-end - (nreverse (list-substitute* ,pred - new - (reverse sequence) - (- (the fixnum length) - (the fixnum end)) - (- (the fixnum length) - (the fixnum start)) - count key test test-not old)) - (list-substitute* ,pred - new sequence start end count key test test-not - old)) - (if from-end - (vector-substitute* ,pred new sequence -1 (1- (the fixnum length)) - -1 length (1- (the fixnum end)) - (1- (the fixnum start)) - count key test test-not old) - (vector-substitute* ,pred new sequence 1 0 length length - start end count key test test-not old)) + (let ((end (or end length))) + (declare (type index end)) + (if from-end + (nreverse (list-substitute* ,pred + new + (reverse sequence) + (- (the fixnum length) + (the fixnum end)) + (- (the fixnum length) + (the fixnum start)) + count key test test-not old)) + (list-substitute* ,pred + new sequence start end count key test test-not + old))) + + (let ((end (or end length))) + (declare (type index end)) + (if from-end + (vector-substitute* ,pred new sequence -1 (1- (the fixnum length)) + -1 length (1- (the fixnum end)) + (1- (the fixnum start)) + count key test test-not old) + (vector-substitute* ,pred new sequence 1 0 length length + start end count key test test-not old))) + ;; FIXME: wow, this is an odd way to implement the dispatch. PRED ;; here is (QUOTE [NORMAL|IF|IF-NOT]). Not only is this pretty ;; pointless, but also LIST-SUBSTITUTE* and VECTOR-SUBSTITUTE* @@ -1975,11 +2077,9 @@ #!+sb-doc "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 (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (type index end)) - (subst-dispatch 'normal))) + (declare (type fixnum start) + (truly-dynamic-extent args)) + (subst-dispatch 'normal)) ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT @@ -1988,13 +2088,11 @@ #!+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 (truly-dynamic-extent args)) - (declare (fixnum start)) - (let ((end (or end length)) - (test predicate) + (declare (type fixnum start) + (truly-dynamic-extent args)) + (let ((test predicate) (test-not nil) old) - (declare (type index length end)) (subst-dispatch 'if))) (define-sequence-traverser substitute-if-not @@ -2002,13 +2100,11 @@ #!+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 (truly-dynamic-extent args)) - (declare (fixnum start)) - (let ((end (or end length)) - (test predicate) + (declare (type fixnum start) + (truly-dynamic-extent args)) + (let ((test predicate) (test-not nil) old) - (declare (type index length end)) (subst-dispatch 'if-not))) ;;;; NSUBSTITUTE @@ -2020,24 +2116,26 @@ "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements equal to OLD are replaced with NEW. SEQUENCE may be destructively modified." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end - (let ((length (length sequence))) - (nreverse (nlist-substitute* - new old (nreverse (the list sequence)) - test test-not (- length end) (- length start) - count key))) + (nreverse (nlist-substitute* + new old (nreverse (the list sequence)) + test test-not (- length end) (- length start) + count key)) (nlist-substitute* new old sequence - test test-not start end count key)) + test test-not start end count key))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (nvector-substitute* new old sequence -1 test test-not (1- end) (1- start) count key) (nvector-substitute* new old sequence 1 - test test-not start end count key)) - (apply #'sb!sequence:nsubstitute new old sequence args)))) + test test-not start end count key))) + (apply #'sb!sequence:nsubstitute new old sequence args))) (defun nlist-substitute* (new old sequence test test-not start end count key) (declare (fixnum start count end)) @@ -2073,27 +2171,29 @@ "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying PREDICATE are replaced with NEW. SEQUENCE may be destructively modified." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (fixnum end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end - (let ((length (length sequence))) - (nreverse (nlist-substitute-if* - new predicate (nreverse (the list sequence)) - (- length end) (- length start) count key))) + (nreverse (nlist-substitute-if* + new predicate (nreverse (the list sequence)) + (- length end) (- length start) count key)) (nlist-substitute-if* new predicate sequence - start end count key)) + start end count key))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (nvector-substitute-if* new predicate sequence -1 (1- end) (1- start) count key) (nvector-substitute-if* new predicate sequence 1 - start end count key)) - (apply #'sb!sequence:nsubstitute-if new predicate sequence args)))) + start end count key))) + (apply #'sb!sequence:nsubstitute-if new predicate sequence args))) (defun nlist-substitute-if* (new test sequence start end count key) - (declare (fixnum end)) + (declare (type fixnum end) + (type function test)) ; coercion is done by caller (do ((list (nthcdr start sequence) (cdr list)) (index start (1+ index))) ((or (= index end) (null list) (= count 0)) sequence) @@ -2103,6 +2203,8 @@ (defun nvector-substitute-if* (new test sequence incrementer start end count key) + (declare (type fixnum end) + (type function test)) ; coercion is done by caller (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (when (funcall test (apply-key key (aref sequence index))) @@ -2115,27 +2217,29 @@ "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying PREDICATE are replaced with NEW. SEQUENCE may be destructively modified." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length))) - (declare (fixnum end)) - (seq-dispatch sequence + (declare (type fixnum start) + (truly-dynamic-extent args)) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (fixnum end)) (if from-end - (let ((length (length sequence))) - (nreverse (nlist-substitute-if-not* - new predicate (nreverse (the list sequence)) - (- length end) (- length start) count key))) + (nreverse (nlist-substitute-if-not* + new predicate (nreverse (the list sequence)) + (- length end) (- length start) count key)) (nlist-substitute-if-not* new predicate sequence - start end count key)) + start end count key))) + (let ((end (or end length))) + (declare (fixnum end)) (if from-end (nvector-substitute-if-not* new predicate sequence -1 (1- end) (1- start) count key) (nvector-substitute-if-not* new predicate sequence 1 - start end count key)) - (apply #'sb!sequence:nsubstitute-if-not new predicate sequence args)))) + start end count key))) + (apply #'sb!sequence:nsubstitute-if-not new predicate sequence args))) (defun nlist-substitute-if-not* (new test sequence start end count key) - (declare (fixnum end)) + (declare (type fixnum end) + (type function test)) ; coercion is done by caller (do ((list (nthcdr start sequence) (cdr list)) (index start (1+ index))) ((or (= index end) (null list) (= count 0)) sequence) @@ -2145,6 +2249,8 @@ (defun nvector-substitute-if-not* (new test sequence incrementer start end count key) + (declare (type fixnum end) + (type function test)) ; coercion is done by caller (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (when (not (funcall test (apply-key key (aref sequence index)))) @@ -2162,7 +2268,7 @@ (macrolet (;; shared logic for defining %FIND-POSITION and ;; %FIND-POSITION-IF in terms of various inlineable cases ;; of the expression defined in FROB and VECTOR*-FROB - (frobs () + (frobs (&optional bit-frob) `(seq-dispatch sequence-arg (frob sequence-arg from-end) (with-array-data ((sequence sequence-arg :offset-var offset) @@ -2170,14 +2276,28 @@ (end end) :check-fill-pointer t) (multiple-value-bind (f p) - (macrolet ((frob2 () '(if from-end - (frob sequence t) - (frob sequence nil)))) + (macrolet ((frob2 () `(if from-end + (frob sequence t) + (frob sequence nil)))) (typecase sequence #!+sb-unicode ((simple-array character (*)) (frob2)) ((simple-array base-char (*)) (frob2)) - (t (vector*-frob sequence)))) + ,@(when bit-frob + `((simple-bit-vector + (if (and (typep item 'bit) + (eq #'identity key) + (or (eq #'eq test) + (eq #'eql test) + (eq #'equal test))) + (let ((p (%bit-position item sequence + from-end start end))) + (if p + (values item p) + (values nil nil))) + (vector*-frob sequence))))) + (t + (vector*-frob sequence)))) (declare (type (or index null) p)) (values f (and p (the index (- p offset))))))))) (defun %find-position (item sequence-arg from-end start end key test) @@ -2187,7 +2307,7 @@ (vector*-frob (sequence) `(%find-position-vector-macro item ,sequence from-end start end key test))) - (frobs))) + (frobs t))) (defun %find-position-if (predicate sequence-arg from-end start end key) (macrolet ((frob (sequence from-end) `(%find-position-if predicate ,sequence @@ -2321,36 +2441,40 @@ (pred sequence &rest args &key from-end start end key) #!+sb-doc "Return the number of elements in SEQUENCE satisfying PRED(el)." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length)) - (pred (%coerce-callable-to-fun pred))) - (declare (type index end)) + (declare (type fixnum start) + (truly-dynamic-extent args)) + (let ((pred (%coerce-callable-to-fun pred))) (seq-dispatch sequence - (if from-end - (list-count-if nil t pred sequence) - (list-count-if nil nil pred sequence)) - (if from-end - (vector-count-if nil t pred sequence) - (vector-count-if nil nil pred sequence)) + (let ((end (or end length))) + (declare (type index end)) + (if from-end + (list-count-if nil t pred sequence) + (list-count-if nil nil pred sequence))) + (let ((end (or end length))) + (declare (type index end)) + (if from-end + (vector-count-if nil t pred sequence) + (vector-count-if nil nil pred sequence))) (apply #'sb!sequence:count-if pred sequence args)))) (define-sequence-traverser count-if-not (pred sequence &rest args &key from-end start end key) #!+sb-doc "Return the number of elements in SEQUENCE not satisfying TEST(el)." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) - (let ((end (or end length)) - (pred (%coerce-callable-to-fun pred))) - (declare (type index end)) + (declare (type fixnum start) + (truly-dynamic-extent args)) + (let ((pred (%coerce-callable-to-fun pred))) (seq-dispatch sequence - (if from-end - (list-count-if t t pred sequence) - (list-count-if t nil pred sequence)) - (if from-end - (vector-count-if t t pred sequence) - (vector-count-if t nil pred sequence)) + (let ((end (or end length))) + (declare (type index end)) + (if from-end + (list-count-if t t pred sequence) + (list-count-if t nil pred sequence))) + (let ((end (or end length))) + (declare (type index end)) + (if from-end + (vector-count-if t t pred sequence) + (vector-count-if t nil pred sequence))) (apply #'sb!sequence:count-if-not pred sequence args)))) (define-sequence-traverser count @@ -2359,27 +2483,29 @@ #!+sb-doc "Return the number of elements in SEQUENCE satisfying a test with ITEM, which defaults to EQL." - (declare (fixnum start)) - (declare (truly-dynamic-extent args)) + (declare (type fixnum start) + (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) (error ":TEST and :TEST-NOT are both present.")) - (let ((end (or end length))) - (declare (type index end)) - (let ((%test (if test-not-p - (lambda (x) - (not (funcall test-not item x))) - (lambda (x) - (funcall test item x))))) - (seq-dispatch sequence + (let ((%test (if test-not-p + (lambda (x) + (not (funcall test-not item x))) + (lambda (x) + (funcall test item x))))) + (seq-dispatch sequence + (let ((end (or end length))) + (declare (type index end)) (if from-end (list-count-if nil t %test sequence) - (list-count-if nil nil %test sequence)) + (list-count-if nil nil %test sequence))) + (let ((end (or end length))) + (declare (type index end)) (if from-end (vector-count-if nil t %test sequence) - (vector-count-if nil nil %test sequence)) - (apply #'sb!sequence:count item sequence args))))) + (vector-count-if nil nil %test sequence))) + (apply #'sb!sequence:count item sequence args)))) ;;;; MISMATCH @@ -2467,26 +2593,39 @@ SEQUENCE1 beyond the last position tested is returned. If a non-NIL :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 (type fixnum start1 start2)) (declare (truly-dynamic-extent args)) - (let* ((end1 (or end1 length1)) - (end2 (or end2 length2))) - (declare (type index end1 end2)) - (match-vars - (seq-dispatch sequence1 - (seq-dispatch sequence2 + (seq-dispatch sequence1 + (seq-dispatch sequence2 + (let ((end1 (or end1 length1)) + (end2 (or end2 length2))) + (declare (type index end1 end2)) + (match-vars (matchify-list (sequence1 start1 length1 end1) (matchify-list (sequence2 start2 length2 end2) - (list-list-mismatch))) + (list-list-mismatch))))) + (let ((end1 (or end1 length1)) + (end2 (or end2 length2))) + (declare (type index end1 end2)) + (match-vars (matchify-list (sequence1 start1 length1 end1) - (list-mumble-mismatch)) - (apply #'sb!sequence:mismatch sequence1 sequence2 args)) - (seq-dispatch sequence2 + (list-mumble-mismatch)))) + (apply #'sb!sequence:mismatch sequence1 sequence2 args)) + (seq-dispatch sequence2 + (let ((end1 (or end1 length1)) + (end2 (or end2 length2))) + (declare (type index end1 end2)) + (match-vars (matchify-list (sequence2 start2 length2 end2) - (mumble-list-mismatch)) - (mumble-mumble-mismatch) - (apply #'sb!sequence:mismatch sequence1 sequence2 args)) - (apply #'sb!sequence:mismatch sequence1 sequence2 args))))) + (mumble-list-mismatch)))) + (let ((end1 (or end1 length1)) + (end2 (or end2 length2))) + (declare (type index end1 end2)) + (match-vars + (mumble-mumble-mismatch))) + (apply #'sb!sequence:mismatch sequence1 sequence2 args)) + (apply #'sb!sequence:mismatch sequence1 sequence2 args))) + ;;; search comparison functions @@ -2577,14 +2716,18 @@ (define-sequence-traverser search (sequence1 sequence2 &rest args &key from-end test test-not start1 end1 start2 end2 key) - (declare (fixnum start1 start2)) - (declare (truly-dynamic-extent args)) - (let ((end1 (or end1 length1)) - (end2 (or end2 length2))) - (seq-dispatch sequence2 - (list-search sequence2 sequence1) - (vector-search sequence2 sequence1) - (apply #'sb!sequence:search sequence1 sequence2 args)))) + (declare (type fixnum start1 start2) + (truly-dynamic-extent args)) + (seq-dispatch sequence2 + (let ((end1 (or end1 length1)) + (end2 (or end2 length2))) + (declare (type index end1 end2)) + (list-search sequence2 sequence1)) + (let ((end1 (or end1 length1)) + (end2 (or end2 length2))) + (declare (type index end1 end2)) + (vector-search sequence2 sequence1)) + (apply #'sb!sequence:search sequence1 sequence2 args))) ;;; FIXME: this was originally in array.lisp; it might be better to ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in