;;;; files for more information.
(in-package "SB!IMPL")
-
-(file-comment
- "$Header$")
\f
;;;; 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.
+(defvar *sequence-keyword-info*
+ ;; (name default supplied-p adjustment new-type)
+ '((count nil
+ nil
+ (etypecase count
+ (null (1- most-positive-fixnum))
+ (fixnum (max 0 count))
+ (integer (if (minusp count)
+ 0
+ (1- most-positive-fixnum))))
+ (mod #.most-positive-fixnum))))
+
+(sb!xc:defmacro define-sequence-traverser (name args &body body)
+ (multiple-value-bind (body declarations docstring)
+ (parse-body body t)
+ (collect ((new-args) (new-declarations) (adjustments))
+ (dolist (arg args)
+ (let ((info (cdr (assoc arg *sequence-keyword-info*))))
+ (cond (info
+ (destructuring-bind (default supplied-p adjuster type) info
+ (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
+ (adjustments `(,arg ,adjuster))
+ (new-declarations `(type ,type ,arg))))
+ (t (new-args arg)))))
+ `(defun ,name ,(new-args)
+ ,docstring
+ ,@declarations
+ (let (,@(adjustments))
+ (declare ,@(new-declarations))
+ ,@body)))))
+
+;;; 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
`(integer 0 ,max-index)
;; This seems silly, is there something better?
- '(integer (0) (0))))))
+ '(integer 0 (0))))))
+
+(defun signal-end-too-large-error (sequence end)
+ (let* ((length (length sequence))
+ (max-end length))
+ (error 'end-too-large-error
+ :datum end
+ :expected-type `(integer 0 ,max-end))))
-(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))))
\f
(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))
(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))))))
\f
;;;; 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))
(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)
(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)))))
) ; 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)))
(list-copy-seq sequence))
(defun vector-copy-seq* (sequence)
- (vector-copy-seq sequence (type-of sequence)))
+ (declare (type vector sequence))
+ (vector-copy-seq sequence))
\f
;;;; FILL
(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))
(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)
(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)))
(list-reverse-macro sequence))
(defun vector-reverse* (sequence)
- (vector-reverse sequence (type-of sequence)))
+ (vector-reverse sequence))
\f
;;;; NREVERSE
(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)
(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)))
) ; EVAL-WHEN
\f
-;;; 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
(defun concat-to-simple* (type &rest sequences)
(concatenate-to-mumble type sequences))
\f
-;;;; 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))
(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) <do something with (APPLY FUN 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)
(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)
\f
;;;; quantifiers
;; 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
,@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."))
\f
`(do ((index start (1+ index))
(jndex start)
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum end)) (= number-zapped count))
(do ((index index (1+ index)) ; Copy the rest of the vector.
(jndex jndex (1+ jndex)))
((= index (the fixnum length))
(declare (fixnum index jndex number-zapped))
(setf (aref sequence jndex) (aref sequence index))
(if ,pred
- (setq number-zapped (1+ number-zapped))
- (setq jndex (1+ jndex)))))
+ (incf number-zapped)
+ (incf jndex))))
(sb!xc:defmacro mumble-delete-from-end (pred)
`(do ((index (1- (the fixnum end)) (1- index)) ; Find the losers.
(losers ())
this-element
(terminus (1- start)))
- ((or (= index terminus) (= number-zapped (the fixnum count)))
+ ((or (= index terminus) (= number-zapped count))
(do ((losers losers) ; Delete the losers.
(index start (1+ index))
(jndex start))
(setf (aref sequence jndex) (aref sequence index))
(if (= index (the fixnum (car losers)))
(pop losers)
- (setq jndex (1+ jndex)))))
+ (incf jndex))))
(declare (fixnum index number-zapped terminus))
(setq this-element (aref sequence index))
(when ,pred
- (setq number-zapped (1+ number-zapped))
+ (incf number-zapped)
(push index losers))))
(sb!xc:defmacro normal-mumble-delete ()
(previous (nthcdr start handle))
(index start (1+ index))
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum end)) (= number-zapped count))
(cdr handle))
(declare (fixnum index number-zapped))
(cond (,pred
(rplacd previous (cdr current))
- (setq number-zapped (1+ number-zapped)))
+ (incf number-zapped))
(t
(setq previous (cdr previous)))))))
(previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
(index start (1+ index))
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum end)) (= number-zapped count))
(nreverse (cdr handle)))
(declare (fixnum index number-zapped))
(cond (,pred
(rplacd previous (cdr current))
- (setq number-zapped (1+ number-zapped)))
+ (incf number-zapped))
(t
(setq previous (cdr previous)))))))
) ; EVAL-WHEN
-(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
- end count key)
+(define-sequence-traverser 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)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(normal-list-delete-from-end)
) ; EVAL-WHEN
-(defun delete-if (predicate sequence &key from-end (start 0) key end count)
+(define-sequence-traverser 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)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-list-delete-from-end)
) ; EVAL-WHEN
-(defun delete-if-not (predicate sequence &key from-end (start 0) end key count)
+(define-sequence-traverser 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)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-not-list-delete-from-end)
(number-zapped 0)
(this-element))
((or (= index (the fixnum ,finish))
- (= number-zapped (the fixnum count)))
+ (= number-zapped count))
(do ((index index (,bump index))
(new-index new-index (,bump new-index)))
((= index (the fixnum ,right)) (shrink-vector result new-index))
(setf (aref result new-index) (aref sequence index))))
(declare (fixnum index new-index number-zapped))
(setq this-element (aref sequence index))
- (cond (,pred (setq number-zapped (1+ number-zapped)))
+ (cond (,pred (incf number-zapped))
(t (setf (aref result new-index) this-element)
(setq new-index (,bump new-index))))))
`(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 count))
(do ((index index (1+ index)))
((null sequence)
,(if reverse?
) ; EVAL-WHEN
-(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
- end count key)
+(define-sequence-traverser 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)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(normal-list-remove-from-end)
(normal-mumble-remove-from-end)
(normal-mumble-remove)))))
-(defun remove-if (predicate sequence &key from-end (start 0) end count key)
+(define-sequence-traverser 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)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-list-remove-from-end)
(if-mumble-remove-from-end)
(if-mumble-remove)))))
-(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
+(define-sequence-traverser 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)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-not-list-remove-from-end)
(setq jndex (1+ jndex)))
(shrink-vector result jndex)))
-(defun remove-duplicates (sequence &key
- (test #'eql)
- test-not
- (start 0)
- from-end
- end
- key)
+(defun remove-duplicates
+ (sequence &key (test #'eql) test-not (start 0) from-end end key)
#!+sb-doc
"The elements of Sequence are compared pairwise, and if any two match,
the one occurring earlier is discarded, unless FROM-END is true, in
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
:end (if from-end jndex end) :test-not test-not)
(setq jndex (1+ jndex)))))
-(defun delete-duplicates (sequence &key
- (test #'eql)
- test-not
- (start 0)
- from-end
- end
- key)
+(defun delete-duplicates
+ (sequence &key (test #'eql) test-not (start 0) from-end end key)
#!+sb-doc
- "The elements of Sequence are examined, and if any two match, one is
+ "The elements of SEQUENCE are examined, and if any two match, one is
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))
- (vector-delete-duplicates* sequence test test-not key from-end start end)))
+ (vector-delete-duplicates* sequence test test-not key from-end start end)))
\f
;;;; SUBSTITUTE
(funcall test old (apply-key key elt))))
(if (funcall test (apply-key key elt)))
(if-not (not (funcall test (apply-key key elt)))))
- (setq count (1- count))
+ (decf count)
new)
(t elt))))))
(setq list (cdr list)))
) ; EVAL-WHEN
-(defun substitute (new old sequence &key from-end (test #'eql) test-not
- (start 0) count end key)
+(define-sequence-traverser 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)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(subst-dispatch 'normal)))
\f
;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
-(defun substitute-if (new test sequence &key from-end (start 0) end count key)
+(define-sequence-traverser 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))
test-not
old)
- (declare (type index length end)
- (fixnum count))
+ (declare (type index length end))
(subst-dispatch 'if)))
-(defun substitute-if-not (new test sequence &key from-end (start 0)
- end count key)
+(define-sequence-traverser 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))
test-not
old)
- (declare (type index length end)
- (fixnum count))
+ (declare (type index length end))
(subst-dispatch 'if-not)))
\f
;;;; NSUBSTITUTE
-(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not
- end count key (start 0))
+(define-sequence-traverser 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)))
- (declare (fixnum count))
+ (let ((end (or end (length sequence))))
(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
\f
;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
-(defun nsubstitute-if (new test sequence &key from-end (start 0) end count key)
+(define-sequence-traverser 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)))
- (declare (fixnum end count))
+ (let ((end (or end (length sequence))))
+ (declare (fixnum end))
(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
(setf (aref sequence index) new)
(setq count (1- count)))))
-(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
- end count key)
+(define-sequence-traverser 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)))
- (declare (fixnum end count))
+ (let ((end (or end (length sequence))))
+ (declare (fixnum end))
(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
((or (= index end) (null list) (= count 0)) sequence)
(when (not (funcall test (apply-key key (car list))))
(rplaca list new)
- (setq count (1- count)))))
+ (decf count))))
(defun nvector-substitute-if-not* (new test sequence incrementer
start end count key)
((or (= index end) (= count 0)) sequence)
(when (not (funcall test (apply-key key (aref sequence index))))
(setf (aref sequence index) new)
- (setq count (1- count)))))
-\f
-;;; 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))
-\f
-(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))
-\f
-(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
-\f
-;;; 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))
-\f
-;;;; 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))))
+ (decf count))))
\f
-;;;; POSITION-IF-NOT
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-position-if-not (test sequence)
- `(vector-locater-if-not ,test ,sequence :position))
+;;;; 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))
-(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))))
\f
-;;;; FIND
+;;;; COUNT-IF, COUNT-IF-NOT, and COUNT
(eval-when (:compile-toplevel :execute)
-(sb!xc:defmacro vector-find (item sequence)
- `(vector-locater ,item ,sequence :element))
+(sb!xc:defmacro vector-count-if (notp from-end-p predicate sequence)
+ (let ((next-index (if from-end-p '(1- index) '(1+ index)))
+ (pred `(funcall ,predicate (apply-key key (aref ,sequence index)))))
+ `(let ((%start ,(if from-end-p '(1- end) 'start))
+ (%end ,(if from-end-p '(1- start) 'end)))
+ (do ((index %start ,next-index)
+ (count 0))
+ ((= index (the fixnum %end)) count)
+ (declare (fixnum index count))
+ (,(if notp 'unless 'when) ,pred
+ (setq count (1+ count)))))))
+
+(sb!xc:defmacro list-count-if (notp from-end-p predicate sequence)
+ (let ((pred `(funcall ,predicate (apply-key key (pop sequence)))))
+ `(let ((%start ,(if from-end-p '(- length end) 'start))
+ (%end ,(if from-end-p '(- length start) 'end))
+ (sequence ,(if from-end-p '(reverse sequence) 'sequence)))
+ (do ((sequence (nthcdr %start ,sequence))
+ (index %start (1+ index))
+ (count 0))
+ ((or (= index (the fixnum %end)) (null sequence)) count)
+ (declare (fixnum index count))
+ (,(if notp 'unless 'when) ,pred
+ (setq count (1+ count)))))))
-(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))
-\f
-;;;; 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)
+(defun count-if (test sequence &key from-end (start 0) end key)
#!+sb-doc
- "Returns the zero-origin index of the first element satisfying the test."
+ "Return the number of elements in SEQUENCE satisfying TEST(el)."
(declare (fixnum start))
- (let ((end (or end (length sequence))))
+ (let* ((length (length sequence))
+ (end (or end length)))
(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
+ (if from-end
+ (list-count-if nil t test sequence)
+ (list-count-if nil nil test sequence))
+ (if from-end
+ (vector-count-if nil t test sequence)
+ (vector-count-if nil nil test sequence)))))
-(defun find-if-not (test sequence &key from-end (start 0) end key)
+(defun count-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."
+ "Return the number of elements in SEQUENCE not satisfying TEST(el)."
(declare (fixnum start))
- (let ((end (or end (length sequence))))
+ (let* ((length (length sequence))
+ (end (or end length)))
(declare (type index end))
(seq-dispatch sequence
- (list-find-if-not test sequence)
- (vector-find-if-not test sequence))))
-\f
-;;;; COUNT
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-count (item sequence)
- `(do ((index start (1+ index))
- (count 0))
- ((= index (the fixnum end)) count)
- (declare (fixnum index count))
- (if test-not
- (unless (funcall test-not ,item
- (apply-key key (aref ,sequence index)))
- (setq count (1+ count)))
- (when (funcall test ,item (apply-key key (aref ,sequence index)))
- (setq count (1+ count))))))
-
-(sb!xc:defmacro list-count (item sequence)
- `(do ((sequence (nthcdr start ,sequence))
- (index start (1+ index))
- (count 0))
- ((or (= index (the fixnum end)) (null sequence)) count)
- (declare (fixnum index count))
- (if test-not
- (unless (funcall test-not ,item (apply-key key (pop sequence)))
- (setq count (1+ count)))
- (when (funcall test ,item (apply-key key (pop sequence)))
- (setq count (1+ count))))))
-
-) ; EVAL-WHEN
+ (if from-end
+ (list-count-if t t test sequence)
+ (list-count-if t nil test sequence))
+ (if from-end
+ (vector-count-if t t test sequence)
+ (vector-count-if t nil test sequence)))))
-(defun count (item sequence &key from-end (test #'eql) test-not (start 0)
- end key)
+(defun count (item sequence &key from-end (start 0) end
+ key (test #'eql test-p) (test-not nil test-not-p))
#!+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))))
- (declare (type index end))
- (seq-dispatch sequence
- (list-count item sequence)
- (vector-count item sequence))))
-\f
-;;;; COUNT-IF and COUNT-IF-NOT
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-count-if (predicate sequence)
- `(do ((index start (1+ index))
- (count 0))
- ((= index (the fixnum end)) count)
- (declare (fixnum index count))
- (if (funcall ,predicate (apply-key key (aref ,sequence index)))
- (setq count (1+ count)))))
-
-(sb!xc:defmacro list-count-if (predicate sequence)
- `(do ((sequence (nthcdr start ,sequence))
- (index start (1+ index))
- (count 0))
- ((or (= index (the fixnum end)) (null sequence)) count)
- (declare (fixnum index count))
- (if (funcall ,predicate (apply-key key (pop sequence)))
- (setq count (1+ count)))))
-
-) ; EVAL-WHEN
-
-(defun count-if (test sequence &key from-end (start 0) end key)
- #!+sb-doc
- "Returns the number of elements in SEQUENCE satisfying TEST(el)."
- (declare (ignore from-end) (fixnum start))
- (let ((end (or end (length sequence))))
+ (declare (fixnum start))
+ (when (and test-p test-not-p)
+ ;; ANSI Common Lisp has left the behavior in this situation unspecified.
+ ;; (CLHS 17.2.1)
+ (error ":TEST and :TEST-NOT are both present."))
+ (let* ((length (length sequence))
+ (end (or end length)))
(declare (type index end))
- (seq-dispatch sequence
- (list-count-if test sequence)
- (vector-count-if test sequence))))
+ (let ((%test (if test-not-p
+ (lambda (x)
+ (not (funcall test-not item x)))
+ (lambda (x)
+ (funcall test item x)))))
+ (seq-dispatch sequence
+ (if from-end
+ (list-count-if nil t %test sequence)
+ (list-count-if nil nil %test sequence))
+ (if from-end
+ (vector-count-if nil t %test sequence)
+ (vector-count-if nil nil %test sequence))))))
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-count-if-not (predicate sequence)
- `(do ((index start (1+ index))
- (count 0))
- ((= index (the fixnum end)) count)
- (declare (fixnum index count))
- (if (not (funcall ,predicate (apply-key key (aref ,sequence index))))
- (setq count (1+ count)))))
-
-(sb!xc:defmacro list-count-if-not (predicate sequence)
- `(do ((sequence (nthcdr start ,sequence))
- (index start (1+ index))
- (count 0))
- ((or (= index (the fixnum end)) (null sequence)) count)
- (declare (fixnum index count))
- (if (not (funcall ,predicate (apply-key key (pop sequence))))
- (setq count (1+ count)))))
-
-) ; EVAL-WHEN
-(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)."
- (declare (ignore from-end) (fixnum start))
- (let ((end (or end (length sequence))))
- (declare (type index end))
- (seq-dispatch sequence
- (list-count-if-not test sequence)
- (vector-count-if-not test sequence))))
\f
;;;; MISMATCH
(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,
+ 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,
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))
projects / sbcl.git / blobdiff