: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
`(integer 0 ,max-end)
;; This seems silly, is there something better?
'(integer (0) 0)))))
+
+(declaim (inline adjust-count)
+ (ftype (function (sequence-count) index) adjust-count))
+(defun adjust-count (count)
+ (cond ((not count) most-positive-fixnum)
+ ((< count 0) 0)
+ (t count)))
+
\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))
+ (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)
;; KLUDGE: the above test essentially asks "Do we know
(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))))
+ (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
(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)))))
+ (sequence-type-too-hairy (type-specifier type))))
(t (bad-sequence-type-error (type-specifier type))))))
\f
;;;; SUBSEQ
(if (null end)
(setf end (length sequence))
(unless (<= end (length sequence))
- (signal-index-too-large-error sequence end)))
+ (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))))
(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)
(list-reverse-macro sequence))
(defun vector-reverse* (sequence)
- (vector-reverse sequence (type-of sequence)))
+ (vector-reverse sequence))
\f
;;;; NREVERSE
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. 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))
- ((csubtypep type (specifier-type 'list))
- (apply #'concat-to-list* sequences))
(t
(bad-sequence-type-error output-type-spec)))))
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
`(let* ((sequence ,(if reverse?
'(reverse (the list sequence))
'sequence))
+ (%start ,(if reverse? '(- length end) 'start))
+ (%end ,(if reverse? '(- length start) 'end))
(splice (list nil))
(results (do ((index 0 (1+ index))
(before-start splice))
- ((= index (the fixnum start)) before-start)
+ ((= index (the fixnum %start)) before-start)
(declare (fixnum index))
(setq splice
(cdr (rplacd splice (list (pop sequence))))))))
- (do ((index start (1+ index))
+ (do ((index %start (1+ index))
(this-element)
(number-zapped 0))
- ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ ((or (= index (the fixnum %end)) (= number-zapped (the fixnum count)))
(do ((index index (1+ index)))
((null sequence)
,(if reverse?
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(seq-dispatch sequence
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
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))
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (type index length end)
(fixnum count))
(subst-dispatch 'normal)))
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum))
+ (count (adjust-count count))
test-not
old)
(declare (type index length end)
(declare (fixnum start))
(let* ((length (length sequence))
(end (or end length))
- (count (or count most-positive-fixnum))
+ (count (adjust-count count))
test-not
old)
(declare (type index length end)
may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (fixnum count))
(if (listp sequence)
(if from-end
- (nreverse (nlist-substitute*
- new old (nreverse (the list sequence))
- test test-not start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute*
+ new old (nreverse (the list sequence))
+ test test-not (- length end) (- length start)
+ count key)))
(nlist-substitute* new old sequence
test test-not start end count key))
(if from-end
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (fixnum end count))
(if (listp sequence)
(if from-end
- (nreverse (nlist-substitute-if*
- new test (nreverse (the list sequence))
- start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if*
+ new test (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
(nlist-substitute-if* new test sequence
start end count key))
(if from-end
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end (length sequence)))
- (count (or count most-positive-fixnum)))
+ (count (adjust-count count)))
(declare (fixnum end count))
(if (listp sequence)
(if from-end
- (nreverse (nlist-substitute-if-not*
- new test (nreverse (the list sequence))
- start end count key))
+ (let ((length (length sequence)))
+ (nreverse (nlist-substitute-if-not*
+ new test (nreverse (the list sequence))
+ (- length end) (- length start) count key)))
(nlist-substitute-if-not* new test sequence
start end count key))
(if from-end
;;; 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
(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