(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)))
+ (key nil
+ nil
+ (and key (%coerce-callable-to-fun key))
+ (or null function))
+ (test #'eql
+ nil
+ (%coerce-callable-to-fun test)
+ function)
+ (test-not nil
+ nil
+ (and test-not (%coerce-callable-to-fun test-not))
+ (or null function))
+ ))
+
+(sb!xc:defmacro define-sequence-traverser (name args &body body)
+ (multiple-value-bind (body declarations docstring)
+ (parse-body body :doc-string-allowed 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)))
+ ((function predicate)
+ (new-args arg)
+ (adjustments `(,arg (%coerce-callable-to-fun ,arg))))
+ (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,
(sb!xc:defmacro make-sequence-like (sequence length)
#!+sb-doc
"Return a sequence of the same type as SEQUENCE and the given LENGTH."
- (let ((type (gensym "TYPE-")))
- `(if *type-system-initialized*
- (let ((,type (specifier-type (type-of ,sequence))))
- (if (csubtypep ,type (specifier-type 'list))
- (make-sequence 'list ,length)
- (progn
- (aver (csubtypep ,type (specifier-type 'vector)))
- (aver (array-type-p ,type))
- (setf (array-type-dimensions ,type) (list '*))
- (make-sequence (type-specifier ,type) ,length))))
- (if (typep ,sequence 'string)
- (make-string ,length)
- (error "MAKE-SEQUENCE-LIKE on non-STRING too early in cold-init")))))
+ `(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
: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))))))
+(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-end
- `(integer 0 ,max-end)
- ;; This seems silly, is there something better?
- '(integer (0) 0)))))
+ '(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."
+ to INITIAL-ELEMENT."
(declare (fixnum length))
- (let ((type (specifier-type type)))
+ (let* ((adjusted-type
+ (typecase type
+ (atom (cond
+ ((eq type 'string) '(vector character))
+ ((eq type 'simple-string) '(simple-array character (*)))
+ (t type)))
+ (cons (cond
+ ((eq (car type) 'string) `(vector character ,@(cdr type)))
+ ((eq (car type) 'simple-string)
+ `(simple-array character ,(if (cdr type)
+ (cdr type)
+ '(*))))
+ (t type)))
+ (t type)))
+ (type (specifier-type adjusted-type)))
(cond ((csubtypep type (specifier-type 'list))
- (make-list length :initial-element initial-element))
+ (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)))
+ ((cons-type-p type)
+ (multiple-value-bind (min exactp)
+ (sb!kernel::cons-type-length-info type)
+ (if exactp
+ (unless (= length min)
+ (sequence-type-length-mismatch-error type length))
+ (unless (>= length min)
+ (sequence-type-length-mismatch-error type length)))
+ (make-list length :initial-element initial-element)))
+ ;; 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)
- ;; 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
+ (cond
+ (;; is it immediately obvious what the result type is?
+ (typep type 'array-type)
+ (progn
+ (aver (= (length (array-type-dimensions type)) 1))
+ (let* ((etype (type-specifier
(array-type-specialized-element-type type)))
+ (etype (if (eq etype '*) t etype))
(type-length (car (array-type-dimensions type))))
- (unless (or (eq type-length '*)
- (= type-length length))
- (error 'simple-type-error
- :datum length
- :expected-type `(eql ,type-length)
- :format-control "The length requested (~S) ~
- does not match the length type restriction in ~S."
- :format-arguments (list length
- (type-specifier type))))
- ;; 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))))
- ;; We have a subtype of VECTOR, but it isn't an array
- ;; type. Maybe this should be a BUG instead?
- (error 'simple-type-error
- :datum type
- :expected-type 'sequence
- :format-control "~S is too hairy for MAKE-SEQUENCE."
- :format-arguments (list (type-specifier 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)))))
+ (t (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
(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)
(1- source-index)))
((= target-index (the fixnum (1- target-start))) target-sequence)
(declare (fixnum target-index source-index))
+ ;; disable bounds checking
+ (declare (optimize (safety 0)))
(setf (aref target-sequence target-index)
(aref source-sequence source-index))))
(do ((target-index target-start (1+ target-index))
(= source-index (the fixnum source-end)))
target-sequence)
(declare (fixnum target-index source-index))
+ ;; disable bounds checking
+ (declare (optimize (safety 0)))
(setf (aref target-sequence target-index)
(aref source-sequence source-index)))))
(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)))
+#!+sb-unicode
+(defun simple-character-string-replace-from-simple-character-string*
+ (target-sequence source-sequence
+ target-start target-end source-start source-end)
+ (declare (type (simple-array character (*)) target-sequence source-sequence))
+ (when (null target-end) (setq target-end (length target-sequence)))
+ (when (null source-end) (setq source-end (length source-sequence)))
+ (mumble-replace-from-mumble))
+
+(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 ,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
(sb!xc:defmacro vector-nreverse (sequence)
`(let ((length (length (the vector ,sequence))))
- (declare (fixnum length))
- (do ((left-index 0 (1+ left-index))
- (right-index (1- length) (1- right-index))
- (half-length (truncate length 2)))
- ((= left-index half-length) ,sequence)
- (declare (fixnum left-index right-index half-length))
- (rotatef (aref ,sequence left-index)
- (aref ,sequence right-index)))))
+ (when (>= length 2)
+ (do ((left-index 0 (1+ left-index))
+ (right-index (1- length) (1- right-index)))
+ ((<= right-index left-index))
+ (declare (type index left-index right-index))
+ (rotatef (aref ,sequence left-index)
+ (aref ,sequence right-index))))
+ ,sequence))
(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)
specified OUTPUT-TYPE-SPEC."
(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.
+ (reduce #'+ sequences :key #'length))))
+ ((cons-type-p type)
+ (multiple-value-bind (min exactp)
+ (sb!kernel::cons-type-length-info type)
+ (let ((length (reduce #'+ sequences :key #'length)))
+ (if exactp
+ (unless (= length min)
+ (sequence-type-length-mismatch-error type length))
+ (unless (>= length min)
+ (sequence-type-length-mismatch-error type length)))
+ (apply #'concat-to-list* sequences))))
+ (t (sequence-type-too-hairy (type-specifier type)))))
((csubtypep type (specifier-type 'vector))
(apply #'concat-to-simple* output-type-spec sequences))
- ((csubtypep type (specifier-type 'list))
- (apply #'concat-to-list* sequences))
(t
(bad-sequence-type-error output-type-spec)))))
ref)
`(do ((index ,start (1+ index))
(value ,initial-value))
- ((= index (the fixnum ,end)) value)
- (declare (fixnum index))
+ ((>= index ,end) value)
(setq value (funcall ,function value
(apply-key ,key (,ref ,sequence index))))))
`(do ((index (1- ,end) (1- index))
(value ,initial-value)
(terminus (1- ,start)))
- ((= index terminus) value)
- (declare (fixnum index terminus))
+ ((<= index terminus) value)
(setq value (funcall ,function
(apply-key ,key (,ref ,sequence index))
value))))
initial-value
ivp)
`(let ((sequence (nthcdr ,start ,sequence)))
- (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+ (do ((count (if ,ivp ,start (1+ ,start))
(1+ count))
(sequence (if ,ivp sequence (cdr sequence))
(cdr sequence))
(value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
(funcall ,function value (apply-key ,key (car sequence)))))
- ((= count (the fixnum ,end)) value)
- (declare (fixnum count)))))
+ ((>= count ,end) value))))
(sb!xc:defmacro list-reduce-from-end (function
sequence
end
initial-value
ivp)
- `(let ((sequence (nthcdr (- (the fixnum (length ,sequence))
- (the fixnum ,end))
+ `(let ((sequence (nthcdr (- (length ,sequence) ,end)
(reverse ,sequence))))
- (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+ (do ((count (if ,ivp ,start (1+ ,start))
(1+ count))
(sequence (if ,ivp sequence (cdr sequence))
(cdr sequence))
(value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
(funcall ,function (apply-key ,key (car sequence)) value)))
- ((= count (the fixnum ,end)) value)
- (declare (fixnum count)))))
+ ((>= count ,end) value))))
) ; 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 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 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"
+ "Return a copy of sequence with elements satisfying PREDICATE 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"
+ "Return a copy of sequence with elements not satisfying PREDICATE 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)
(declare (fixnum index))
(setq splice (cdr (rplacd splice (list (car current)))))
(setq current (cdr current)))
- (do ((index 0 (1+ index)))
+ (do ((index start (1+ index)))
((or (and end (= index (the fixnum 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 test-not start 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 test-not start 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 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."
+ except that all elements equal to OLD are replaced with NEW."
(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 predicate 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."
+ except that all elements satisfying the PRED are replaced with NEW."
(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 predicate)
+ (test-not nil)
+ 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 predicate 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."
+ except that all elements not satisfying the PRED are replaced with NEW."
(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 predicate)
+ (test-not nil)
+ 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 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."
+ except that all elements equal to OLD are replaced with NEW. SEQUENCE
+ may be destructively modified."
(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 predicate 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."
+ except that all elements satisfying PREDICATE are replaced with NEW.
+ SEQUENCE may be destructively modified."
(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))
- (nlist-substitute-if* new test sequence
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if*
+ new predicate (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
+ (nlist-substitute-if* new predicate sequence
start end count key))
(if from-end
- (nvector-substitute-if* new test sequence -1
+ (nvector-substitute-if* new predicate sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if* new test sequence 1
+ (nvector-substitute-if* new predicate sequence 1
start end count key)))))
(defun nlist-substitute-if* (new test sequence start end count key)
(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 predicate 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."
+ except that all elements not satisfying PREDICATE are replaced with NEW.
+ SEQUENCE may be destructively modified."
(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))
- (nlist-substitute-if-not* new test sequence
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if-not*
+ new predicate (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
+ (nlist-substitute-if-not* new predicate sequence
start end count key))
(if from-end
- (nvector-substitute-if-not* new test sequence -1
+ (nvector-substitute-if-not* new predicate sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if-not* new test sequence 1
+ (nvector-substitute-if-not* new predicate sequence 1
start end count key)))))
(defun nlist-substitute-if-not* (new test sequence start end count key)
((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)
(frob sequence nil))))
(typecase sequence
(simple-vector (frob2))
- (simple-string (frob2))
+ (simple-base-string (frob2))
(t (vector*-frob sequence))))
(declare (type (or index null) p))
- (values f (and p (the index (+ p offset))))))))))
+ (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)))
(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))))))
+(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)))))))
+
) ; EVAL-WHEN
-(defun count (item sequence &key from-end (test #'eql) test-not (start 0)
- end key)
+(define-sequence-traverser count-if (pred sequence &key from-end start 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))))
+ "Return the number of elements in SEQUENCE satisfying PRED(el)."
+ (declare (fixnum start))
+ (let ((end (or end length))
+ (pred (%coerce-callable-to-fun pred)))
(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
+ (if from-end
+ (list-count-if nil t pred sequence)
+ (list-count-if nil nil pred sequence))
+ (if from-end
+ (vector-count-if nil t pred sequence)
+ (vector-count-if nil nil pred sequence)))))
-(defun count-if (test sequence &key from-end (start 0) end key)
+(define-sequence-traverser count-if-not
+ (pred 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))))
+ "Return the number of elements in SEQUENCE not satisfying TEST(el)."
+ (declare (fixnum start))
+ (let ((end (or end length))
+ (pred (%coerce-callable-to-fun pred)))
(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 t t pred sequence)
+ (list-count-if t nil pred sequence))
+ (if from-end
+ (vector-count-if t t pred sequence)
+ (vector-count-if t nil pred sequence)))))
-(defun count-if-not (test sequence &key from-end (start 0) end key)
+(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 not satisfying TEST(el)."
- (declare (ignore from-end) (fixnum start))
- (let ((end (or end (length sequence))))
+ "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))
- (seq-dispatch sequence
- (list-count-if-not test sequence)
- (vector-count-if-not 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))))))
+
+
\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 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)
`(do ((main ,main (cdr main))
(jndex start1 (1+ jndex))
(sub (nthcdr start1 ,sub) (cdr sub)))
- ((or (null main) (null sub) (= (the fixnum end1) jndex))
+ ((or (endp main) (endp sub) (<= end1 jndex))
t)
- (declare (fixnum jndex))
- (compare-elements (car main) (car sub))))
+ (declare (type (integer 0) jndex))
+ (compare-elements (car sub) (car main))))
(sb!xc:defmacro search-compare-list-vector (main sub)
`(do ((main ,main (cdr main))
(index start1 (1+ index)))
- ((or (null main) (= index (the fixnum end1))) t)
- (declare (fixnum index))
- (compare-elements (car main) (aref ,sub index))))
+ ((or (endp main) (= index end1)) t)
+ (compare-elements (aref ,sub index) (car main))))
(sb!xc:defmacro search-compare-vector-list (main sub index)
`(do ((sub (nthcdr start1 ,sub) (cdr sub))
(jndex start1 (1+ jndex))
(index ,index (1+ index)))
- ((or (= (the fixnum end1) jndex) (null sub)) t)
- (declare (fixnum jndex index))
- (compare-elements (aref ,main index) (car sub))))
+ ((or (<= end1 jndex) (endp sub)) t)
+ (declare (type (integer 0) jndex))
+ (compare-elements (car sub) (aref ,main index))))
(sb!xc:defmacro search-compare-vector-vector (main sub index)
`(do ((index ,index (1+ index))
(sub-index start1 (1+ sub-index)))
- ((= sub-index (the fixnum end1)) t)
- (declare (fixnum sub-index index))
- (compare-elements (aref ,main index) (aref ,sub sub-index))))
+ ((= sub-index end1) t)
+ (compare-elements (aref ,sub sub-index) (aref ,main index))))
(sb!xc:defmacro search-compare (main-type main sub index)
(if (eq main-type 'list)
(sb!xc:defmacro list-search (main sub)
`(do ((main (nthcdr start2 ,main) (cdr main))
(index2 start2 (1+ index2))
- (terminus (- (the fixnum end2)
- (the fixnum (- (the fixnum end1)
- (the fixnum start1)))))
+ (terminus (- end2 (the (integer 0) (- end1 start1))))
(last-match ()))
((> index2 terminus) last-match)
- (declare (fixnum index2 terminus))
+ (declare (type (integer 0) index2))
(if (search-compare list main ,sub index2)
(if from-end
(setq last-match index2)
(sb!xc:defmacro vector-search (main sub)
`(do ((index2 start2 (1+ index2))
- (terminus (- (the fixnum end2)
- (the fixnum (- (the fixnum end1)
- (the fixnum start1)))))
+ (terminus (- end2 (the (integer 0) (- end1 start1))))
(last-match ()))
((> index2 terminus) last-match)
- (declare (fixnum index2 terminus))
+ (declare (type (integer 0) index2))
(if (search-compare vector ,main ,sub index2)
(if from-end
(setq last-match index2)
) ; 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 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