(eval-when (:compile-toplevel)
+(defvar *sequence-keyword-info*
+ ;; (name default supplied-p adjustment new-type)
+ '((count nil
+ nil
+ (etypecase count
+ (null (1- most-positive-fixnum))
+ (fixnum (max 0 count))
+ (integer (if (minusp count)
+ 0
+ (1- most-positive-fixnum))))
+ (mod #.most-positive-fixnum))))
+
+(sb!xc:defmacro define-sequence-traverser (name args &body body)
+ (multiple-value-bind (body declarations docstring)
+ (parse-body body t)
+ (collect ((new-args) (new-declarations) (adjustments))
+ (dolist (arg args)
+ (let ((info (cdr (assoc arg *sequence-keyword-info*))))
+ (cond (info
+ (destructuring-bind (default supplied-p adjuster type) info
+ (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
+ (adjustments `(,arg ,adjuster))
+ (new-declarations `(type ,type ,arg))))
+ (t (new-args arg)))))
+ `(defun ,name ,(new-args)
+ ,docstring
+ ,@declarations
+ (let (,@(adjustments))
+ (declare ,@(new-declarations))
+ ,@body)))))
+
;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE.
;;;
;;; FIXME: It might be worth making three cases here, LIST,
;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR.
-;;; It 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
:datum vector
:expected-type `(vector ,declared-length)
:format-control
- "Vector length (~D) doesn't match declared length (~D)."
+ "Vector length (~W) doesn't match declared length (~W)."
:format-arguments (list actual-length declared-length))))
vector)
(defun sequence-of-checked-length-given-type (sequence result-type)
(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))))))
-
(defun signal-index-too-large-error (sequence index)
(let* ((length (length sequence))
- (max-index (and (plusp length) (1- length))))
+ (max-index (and (plusp length)
+ (1- length))))
(error 'index-too-large-error
:datum index
:expected-type (if max-index
`(integer 0 ,max-index)
;; This seems silly, is there something better?
- '(integer (0) (0))))))
+ '(integer 0 (0))))))
+
+(defun signal-end-too-large-error (sequence end)
+ (let* ((length (length sequence))
+ (max-end length))
+ (error 'end-too-large-error
+ :datum end
+ :expected-type `(integer 0 ,max-end))))
-(defun make-sequence-of-type (type length)
- #!+sb-doc "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))))
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
(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
;;;;
-;;;; The support routines for SUBSEQ are used by compiler transforms, so we
-;;;; worry about dealing with END being supplied or defaulting to NIL
-;;;; at this level.
+;;;; The support routines for SUBSEQ are used by compiler transforms,
+;;;; so we worry about dealing with END being supplied or defaulting
+;;;; to NIL at this level.
(defun vector-subseq* (sequence start &optional end)
(declare (type vector sequence))
(declare (type fixnum start))
(declare (type (or null fixnum) end))
- (when (null end) (setf end (length sequence)))
+ (if (null end)
+ (setf end (length sequence))
+ (unless (<= end (length sequence))
+ (signal-end-too-large-error sequence end)))
(do ((old-index start (1+ old-index))
(new-index 0 (1+ new-index))
(copy (make-sequence-like sequence (- end start))))
((= old-index end) copy)
(declare (fixnum old-index new-index))
- (setf (aref copy new-index) (aref sequence old-index))))
+ (setf (aref copy new-index)
+ (aref sequence old-index))))
(defun list-subseq* (sequence start &optional end)
(declare (type list sequence))
(declare (fixnum index)))
()))))
-;;; SUBSEQ cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value. We must test for end being nil
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see above).
+;;; SUBSEQ cannot default END to the length of sequence since it is
+;;; not an error to supply NIL for its value. We must test for END
+;;; being NIL in the body of the function, and this is actually done
+;;; in the support routines for other reasons. (See above.)
(defun subseq (sequence start &optional end)
#!+sb-doc
"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)))))
(list-copy-seq sequence))
(defun vector-copy-seq* (sequence)
- (vector-copy-seq sequence (type-of sequence)))
+ (declare (type vector sequence))
+ (vector-copy-seq sequence))
\f
;;;; FILL
(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)
(list-reverse-macro sequence))
(defun vector-reverse* (sequence)
- (vector-reverse sequence (type-of sequence)))
+ (vector-reverse sequence))
\f
;;;; NREVERSE
(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-function (%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
;; there's no consing overhead to dwarf our inefficiency.)
(if (and (null more-sequences)
(null result-type))
- (%map-for-effect-arity-1 really-function first-sequence)
+ (%map-for-effect-arity-1 really-fun first-sequence)
;; Otherwise, use the industrial-strength full-generality
;; approach, consing O(N-ARGS) temporary storage (which can have
;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time.
(let ((sequences (cons first-sequence more-sequences)))
- (case (type-specifier-atom result-type)
- ((nil) (%map-for-effect really-function sequences))
- (list (%map-to-list really-function sequences))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string simple-base-string)
- (%map-to-vector result-type really-function sequences))
+ (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-function
- 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
(dotimes (index len)
(setf (elt result-sequence index)
(apply really-fun
- (mapcar #'(lambda (seq) (elt seq index))
+ (mapcar (lambda (seq) (elt seq index))
sequences))))))
result-sequence)
\f
`(do ((index start (1+ index))
(jndex start)
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum end)) (= number-zapped count))
(do ((index index (1+ index)) ; Copy the rest of the vector.
(jndex jndex (1+ jndex)))
((= index (the fixnum length))
(declare (fixnum index jndex number-zapped))
(setf (aref sequence jndex) (aref sequence index))
(if ,pred
- (setq number-zapped (1+ number-zapped))
- (setq jndex (1+ jndex)))))
+ (incf number-zapped)
+ (incf jndex))))
(sb!xc:defmacro mumble-delete-from-end (pred)
`(do ((index (1- (the fixnum end)) (1- index)) ; Find the losers.
(losers ())
this-element
(terminus (1- start)))
- ((or (= index terminus) (= number-zapped (the fixnum count)))
+ ((or (= index terminus) (= number-zapped count))
(do ((losers losers) ; Delete the losers.
(index start (1+ index))
(jndex start))
(setf (aref sequence jndex) (aref sequence index))
(if (= index (the fixnum (car losers)))
(pop losers)
- (setq jndex (1+ jndex)))))
+ (incf jndex))))
(declare (fixnum index number-zapped terminus))
(setq this-element (aref sequence index))
(when ,pred
- (setq number-zapped (1+ number-zapped))
+ (incf number-zapped)
(push index losers))))
(sb!xc:defmacro normal-mumble-delete ()
(previous (nthcdr start handle))
(index start (1+ index))
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum end)) (= number-zapped count))
(cdr handle))
(declare (fixnum index number-zapped))
(cond (,pred
(rplacd previous (cdr current))
- (setq number-zapped (1+ number-zapped)))
+ (incf number-zapped))
(t
(setq previous (cdr previous)))))))
(previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
(index start (1+ index))
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum end)) (= number-zapped count))
(nreverse (cdr handle)))
(declare (fixnum index number-zapped))
(cond (,pred
(rplacd previous (cdr current))
- (setq number-zapped (1+ number-zapped)))
+ (incf number-zapped))
(t
(setq previous (cdr previous)))))))
) ; EVAL-WHEN
-(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
- end count key)
+(define-sequence-traverser delete
+ (item sequence &key from-end (test #'eql) test-not (start 0)
+ end count key)
#!+sb-doc
"Return a sequence formed by destructively removing the specified ITEM from
the given SEQUENCE."
(declare (fixnum start))
(let* ((length (length sequence))
- (end (or end length))
- (count (or count most-positive-fixnum)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(normal-list-delete-from-end)
) ; EVAL-WHEN
-(defun delete-if (predicate sequence &key from-end (start 0) key end count)
+(define-sequence-traverser delete-if
+ (predicate sequence &key from-end (start 0) key end count)
#!+sb-doc
"Return a sequence formed by destructively removing the elements satisfying
the specified PREDICATE from the given SEQUENCE."
(declare (fixnum start))
(let* ((length (length sequence))
- (end (or end length))
- (count (or count most-positive-fixnum)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-list-delete-from-end)
) ; EVAL-WHEN
-(defun delete-if-not (predicate sequence &key from-end (start 0) end key count)
+(define-sequence-traverser delete-if-not
+ (predicate sequence &key from-end (start 0) end key count)
#!+sb-doc
"Return a sequence formed by destructively removing the elements not
satisfying the specified PREDICATE from the given SEQUENCE."
(declare (fixnum start))
(let* ((length (length sequence))
- (end (or end length))
- (count (or count most-positive-fixnum)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-not-list-delete-from-end)
(number-zapped 0)
(this-element))
((or (= index (the fixnum ,finish))
- (= number-zapped (the fixnum count)))
+ (= number-zapped count))
(do ((index index (,bump index))
(new-index new-index (,bump new-index)))
((= index (the fixnum ,right)) (shrink-vector result new-index))
(setf (aref result new-index) (aref sequence index))))
(declare (fixnum index new-index number-zapped))
(setq this-element (aref sequence index))
- (cond (,pred (setq number-zapped (1+ number-zapped)))
+ (cond (,pred (incf number-zapped))
(t (setf (aref result new-index) this-element)
(setq new-index (,bump new-index))))))
`(let* ((sequence ,(if reverse?
'(reverse (the list sequence))
'sequence))
+ (%start ,(if reverse? '(- length end) 'start))
+ (%end ,(if reverse? '(- length start) 'end))
(splice (list nil))
(results (do ((index 0 (1+ index))
(before-start splice))
- ((= index (the fixnum start)) before-start)
+ ((= index (the fixnum %start)) before-start)
(declare (fixnum index))
(setq splice
(cdr (rplacd splice (list (pop sequence))))))))
- (do ((index start (1+ index))
+ (do ((index %start (1+ index))
(this-element)
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum %end)) (= number-zapped count))
(do ((index index (1+ index)))
((null sequence)
,(if reverse?
) ; EVAL-WHEN
-(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
- end count key)
+(define-sequence-traverser remove
+ (item sequence &key from-end (test #'eql) test-not (start 0)
+ end count key)
#!+sb-doc
"Return a copy of SEQUENCE with elements satisfying the test (default is
EQL) with ITEM removed."
(declare (fixnum start))
(let* ((length (length sequence))
- (end (or end length))
- (count (or count most-positive-fixnum)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(normal-list-remove-from-end)
(normal-mumble-remove-from-end)
(normal-mumble-remove)))))
-(defun remove-if (predicate sequence &key from-end (start 0) end count key)
+(define-sequence-traverser remove-if
+ (predicate sequence &key from-end (start 0) end count key)
#!+sb-doc
"Return a copy of sequence with elements such that predicate(element)
is non-null removed"
(declare (fixnum start))
(let* ((length (length sequence))
- (end (or end length))
- (count (or count most-positive-fixnum)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-list-remove-from-end)
(if-mumble-remove-from-end)
(if-mumble-remove)))))
-(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
+(define-sequence-traverser remove-if-not
+ (predicate sequence &key from-end (start 0) end count key)
#!+sb-doc
"Return a copy of sequence with elements such that predicate(element)
is null removed"
(declare (fixnum start))
(let* ((length (length sequence))
- (end (or end length))
- (count (or count most-positive-fixnum)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(seq-dispatch sequence
(if from-end
(if-not-list-remove-from-end)
(setq jndex (1+ jndex)))
(shrink-vector result jndex)))
-(defun remove-duplicates (sequence &key
- (test #'eql)
- test-not
- (start 0)
- from-end
- end
- key)
+(defun remove-duplicates
+ (sequence &key (test #'eql) test-not (start 0) from-end end key)
#!+sb-doc
"The elements of Sequence are compared pairwise, and if any two match,
the one occurring earlier is discarded, unless FROM-END is true, in
which case the one later in the sequence is discarded. The resulting
sequence is returned.
- The :TEST-NOT argument is depreciated."
+ The :TEST-NOT argument is deprecated."
(declare (fixnum start))
(seq-dispatch sequence
(if sequence
:end (if from-end jndex end) :test-not test-not)
(setq jndex (1+ jndex)))))
-(defun delete-duplicates (sequence &key
- (test #'eql)
- test-not
- (start 0)
- from-end
- end
- key)
+(defun delete-duplicates
+ (sequence &key (test #'eql) test-not (start 0) from-end end key)
#!+sb-doc
- "The elements of Sequence are examined, and if any two match, one is
+ "The elements of SEQUENCE are examined, and if any two match, one is
discarded. The resulting sequence, which may be formed by destroying the
given sequence, is returned.
- The :TEST-NOT argument is depreciated."
+ The :TEST-NOT argument is deprecated."
(seq-dispatch sequence
(if sequence
(list-delete-duplicates* sequence test test-not key from-end start end))
- (vector-delete-duplicates* sequence test test-not key from-end start end)))
+ (vector-delete-duplicates* sequence test test-not key from-end start end)))
\f
;;;; SUBSTITUTE
(funcall test old (apply-key key elt))))
(if (funcall test (apply-key key elt)))
(if-not (not (funcall test (apply-key key elt)))))
- (setq count (1- count))
+ (decf count)
new)
(t elt))))))
(setq list (cdr list)))
) ; EVAL-WHEN
-(defun substitute (new old sequence &key from-end (test #'eql) test-not
- (start 0) count end key)
+(define-sequence-traverser substitute
+ (new old sequence &key from-end (test #'eql) test-not
+ (start 0) count end key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements,
except that all elements equal to OLD are replaced with NEW. See manual
for details."
(declare (fixnum start))
(let* ((length (length sequence))
- (end (or end length))
- (count (or count most-positive-fixnum)))
- (declare (type index length end)
- (fixnum count))
+ (end (or end length)))
+ (declare (type index length end))
(subst-dispatch 'normal)))
\f
;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
-(defun substitute-if (new test sequence &key from-end (start 0) end count key)
+(define-sequence-traverser substitute-if
+ (new test sequence &key from-end (start 0) end count key)
#!+sb-doc
"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
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum))
test-not
old)
- (declare (type index length end)
- (fixnum count))
+ (declare (type index length end))
(subst-dispatch 'if)))
-(defun substitute-if-not (new test sequence &key from-end (start 0)
- end count key)
+(define-sequence-traverser substitute-if-not
+ (new test sequence &key from-end (start 0) end count key)
#!+sb-doc
"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.
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum))
test-not
old)
- (declare (type index length end)
- (fixnum count))
+ (declare (type index length end))
(subst-dispatch 'if-not)))
\f
;;;; NSUBSTITUTE
-(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not
- end count key (start 0))
+(define-sequence-traverser nsubstitute
+ (new old sequence &key from-end (test #'eql) test-not
+ end count key (start 0))
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements equal to OLD are replaced with NEW. The SEQUENCE
may be destructively modified. See manual for details."
(declare (fixnum start))
- (let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
- (declare (fixnum count))
+ (let ((end (or end (length sequence))))
(if (listp sequence)
(if from-end
- (nreverse (nlist-substitute*
- new old (nreverse (the list sequence))
- test test-not start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute*
+ new old (nreverse (the list sequence))
+ test test-not (- length end) (- length start)
+ count key)))
(nlist-substitute* new old sequence
test test-not start end count key))
(if from-end
\f
;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
-(defun nsubstitute-if (new test sequence &key from-end (start 0) end count key)
+(define-sequence-traverser nsubstitute-if
+ (new test sequence &key from-end (start 0) end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements satisfying the TEST are replaced with NEW.
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
- (let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
- (declare (fixnum end count))
+ (let ((end (or end (length sequence))))
+ (declare (fixnum end))
(if (listp sequence)
(if from-end
- (nreverse (nlist-substitute-if*
- new test (nreverse (the list sequence))
- start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if*
+ new test (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
(nlist-substitute-if* new test sequence
start end count key))
(if from-end
(setf (aref sequence index) new)
(setq count (1- count)))))
-(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
- end count key)
+(define-sequence-traverser nsubstitute-if-not
+ (new test sequence &key from-end (start 0) end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements not satisfying the TEST are replaced with NEW.
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
- (let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
- (declare (fixnum end count))
+ (let ((end (or end (length sequence))))
+ (declare (fixnum end))
(if (listp sequence)
(if from-end
- (nreverse (nlist-substitute-if-not*
- new test (nreverse (the list sequence))
- start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if-not*
+ new test (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
(nlist-substitute-if-not* new test sequence
start end count key))
(if from-end
((or (= index end) (null list) (= count 0)) sequence)
(when (not (funcall test (apply-key key (car list))))
(rplaca list new)
- (setq count (1- count)))))
+ (decf count))))
(defun nvector-substitute-if-not* (new test sequence incrementer
start end count key)
((or (= index end) (= count 0)) sequence)
(when (not (funcall test (apply-key key (aref sequence index))))
(setf (aref sequence index) new)
- (setq count (1- count)))))
+ (decf count))))
\f
;;;; FIND, POSITION, and their -IF and -IF-NOT variants
(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))))
(vector*-frob (sequence)
`(%find-position-if-vector-macro predicate ,sequence
from-end start end key)))
+ (frobs)))
+ (defun %find-position-if-not (predicate sequence-arg from-end start end key)
+ (macrolet ((frob (sequence from-end)
+ `(%find-position-if-not predicate ,sequence
+ ,from-end start end key))
+ (vector*-frob (sequence)
+ `(%find-position-if-not-vector-macro predicate ,sequence
+ from-end start end key)))
(frobs))))
;;; the user interface to FIND and POSITION: Get all our ducks in a
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 don'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
+;;; 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
;;; 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.
+;;; FIXME: Maybe remove uses of these deprecated functions (and
+;;; definitely of :TEST-NOT) within the implementation of SBCL.
+(declaim (inline find-if-not position-if-not))
(macrolet ((def-find-position-if-not (fun-name values-index)
`(defun ,fun-name (predicate sequence
&key from-end (start 0) end key)
(nth-value
,values-index
- (%find-position-if (complement (%coerce-callable-to-fun
- predicate))
- sequence
- from-end
- start
- end
- (effective-find-position-key key))))))
+ (%find-position-if-not (%coerce-callable-to-fun predicate)
+ sequence
+ from-end
+ start
+ end
+ (effective-find-position-key key))))))
+
(def-find-position-if-not find-if-not 0)
(def-find-position-if-not position-if-not 1))
-\f
-;;;; COUNT
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-count (item sequence)
- `(do ((index start (1+ index))
- (count 0))
- ((= index (the fixnum end)) count)
- (declare (fixnum index count))
- (if test-not
- (unless (funcall test-not ,item
- (apply-key key (aref ,sequence index)))
- (setq count (1+ count)))
- (when (funcall test ,item (apply-key key (aref ,sequence index)))
- (setq count (1+ count))))))
-
-(sb!xc:defmacro list-count (item sequence)
- `(do ((sequence (nthcdr start ,sequence))
- (index start (1+ index))
- (count 0))
- ((or (= index (the fixnum end)) (null sequence)) count)
- (declare (fixnum index count))
- (if test-not
- (unless (funcall test-not ,item (apply-key key (pop sequence)))
- (setq count (1+ count)))
- (when (funcall test ,item (apply-key key (pop sequence)))
- (setq count (1+ count))))))
-) ; EVAL-WHEN
-
-(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
+;;;; COUNT-IF, COUNT-IF-NOT, and COUNT
(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)))))
+(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-if (test sequence &key from-end (start 0) 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* ((length (length sequence))
+ (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)
#!+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* ((length (length sequence))
+ (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)))))
+
+(defun count (item sequence &key from-end (start 0) 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* ((length (length sequence))
+ (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
#!+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
projects / sbcl.git / blobdiff