\f
;;;; utilities
+(defun %check-generic-sequence-bounds (seq start end)
+ (let ((length (sb!sequence:length seq)))
+ (if (<= 0 start (or end length) length)
+ (or end length)
+ (sequence-bounding-indices-bad-error seq start end))))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *sequence-keyword-info*
nil
(if (<= 0 ,start ,length)
,start
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
index)
`(,end
nil
;; FIXME: defend against non-number non-NIL
;; stuff?
,end
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
(or null index)))))
'((start end length sequence)
(start1 end1 length1 sequence1)
;; This seems silly, is there something better?
'(integer 0 (0))))))
-(defun signal-bounding-indices-bad-error (sequence start end)
- (let ((length (length sequence)))
+(declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error))
+(defun sequence-bounding-indices-bad-error (sequence start end)
+ (let ((size (length sequence)))
(error 'bounding-indices-bad-error
:datum (cons start end)
- :expected-type `(cons (integer 0 ,length)
- (or null (integer ,start ,length)))
+ :expected-type `(cons (integer 0 ,size)
+ (integer ,start ,size))
:object sequence)))
+
+(declaim (ftype (function (t t t) nil) array-bounding-indices-bad-error))
+(defun array-bounding-indices-bad-error (array start end)
+ (let ((size (array-total-size array)))
+ (error 'bounding-indices-bad-error
+ :datum (cons start end)
+ :expected-type `(cons (integer 0 ,size)
+ (integer ,start ,size))
+ :object array)))
+
+(declaim (ftype (function (t) nil) circular-list-error))
+(defun circular-list-error (list)
+ (let ((*print-circle* t))
+ (error 'simple-type-error
+ :format-control "List is circular:~% ~S"
+ :format-arguments (list list)
+ :datum list
+ :type '(and list (satisfies list-length)))))
+
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
"Return a sequence of the given TYPE and LENGTH, with elements initialized
to INITIAL-ELEMENT."
(declare (fixnum length))
- (let* ((adjusted-type
- (typecase type
+ (let* ((expanded-type (typexpand type))
+ (adjusted-type
+ (typecase expanded-type
(atom (cond
- ((eq type 'string) '(vector character))
- ((eq type 'simple-string) '(simple-array character (*)))
+ ((eq expanded-type 'string) '(vector character))
+ ((eq expanded-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)
+ ((eq (car expanded-type) 'string) `(vector character ,@(cdr expanded-type)))
+ ((eq (car expanded-type) 'simple-string)
+ `(simple-array character ,(if (cdr expanded-type)
+ (cdr expanded-type)
'(*))))
(t type)))
(t type)))
;;;; so we worry about dealing with END being supplied or defaulting
;;;; to NIL at this level.
-(defun vector-subseq* (sequence start &optional end)
+(defun string-subseq* (sequence start end)
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :force-inline t
+ :check-fill-pointer t)
+ (declare (optimize (speed 3) (safety 0)))
+ (string-dispatch ((simple-array character (*))
+ (simple-array base-char (*))
+ (vector nil))
+ data
+ (subseq data start end))))
+
+(defun vector-subseq* (sequence start end)
(declare (type vector sequence))
- (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))))
- ((= old-index end) copy)
- (declare (fixnum old-index new-index))
- (setf (aref copy new-index)
- (aref sequence old-index))))
-
-(defun list-subseq* (sequence start &optional end)
- (declare (type list sequence))
- ;; 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)))))
+ (declare (type index start)
+ (type (or null index) end))
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :check-fill-pointer t
+ :force-inline t)
+ (let* ((copy (%make-sequence-like sequence (- end start)))
+ (setter (!find-data-vector-setter copy))
+ (reffer (!find-data-vector-reffer data)))
+ (declare (optimize (speed 3) (safety 0)))
+ (do ((old-index start (1+ old-index))
+ (new-index 0 (1+ new-index)))
+ ((= old-index end) copy)
+ (declare (index old-index new-index))
+ (funcall setter copy new-index
+ (funcall reffer data old-index))))))
+
+(defun list-subseq* (sequence start end)
+ (declare (type list sequence)
+ (type unsigned-byte start)
+ (type (or null unsigned-byte) end))
+ (flet ((oops ()
+ (sequence-bounding-indices-bad-error sequence start end)))
+ (let ((pointer sequence))
+ (unless (zerop start)
+ ;; If START > 0 the list cannot be empty. So CDR down to
+ ;; it START-1 times, check that we still have something, then
+ ;; CDR the final time.
+ ;;
+ ;; If START was zero, the list may be empty if END is NIL or
+ ;; also zero.
+ (when (> start 1)
+ (setf pointer (nthcdr (1- start) pointer)))
+ (if pointer
+ (pop pointer)
+ (oops)))
+ (if end
+ (let ((n (- end start)))
+ (declare (integer n))
+ (when (minusp n)
+ (oops))
+ (when (plusp n)
+ (let* ((head (list nil))
+ (tail head))
+ (macrolet ((pop-one ()
+ `(let ((tmp (list (pop pointer))))
+ (setf (cdr tail) tmp
+ tail tmp))))
+ ;; Bignum case
+ (loop until (fixnump n)
+ do (pop-one)
+ (decf n))
+ ;; Fixnum case, but leave last element, so we should
+ ;; still have something left in the sequence.
+ (let ((m (1- n)))
+ (declare (fixnum m))
+ (loop repeat m
+ do (pop-one)))
+ (unless pointer
+ (oops))
+ ;; OK, pop the last one.
+ (pop-one)
+ (cdr head)))))
+ (loop while pointer
+ collect (pop pointer))))))
(defun subseq (sequence start &optional end)
#!+sb-doc
\f
;;;; COPY-SEQ
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-copy-seq (sequence)
- `(let ((length (length (the vector ,sequence))))
- (declare (fixnum length))
- (do ((index 0 (1+ index))
- (copy (%make-sequence-like ,sequence length)))
- ((= index length) copy)
- (declare (fixnum index))
- (setf (aref copy index) (aref ,sequence index)))))
-
-(sb!xc:defmacro list-copy-seq (list)
- `(if (atom ,list) '()
- (let ((result (cons (car ,list) '()) ))
- (do ((x (cdr ,list) (cdr x))
- (splice result
- (cdr (rplacd splice (cons (car x) '() ))) ))
- ((atom x) (unless (null x)
- (rplacd splice x))
- result)))))
-
-) ; EVAL-WHEN
-
(defun copy-seq (sequence)
#!+sb-doc "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
(seq-dispatch sequence
(list-copy-seq* sequence)
- (vector-copy-seq* sequence)
+ (vector-subseq* sequence 0 nil)
(sb!sequence:copy-seq sequence)))
-;;; internal frobs
-
(defun list-copy-seq* (sequence)
- (list-copy-seq sequence))
-
-(defun vector-copy-seq* (sequence)
- (declare (type vector sequence))
- (vector-copy-seq sequence))
+ (!copy-list-macro sequence :check-proper-list t))
\f
;;;; FILL
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-fill (sequence item start end)
- `(do ((index ,start (1+ index)))
- ((= index (the fixnum ,end)) ,sequence)
- (declare (fixnum index))
- (setf (aref ,sequence index) ,item)))
-
-(sb!xc:defmacro list-fill (sequence item start end)
- `(do ((current (nthcdr ,start ,sequence) (cdr current))
- (index ,start (1+ index)))
- ((or (atom current) (and end (= index (the fixnum ,end))))
- sequence)
- (declare (fixnum index))
- (rplaca current ,item)))
-
-) ; EVAL-WHEN
-
-;;; The support routines for FILL are used by compiler transforms, so we
-;;; worry about dealing with END being supplied or defaulting to NIL
-;;; at this level.
-
(defun list-fill* (sequence item start end)
- (declare (list sequence))
- (list-fill sequence item start end))
+ (declare (type list sequence)
+ (type unsigned-byte start)
+ (type (or null unsigned-byte) end))
+ (flet ((oops ()
+ (sequence-bounding-indices-bad-error sequence start end)))
+ (let ((pointer sequence))
+ (unless (zerop start)
+ ;; If START > 0 the list cannot be empty. So CDR down to it
+ ;; START-1 times, check that we still have something, then CDR
+ ;; the final time.
+ ;;
+ ;; If START was zero, the list may be empty if END is NIL or
+ ;; also zero.
+ (unless (= start 1)
+ (setf pointer (nthcdr (1- start) pointer)))
+ (if pointer
+ (pop pointer)
+ (oops)))
+ (if end
+ (let ((n (- end start)))
+ (declare (integer n))
+ (when (minusp n)
+ (oops))
+ (when (plusp n)
+ (loop repeat n
+ do (setf pointer (cdr (rplaca pointer item))))))
+ (loop while pointer
+ do (setf pointer (cdr (rplaca pointer item)))))))
+ sequence)
(defun vector-fill* (sequence item start end)
- (declare (vector sequence))
- (when (null end) (setq end (length sequence)))
- (vector-fill sequence item start end))
-
-(define-sequence-traverser fill (sequence item &rest args &key start end)
- #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :force-inline t
+ :check-fill-pointer t)
+ (let ((setter (!find-data-vector-setter data)))
+ (declare (optimize (speed 3) (safety 0)))
+ (do ((index start (1+ index)))
+ ((= index end) sequence)
+ (declare (index index))
+ (funcall setter data index item)))))
+
+(defun string-fill* (sequence item start end)
+ (declare (string sequence))
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :force-inline t
+ :check-fill-pointer t)
+ ;; DEFTRANSFORM for FILL will turn these into
+ ;; calls to UB*-BASH-FILL.
+ (etypecase data
+ #!+sb-unicode
+ ((simple-array character (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the character item))))
+ (fill data item :start start :end end)))
+ ((simple-array base-char (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the base-char item))))
+ (fill data item :start start :end end))))))
+
+(defun fill (sequence item &key (start 0) end)
+ #!+sb-doc
+ "Replace the specified elements of SEQUENCE with ITEM."
(seq-dispatch sequence
- (list-fill* sequence item start end)
- (vector-fill* sequence item start end)
- (apply #'sb!sequence:fill sequence item args)))
+ (list-fill* sequence item start end)
+ (vector-fill* sequence item start end)
+ (sb!sequence:fill sequence item
+ :start start
+ :end (%check-generic-sequence-bounds sequence start end))))
\f
;;;; REPLACE
#!+sb-doc
"The target sequence is destructively modified by copying successive
elements into it from the source sequence."
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(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
,@decls
(tagbody
,@forms))))))))))
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro concatenate-to-list (sequences)
- `(let ((result (list nil)))
- (do ((sequences ,sequences (cdr sequences))
- (splice result))
- ((null sequences) (cdr result))
- (let ((sequence (car sequences)))
- (sb!sequence:dosequence (e sequence)
- (setq splice (cdr (rplacd splice (list e)))))))))
-
-(sb!xc:defmacro concatenate-to-mumble (output-type-spec sequences)
- `(do ((seqs ,sequences (cdr seqs))
- (total-length 0)
- (lengths ()))
- ((null seqs)
- (do ((sequences ,sequences (cdr sequences))
- (lengths lengths (cdr lengths))
- (index 0)
- (result (make-sequence ,output-type-spec total-length)))
- ((= index total-length) result)
- (declare (fixnum index))
- (let ((sequence (car sequences)))
- (sb!sequence:dosequence (e sequence)
- (setf (aref result index) e)
- (incf index)))))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (setq lengths (nconc lengths (list length)))
- (setq total-length (+ total-length length)))))
-
-) ; EVAL-WHEN
\f
(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."
- (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))
- ((and (csubtypep type (specifier-type 'sequence))
- (find-class output-type-spec nil))
- (coerce (apply #'concat-to-simple* 'vector sequences) output-type-spec))
- (t
- (bad-sequence-type-error output-type-spec)))))
-
-;;; internal frobs
-;;; FIXME: These are weird. They're never called anywhere except in
-;;; CONCATENATE. It seems to me that the macros ought to just
-;;; be expanded directly in CONCATENATE, or in CONCATENATE-STRING
-;;; and CONCATENATE-LIST variants. Failing that, these ought to be local
-;;; functions (FLET).
-(defun concat-to-list* (&rest sequences)
- (concatenate-to-list sequences))
-(defun concat-to-simple* (type &rest sequences)
- (concatenate-to-mumble type sequences))
+ (flet ((concat-to-list* (sequences)
+ (let ((result (list nil)))
+ (do ((sequences sequences (cdr sequences))
+ (splice result))
+ ((null sequences) (cdr result))
+ (let ((sequence (car sequences)))
+ (sb!sequence:dosequence (e sequence)
+ (setq splice (cdr (rplacd splice (list e)))))))))
+ (concat-to-simple* (type-spec sequences)
+ (do ((seqs sequences (cdr seqs))
+ (total-length 0)
+ (lengths ()))
+ ((null seqs)
+ (do ((sequences sequences (cdr sequences))
+ (lengths lengths (cdr lengths))
+ (index 0)
+ (result (make-sequence type-spec total-length)))
+ ((= index total-length) result)
+ (declare (fixnum index))
+ (let ((sequence (car sequences)))
+ (sb!sequence:dosequence (e sequence)
+ (setf (aref result index) e)
+ (incf index)))))
+ (let ((length (length (car seqs))))
+ (declare (fixnum length))
+ (setq lengths (nconc lengths (list length)))
+ (setq total-length (+ total-length length))))))
+ (let ((type (specifier-type output-type-spec)))
+ (cond
+ ((csubtypep type (specifier-type 'list))
+ (cond
+ ((type= type (specifier-type 'list))
+ (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)))
+ (concat-to-list* sequences))))
+ (t (sequence-type-too-hairy (type-specifier type)))))
+ ((csubtypep type (specifier-type 'vector))
+ (concat-to-simple* output-type-spec sequences))
+ ((and (csubtypep type (specifier-type 'sequence))
+ (find-class output-type-spec nil))
+ (coerce (concat-to-simple* 'vector sequences) output-type-spec))
+ (t
+ (bad-sequence-type-error output-type-spec))))))
+
+;;; Efficient out-of-line concatenate for strings. Compiler transforms
+;;; CONCATENATE 'STRING &co into these.
+(macrolet ((def (name element-type)
+ `(defun ,name (&rest sequences)
+ (declare (dynamic-extent sequences)
+ (optimize speed)
+ (optimize (sb!c::insert-array-bounds-checks 0)))
+ (let* ((lengths (mapcar #'length sequences))
+ (result (make-array (the integer (apply #'+ lengths))
+ :element-type ',element-type))
+ (start 0))
+ (declare (index start))
+ (dolist (seq sequences)
+ (string-dispatch
+ ((simple-array character (*))
+ (simple-array base-char (*))
+ t)
+ seq
+ (replace result seq :start1 start))
+ (incf start (the index (pop lengths))))
+ result))))
+ (def %concatenate-to-string character)
+ (def %concatenate-to-base-string base-char))
\f
;;;; MAP and MAP-INTO
(type list sequences))
(let ((result nil))
(flet ((f (&rest args)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(push (apply fun args) result)))
- (declare (dynamic-extent #'f))
+ (declare (truly-dynamic-extent #'f))
(%map-for-effect #'f sequences))
(nreverse result)))
(defun %map-to-vector (output-type-spec fun sequences)
(type list sequences))
(let ((min-len 0))
(flet ((f (&rest args)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(declare (ignore args))
(incf min-len)))
- (declare (dynamic-extent #'f))
+ (declare (truly-dynamic-extent #'f))
(%map-for-effect #'f sequences))
(let ((result (make-sequence output-type-spec min-len))
(i 0))
(declare (type (simple-array * (*)) result))
(flet ((f (&rest args)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(setf (aref result i) (apply fun args))
(incf i)))
- (declare (dynamic-extent #'f))
+ (declare (truly-dynamic-extent #'f))
(%map-for-effect #'f sequences))
result)))
(defun %map-to-sequence (result-type fun sequences)
(type list sequences))
(let ((min-len 0))
(flet ((f (&rest args)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(declare (ignore args))
(incf min-len)))
- (declare (dynamic-extent #'f))
+ (declare (truly-dynamic-extent #'f))
(%map-for-effect #'f sequences))
(let ((result (make-sequence result-type min-len)))
(multiple-value-bind (state limit from-end step endp elt setelt)
(sb!sequence:make-sequence-iterator result)
(declare (ignore limit endp elt))
(flet ((f (&rest args)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(funcall setelt (apply fun args) result state)
(setq state (funcall step result state from-end))))
- (declare (dynamic-extent #'f))
+ (declare (truly-dynamic-extent #'f))
(%map-for-effect #'f sequences)))
result)))
(define-sequence-traverser reduce (function sequence &rest args &key key
from-end start end (initial-value nil ivp))
(declare (type index start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((start start)
(end (or end length)))
(declare (type index start end))
"Return a sequence formed by destructively removing the specified ITEM from
the given SEQUENCE."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
"Return a sequence formed by destructively removing the elements satisfying
the specified PREDICATE from the given SEQUENCE."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
"Return a sequence formed by destructively removing the elements not
satisfying the specified PREDICATE from the given SEQUENCE."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
"Return a copy of SEQUENCE with elements satisfying the test (default is
EQL) with ITEM removed."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
#!+sb-doc
"Return a copy of sequence with elements satisfying PREDICATE removed."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
#!+sb-doc
"Return a copy of sequence with elements not satisfying PREDICATE removed."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
(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))
+ (if test-not
+ (position (apply-key key elt) result
+ :start start :end jndex
+ :test-not test-not :key key)
+ (position (apply-key key elt) result
+ :start start :end jndex
+ :test test :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)))
+ (if test-not
+ (position (apply-key key elt) vector
+ :start (1+ index) :end end
+ :test-not test-not :key key)
+ (position (apply-key key elt) vector
+ :start (1+ index) :end end
+ :test test :key key))))
(setf (aref result jndex) elt)
(setq jndex (1+ jndex)))
(setq index (1+ index)))
The :TEST-NOT argument is deprecated."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(if sequence
(list-remove-duplicates* sequence test test-not
(setf (aref vector jndex) (aref vector index))))
(declare (fixnum index jndex))
(setf (aref vector jndex) (aref vector index))
- (unless (position (apply-key key (aref vector index)) vector :key key
- :start (if from-end start (1+ index)) :test test
- :end (if from-end jndex end) :test-not test-not)
+ (unless (if test-not
+ (position (apply-key key (aref vector index)) vector :key key
+ :start (if from-end start (1+ index))
+ :end (if from-end jndex end)
+ :test-not test-not)
+ (position (apply-key key (aref vector index)) vector :key key
+ :start (if from-end start (1+ index))
+ :end (if from-end jndex end)
+ :test test))
(setq jndex (1+ jndex)))))
(define-sequence-traverser delete-duplicates
given sequence, is returned.
The :TEST-NOT argument is deprecated."
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(if sequence
(list-delete-duplicates* sequence test test-not
"Return a sequence of the same kind as SEQUENCE with the same elements,
except that all elements equal to OLD are replaced with NEW."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(subst-dispatch 'normal)))
#!+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."
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(declare (fixnum start))
(let ((end (or end length))
(test predicate)
#!+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."
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(declare (fixnum start))
(let ((end (or end length))
(test predicate)
except that all elements equal to OLD are replaced with NEW. SEQUENCE
may be destructively modified."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(seq-dispatch sequence
(if from-end
except that all elements satisfying PREDICATE are replaced with NEW.
SEQUENCE may be destructively modified."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (fixnum end))
(seq-dispatch sequence
except that all elements not satisfying PREDICATE are replaced with NEW.
SEQUENCE may be destructively modified."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length)))
(declare (fixnum end))
(seq-dispatch sequence
(frob sequence-arg from-end)
(with-array-data ((sequence sequence-arg :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds
- sequence-arg start end)))
+ (end end)
+ :check-fill-pointer t)
(multiple-value-bind (f p)
(macrolet ((frob2 () '(if from-end
(frob sequence t)
(frob sequence nil))))
(typecase sequence
- (simple-vector (frob2))
- (simple-base-string (frob2))
+ #!+sb-unicode
+ ((simple-array character (*)) (frob2))
+ ((simple-array base-char (*)) (frob2))
(t (vector*-frob sequence))))
(declare (type (or index null) p))
(values f (and p (the index (- p offset)))))))))
(defun find
(item sequence &rest args &key from-end (start 0) end key test test-not)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(nth-value 0 (%find-position
item sequence from-end start end
(apply #'sb!sequence:find item sequence args)))
(defun position
(item sequence &rest args &key from-end (start 0) end key test test-not)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(nth-value 1 (%find-position
item sequence from-end start end
(apply #'sb!sequence:position item sequence args)))
(defun find-if (predicate sequence &rest args &key from-end (start 0) end key)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(nth-value 0 (%find-position-if
(%coerce-callable-to-fun predicate)
(apply #'sb!sequence:find-if predicate sequence args)))
(defun position-if
(predicate sequence &rest args &key from-end (start 0) end key)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(nth-value 1 (%find-position-if
(%coerce-callable-to-fun predicate)
(defun find-if-not
(predicate sequence &rest args &key from-end (start 0) end key)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(nth-value 0 (%find-position-if-not
(%coerce-callable-to-fun predicate)
(apply #'sb!sequence:find-if-not predicate sequence args)))
(defun position-if-not
(predicate sequence &rest args &key from-end (start 0) end key)
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
(nth-value 1 (%find-position-if-not
(%coerce-callable-to-fun predicate)
#!+sb-doc
"Return the number of elements in SEQUENCE satisfying PRED(el)."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length))
(pred (%coerce-callable-to-fun pred)))
(declare (type index end))
#!+sb-doc
"Return the number of elements in SEQUENCE not satisfying TEST(el)."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end (or end length))
(pred (%coerce-callable-to-fun pred)))
(declare (type index end))
"Return the number of elements in SEQUENCE satisfying a test with ITEM,
which defaults to EQL."
(declare (fixnum start))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(when (and test-p test-not-p)
;; ANSI Common Lisp has left the behavior in this situation unspecified.
;; (CLHS 17.2.1)
: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))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let* ((end1 (or end1 length1))
(end2 (or end2 length2)))
(declare (type index end1 end2))
(sequence1 sequence2 &rest args &key
from-end test test-not start1 end1 start2 end2 key)
(declare (fixnum start1 start2))
- (declare (dynamic-extent args))
+ (declare (truly-dynamic-extent args))
(let ((end1 (or end1 length1))
(end2 (or end2 length2)))
(seq-dispatch sequence2
(vector-search sequence2 sequence1)
(apply #'sb!sequence:search sequence1 sequence2 args))))
-(sb!xc:defmacro string-dispatch ((&rest types) var &body body)
- (let ((fun (gensym "STRING-DISPATCH-FUN-")))
- `(flet ((,fun (,var)
- ,@body))
- (declare (inline ,fun))
- (etypecase ,var
- ,@(loop for type in types
- collect `(,type (,fun (the ,type ,var))))))))
-
;;; FIXME: this was originally in array.lisp; it might be better to
;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
;;; a new early-seq.lisp file.
axis (car dims) contents (length contents)))
(sb!sequence:dosequence (content contents)
(frob (1+ axis) (cdr dims) content))))))
- (frob 0 dimensions initial-contents))))
\ No newline at end of file
+ (frob 0 dimensions initial-contents))))
projects / sbcl.git / blobdiff