X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=977e8a20340316e78e46689ab0c4a36d744d3f5c;hb=0f726536ee7ec85f3a9483a26d08bd7d1cd96750;hp=e4fdf4a78dde84aa9b8876b52e8612a1431a3c3e;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index e4fdf4a..977e8a2 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) @@ -106,8 +106,18 @@ ;; This seems silly, is there something better? '(integer (0) (0)))))) +(defun signal-end-too-large-error (sequence end) + (let* ((length (length sequence)) + (max-end (and (not (minusp length) length)))) + (error 'end-too-large-error + :datum end + :expected-type (if max-index + `(integer 0 ,max-end) + ;; This seems silly, is there something better? + '(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 +133,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)) @@ -207,21 +217,25 @@ ;;;; SUBSEQ ;;;; -;;;; 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. +;;;; 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 vector-subseq* (sequence start &optional end) (declare (type vector sequence)) (declare (type fixnum start)) (declare (type (or null fixnum) end)) - (when (null end) (setf end (length sequence))) + (if (null end) + (setf end (length sequence)) + (unless (<= end (length sequence)) + (signal-index-too-large-error sequence 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)))) + (setf (aref copy new-index) + (aref sequence old-index)))) (defun list-subseq* (sequence start &optional end) (declare (type list sequence)) @@ -240,13 +254,13 @@ (declare (fixnum index))) ())))) -;;; SUBSEQ 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). +;;; SUBSEQ 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 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) @@ -278,7 +292,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))) @@ -289,7 +303,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 @@ -487,7 +511,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))) @@ -532,7 +556,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) @@ -599,7 +623,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) @@ -638,7 +662,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 +670,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 +678,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 +784,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 +792,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 +850,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 +903,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"))) @@ -1122,8 +1156,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 +1194,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 +1232,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 +1379,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 +1397,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 +1415,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 +1702,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 +1717,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 +1733,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 +1751,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 +1801,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 +1841,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))) @@ -1852,16 +1886,16 @@ (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-function test)) + (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-function test-not))) + (complement (%coerce-callable-to-fun test-not))) (t #'eql))) (defun effective-find-position-key (key) (if key - (%coerce-callable-to-function key) + (%coerce-callable-to-fun key) #'identity)) ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF @@ -1900,6 +1934,14 @@ (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 @@ -1936,7 +1978,7 @@ &key from-end (start 0) end key) (nth-value ,values-index - (%find-position-if (%coerce-callable-to-function predicate) + (%find-position-if (%coerce-callable-to-fun predicate) sequence from-end start @@ -1946,23 +1988,43 @@ (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 don't -;;; bother to worry about optimizing them. +;;; 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 (complement (%coerce-callable-to-function - predicate)) - sequence - from-end - start - end - (effective-find-position-key key)))))) + (%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)) @@ -1999,7 +2061,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)))) @@ -2033,7 +2095,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)) @@ -2064,7 +2126,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))