(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
(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
(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
(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))
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
(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 ((end (or end length)))
(declare (type index end))
(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 ((end (or end length)))
(declare (type index 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))
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 ((end (or end length)))
(declare (type index end))
;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
(define-sequence-traverser substitute-if
- (new pred sequence &key from-end start end count key)
+ (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 PRED are replaced with NEW. See
- manual for details."
+ except that all elements satisfying the PRED are replaced with NEW."
(declare (fixnum start))
(let ((end (or end length))
- (test pred)
- test-not
+ (test predicate)
+ (test-not nil)
old)
(declare (type index length end))
(subst-dispatch 'if)))
(define-sequence-traverser substitute-if-not
- (new pred sequence &key from-end start end count key)
+ (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 PRED are replaced with NEW.
- See manual for details."
+ except that all elements not satisfying the PRED are replaced with NEW."
(declare (fixnum start))
(let ((end (or end length))
- (test pred)
- test-not
+ (test predicate)
+ (test-not nil)
old)
(declare (type index length end))
(subst-dispatch 'if-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)))
(if (listp sequence)
;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
(define-sequence-traverser nsubstitute-if
- (new pred sequence &key from-end start end count key)
+ (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 PRED 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)))
(declare (fixnum end))
(if from-end
(let ((length (length sequence)))
(nreverse (nlist-substitute-if*
- new pred (nreverse (the list sequence))
+ new predicate (nreverse (the list sequence))
(- length end) (- length start) count key)))
- (nlist-substitute-if* new pred sequence
+ (nlist-substitute-if* new predicate sequence
start end count key))
(if from-end
- (nvector-substitute-if* new pred sequence -1
+ (nvector-substitute-if* new predicate sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if* new pred sequence 1
+ (nvector-substitute-if* new predicate 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 pred sequence &key from-end start end count key)
+ (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)))
(declare (fixnum end))
(if from-end
(let ((length (length sequence)))
(nreverse (nlist-substitute-if-not*
- new pred (nreverse (the list sequence))
+ new predicate (nreverse (the list sequence))
(- length end) (- length start) count key)))
- (nlist-substitute-if-not* new pred sequence
+ (nlist-substitute-if-not* new predicate sequence
start end count key))
(if from-end
- (nvector-substitute-if-not* new pred sequence -1
+ (nvector-substitute-if-not* new predicate sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if-not* new pred 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)
(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
#!+sb-doc
"Return the number of elements in SEQUENCE satisfying PRED(el)."
(declare (fixnum start))
- (let ((end (or end length)))
+ (let ((end (or end length))
+ (pred (%coerce-callable-to-fun pred)))
(declare (type index end))
(seq-dispatch sequence
(if from-end
#!+sb-doc
"Return the number of elements in SEQUENCE not satisfying TEST(el)."
(declare (fixnum start))
- (let ((end (or end length)))
+ (let ((end (or end length))
+ (pred (%coerce-callable-to-fun pred)))
(declare (type index end))
(seq-dispatch sequence
(if from-end
projects / sbcl.git / blobdiff