'((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 t)
+ (parse-body body :doc-string-allowed t)
(collect ((new-args) (new-declarations) (adjustments))
(dolist (arg args)
(case arg
(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))
(cond
((type= type (specifier-type 'list))
(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)))
+ ((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
- (array-type-specialized-element-type type)))
- (etype (if (eq etype '*) t etype))
+ (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))
- (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))))
+ (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
(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))
+#!+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
(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 (endp 1st) 1st (cdr 1st)))
(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)))
+ (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))
) ; EVAL-WHEN
(define-sequence-traverser delete
- (item sequence &key from-end (test #'eql) test-not start
+ (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
) ; EVAL-WHEN
(define-sequence-traverser remove
- (item sequence &key from-end (test #'eql) test-not start
+ (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
(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))
(shrink-vector result jndex)))
(define-sequence-traverser remove-duplicates
- (sequence &key (test #'eql) test-not (start 0) end from-end key)
+ (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 one occurring earlier is discarded, unless FROM-END is true, in
(setq jndex (1+ jndex)))))
(define-sequence-traverser delete-duplicates
- (sequence &key (test #'eql) test-not (start 0) end from-end key)
+ (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
discarded. The resulting sequence, which may be formed by destroying the
) ; EVAL-WHEN
(define-sequence-traverser substitute
- (new old sequence &key from-end (test #'eql) test-not
+ (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,
;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
(define-sequence-traverser substitute-if
- (new test sequence &key from-end start end count key)
+ (new pred 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
+ except that all elements satisfying the PRED are replaced with NEW. See
manual for details."
(declare (fixnum start))
(let ((end (or end length))
+ (test pred)
test-not
old)
(declare (type index length end))
(subst-dispatch 'if)))
(define-sequence-traverser substitute-if-not
- (new test sequence &key from-end start end count key)
+ (new pred 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.
+ except that all elements not satisfying the PRED are replaced with NEW.
See manual for details."
(declare (fixnum start))
(let ((end (or end length))
+ (test pred)
test-not
old)
(declare (type index length end))
;;;; NSUBSTITUTE
(define-sequence-traverser nsubstitute
- (new old sequence &key from-end (test #'eql) test-not
+ (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
;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
(define-sequence-traverser nsubstitute-if
- (new test sequence &key from-end start end count key)
+ (new pred 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.
+ except that all elements satisfying the PRED are replaced with NEW.
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end length)))
(if from-end
(let ((length (length sequence)))
(nreverse (nlist-substitute-if*
- new test (nreverse (the list sequence))
+ new pred (nreverse (the list sequence))
(- length end) (- length start) count key)))
- (nlist-substitute-if* new test sequence
+ (nlist-substitute-if* new pred sequence
start end count key))
(if from-end
- (nvector-substitute-if* new test sequence -1
+ (nvector-substitute-if* new pred sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if* new test sequence 1
+ (nvector-substitute-if* new pred sequence 1
start end count key)))))
(defun nlist-substitute-if* (new test sequence start end count key)
(setq count (1- count)))))
(define-sequence-traverser nsubstitute-if-not
- (new test sequence &key from-end start end count key)
+ (new pred 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.
(if from-end
(let ((length (length sequence)))
(nreverse (nlist-substitute-if-not*
- new test (nreverse (the list sequence))
+ new pred (nreverse (the list sequence))
(- length end) (- length start) count key)))
- (nlist-substitute-if-not* new test sequence
+ (nlist-substitute-if-not* new pred sequence
start end count key))
(if from-end
- (nvector-substitute-if-not* new test sequence -1
+ (nvector-substitute-if-not* new pred sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if-not* new test sequence 1
+ (nvector-substitute-if-not* new pred sequence 1
start end count key)))))
(defun nlist-substitute-if-not* (new test sequence start end count key)
(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
) ; EVAL-WHEN
-(define-sequence-traverser count-if (test sequence &key from-end start 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 TEST(el)."
+ "Return the number of elements in SEQUENCE satisfying PRED(el)."
(declare (fixnum start))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
(if from-end
- (list-count-if nil t test sequence)
- (list-count-if nil nil test sequence))
+ (list-count-if nil t pred sequence)
+ (list-count-if nil nil pred sequence))
(if from-end
- (vector-count-if nil t test sequence)
- (vector-count-if nil nil test sequence)))))
+ (vector-count-if nil t pred sequence)
+ (vector-count-if nil nil pred sequence)))))
(define-sequence-traverser count-if-not
- (test sequence &key from-end start end key)
+ (pred sequence &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE not satisfying TEST(el)."
(declare (fixnum start))
(declare (type index end))
(seq-dispatch sequence
(if from-end
- (list-count-if t t test sequence)
- (list-count-if t nil test sequence))
+ (list-count-if t t pred sequence)
+ (list-count-if t nil pred sequence))
(if from-end
- (vector-count-if t t test sequence)
- (vector-count-if t nil test sequence)))))
+ (vector-count-if t t pred sequence)
+ (vector-count-if t nil pred sequence)))))
(define-sequence-traverser count
(item sequence &key from-end start end
(define-sequence-traverser mismatch
(sequence1 sequence2
- &key from-end (test #'eql) test-not
+ &key from-end test test-not
start1 end1 start2 end2 key)
#!+sb-doc
"The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
`(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)
(define-sequence-traverser search
(sequence1 sequence2
- &key from-end (test #'eql) test-not
+ &key from-end test test-not
start1 end1 start2 end2 key)
(declare (fixnum start1 start2))
(let ((end1 (or end1 length1))
projects / sbcl.git / blobdiff