\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)))
+ (t type)))))
(type (specifier-type adjusted-type)))
(cond ((csubtypep type (specifier-type 'list))
(cond
\f
;;;; SUBSEQ
;;;;
+
+(define-array-dispatch vector-subseq-dispatch (array start end)
+ (declare (optimize speed (safety 0)))
+ (declare (type index start end))
+ (subseq array start end))
+
;;;; 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)
+(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))))
+ (declare (type index start)
+ (type (or null index) end)
+ (optimize speed))
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :check-fill-pointer t
+ :force-inline t)
+ (vector-subseq-dispatch data start end)))
(defun list-subseq* (sequence start end)
(declare (type list sequence)
(type unsigned-byte start)
(type (or null unsigned-byte) end))
(flet ((oops ()
- (signal-bounding-indices-bad-error sequence start end)))
+ (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
\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
(define-sequence-traverser replace
(sequence1 sequence2 &rest args &key start1 end1 start2 end2)
#!+sb-doc
- "The target sequence is destructively modified by copying successive
- elements into it from the source sequence."
- (declare (dynamic-extent args))
+ "Destructively modifies SEQUENCE1 by copying successive elements
+into it from the SEQUENCE2.
+
+Elements are copied to the subseqeuence bounded by START1 and END1,
+from the subsequence bounded by START2 and END2. If these subsequences
+are not of the same length, then the shorter length determines how
+many elements are copied."
+ (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
(let ((,sequence ,s))
(seq-dispatch ,sequence
(dolist (,e ,sequence ,return) ,@body)
- (dovector (,e ,sequence ,return) ,@body)
+ (do-vector-data (,e ,sequence ,return) ,@body)
(multiple-value-bind (state limit from-end step endp elt)
(sb!sequence:make-sequence-iterator ,sequence)
(do ((state state (funcall step ,sequence state from-end)))
,@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
+;;;; MAP
;;; helper functions to handle arity-1 subcases of MAP
(declaim (ftype (function (function sequence) list) %map-list-arity-1))
(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)))
first-sequence
more-sequences))
-;;; KLUDGE: MAP has been rewritten substantially since the fork from
-;;; CMU CL in order to give reasonable performance, but this
-;;; implementation of MAP-INTO still has the same problems as the old
-;;; MAP code. Ideally, MAP-INTO should be rewritten to be efficient in
-;;; the same way that the corresponding cases of MAP have been
-;;; rewritten. Instead of doing it now, though, it's easier to wait
-;;; until we have DYNAMIC-EXTENT, at which time it should become
-;;; extremely easy to define a reasonably efficient MAP-INTO in terms
-;;; of (MAP NIL ..). -- WHN 20000920
+;;;; MAP-INTO
+
+(defmacro map-into-lambda (sequences params &body body)
+ (check-type sequences symbol)
+ `(flet ((f ,params ,@body))
+ (declare (truly-dynamic-extent #'f))
+ ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a different animal,
+ ;; hence the awkward flip between MAP and LOOP.
+ (if ,sequences
+ (apply #'map nil #'f ,sequences)
+ (loop (f)))))
+
+(define-array-dispatch vector-map-into (data start end fun sequences)
+ (declare (optimize speed (safety 0))
+ (type index start end)
+ (type function fun)
+ (type list sequences))
+ (let ((index start))
+ (declare (type index index))
+ (block mapping
+ (map-into-lambda sequences (&rest args)
+ (declare (truly-dynamic-extent args))
+ (when (eql index end)
+ (return-from mapping))
+ (setf (aref data index) (apply fun args))
+ (incf index)))
+ index))
+
+;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid
+;;; computing the length of the result sequence since we can detect
+;;; the end during mapping (if MAP even gets that far).
+;;;
+;;; For each result type, define a mapping function which is
+;;; responsible for replacing RESULT-SEQUENCE elements and for
+;;; terminating itself if the end of RESULT-SEQUENCE is reached.
+;;; The mapping function is defined with MAP-INTO-LAMBDA.
+;;;
+;;; MAP-INTO-LAMBDAs are optimized since they are the inner loops.
+;;; Because we are manually doing bounds checking with known types,
+;;; safety is turned off for vectors and lists but kept for generic
+;;; sequences.
(defun map-into (result-sequence function &rest sequences)
- (let* ((fp-result
- (and (arrayp result-sequence)
- (array-has-fill-pointer-p result-sequence)))
- (len (apply #'min
- (if fp-result
- (array-dimension result-sequence 0)
- (length result-sequence))
- (mapcar #'length sequences))))
-
- (when fp-result
- (setf (fill-pointer result-sequence) len))
-
- (let ((really-fun (%coerce-callable-to-fun function)))
- (dotimes (index len)
- (setf (elt result-sequence index)
- (apply really-fun
- (mapcar (lambda (seq) (elt seq index))
- sequences))))))
+ (let ((really-fun (%coerce-callable-to-fun function)))
+ (etypecase result-sequence
+ (vector
+ (with-array-data ((data result-sequence) (start) (end)
+ ;; MAP-INTO ignores fill pointer when mapping
+ :check-fill-pointer nil)
+ (let ((new-end (vector-map-into data start end really-fun sequences)))
+ (when (array-has-fill-pointer-p result-sequence)
+ (setf (fill-pointer result-sequence) (- new-end start))))))
+ (list
+ (let ((node result-sequence))
+ (declare (type list node))
+ (map-into-lambda sequences (&rest args)
+ (declare (truly-dynamic-extent args)
+ (optimize speed (safety 0)))
+ (when (null node)
+ (return-from map-into result-sequence))
+ (setf (car node) (apply really-fun args))
+ (setf node (cdr node)))))
+ (sequence
+ (multiple-value-bind (iter limit from-end)
+ (sb!sequence:make-sequence-iterator result-sequence)
+ (map-into-lambda sequences (&rest args)
+ (declare (truly-dynamic-extent args) (optimize speed))
+ (when (sb!sequence:iterator-endp result-sequence
+ iter limit from-end)
+ (return-from map-into result-sequence))
+ (setf (sb!sequence:iterator-element result-sequence iter)
+ (apply really-fun args))
+ (setf iter (sb!sequence:iterator-step result-sequence
+ iter from-end)))))))
result-sequence)
\f
;;;; quantifiers
;; from the old seq.lisp into target-seq.lisp.
(define-compiler-macro ,name (pred first-seq &rest more-seqs)
(let ((elements (make-gensym-list (1+ (length more-seqs))))
- (blockname (gensym "BLOCK")))
+ (blockname (sb!xc:gensym "BLOCK")))
(once-only ((pred pred))
`(block ,blockname
(map nil
(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
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
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
- (let ((length (length sequence)))
- (nreverse (nlist-substitute*
- new old (nreverse (the list sequence))
- test test-not (- length end) (- length start)
- count key)))
+ (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
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
(if from-end
- (let ((length (length sequence)))
- (nreverse (nlist-substitute-if*
- new predicate (nreverse (the list sequence))
- (- length end) (- length start) count key)))
+ (nreverse (nlist-substitute-if*
+ new predicate (nreverse (the list sequence))
+ (- length end) (- length start) count key))
(nlist-substitute-if* new predicate sequence
start end count key))
(if from-end
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
(if from-end
- (let ((length (length sequence)))
- (nreverse (nlist-substitute-if-not*
- new predicate (nreverse (the list sequence))
- (- length end) (- length start) count key)))
+ (nreverse (nlist-substitute-if-not*
+ new predicate (nreverse (the list sequence))
+ (- length end) (- length start) count key))
(nlist-substitute-if-not* new predicate sequence
start end count key))
(if from-end
(macrolet (;; shared logic for defining %FIND-POSITION and
;; %FIND-POSITION-IF in terms of various inlineable cases
;; of the expression defined in FROB and VECTOR*-FROB
- (frobs ()
+ (frobs (&optional bit-frob)
`(seq-dispatch sequence-arg
(frob sequence-arg from-end)
(with-array-data ((sequence sequence-arg :offset-var offset)
(end end)
:check-fill-pointer t)
(multiple-value-bind (f p)
- (macrolet ((frob2 () '(if from-end
- (frob sequence t)
- (frob sequence nil))))
+ (macrolet ((frob2 () `(if from-end
+ (frob sequence t)
+ (frob sequence nil))))
(typecase sequence
- (simple-vector (frob2))
- (simple-base-string (frob2))
- (t (vector*-frob sequence))))
+ #!+sb-unicode
+ ((simple-array character (*)) (frob2))
+ ((simple-array base-char (*)) (frob2))
+ ,@(when bit-frob
+ `((simple-bit-vector
+ (if (and (typep item 'bit)
+ (eq #'identity key)
+ (or (eq #'eq test)
+ (eq #'eql test)
+ (eq #'equal test)))
+ (let ((p (%bit-position item sequence
+ from-end start end)))
+ (if p
+ (values item p)
+ (values nil nil)))
+ (vector*-frob sequence)))))
+ (t
+ (vector*-frob sequence))))
(declare (type (or index null) p))
(values f (and p (the index (- p offset)))))))))
(defun %find-position (item sequence-arg from-end start end key test)
(vector*-frob (sequence)
`(%find-position-vector-macro item ,sequence
from-end start end key test)))
- (frobs)))
+ (frobs t)))
(defun %find-position-if (predicate sequence-arg from-end start end key)
(macrolet ((frob (sequence from-end)
`(%find-position-if predicate ,sequence
(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
projects / sbcl.git / blobdiff