(eval-when (:compile-toplevel)
+(defparameter *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 #.sb!xc:most-positive-fixnum))
+ ,@(mapcan (lambda (names)
+ (destructuring-bind (start end length sequence) names
+ (list
+ `(,start
+ 0
+ nil
+ (if (<= 0 ,start ,length)
+ ,start
+ (signal-bounding-indices-bad-error ,sequence
+ ,start ,end))
+ index)
+ `(,end
+ nil
+ nil
+ (if (or (null ,end) (<= ,start ,end ,length))
+ ;; Defaulting of NIL is done inside the
+ ;; bodies, for ease of sharing with compiler
+ ;; transforms.
+ ;;
+ ;; FIXME: defend against non-number non-NIL
+ ;; stuff?
+ ,end
+ (signal-bounding-indices-bad-error ,sequence
+ ,start ,end))
+ (or null index)))))
+ '((start end length sequence)
+ (start1 end1 length1 sequence1)
+ (start2 end2 length2 sequence2)))
+ ))
+
+(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)
+ (case arg
+ ;; FIXME: make this robust. And clean.
+ ((sequence)
+ (new-args arg)
+ (adjustments '(length (etypecase sequence
+ (list (length sequence))
+ (vector (length sequence)))))
+ (new-declarations '(type index length)))
+ ((sequence1)
+ (new-args arg)
+ (adjustments '(length1 (etypecase sequence1
+ (list (length sequence1))
+ (vector (length sequence1)))))
+ (new-declarations '(type index length1)))
+ ((sequence2)
+ (new-args arg)
+ (adjustments '(length2 (etypecase sequence2
+ (list (length sequence2))
+ (vector (length sequence2)))))
+ (new-declarations '(type index length2)))
+ (t (let ((info (cdr (assoc arg *sequence-keyword-info*))))
+ (cond (info
+ (destructuring-bind (default supplied-p adjuster type) info
+ (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
+ (adjustments `(,arg ,adjuster))
+ (new-declarations `(type ,type ,arg))))
+ (t (new-args arg)))))))
+ `(defun ,name ,(new-args)
+ ,@(when docstring (list 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 tend to make code run faster but be bigger; some benchmarking
+;;; 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)
(sb!xc:defmacro make-sequence-like (sequence length)
#!+sb-doc
"Return a sequence of the same type as SEQUENCE and the given LENGTH."
- `(make-sequence-of-type (type-of ,sequence) ,length))
-
-(sb!xc:defmacro type-specifier-atom (type)
- #!+sb-doc "Return the broad class of which TYPE is a specific subclass."
- `(if (atom ,type) ,type (car ,type)))
-
+ `(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
;;; It's possible with some sequence operations to declare the length
(vector-of-checked-length-given-length sequence
declared-length))))))
-;;; 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
- "A NIL output type is invalid for this sequence function."
- :format-arguments ())))
- ((dolist (seq-type '(list string simple-vector bit-vector))
- (when (csubtypep type (specifier-type seq-type))
- (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 not a legal type specifier for sequence functions."
- :format-arguments (list type))))))
-
+(declaim (ftype (function (sequence index) nil) signal-index-too-large-error))
(defun signal-index-too-large-error (sequence index)
(let* ((length (length sequence))
(max-index (and (plusp length)
:expected-type (if max-index
`(integer 0 ,max-index)
;; This seems silly, is there something better?
- '(integer (0) (0))))))
-
-(defun signal-end-too-large-error (sequence end)
- (let* ((length (length sequence))
- (max-end (and (not (minusp length))
- length)))
- (error 'end-too-large-error
- :datum end
- :expected-type (if max-index
- `(integer 0 ,max-end)
- ;; This seems silly, is there something better?
- '(integer (0) 0)))))
-
-(defun make-sequence-of-type (type length)
- #!+sb-doc "Return 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))))
+ '(integer 0 (0))))))
+
+(defun signal-bounding-indices-bad-error (sequence start end)
+ (let ((length (length sequence)))
+ (error 'bounding-indices-bad-error
+ :datum (cons start end)
+ :expected-type `(cons (integer 0 ,length)
+ (or null (integer ,start ,length)))
+ :object sequence)))
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
(vector (length (truly-the vector sequence)))
(list (length (truly-the list sequence)))))
-(defun make-sequence (type length &key (initial-element NIL iep))
+(defun make-sequence (type length &key (initial-element nil iep))
#!+sb-doc
"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=~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
;;;;
(defun vector-subseq* (sequence start &optional end)
(declare (type vector sequence))
- (declare (type fixnum start))
- (declare (type (or null fixnum) end))
- (if (null end)
- (setf end (length sequence))
- (unless (<= end (length sequence))
- (signal-index-too-large-error sequence end)))
+ (declare (type index start))
+ (declare (type (or null index) end))
+ (when (null end)
+ (setf end (length sequence)))
+ (unless (<= 0 start end (length sequence))
+ (signal-bounding-indices-bad-error sequence start end))
(do ((old-index start (1+ old-index))
(new-index 0 (1+ new-index))
(copy (make-sequence-like sequence (- end start))))
(defun list-subseq* (sequence start &optional end)
(declare (type list sequence))
- (declare (type fixnum start))
- (declare (type (or null fixnum) end))
- (if (and end (>= start (the fixnum end)))
- ()
- (let* ((groveled (nthcdr start sequence))
- (result (list (car groveled))))
- (if groveled
- (do ((list (cdr groveled) (cdr list))
- (splice result (cdr (rplacd splice (list (car list)))))
- (index (1+ start) (1+ index)))
- ((or (atom list) (and end (= index (the fixnum end))))
- result)
- (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.)
+ ;; the INDEX declaration isn't actually mandatory, but it's true for
+ ;; all practical purposes.
+ (declare (type index start))
+ (declare (type (or null index) end))
+ (do ((list sequence (cdr list))
+ (index 0 (1+ index))
+ (result nil))
+ (nil)
+ (cond
+ ((null list) (if (or (and end (> end index))
+ (< index start))
+ (signal-bounding-indices-bad-error sequence start end)
+ (return (nreverse result))))
+ ((< index start) nil)
+ ((and end (= index end)) (return (nreverse result)))
+ (t (push (car list) result)))))
+
(defun subseq (sequence start &optional end)
#!+sb-doc
"Return a copy of a subsequence of SEQUENCE starting with element number
(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)))))
(defun vector-copy-seq* (sequence)
(declare (type vector sequence))
- (vector-copy-seq sequence
- (typecase sequence
- ;; Pick off the common cases so that we don't have to...
- ((vector t) 'simple-vector)
- (string 'simple-string)
- (bit-vector 'simple-bit-vector)
- ((vector single-float) '(simple-array single-float 1))
- ((vector double-float) '(simple-array double-float 1))
- ;; ...do a full call to TYPE-OF.
- (t (type-of sequence)))))
+ (vector-copy-seq sequence))
\f
;;;; FILL
(when (null end) (setq end (length sequence)))
(vector-fill sequence item start end))
-;;; FILL 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 fill (sequence item &key (start 0) end)
+(define-sequence-traverser fill (sequence item &key start end)
#!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
(seq-dispatch sequence
(list-fill* sequence item start end)
(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.
-(defun replace (target-sequence source-sequence &key
- ((:start1 target-start) 0)
- ((:end1 target-end))
- ((:start2 source-start) 0)
- ((:end2 source-end)))
+(define-sequence-traverser replace
+ (sequence1 sequence2 &key start1 end1 start2 end2)
#!+sb-doc
"The target sequence is destructively modified by copying successive
elements into it from the source sequence."
- (let ((target-end (or target-end (length target-sequence)))
- (source-end (or source-end (length source-sequence))))
+ (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or
+ ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind
+ ;; these things here so that legacy code gets the names it's
+ ;; expecting. We could use &AUX instead :-/.
+ (target-sequence sequence1)
+ (source-sequence sequence2)
+ (target-start start1)
+ (source-start start2)
+ (target-end (or end1 length1))
+ (source-end (or end2 length2)))
(seq-dispatch target-sequence
(seq-dispatch source-sequence
(list-replace-from-list)
(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)
(sb!xc:defmacro list-reverse-macro (sequence)
`(do ((new-list ()))
- ((atom ,sequence) new-list)
+ ((endp ,sequence) new-list)
(push (pop ,sequence) new-list)))
) ; EVAL-WHEN
(list-reverse-macro sequence))
(defun vector-reverse* (sequence)
- (vector-reverse sequence (type-of sequence)))
+ (vector-reverse sequence))
\f
;;;; NREVERSE
(aref ,sequence right-index)))))
(sb!xc:defmacro list-nreverse-macro (list)
- `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st)))
+ `(do ((1st (cdr ,list) (if (endp 1st) 1st (cdr 1st)))
(2nd ,list 1st)
(3rd '() 2nd))
((atom 2nd) 3rd)
(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
"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 (aver (typep 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
(declare (type index counter))))))
(declare (type index min-len))
(with-map-state sequences
- (let ((result (make-sequence-of-type output-type-spec min-len))
+ (let ((result (make-sequence output-type-spec min-len))
(index 0))
(declare (type index index))
(loop with updated-map-apply-args
;;; 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)))
+ (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
;; approach, consing O(N-ARGS) temporary storage (which can have
;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time.
(let ((sequences (cons first-sequence more-sequences)))
- (case (type-specifier-atom result-type)
- ((nil) (%map-for-effect really-fun sequences))
- (list (%map-to-list really-fun sequences))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string simple-base-string)
+ (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
- (apply #'map
- (result-type-or-lose result-type t)
- really-fun
- sequences)))))))
+ (bad-sequence-type-error result-type)))))))
(defun map (result-type function first-sequence &rest more-sequences)
- (sequence-of-checked-length-given-type (apply #'%map
- result-type
- function
- first-sequence
- more-sequences)
- ;; (The RESULT-TYPE isn't
- ;; strictly the type of the
- ;; result, because when
- ;; RESULT-TYPE=NIL, the result
- ;; actually has NULL type. But
- ;; that special case doesn't
- ;; matter here, since we only
- ;; look closely at vector
- ;; types; so we can just pass
- ;; RESULT-TYPE straight through
- ;; as a type specifier.)
- result-type))
+ (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
) ; EVAL-WHEN
-(defun reduce (function sequence &key key from-end (start 0)
- end (initial-value nil ivp))
+(define-sequence-traverser reduce
+ (function sequence &key key from-end start end (initial-value nil ivp))
(declare (type index start))
(let ((start start)
- (end (or end (length sequence))))
+ (end (or end length)))
(declare (type index start end))
(cond ((= end start)
(if ivp initial-value (funcall function)))
`(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
+ end count key)
#!+sb-doc
"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))
+ (let ((end (or end length)))
+ (declare (type index 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 key end count)
#!+sb-doc
"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))
+ (let ((end (or end length)))
+ (declare (type index 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 end key count)
#!+sb-doc
"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))
+ (let ((end (or end length)))
+ (declare (type index 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
+ end count key)
#!+sb-doc
"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))
+ (let ((end (or end length)))
+ (declare (type index 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 end count key)
#!+sb-doc
"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))
+ (let ((end (or end length)))
+ (declare (type index 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 end count key)
#!+sb-doc
"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))
+ (let ((end (or end length)))
+ (declare (type index end))
(seq-dispatch sequence
(if from-end
(if-not-list-remove-from-end)
(atom current)))
(declare (fixnum index))
(if (or (and from-end
- (not (member (apply-key key (car current))
- (nthcdr (1+ start) result)
- :test test
- :test-not test-not
- :key key)))
+ (not (if test-not
+ (member (apply-key key (car current))
+ (nthcdr (1+ start) result)
+ :test-not test-not
+ :key key)
+ (member (apply-key key (car current))
+ (nthcdr (1+ start) result)
+ :test test
+ :key key))))
(and (not from-end)
(not (do ((it (apply-key key (car current)))
(l (cdr current) (cdr l))
())
(declare (fixnum i))
(if (if test-not
- (not (funcall test-not it (apply-key key (car l))))
+ (not (funcall test-not
+ it
+ (apply-key key (car l))))
(funcall test it (apply-key key (car l))))
(return t))))))
(setq splice (cdr (rplacd splice (list (car current))))))
(do ((elt))
((= index end))
(setq elt (aref vector index))
+ ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT
+ ;; arguments simultaneously is a little fragile, since ANSI says
+ ;; we can't depend on it, so we need to remember to keep that
+ ;; extension in our implementation. It'd probably be better to
+ ;; rewrite this to avoid passing both (as
+ ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18).
(unless (or (and from-end
- (position (apply-key key elt) result :start start
- :end jndex :test test :test-not test-not :key key))
+ (position (apply-key key elt) result
+ :start start :end jndex
+ :test test :test-not test-not :key key))
(and (not from-end)
- (position (apply-key key elt) vector :start (1+ index)
- :end end :test test :test-not test-not :key key)))
+ (position (apply-key key elt) vector
+ :start (1+ index) :end end
+ :test test :test-not test-not :key key)))
(setf (aref result jndex) elt)
(setq jndex (1+ jndex)))
(setq index (1+ index)))
(setq jndex (1+ jndex)))
(shrink-vector result jndex)))
-(defun remove-duplicates (sequence &key
- (test #'eql)
- test-not
- (start 0)
- from-end
- end
- key)
+(define-sequence-traverser remove-duplicates
+ (sequence &key (test #'eql) test-not (start 0) end from-end key)
#!+sb-doc
- "The elements of Sequence are compared pairwise, and if any two match,
+ "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)
+(define-sequence-traverser delete-duplicates
+ (sequence &key (test #'eql) test-not (start 0) end from-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 count end key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements,
except that all elements equal to OLD are replaced with NEW. 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))
+ (let ((end (or end length)))
+ (declare (type index 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 end count key)
#!+sb-doc
"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))
+ (let ((end (or end length))
+ test-not
+ old)
+ (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 end count key)
#!+sb-doc
"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))
+ (let ((end (or end length))
+ test-not
+ old)
+ (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)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements equal to OLD are replaced with NEW. 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)))
(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 end count key)
#!+sb-doc
"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)))
+ (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 end count key)
#!+sb-doc
"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)))
+ (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)))))
+ (decf count))))
\f
;;;; 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)))
+ (effective-find-position-test test test-not))
(defun effective-find-position-key (key)
- (if key
- (%coerce-callable-to-fun key)
- #'identity))
+ (effective-find-position-key key))
;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
(macrolet (;; shared logic for defining %FIND-POSITION and
(frobs ()
`(etypecase sequence-arg
(list (frob sequence-arg from-end))
- (vector
+ (vector
(with-array-data ((sequence sequence-arg :offset-var offset)
(start start)
- (end (or end (length sequence-arg))))
+ (end (%check-vector-sequence-bounds
+ sequence-arg start end)))
(multiple-value-bind (f p)
(macrolet ((frob2 () '(if from-end
(frob sequence t)
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 and POSITION: just interpreter stubs,
+;;; nowadays.
+(defun find (item sequence &key from-end (start 0) end key test test-not)
+ ;; FIXME: this can't be the way to go, surely?
+ (find item sequence :from-end from-end :start start :end end :key key
+ :test test :test-not test-not))
+(defun position (item sequence &key from-end (start 0) end key test test-not)
+ (position item sequence :from-end from-end :start start :end end :key key
+ :test test :test-not test-not))
;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
;;; to the interface to FIND and POSITION
-(declaim (inline find-if position-if))
-(macrolet ((def-find-position-if (fun-name values-index)
- `(defun ,fun-name (predicate sequence
- &key from-end (start 0) end key)
- (nth-value
- ,values-index
- (%find-position-if (%coerce-callable-to-fun predicate)
- sequence
- from-end
- start
- end
- (effective-find-position-key key))))))
-
- (def-find-position-if find-if 0)
- (def-find-position-if position-if 1))
-
-;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
-;;; didn't bother to worry about optimizing them, except note that on
-;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on
-;;; sbcl-devel
-;;;
-;;; My understanding is that while the :test-not argument is
-;;; deprecated in favour of :test (complement #'foo) because of
-;;; semantic difficulties (what happens if both :test and :test-not
-;;; are supplied, etc) the -if-not variants, while officially
-;;; deprecated, would be undeprecated were X3J13 actually to produce
-;;; a revised standard, as there are perfectly legitimate idiomatic
-;;; reasons for allowing the -if-not versions equal status,
-;;; particularly remove-if-not (== filter).
-;;;
-;;; This is only an informal understanding, I grant you, but
-;;; perhaps it's worth optimizing the -if-not versions in the same
-;;; way as the others?
-;;;
-;;; That sounds reasonable, so if someone wants to submit patches to
-;;; make the -IF-NOT functions compile as efficiently as the
-;;; corresponding -IF variants do, go for it. -- WHN 2001-10-06)
-;;;
-;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT
-;;; too) within the implementation of SBCL.
-(declaim (inline find-if-not position-if-not))
-(macrolet ((def-find-position-if-not (fun-name values-index)
- `(defun ,fun-name (predicate sequence
- &key from-end (start 0) end key)
- (nth-value
- ,values-index
- (%find-position-if-not (%coerce-callable-to-fun predicate)
- sequence
- from-end
- start
- end
- (effective-find-position-key key))))))
-
- (def-find-position-if-not find-if-not 0)
- (def-find-position-if-not position-if-not 1))
+(defun find-if (predicate sequence &key from-end (start 0) end key)
+ (find-if predicate sequence :from-end from-end :start start
+ :end end :key key))
+(defun position-if (predicate sequence &key from-end (start 0) end key)
+ (position-if predicate sequence :from-end from-end :start start
+ :end end :key key))
+
+(defun find-if-not (predicate sequence &key from-end (start 0) end key)
+ (find-if-not predicate sequence :from-end from-end :start start
+ :end end :key key))
+(defun position-if-not (predicate sequence &key from-end (start 0) end key)
+ (position-if-not predicate sequence :from-end from-end :start start
+ :end end :key key))
\f
-;;;; COUNT
+;;;; COUNT-IF, COUNT-IF-NOT, and 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
-
-(defun count (item sequence &key from-end (test #'eql) test-not (start 0)
- end key)
- #!+sb-doc
- "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 (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 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)
+(define-sequence-traverser count-if (test sequence &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE satisfying TEST(el)."
- (declare (ignore from-end) (fixnum start))
- (let ((end (or end (length sequence))))
+ (declare (fixnum start))
+ (let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
- (list-count-if test sequence)
- (vector-count-if 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
+ (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 count-if-not (test sequence &key from-end (start 0) end key)
+(define-sequence-traverser count-if-not
+ (test sequence &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE not satisfying TEST(el)."
- (declare (ignore from-end) (fixnum start))
- (let ((end (or end (length sequence))))
+ (declare (fixnum start))
+ (let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
- (list-count-if-not test sequence)
- (vector-count-if-not test sequence))))
+ (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)))))
+
+(define-sequence-traverser count
+ (item sequence &key from-end start end
+ key (test #'eql test-p) (test-not nil test-not-p))
+ #!+sb-doc
+ "Return the number of elements in SEQUENCE satisfying a test with ITEM,
+ which defaults to EQL."
+ (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 ((end (or end length)))
+ (declare (type index end))
+ (let ((%test (if test-not-p
+ (lambda (x)
+ (not (funcall test-not item x)))
+ (lambda (x)
+ (funcall test item x)))))
+ (seq-dispatch sequence
+ (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))))))
+
+
\f
;;;; MISMATCH
) ; EVAL-WHEN
-(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not
- (start1 0) end1 (start2 0) end2 key)
+(define-sequence-traverser mismatch
+ (sequence1 sequence2
+ &key from-end (test #'eql) test-not
+ start1 end1 start2 end2 key)
#!+sb-doc
"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
+ 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 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))
- (length2 (length sequence2))
+ (let* ((end1 (or end1 length1))
(end2 (or end2 length2)))
- (declare (type index length1 end1 length2 end2))
+ (declare (type index end1 end2))
(match-vars
(seq-dispatch sequence1
(matchify-list (sequence1 start1 length1 end1)
) ; EVAL-WHEN
-(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not
- (start1 0) end1 (start2 0) end2 key)
+(define-sequence-traverser search
+ (sequence1 sequence2
+ &key from-end (test #'eql) test-not
+ start1 end1 start2 end2 key)
(declare (fixnum start1 start2))
- (let ((end1 (or end1 (length sequence1)))
- (end2 (or end2 (length sequence2))))
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
(seq-dispatch sequence2
(list-search sequence2 sequence1)
(vector-search sequence2 sequence1))))
projects / sbcl.git / blobdiff