X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fseq.lisp;h=fe0933880766bfb1463b83d69b832cf92c975296;hb=e43ebe3057bd62a58987b22f53c386ca7f5740f8;hp=52c28e8b1c9f9328390853cf43ef113cfb27852f;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 52c28e8..fe09338 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -17,73 +17,104 @@ ;;;; files for more information. (in-package "SB!IMPL") - -(file-comment - "$Header$") ;;;; utilities (eval-when (:compile-toplevel) -;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence. - -;;; FIXME: It might be worth making three cases here, LIST, SIMPLE-VECTOR, -;;; and VECTOR, instead of the current LIST and VECTOR. It tend to make code -;;; run faster but be bigger; some benchmarking is needed to decide. +;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE. +;;; +;;; FIXME: It might be worth making three cases here, LIST, +;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR. +;;; It tends to make code run faster but be bigger; some benchmarking +;;; is needed to decide. (sb!xc:defmacro seq-dispatch (sequence list-form array-form) `(if (listp ,sequence) ,list-form ,array-form)) -;;; FIXME: Implementations of MAPFOO which use this are O(N*N) when users -;;; could reasonably expect them to be O(N). This should be fixed. -(sb!xc:defmacro elt-slice (sequences n) - #!+sb-doc - "Returns a list of the Nth element of each of the sequences. Used by MAP - and friends." - `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences)) - (sb!xc:defmacro make-sequence-like (sequence length) #!+sb-doc - "Returns 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." - `(if (atom ,type) ,type (car ,type))) - + "Return a sequence of the same type as SEQUENCE and the given LENGTH." + `(if (typep ,sequence 'list) + (make-list ,length) + (progn + ;; This is only called from places which have already deduced + ;; that the SEQUENCE argument is actually a sequence. So + ;; this would be a candidate place for (AVER (TYPEP ,SEQUENCE + ;; 'VECTOR)), except that this seems to be a performance + ;; hotspot. + (make-array ,length + :element-type (array-element-type ,sequence))))) + +(sb!xc:defmacro bad-sequence-type-error (type-spec) + `(error 'simple-type-error + :datum ,type-spec + ;; FIXME: This is actually wrong, and should be something + ;; like (SATISFIES IS-A-VALID-SEQUENCE-TYPE-SPECIFIER-P). + :expected-type 'sequence + :format-control "~S is a bad type specifier for sequences." + :format-arguments (list ,type-spec))) + +(sb!xc:defmacro sequence-type-length-mismatch-error (type length) + `(error 'simple-type-error + :datum ,length + :expected-type (cond ((array-type-p ,type) + `(eql ,(car (array-type-dimensions ,type)))) + ((type= ,type (specifier-type 'null)) + '(eql 0)) + ((cons-type-p ,type) + '(integer 1)) + (t (bug "weird type in S-T-L-M-ERROR"))) + ;; FIXME: this format control causes ugly printing. There's + ;; probably some ~<~@:_~> incantation that would make it + ;; nicer. -- CSR, 2002-10-18 + :format-control "The length requested (~S) does not match the type restriction in ~S." + :format-arguments (list ,length (type-specifier ,type)))) + +(sb!xc:defmacro sequence-type-too-hairy (type-spec) + ;; FIXME: Should this be a BUG? I'm inclined to think not; there are + ;; words that give some but not total support to this position in + ;; ANSI. Essentially, we are justified in throwing this on + ;; e.g. '(OR SIMPLE-VECTOR (VECTOR FIXNUM)), but maybe not (by ANSI) + ;; on '(CONS * (CONS * NULL)) -- CSR, 2002-10-18 + `(error 'simple-type-error + :datum ,type-spec + ;; FIXME: as in BAD-SEQUENCE-TYPE-ERROR, this is wrong. + :expected-type 'sequence + :format-control "~S is too hairy for sequence functions." + :format-arguments (list ,type-spec))) ) ; EVAL-WHEN -;;; Given an arbitrary type specifier, return a sane sequence type -;;; specifier that we can directly match. -(defun result-type-or-lose (type &optional nil-ok) - (let ((type (specifier-type type))) - (cond - ((eq type *empty-type*) - (if nil-ok - nil - (error 'simple-type-error - :datum type - :expected-type '(or vector cons) - :format-control - "NIL output type invalid for this sequence function." - :format-arguments ()))) - ((dolist (seq-type '(list string simple-vector bit-vector)) - (when (csubtypep type (specifier-type seq-type)) - (return seq-type)))) - ((csubtypep type (specifier-type 'vector)) - (type-specifier type)) - (t - (error 'simple-type-error - :datum type - :expected-type 'sequence - :format-control - "~S is a bad type specifier for sequence functions." - :format-arguments (list type)))))) +;;; It's possible with some sequence operations to declare the length +;;; of a result vector, and to be safe, we really ought to verify that +;;; the actual result has the declared length. +(defun vector-of-checked-length-given-length (vector declared-length) + (declare (type vector vector)) + (declare (type index declared-length)) + (let ((actual-length (length vector))) + (unless (= actual-length declared-length) + (error 'simple-type-error + :datum vector + :expected-type `(vector ,declared-length) + :format-control + "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)) + sequence + (let ((declared-length (first (array-type-dimensions ctype)))) + (if (eq declared-length '*) + sequence + (vector-of-checked-length-given-length sequence + declared-length)))))) (defun signal-index-too-large-error (sequence index) (let* ((length (length sequence)) - (max-index (and (plusp length)(1- length)))) + (max-index (and (plusp length) + (1- length)))) (error 'index-too-large-error :datum index :expected-type (if max-index @@ -91,24 +122,27 @@ ;; 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." - (declare (fixnum length)) - (case (type-specifier-atom type) - (list (make-list length)) - ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) - ((string simple-string base-string simple-base-string) - (make-string length)) - (simple-vector (make-array length)) - ((array simple-array vector) - (if (listp type) - (make-array length :element-type (cadr type)) - (make-array length))) - (t - (make-sequence-of-type (result-type-or-lose type) length)))) +(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-end + `(integer 0 ,max-end) + ;; This seems silly, is there something better? + '(integer (0) 0))))) + +(declaim (inline adjust-count) + (ftype (function (sequence-count) index) adjust-count)) +(defun adjust-count (count) + (cond ((not count) most-positive-fixnum) + ((< count 0) 0) + (t count))) + (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)) @@ -140,72 +174,86 @@ (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)) - (make-list length :initial-element initial-element)) - ((csubtypep type (specifier-type 'string)) - (if iep - (make-string length :initial-element initial-element) - (make-string length))) - ((csubtypep type (specifier-type 'simple-vector)) - (make-array length :initial-element initial-element)) - ((csubtypep type (specifier-type 'bit-vector)) - (if iep - (make-array length :element-type '(mod 2) - :initial-element initial-element) - (make-array length :element-type '(mod 2)))) + (cond + ((type= type (specifier-type 'list)) + (make-list length :initial-element initial-element)) + ((eq type *empty-type*) + (bad-sequence-type-error nil)) + ((type= type (specifier-type 'null)) + (if (= length 0) + 'nil + (sequence-type-length-mismatch-error type length))) + ((csubtypep (specifier-type '(cons nil t)) type) + ;; The above is quite a neat way of finding out if + ;; there's a type restriction on the CDR of the + ;; CONS... if there is, I think it's probably fair to + ;; give up; if there isn't, then the list to be made + ;; must have a length of more than 0. + (if (> length 0) + (make-list length :initial-element initial-element) + (sequence-type-length-mismatch-error type length))) + ;; We'll get here for e.g. (OR NULL (CONS INTEGER *)), + ;; which may seem strange and non-ideal, but then I'd say + ;; it was stranger to feed that type in to MAKE-SEQUENCE. + (t (sequence-type-too-hairy (type-specifier type))))) ((csubtypep type (specifier-type 'vector)) (if (typep type 'array-type) - (let ((etype (type-specifier - (array-type-specialized-element-type type))) - (vlen (car (array-type-dimensions type)))) - (if (and (numberp vlen) (/= vlen length)) - (error 'simple-type-error - ;; 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." - :format-arguments - (list (type-specifier type) length))) - (if iep - (make-array length :element-type etype - :initial-element initial-element) - (make-array length :element-type etype))) - (make-array length :initial-element initial-element))) - (t (error 'simple-type-error - :datum type - :expected-type 'sequence - :format-control "~S is a bad type specifier for sequences." - :format-arguments (list type)))))) + ;; KLUDGE: the above test essentially asks "Do we know + ;; what the upgraded-array-element-type is?" [consider + ;; (OR STRING BIT-VECTOR)] + (progn + (aver (= (length (array-type-dimensions type)) 1)) + (let ((etype (type-specifier + (array-type-specialized-element-type type))) + (type-length (car (array-type-dimensions type)))) + (unless (or (eq type-length '*) + (= type-length length)) + (sequence-type-length-mismatch-error type length)) + ;; FIXME: These calls to MAKE-ARRAY can't be + ;; open-coded, as the :ELEMENT-TYPE argument isn't + ;; constant. Probably we ought to write a + ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR, + ;; 2002-07-22 + (if iep + (make-array length :element-type etype + :initial-element initial-element) + (make-array length :element-type etype)))) + (sequence-type-too-hairy (type-specifier type)))) + (t (bad-sequence-type-error (type-specifier type)))))) ;;;; 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-end-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)) @@ -224,13 +272,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) @@ -240,11 +288,11 @@ (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-copy-seq (sequence type) +(sb!xc:defmacro vector-copy-seq (sequence) `(let ((length (length (the vector ,sequence)))) (declare (fixnum length)) (do ((index 0 (1+ index)) - (copy (make-sequence-of-type ,type length))) + (copy (make-sequence-like ,sequence length))) ((= index length) copy) (declare (fixnum index)) (setf (aref copy index) (aref ,sequence index))))) @@ -262,7 +310,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))) @@ -273,7 +321,8 @@ (list-copy-seq sequence)) (defun vector-copy-seq* (sequence) - (vector-copy-seq sequence (type-of sequence))) + (declare (type vector sequence)) + (vector-copy-seq sequence)) ;;;; FILL @@ -426,9 +475,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)) @@ -451,12 +500,12 @@ (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-reverse (sequence type) +(sb!xc:defmacro vector-reverse (sequence) `(let ((length (length ,sequence))) (declare (fixnum length)) (do ((forward-index 0 (1+ forward-index)) (backward-index (1- length) (1- backward-index)) - (new-sequence (make-sequence-of-type ,type length))) + (new-sequence (make-sequence-like sequence length))) ((= forward-index length) new-sequence) (declare (fixnum forward-index backward-index)) (setf (aref new-sequence forward-index) @@ -471,7 +520,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))) @@ -482,7 +531,7 @@ (list-reverse-macro sequence)) (defun vector-reverse* (sequence) - (vector-reverse sequence (type-of sequence))) + (vector-reverse sequence)) ;;;; NREVERSE @@ -516,7 +565,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) @@ -555,7 +604,7 @@ (do ((sequences ,sequences (cdr sequences)) (lengths lengths (cdr lengths)) (index 0) - (result (make-sequence-of-type ,output-type-spec total-length))) + (result (make-sequence ,output-type-spec total-length))) ((= index total-length) result) (declare (fixnum index)) (let ((sequence (car sequences))) @@ -578,25 +627,42 @@ ) ; EVAL-WHEN -;;; FIXME: Make a compiler macro or transform for this which efficiently -;;; handles the case of constant 'STRING first argument. (It's not just time -;;; 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) - ((simple-vector simple-string vector string array simple-array - 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) - result)) - (list (apply #'concat-to-list* sequences)) + (let ((type (specifier-type output-type-spec))) + (cond + ((csubtypep type (specifier-type 'list)) + (cond + ((type= type (specifier-type 'list)) + (apply #'concat-to-list* sequences)) + ((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. And + ;; rightward-drift. + (reduce #'+ + (mapcar #'length + sequences))))) + ((csubtypep (specifier-type '(cons nil t)) type) + (if (notevery (lambda (x) (or (null x) + (and (vectorp x) (= (length x) 0)))) + sequences) + (apply #'concat-to-list* sequences) + (sequence-type-length-mismatch-error type 0))) + (t (sequence-type-too-hairy (type-specifier type))))) + ((csubtypep type (specifier-type 'vector)) + (apply #'concat-to-simple* output-type-spec sequences)) (t - (apply #'concatenate (result-type-or-lose output-type-spec) sequences)))) + (bad-sequence-type-error output-type-spec))))) ;;; internal frobs ;;; FIXME: These are weird. They're never called anywhere except in @@ -609,9 +675,9 @@ (defun concat-to-simple* (type &rest sequences) (concatenate-to-mumble type sequences)) -;;;; MAP +;;;; MAP and MAP-INTO -;;; helper functions to handle the common consing subcases of MAP +;;; helper functions to handle arity-1 subcases of MAP (declaim (ftype (function (function sequence) list) %map-list-arity-1)) (declaim (ftype (function (function sequence) simple-vector) %map-simple-vector-arity-1)) @@ -622,167 +688,168 @@ (simple-vector (dovector (,i sequence) ,@body)) (vector (dovector (,i sequence) ,@body)))))) (defun %map-to-list-arity-1 (fun sequence) - (declare (type function fun)) - (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun))) - (reversed-result nil)) + (let ((reversed-result nil) + (really-fun (%coerce-callable-to-fun fun))) (dosequence (element sequence) (push (funcall really-fun element) reversed-result)) (nreverse reversed-result))) (defun %map-to-simple-vector-arity-1 (fun sequence) - (declare (type function fun)) - (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun))) - (result (make-array (length sequence))) - (index 0)) + (let ((result (make-array (length sequence))) + (index 0) + (really-fun (%coerce-callable-to-fun fun))) (declare (type index index)) (dosequence (element sequence) (setf (aref result index) (funcall really-fun element)) (incf index)) - result))) - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro map-to-list (function sequences) - `(do ((seqs more-sequences (cdr seqs)) - (min-length (length first-sequence))) - ((null seqs) - (let ((result (list nil))) - (do ((index 0 (1+ index)) - (splice result)) - ((= index min-length) (cdr result)) - (declare (fixnum index)) - (setq splice - (cdr (rplacd splice - (list (apply ,function (elt-slice ,sequences - index))))))))) - (declare (fixnum min-length)) - (let ((length (length (car seqs)))) - (declare (fixnum length)) - (if (< length min-length) - (setq min-length length))))) - -(sb!xc:defmacro map-to-simple (output-type-spec function sequences) - `(do ((seqs more-sequences (cdr seqs)) - (min-length (length first-sequence))) - ((null seqs) - (do ((index 0 (1+ index)) - (result (make-sequence-of-type ,output-type-spec min-length))) - ((= index min-length) result) - (declare (fixnum index)) - (setf (aref result index) - (apply ,function (elt-slice ,sequences index))))) - (declare (fixnum min-length)) - (let ((length (length (car seqs)))) - (declare (fixnum length)) - (if (< length min-length) - (setq min-length length))))) - -(sb!xc:defmacro map-for-effect (function sequences) - `(do ((seqs more-sequences (cdr seqs)) - (min-length (length first-sequence))) - ((null seqs) - (do ((index 0 (1+ index))) - ((= index min-length) nil) - (apply ,function (elt-slice ,sequences index)))) - (declare (fixnum min-length)) - (let ((length (length (car seqs)))) - (declare (fixnum length)) - (if (< length min-length) - (setq min-length length))))) - -) ; EVAL-WHEN - -#!+high-security-support -(defun get-minimum-length-sequences (sequences) - #!+sb-doc "Gets the minimum length of the sequences. This is -needed to check whether the supplied type is appropriate." - (let ((min nil)) - (dolist (i sequences) - (when (or (listp i) (vectorp i)) - (let ((l (length i))) - (when (or (null min) - (> min l))) - (setf min l)))) - min)) - -(defun map (output-type-spec function first-sequence &rest more-sequences) - #!+sb-doc - "FUNCTION must take as many arguments as there are sequences provided. The - result is a sequence such that element i is the result of applying FUNCTION - to element i of each of the argument sequences." - (let ((really-function (if (functionp function) - function - (%coerce-name-to-function function)))) - ;; Pick off the easy non-consing arity-1 special case and handle - ;; it without consing, since the user probably didn't expect us to - ;; cons here. (Notably, the super duper users who wrote PCL in - ;; terms of quantifiers without declaring the types of their - ;; sequence arguments didn't expect to end up consing when SBCL - ;; transforms the quantifiers into calls to MAP NIL.) - (when (and (null more-sequences) - (null output-type-spec)) - (macrolet ((frob () '(return-from map - (map nil really-function first-sequence)))) - (etypecase first-sequence - (simple-vector (frob)) - (list (frob)) - (vector (frob))))) - ;; Otherwise, if the user didn't give us enough information to - ;; simplify at compile time, we cons and cons and cons.. - (let ((sequences (cons first-sequence more-sequences))) - (case (type-specifier-atom output-type-spec) - ((nil) (map-for-effect really-function sequences)) - (list (map-to-list really-function sequences)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string simple-base-string) - #!+high-security - (let ((min-length-sequences (get-minimum-length-sequences - sequences)) - (dimensions (array-type-dimensions (specifier-type - output-type-spec)))) - (when (or (/= (length dimensions) 1) - (and (not (eq (car dimensions) '*)) - (/= (car dimensions) min-length-sequences))) - (error 'simple-type-error - :datum output-type-spec - :expected-type - (ecase (type-specifier-atom output-type-spec) - ((simple-vector bit-vector simple-bit-vector string simple-string base-string) - `(,(type-specifier-atom output-type-spec) ,min-length-sequences)) - ((array vector simple-array) `(,(type-specifier-atom output-type-spec) * ,min-length-sequences))) - :format-control "Minimum length of sequences is ~S, this is not compatible with the type ~S." - :format-arguments - (list min-length-sequences output-type-spec)))) - (let ((result (map-to-simple output-type-spec - really-function - sequences))) - #!+high-security - (check-type-var result output-type-spec) - result)) - (t - (apply #'map (result-type-or-lose output-type-spec t) - really-function sequences)))))) - -#!+high-security-support -(defun map-without-errorchecking - (output-type-spec function first-sequence &rest more-sequences) - #!+sb-doc - "FUNCTION must take as many arguments as there are sequences provided. The - result is a sequence such that element i is the result of applying FUNCTION - to element I of each of the argument sequences. This version has no - error-checking, to pass cold-load." - (let ((sequences (cons first-sequence more-sequences))) - (case (type-specifier-atom output-type-spec) - ((nil) (map-for-effect function sequences)) - (list (map-to-list function sequences)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string simple-base-string) - (map-to-simple output-type-spec function sequences)) - (t - (apply #'map (result-type-or-lose output-type-spec t) - function sequences))))) - + result)) + (defun %map-for-effect-arity-1 (fun sequence) + (let ((really-fun (%coerce-callable-to-fun fun))) + (dosequence (element sequence) + (funcall really-fun element))) + nil)) + +;;; helper functions to handle arity-N subcases of MAP +;;; +;;; KLUDGE: This is hairier, and larger, than need be, because we +;;; don't have DYNAMIC-EXTENT. With DYNAMIC-EXTENT, we could define +;;; %MAP-FOR-EFFECT, and then implement the +;;; other %MAP-TO-FOO functions reasonably efficiently by passing closures to +;;; %MAP-FOR-EFFECT. (DYNAMIC-EXTENT would help a little by avoiding +;;; consing each closure, and would help a lot by allowing us to define +;;; a closure (LAMBDA (&REST REST) ) +;;; with the REST list allocated with DYNAMIC-EXTENT. -- WHN 20000920 +(macrolet (;; Execute BODY in a context where the machinery for + ;; UPDATED-MAP-APPLY-ARGS has been set up. + (with-map-state (sequences &body body) + `(let* ((%sequences ,sequences) + (%iters (mapcar (lambda (sequence) + (etypecase sequence + (list sequence) + (vector 0))) + %sequences)) + (%apply-args (make-list (length %sequences)))) + (declare (type list %sequences %iters %apply-args)) + ,@body)) + ;; Return a list of args to pass to APPLY for the next + ;; function call in the mapping, or NIL if no more function + ;; calls should be made (because we've reached the end of a + ;; sequence arg). + (updated-map-apply-args () + '(do ((in-sequences %sequences (cdr in-sequences)) + (in-iters %iters (cdr in-iters)) + (in-apply-args %apply-args (cdr in-apply-args))) + ((null in-sequences) + %apply-args) + (declare (type list in-sequences in-iters in-apply-args)) + (let ((i (car in-iters))) + (declare (type (or list index) i)) + (if (listp i) + (if (null i) ; if end of this sequence + (return nil) + (setf (car in-apply-args) (car i) + (car in-iters) (cdr i))) + (let ((v (the vector (car in-sequences)))) + (if (>= i (length v)) ; if end of this sequence + (return nil) + (setf (car in-apply-args) (aref v i) + (car in-iters) (1+ i))))))))) + (defun %map-to-list (func sequences) + (declare (type function func)) + (declare (type list sequences)) + (with-map-state sequences + (loop with updated-map-apply-args + while (setf updated-map-apply-args (updated-map-apply-args)) + collect (apply func updated-map-apply-args)))) + (defun %map-to-vector (output-type-spec func sequences) + (declare (type function func)) + (declare (type list sequences)) + (let ((min-len (with-map-state sequences + (do ((counter 0 (1+ counter))) + ;; Note: Doing everything in + ;; UPDATED-MAP-APPLY-ARGS here is somewhat + ;; wasteful; we even do some extra consing. + ;; And stepping over every element of + ;; VECTORs, instead of just grabbing their + ;; LENGTH, is also wasteful. But it's easy + ;; and safe. (If you do rewrite it, please + ;; try to make sure that + ;; (MAP NIL #'F SOME-CIRCULAR-LIST #(1)) + ;; does the right thing.) + ((not (updated-map-apply-args)) + counter) + (declare (type index counter)))))) + (declare (type index min-len)) + (with-map-state sequences + (let ((result (make-sequence output-type-spec min-len)) + (index 0)) + (declare (type index index)) + (loop with updated-map-apply-args + while (setf updated-map-apply-args (updated-map-apply-args)) + do + (setf (aref result index) + (apply func updated-map-apply-args)) + (incf index)) + result)))) + (defun %map-for-effect (func sequences) + (declare (type function func)) + (declare (type list sequences)) + (with-map-state sequences + (loop with updated-map-apply-args + while (setf updated-map-apply-args (updated-map-apply-args)) + do + (apply func updated-map-apply-args)) + nil))) + + "FUNCTION must take as many arguments as there are sequences provided. + The result is a sequence of type OUTPUT-TYPE-SPEC such that element I + is the result of applying FUNCTION to element I of each of the argument + sequences." + +;;; %MAP is just MAP without the final just-to-be-sure check that +;;; length of the output sequence matches any length specified +;;; in RESULT-TYPE. +(defun %map (result-type function first-sequence &rest more-sequences) + (let ((really-fun (%coerce-callable-to-fun function)) + (type (specifier-type result-type))) + ;; 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 + ;; quantifiers like SOME are transformed into this case, and since + ;; there's no consing overhead to dwarf our inefficiency.) + (if (and (null more-sequences) + (null result-type)) + (%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))) + (cond + ((eq type *empty-type*) (%map-for-effect really-fun sequences)) + ((csubtypep type (specifier-type 'list)) + (%map-to-list really-fun sequences)) + ((csubtypep type (specifier-type 'vector)) + (%map-to-vector result-type really-fun sequences)) + (t + (bad-sequence-type-error result-type))))))) + +(defun map (result-type function first-sequence &rest more-sequences) + (apply #'%map + result-type + function + 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 (defun map-into (result-sequence function &rest sequences) (let* ((fp-result (and (arrayp result-sequence) @@ -796,11 +863,12 @@ needed to check whether the supplied type is appropriate." (when fp-result (setf (fill-pointer result-sequence) len)) - (dotimes (index len) - (setf (elt result-sequence index) - (apply function - (mapcar #'(lambda (seq) (elt seq index)) - sequences))))) + (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)))))) result-sequence) ;;;; quantifiers @@ -848,11 +916,18 @@ needed to check whether the supplied type is appropriate." ;; 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 (mapcar (lambda (x) - (declare (ignore x)) - (gensym "ARG")) - (cons first-seq more-seqs))) + (let ((elements (make-gensym-list (1+ (length more-seqs)))) (blockname (gensym "BLOCK"))) (once-only ((pred pred)) `(block ,blockname @@ -866,22 +941,22 @@ needed to check whether the supplied type is appropriate." ,@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.")) @@ -1094,12 +1169,12 @@ needed to check whether the supplied type is appropriate." (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)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1132,12 +1207,12 @@ needed to check whether the supplied type is appropriate." (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)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1170,12 +1245,12 @@ needed to check whether the supplied type is appropriate." (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)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1254,17 +1329,19 @@ needed to check whether the supplied type is appropriate." `(let* ((sequence ,(if reverse? '(reverse (the list sequence)) 'sequence)) + (%start ,(if reverse? '(- length end) 'start)) + (%end ,(if reverse? '(- length start) 'end)) (splice (list nil)) (results (do ((index 0 (1+ index)) (before-start splice)) - ((= index (the fixnum start)) before-start) + ((= index (the fixnum %start)) before-start) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (pop sequence)))))))) - (do ((index start (1+ index)) + (do ((index %start (1+ index)) (this-element) (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + ((or (= index (the fixnum %end)) (= number-zapped (the fixnum count))) (do ((index index (1+ index))) ((null sequence) ,(if reverse? @@ -1317,12 +1394,12 @@ needed to check whether the supplied type is appropriate." (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)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1335,12 +1412,12 @@ needed to check whether the supplied type is appropriate." (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)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1353,12 +1430,12 @@ needed to check whether the supplied type is appropriate." (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)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1460,7 +1537,7 @@ needed to check whether the supplied type is appropriate." which case the one later in the sequence is discarded. The resulting sequence is returned. - The :TEST-NOT argument is depreciated." + The :TEST-NOT argument is deprecated." (declare (fixnum start)) (seq-dispatch sequence (if sequence @@ -1533,7 +1610,7 @@ needed to check whether the supplied type is appropriate." discarded. The resulting sequence, which may be formed by destroying the given sequence, is returned. - The :TEST-NOT argument is depreciated." + The :TEST-NOT argument is deprecated." (seq-dispatch sequence (if sequence (list-delete-duplicates* sequence test test-not key from-end start end)) @@ -1640,13 +1717,13 @@ needed to check whether the supplied type is appropriate." (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)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (subst-dispatch 'normal))) @@ -1655,13 +1732,13 @@ needed to check whether the supplied type is appropriate." (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)) (end (or end length)) - (count (or count most-positive-fixnum)) + (count (adjust-count count)) test-not old) (declare (type index length end) @@ -1671,13 +1748,13 @@ needed to check whether the supplied type is appropriate." (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)) (end (or end length)) - (count (or count most-positive-fixnum)) + (count (adjust-count count)) test-not old) (declare (type index length end) @@ -1689,18 +1766,20 @@ needed to check whether the supplied type is appropriate." (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))) + (count (adjust-count count))) (declare (fixnum count)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute* - new old (nreverse (the list sequence)) - test test-not start end count key)) + (let ((length (length sequence))) + (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)) (if from-end @@ -1739,18 +1818,19 @@ needed to check whether the supplied type is appropriate." (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))) + (count (adjust-count count))) (declare (fixnum end count)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute-if* - new test (nreverse (the list sequence)) - start end count key)) + (let ((length (length sequence))) + (nreverse (nlist-substitute-if* + new test (nreverse (the list sequence)) + (- length end) (- length start) count key))) (nlist-substitute-if* new test sequence start end count key)) (if from-end @@ -1779,18 +1859,19 @@ needed to check whether the supplied type is appropriate." (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))) + (count (adjust-count count))) (declare (fixnum end count)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute-if-not* - new test (nreverse (the list sequence)) - start end count key)) + (let ((length (length sequence))) + (nreverse (nlist-substitute-if-not* + new test (nreverse (the list sequence)) + (- length end) (- length start) count key))) (nlist-substitute-if-not* new test sequence start end count key)) (if from-end @@ -1816,276 +1897,151 @@ needed to check whether the supplied type is appropriate." (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? +;;; +;;; FIXME: Maybe remove uses of these deprecated functions (and +;;; definitely of :TEST-NOT) 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 @@ -2120,7 +2076,7 @@ needed to check whether the supplied type is appropriate." (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)))) @@ -2154,7 +2110,7 @@ needed to check whether the supplied type is appropriate." (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)) @@ -2185,7 +2141,7 @@ needed to check whether the supplied type is appropriate." (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)) @@ -2270,14 +2226,14 @@ needed to check whether the supplied type is appropriate." (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))