X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=7a20475cf6840bb639304aa0788cf17c9c8d92df;hb=c25e4572f5505236faf126f38a74f32a80bf1e8c;hp=a4fa13830633a5cda93e0f0c87d46a6e9a8239aa;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index a4fa138..7a20475 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -35,11 +35,11 @@ (sb!xc:defmacro make-sequence-like (sequence length) #!+sb-doc - "Returns a sequence of the same type as SEQUENCE and the given LENGTH." + "Return a sequence of the same type as SEQUENCE and the given LENGTH." `(make-sequence-of-type (type-of ,sequence) ,length)) (sb!xc:defmacro type-specifier-atom (type) - #!+sb-doc "Returns the broad class of which TYPE is a specific subclass." + #!+sb-doc "Return the broad class of which TYPE is a specific subclass." `(if (atom ,type) ,type (car ,type))) ) ; EVAL-WHEN @@ -56,7 +56,7 @@ :datum vector :expected-type `(vector ,declared-length) :format-control - "Vector length (~D) doesn't match declared length (~D)." + "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) @@ -81,7 +81,7 @@ :datum type :expected-type '(or vector cons) :format-control - "NIL output type invalid for this sequence function." + "A NIL output type is invalid for this sequence function." :format-arguments ()))) ((dolist (seq-type '(list string simple-vector bit-vector)) (when (csubtypep type (specifier-type seq-type)) @@ -93,7 +93,7 @@ :datum type :expected-type 'sequence :format-control - "~S is a bad type specifier for sequence functions." + "~S is not a legal type specifier for sequence functions." :format-arguments (list type)))))) (defun signal-index-too-large-error (sequence index) @@ -107,7 +107,7 @@ '(integer (0) (0)))))) (defun make-sequence-of-type (type length) - #!+sb-doc "Returns a sequence of the given TYPE and LENGTH." + #!+sb-doc "Return a sequence of the given TYPE and LENGTH." (declare (fixnum length)) (case (type-specifier-atom type) (list (make-list length)) @@ -123,7 +123,7 @@ (make-sequence-of-type (result-type-or-lose type) length)))) (defun elt (sequence index) - #!+sb-doc "Returns the element of SEQUENCE specified by INDEX." + #!+sb-doc "Return the element of SEQUENCE specified by INDEX." (etypecase sequence (list (do ((count index (1- count)) @@ -155,15 +155,15 @@ (setf (aref sequence index) newval)))) (defun length (sequence) - #!+sb-doc "Returns an integer that is the length of SEQUENCE." + #!+sb-doc "Return an integer that is the length of SEQUENCE." (etypecase sequence (vector (length (truly-the vector sequence))) (list (length (truly-the list sequence))))) (defun make-sequence (type length &key (initial-element NIL iep)) #!+sb-doc - "Returns a sequence of the given Type and Length, with elements initialized - to :Initial-Element." + "Return a sequence of the given TYPE and LENGTH, with elements initialized + to :INITIAL-ELEMENT." (declare (fixnum length)) (let ((type (specifier-type type))) (cond ((csubtypep type (specifier-type 'list)) @@ -186,11 +186,12 @@ (vlen (car (array-type-dimensions type)))) (if (and (numberp vlen) (/= vlen length)) (error 'simple-type-error - ;; these two are under-specified by ANSI + ;; These two are under-specified by ANSI. :datum (type-specifier type) :expected-type (type-specifier type) :format-control - "The length of ~S does not match the specified length of ~S." + "The length of ~S does not match the specified ~ + length=~S." :format-arguments (list (type-specifier type) length))) (if iep @@ -245,7 +246,7 @@ ;;; routines for other reasons (see above). (defun subseq (sequence start &optional end) #!+sb-doc - "Returns a copy of a subsequence of SEQUENCE starting with element number + "Return a copy of a subsequence of SEQUENCE starting with element number START and continuing to the end of SEQUENCE or the optional END." (seq-dispatch sequence (list-subseq* sequence start end) @@ -277,7 +278,7 @@ ) ; EVAL-WHEN (defun copy-seq (sequence) - #!+sb-doc "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." + #!+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))) @@ -288,7 +289,17 @@ (list-copy-seq sequence)) (defun vector-copy-seq* (sequence) - (vector-copy-seq sequence (type-of sequence))) + (declare (type vector sequence)) + (vector-copy-seq sequence + (typecase sequence + ;; Pick off the common cases so that we don't have to... + ((vector t) 'simple-vector) + (string 'simple-string) + (bit-vector 'simple-bit-vector) + ((vector single-float) '(simple-array single-float 1)) + ((vector double-float) '(simple-array double-float 1)) + ;; ...do a full call to TYPE-OF. + (t (type-of sequence))))) ;;;; FILL @@ -441,9 +452,9 @@ (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-mumble)) -;;; REPLACE cannot default end arguments to the length of sequence since it -;;; is not an error to supply nil for their values. We must test for ends -;;; being nil in the body of the function. +;;; REPLACE cannot default END arguments to the length of SEQUENCE since it +;;; is not an error to supply NIL for their values. We must test for ENDs +;;; being NIL in the body of the function. (defun replace (target-sequence source-sequence &key ((:start1 target-start) 0) ((:end1 target-end)) @@ -486,7 +497,7 @@ (defun reverse (sequence) #!+sb-doc - "Returns a new sequence containing the same elements but in reverse order." + "Return a new sequence containing the same elements but in reverse order." (seq-dispatch sequence (list-reverse* sequence) (vector-reverse* sequence))) @@ -531,7 +542,7 @@ (defun nreverse (sequence) #!+sb-doc - "Returns a sequence of the same elements in reverse order; the argument + "Return a sequence of the same elements in reverse order; the argument is destroyed." (seq-dispatch sequence (list-nreverse* sequence) @@ -598,7 +609,7 @@ ;;; efficiency, but space efficiency..) (defun concatenate (output-type-spec &rest sequences) #!+sb-doc - "Returns a new sequence of all the argument sequences concatenated together + "Return a new sequence of all the argument sequences concatenated together which shares no structure with the original argument sequences of the specified OUTPUT-TYPE-SPEC." (case (type-specifier-atom output-type-spec) @@ -606,8 +617,7 @@ bit-vector simple-bit-vector base-string simple-base-string) ; FIXME: unifying principle here? (let ((result (apply #'concat-to-simple* output-type-spec sequences))) - #!+high-security - (check-type-var result output-type-spec) + #!+high-security (aver (typep result output-type-spec)) result)) (list (apply #'concat-to-list* sequences)) (t @@ -638,7 +648,7 @@ (vector (dovector (,i sequence) ,@body)))))) (defun %map-to-list-arity-1 (fun sequence) (let ((reversed-result nil) - (really-fun (%coerce-callable-to-function fun))) + (really-fun (%coerce-callable-to-fun fun))) (dosequence (element sequence) (push (funcall really-fun element) reversed-result)) @@ -646,7 +656,7 @@ (defun %map-to-simple-vector-arity-1 (fun sequence) (let ((result (make-array (length sequence))) (index 0) - (really-fun (%coerce-callable-to-function fun))) + (really-fun (%coerce-callable-to-fun fun))) (declare (type index index)) (dosequence (element sequence) (setf (aref result index) @@ -654,7 +664,7 @@ (incf index)) result)) (defun %map-for-effect-arity-1 (fun sequence) - (let ((really-fun (%coerce-callable-to-function fun))) + (let ((really-fun (%coerce-callable-to-fun fun))) (dosequence (element sequence) (funcall really-fun element))) nil)) @@ -760,7 +770,7 @@ ;;; length of the output sequence matches any length specified ;;; in RESULT-TYPE. (defun %map (result-type function first-sequence &rest more-sequences) - (let ((really-function (%coerce-callable-to-function function))) + (let ((really-fun (%coerce-callable-to-fun function))) ;; Handle one-argument MAP NIL specially, using ETYPECASE to turn ;; it into something which can be DEFTRANSFORMed away. (It's ;; fairly important to handle this case efficiently, since @@ -768,21 +778,21 @@ ;; there's no consing overhead to dwarf our inefficiency.) (if (and (null more-sequences) (null result-type)) - (%map-for-effect-arity-1 really-function first-sequence) + (%map-for-effect-arity-1 really-fun first-sequence) ;; Otherwise, use the industrial-strength full-generality ;; approach, consing O(N-ARGS) temporary storage (which can have ;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time. (let ((sequences (cons first-sequence more-sequences))) (case (type-specifier-atom result-type) - ((nil) (%map-for-effect really-function sequences)) - (list (%map-to-list really-function sequences)) + ((nil) (%map-for-effect really-fun sequences)) + (list (%map-to-list really-fun sequences)) ((simple-vector simple-string vector string array simple-array bit-vector simple-bit-vector base-string simple-base-string) - (%map-to-vector result-type really-function sequences)) + (%map-to-vector result-type really-fun sequences)) (t (apply #'map (result-type-or-lose result-type t) - really-function + really-fun sequences))))))) (defun map (result-type function first-sequence &rest more-sequences) @@ -826,11 +836,11 @@ (when fp-result (setf (fill-pointer result-sequence) len)) - (let ((really-fun (%coerce-callable-to-function function))) + (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)) + (mapcar (lambda (seq) (elt seq index)) sequences)))))) result-sequence) @@ -879,6 +889,16 @@ ;; obviously correct solution is to make Python smart ;; enough that we can use an inline function instead ;; of a compiler macro (as above). -- WHN 20000410 + ;; + ;; FIXME: The DEFINE-COMPILER-MACRO here can be + ;; important for performance, and it'd be good to have + ;; it be visible throughout the compilation of all the + ;; target SBCL code. That could be done by defining + ;; SB-XC:DEFINE-COMPILER-MACRO and using it here, + ;; moving this DEFQUANTIFIER stuff (and perhaps other + ;; inline definitions in seq.lisp as well) into a new + ;; seq.lisp, and moving remaining target-only stuff + ;; 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"))) @@ -894,22 +914,22 @@ ,@more-seqs) ,',unfound-result))))))) (defquantifier some when pred-value :unfound-result nil :doc - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. SOME returns the first - non-NIL value encountered, or NIL if the end of a sequence is reached.") + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return the first + non-NIL value encountered, or NIL if the end of any sequence is reached.") (defquantifier every unless nil :doc - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. EVERY returns NIL as soon + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon as any invocation of PREDICATE returns NIL, or T if every invocation is non-NIL.") (defquantifier notany when nil :doc - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. NOTANY returns NIL as soon + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon as any invocation of PREDICATE returns a non-NIL value, or T if the end - of a sequence is reached.") + of any sequence is reached.") (defquantifier notevery unless t :doc - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. NOTEVERY returns T as soon + "Apply PREDICATE to 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return T as soon as any invocation of PREDICATE returns NIL, or NIL if every invocation is non-NIL.")) @@ -1122,8 +1142,8 @@ (defun delete (item sequence &key from-end (test #'eql) test-not (start 0) end count key) #!+sb-doc - "Returns a sequence formed by destructively removing the specified Item from - the given Sequence." + "Return a sequence formed by destructively removing the specified ITEM from + the given SEQUENCE." (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) @@ -1160,8 +1180,8 @@ (defun delete-if (predicate sequence &key from-end (start 0) key end count) #!+sb-doc - "Returns a sequence formed by destructively removing the elements satisfying - the specified Predicate from the given Sequence." + "Return a sequence formed by destructively removing the elements satisfying + the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) @@ -1198,8 +1218,8 @@ (defun delete-if-not (predicate sequence &key from-end (start 0) end key count) #!+sb-doc - "Returns a sequence formed by destructively removing the elements not - satisfying the specified Predicate from the given Sequence." + "Return a sequence formed by destructively removing the elements not + satisfying the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) @@ -1345,7 +1365,7 @@ (defun remove (item sequence &key from-end (test #'eql) test-not (start 0) end count key) #!+sb-doc - "Returns a copy of SEQUENCE with elements satisfying the test (default is + "Return a copy of SEQUENCE with elements satisfying the test (default is EQL) with ITEM removed." (declare (fixnum start)) (let* ((length (length sequence)) @@ -1363,8 +1383,8 @@ (defun remove-if (predicate sequence &key from-end (start 0) end count key) #!+sb-doc - "Returns a copy of sequence with elements such that predicate(element) - is non-null are removed" + "Return a copy of sequence with elements such that predicate(element) + is non-null removed" (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) @@ -1381,8 +1401,8 @@ (defun remove-if-not (predicate sequence &key from-end (start 0) end count key) #!+sb-doc - "Returns a copy of sequence with elements such that predicate(element) - is null are removed" + "Return a copy of sequence with elements such that predicate(element) + is null removed" (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) @@ -1668,8 +1688,8 @@ (defun substitute (new old sequence &key from-end (test #'eql) test-not (start 0) count end key) #!+sb-doc - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements equal to Old are replaced with New. See manual + "Return a sequence of the same kind as SEQUENCE with the same elements, + except that all elements equal to OLD are replaced with NEW. See manual for details." (declare (fixnum start)) (let* ((length (length sequence)) @@ -1683,8 +1703,8 @@ (defun substitute-if (new test sequence &key from-end (start 0) end count key) #!+sb-doc - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements satisfying the Test are replaced with New. See + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements satisfying the TEST are replaced with NEW. See manual for details." (declare (fixnum start)) (let* ((length (length sequence)) @@ -1699,8 +1719,8 @@ (defun substitute-if-not (new test sequence &key from-end (start 0) end count key) #!+sb-doc - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements not satisfying the Test are replaced with New. + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements not satisfying the TEST are replaced with NEW. See manual for details." (declare (fixnum start)) (let* ((length (length sequence)) @@ -1717,9 +1737,9 @@ (defun nsubstitute (new old sequence &key from-end (test #'eql) test-not end count key (start 0)) #!+sb-doc - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements equal to Old are replaced with New. The Sequence - may be destroyed. See manual for details." + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements equal to OLD are replaced with NEW. The SEQUENCE + may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end (length sequence))) (count (or count most-positive-fixnum))) @@ -1767,9 +1787,9 @@ (defun nsubstitute-if (new test sequence &key from-end (start 0) end count key) #!+sb-doc - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements satisfying the Test are replaced with New. The - Sequence may be destroyed. See manual for details." + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements satisfying the TEST are replaced with NEW. + SEQUENCE may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end (length sequence))) (count (or count most-positive-fixnum))) @@ -1807,9 +1827,9 @@ (defun nsubstitute-if-not (new test sequence &key from-end (start 0) end count key) #!+sb-doc - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements not satisfying the Test are replaced with New. - The Sequence may be destroyed. See manual for details." + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements not satisfying the TEST are replaced with NEW. + SEQUENCE may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end (length sequence))) (count (or count most-positive-fixnum))) @@ -1844,276 +1864,155 @@ (setf (aref sequence index) new) (setq count (1- count))))) -;;; locater macros used by FIND and POSITION - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-locater-macro (sequence body-form return-type) - `(let ((incrementer (if from-end -1 1)) - (start (if from-end (1- (the fixnum end)) start)) - (end (if from-end (1- (the fixnum start)) end))) - (declare (fixnum start end incrementer)) - (do ((index start (+ index incrementer)) - ,@(case return-type (:position nil) (:element '(current)))) - ((= index end) ()) - (declare (fixnum index)) - ,@(case return-type - (:position nil) - (:element `((setf current (aref ,sequence index))))) - ,body-form))) - -(sb!xc:defmacro locater-test-not (item sequence seq-type return-type) - (let ((seq-ref (case return-type - (:position - (case seq-type - (:vector `(aref ,sequence index)) - (:list `(pop ,sequence)))) - (:element 'current))) - (return (case return-type - (:position 'index) - (:element 'current)))) - `(if test-not - (if (not (funcall test-not ,item (apply-key key ,seq-ref))) - (return ,return)) - (if (funcall test ,item (apply-key key ,seq-ref)) - (return ,return))))) - -(sb!xc:defmacro vector-locater (item sequence return-type) - `(vector-locater-macro ,sequence - (locater-test-not ,item ,sequence :vector ,return-type) - ,return-type)) - -(sb!xc:defmacro locater-if-test (test sequence seq-type return-type sense) - (let ((seq-ref (case return-type - (:position - (case seq-type - (:vector `(aref ,sequence index)) - (:list `(pop ,sequence)))) - (:element 'current))) - (return (case return-type - (:position 'index) - (:element 'current)))) - (if sense - `(if (funcall ,test (apply-key key ,seq-ref)) - (return ,return)) - `(if (not (funcall ,test (apply-key key ,seq-ref))) - (return ,return))))) - -(sb!xc:defmacro vector-locater-if-macro (test sequence return-type sense) - `(vector-locater-macro ,sequence - (locater-if-test ,test ,sequence :vector ,return-type ,sense) - ,return-type)) - -(sb!xc:defmacro vector-locater-if (test sequence return-type) - `(vector-locater-if-macro ,test ,sequence ,return-type t)) - -(sb!xc:defmacro vector-locater-if-not (test sequence return-type) - `(vector-locater-if-macro ,test ,sequence ,return-type nil)) - -(sb!xc:defmacro list-locater-macro (sequence body-form return-type) - `(if from-end - (do ((sequence (nthcdr (- (the fixnum (length sequence)) - (the fixnum end)) - (reverse (the list ,sequence)))) - (index (1- (the fixnum end)) (1- index)) - (terminus (1- (the fixnum start))) - ,@(case return-type (:position nil) (:element '(current)))) - ((or (= index terminus) (null sequence)) ()) - (declare (fixnum index terminus)) - ,@(case return-type - (:position nil) - (:element `((setf current (pop ,sequence))))) - ,body-form) - (do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - ,@(case return-type (:position nil) (:element '(current)))) - ((or (= index (the fixnum end)) (null sequence)) ()) - (declare (fixnum index)) - ,@(case return-type - (:position nil) - (:element `((setf current (pop ,sequence))))) - ,body-form))) - -(sb!xc:defmacro list-locater (item sequence return-type) - `(list-locater-macro ,sequence - (locater-test-not ,item ,sequence :list ,return-type) - ,return-type)) - -(sb!xc:defmacro list-locater-if-macro (test sequence return-type sense) - `(list-locater-macro ,sequence - (locater-if-test ,test ,sequence :list ,return-type ,sense) - ,return-type)) - -(sb!xc:defmacro list-locater-if (test sequence return-type) - `(list-locater-if-macro ,test ,sequence ,return-type t)) - -(sb!xc:defmacro list-locater-if-not (test sequence return-type) - `(list-locater-if-macro ,test ,sequence ,return-type nil)) - -) ; EVAL-WHEN - -;;; POSITION - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-position (item sequence) - `(vector-locater ,item ,sequence :position)) - -(sb!xc:defmacro list-position (item sequence) - `(list-locater ,item ,sequence :position)) - -) ; EVAL-WHEN - -;;; POSITION cannot default end to the length of sequence since it is not -;;; an error to supply nil for its value. We must test for end being nil -;;; in the body of the function, and this is actually done in the support -;;; routines for other reasons (see below). -(defun position (item sequence &key from-end (test #'eql) test-not (start 0) - end key) - #!+sb-doc - "Returns the zero-origin index of the first element in SEQUENCE - satisfying the test (default is EQL) with the given ITEM" - (seq-dispatch sequence - (list-position* item sequence from-end test test-not start end key) - (vector-position* item sequence from-end test test-not start end key))) - -;;; 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. - -(defun list-position* (item sequence from-end test test-not start end key) - (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (list-position item sequence)) - -(defun vector-position* (item sequence from-end test test-not start end key) - (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (vector-position item sequence)) - -;;;; POSITION-IF - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-position-if (test sequence) - `(vector-locater-if ,test ,sequence :position)) - -(sb!xc:defmacro list-position-if (test sequence) - `(list-locater-if ,test ,sequence :position)) - -) ; EVAL-WHEN - -(defun position-if (test sequence &key from-end (start 0) key end) - #!+sb-doc - "Returns the zero-origin index of the first element satisfying test(el)" - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-position-if test sequence) - (vector-position-if test sequence)))) - -;;;; POSITION-IF-NOT - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-position-if-not (test sequence) - `(vector-locater-if-not ,test ,sequence :position)) - -(sb!xc:defmacro list-position-if-not (test sequence) - `(list-locater-if-not ,test ,sequence :position)) - -) ; EVAL-WHEN - -(defun position-if-not (test sequence &key from-end (start 0) key end) - #!+sb-doc - "Returns the zero-origin index of the first element not satisfying test(el)" - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-position-if-not test sequence) - (vector-position-if-not test sequence)))) - -;;;; FIND - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-find (item sequence) - `(vector-locater ,item ,sequence :element)) - -(sb!xc:defmacro list-find (item sequence) - `(list-locater ,item ,sequence :element)) - -) ; EVAL-WHEN - -;;; Note: FIND cannot default end to the length of sequence since it -;;; is not an error to supply NIL for its value. We must test for end -;;; being NIL in the body of the function, and this is actually done -;;; in the support routines for other reasons (see above). -(defun find (item sequence &key from-end (test #'eql) test-not (start 0) - end key) - #!+sb-doc - "Returns the first element in SEQUENCE satisfying the test (default - is EQL) with the given ITEM" - (declare (fixnum start)) - (seq-dispatch sequence - (list-find* item sequence from-end test test-not start end key) - (vector-find* item sequence from-end test test-not start end key))) - -;;; The support routines for FIND are used by compiler transforms, so we -;;; worry about dealing with END being supplied or defaulting to NIL -;;; at this level. - -(defun list-find* (item sequence from-end test test-not start end key) - (when (null end) (setf end (length sequence))) - (list-find item sequence)) - -(defun vector-find* (item sequence from-end test test-not start end key) - (when (null end) (setf end (length sequence))) - (vector-find item sequence)) - -;;;; FIND-IF and FIND-IF-NOT - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-find-if (test sequence) - `(vector-locater-if ,test ,sequence :element)) - -(sb!xc:defmacro list-find-if (test sequence) - `(list-locater-if ,test ,sequence :element)) - -) ; EVAL-WHEN - -(defun find-if (test sequence &key from-end (start 0) end key) - #!+sb-doc - "Returns the zero-origin index of the first element satisfying the test." - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-find-if test sequence) - (vector-find-if test sequence)))) - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-find-if-not (test sequence) - `(vector-locater-if-not ,test ,sequence :element)) - -(sb!xc:defmacro list-find-if-not (test sequence) - `(list-locater-if-not ,test ,sequence :element)) - -) ; EVAL-WHEN - -(defun find-if-not (test sequence &key from-end (start 0) end key) - #!+sb-doc - "Returns the zero-origin index of the first element not satisfying the test." - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-find-if-not test sequence) - (vector-find-if-not test sequence)))) +;;;; FIND, POSITION, and their -IF and -IF-NOT variants + +;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, +;;; POSITION-IF, etc. +(declaim (inline effective-find-position-test effective-find-position-key)) +(defun effective-find-position-test (test test-not) + (cond ((and test test-not) + (error "can't specify both :TEST and :TEST-NOT")) + (test (%coerce-callable-to-fun test)) + (test-not + ;; (Without DYNAMIC-EXTENT, this is potentially horribly + ;; inefficient, but since the TEST-NOT option is deprecated + ;; anyway, we don't care.) + (complement (%coerce-callable-to-fun test-not))) + (t #'eql))) +(defun effective-find-position-key (key) + (if key + (%coerce-callable-to-fun key) + #'identity)) + +;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF +(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 () + `(etypecase sequence-arg + (list (frob sequence-arg from-end)) + (vector + (with-array-data ((sequence sequence-arg :offset-var offset) + (start start) + (end (or end (length sequence-arg)))) + (multiple-value-bind (f p) + (macrolet ((frob2 () '(if from-end + (frob sequence t) + (frob sequence nil)))) + (typecase sequence + (simple-vector (frob2)) + (simple-string (frob2)) + (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) + (macrolet ((frob (sequence from-end) + `(%find-position item ,sequence + ,from-end start end key test)) + (vector*-frob (sequence) + `(%find-position-vector-macro item ,sequence + from-end start end key test))) + (frobs))) + (defun %find-position-if (predicate sequence-arg from-end start end key) + (macrolet ((frob (sequence from-end) + `(%find-position-if predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-vector-macro predicate ,sequence + from-end start end key))) + (frobs))) + (defun %find-position-if-not (predicate sequence-arg from-end start end key) + (macrolet ((frob (sequence from-end) + `(%find-position-if-not predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-not-vector-macro predicate ,sequence + from-end start end key))) + (frobs)))) + +;;; the user interface to FIND and POSITION: Get all our ducks in a +;;; row, then call %FIND-POSITION. +(declaim (inline find position)) +(macrolet ((def-find-position (fun-name values-index) + `(defun ,fun-name (item + sequence + &key + from-end + (start 0) + end + key + test + test-not) + (nth-value + ,values-index + (%find-position item + sequence + from-end + start + end + (effective-find-position-key key) + (effective-find-position-test test + test-not)))))) + (def-find-position find 0) + (def-find-position position 1)) + +;;; the user interface to FIND-IF and POSITION-IF, entirely analogous +;;; to the interface to FIND and POSITION +(declaim (inline find-if position-if)) +(macrolet ((def-find-position-if (fun-name values-index) + `(defun ,fun-name (predicate sequence + &key from-end (start 0) end key) + (nth-value + ,values-index + (%find-position-if (%coerce-callable-to-fun predicate) + sequence + from-end + start + end + (effective-find-position-key key)))))) + + (def-find-position-if find-if 0) + (def-find-position-if position-if 1)) + +;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We +;;; didn't bother to worry about optimizing them, except note that on +;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on +;;; sbcl-devel +;;; +;;; My understanding is that while the :test-not argument is +;;; deprecated in favour of :test (complement #'foo) because of +;;; semantic difficulties (what happens if both :test and :test-not +;;; are supplied, etc) the -if-not variants, while officially +;;; deprecated, would be undeprecated were X3J13 actually to produce +;;; a revised standard, as there are perfectly legitimate idiomatic +;;; reasons for allowing the -if-not versions equal status, +;;; particularly remove-if-not (== filter). +;;; +;;; This is only an informal understanding, I grant you, but +;;; perhaps it's worth optimizing the -if-not versions in the same +;;; way as the others? +;;; +;;; That sounds reasonable, so if someone wants to submit patches to +;;; make the -IF-NOT functions compile as efficiently as the +;;; corresponding -IF variants do, go for it. -- WHN 2001-10-06) +;;; +;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT +;;; too) within the implementation of SBCL. +(declaim (inline find-if-not position-if-not)) +(macrolet ((def-find-position-if-not (fun-name values-index) + `(defun ,fun-name (predicate sequence + &key from-end (start 0) end key) + (nth-value + ,values-index + (%find-position-if-not (%coerce-callable-to-fun predicate) + sequence + from-end + start + end + (effective-find-position-key key)))))) + + (def-find-position-if-not find-if-not 0) + (def-find-position-if-not position-if-not 1)) ;;;; COUNT @@ -2148,7 +2047,7 @@ (defun count (item sequence &key from-end (test #'eql) test-not (start 0) end key) #!+sb-doc - "Returns the number of elements in SEQUENCE satisfying a test with ITEM, + "Return the number of elements in SEQUENCE satisfying a test with ITEM, which defaults to EQL." (declare (ignore from-end) (fixnum start)) (let ((end (or end (length sequence)))) @@ -2182,7 +2081,7 @@ (defun count-if (test sequence &key from-end (start 0) end key) #!+sb-doc - "Returns the number of elements in SEQUENCE satisfying TEST(el)." + "Return the number of elements in SEQUENCE satisfying TEST(el)." (declare (ignore from-end) (fixnum start)) (let ((end (or end (length sequence)))) (declare (type index end)) @@ -2213,7 +2112,7 @@ (defun count-if-not (test sequence &key from-end (start 0) end key) #!+sb-doc - "Returns the number of elements in SEQUENCE not satisfying TEST(el)." + "Return the number of elements in SEQUENCE not satisfying TEST(el)." (declare (ignore from-end) (fixnum start)) (let ((end (or end (length sequence)))) (declare (type index end)) @@ -2298,14 +2197,14 @@ (defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not (start1 0) end1 (start2 0) end2 key) #!+sb-doc - "The specified subsequences of Sequence1 and Sequence2 are compared + "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the result is Nil. Otherwise, the result is a non-negative integer, the index - within Sequence1 of the leftmost position at which they fail to match; or, + within SEQUENCE1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within - Sequence1 beyond the last position tested is returned. If a non-Nil - :From-End keyword argument is given, then one plus the index of the - rightmost position in which the sequences differ is returned." + 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)) (let* ((length1 (length sequence1)) (end1 (or end1 length1))