\f
;;;; utilities
-(eval-when (:compile-toplevel)
+(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*
;; (name default supplied-p adjustment new-type)
0
(1- most-positive-fixnum))))
(mod #.sb!xc:most-positive-fixnum))
+ ;; Entries for {start,end}{,1,2}
,@(mapcan (lambda (names)
(destructuring-bind (start end length sequence) names
(list
`(,start
0
nil
- (if (<= 0 ,start ,length)
+ ;; Only evaluate LENGTH (which may be expensive)
+ ;; if START is non-NIL.
+ (if (or (zerop ,start) (<= 0 ,start ,length))
,start
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
index)
- `(,end
- nil
- nil
- (if (or (null ,end) (<= ,start ,end ,length))
- ;; Defaulting of NIL is done inside the
- ;; bodies, for ease of sharing with compiler
- ;; transforms.
- ;;
- ;; FIXME: defend against non-number non-NIL
- ;; stuff?
- ,end
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
- (or null index)))))
+ `(,end
+ nil
+ nil
+ ;; Only evaluate LENGTH (which may be expensive)
+ ;; if END is non-NIL.
+ (if (or (null ,end) (<= ,start ,end ,length))
+ ;; Defaulting of NIL is done inside the
+ ;; bodies, for ease of sharing with compiler
+ ;; transforms.
+ ;;
+ ;; FIXME: defend against non-number non-NIL
+ ;; stuff?
+ ,end
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
+ (or null index)))))
'((start end length sequence)
(start1 end1 length1 sequence1)
(start2 end2 length2 sequence2)))
(test-not nil
nil
(and test-not (%coerce-callable-to-fun test-not))
- (or null function))
- ))
+ (or null function))))
(sb!xc:defmacro define-sequence-traverser (name args &body body)
(multiple-value-bind (body declarations docstring)
(parse-body body :doc-string-allowed t)
- (collect ((new-args) (new-declarations) (adjustments))
+ (collect ((new-args)
+ (new-declarations)
+ ;; Things which are definitely used in any code path.
+ (rebindings/eager)
+ ;; Things which may be used/are only used in certain
+ ;; code paths (e.g. length).
+ (rebindings/lazy))
(dolist (arg args)
(case arg
;; FIXME: make this robust. And clean.
- ((sequence)
- (new-args arg)
- (adjustments '(length (etypecase sequence
- (list (length sequence))
- (vector (length sequence)))))
- (new-declarations '(type index length)))
- ((sequence1)
- (new-args arg)
- (adjustments '(length1 (etypecase sequence1
- (list (length sequence1))
- (vector (length sequence1)))))
- (new-declarations '(type index length1)))
- ((sequence2)
- (new-args arg)
- (adjustments '(length2 (etypecase sequence2
- (list (length sequence2))
- (vector (length sequence2)))))
- (new-declarations '(type index length2)))
+ ((sequence sequence1 sequence2)
+ (let* ((length-var (ecase arg
+ (sequence 'length)
+ (sequence1 'length1)
+ (sequence2 'length2)))
+ (cache-var (symbolicate length-var '#:-cache)))
+ (new-args arg)
+ (rebindings/eager `(,cache-var nil))
+ (rebindings/lazy
+ `(,length-var (truly-the
+ index
+ (or ,cache-var (setf ,cache-var (length ,arg))))))))
((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
- (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
- (adjustments `(,arg ,adjuster))
- (new-declarations `(type ,type ,arg))))
- (t (new-args arg)))))))
+ (rebindings/eager `(,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
+ (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
+ (rebindings/eager `(,arg ,adjuster))
+ (new-declarations `(type ,type ,arg))))
+ (t (new-args arg)))))))
`(defun ,name ,(new-args)
,@(when docstring (list docstring))
,@declarations
- (let* (,@(adjustments))
- (declare ,@(new-declarations))
- ,@body)))))
+ (symbol-macrolet (,@(rebindings/lazy))
+ (let* (,@(rebindings/eager))
+ (declare ,@(new-declarations))
+ ,@body
+ ))))))
;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE.
;;;
;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR.
;;; It tends to make code run faster but be bigger; some benchmarking
;;; is needed to decide.
-(sb!xc:defmacro seq-dispatch (sequence list-form array-form)
+(sb!xc:defmacro seq-dispatch
+ (sequence list-form array-form &optional other-form)
`(if (listp ,sequence)
- ,list-form
- ,array-form))
-
-(sb!xc:defmacro make-sequence-like (sequence length)
+ (let ((,sequence (truly-the list ,sequence)))
+ (declare (ignorable ,sequence))
+ ,list-form)
+ ,@(if other-form
+ `((if (arrayp ,sequence)
+ (let ((,sequence (truly-the vector ,sequence)))
+ (declare (ignorable ,sequence))
+ ,array-form)
+ ,other-form))
+ `((let ((,sequence (truly-the vector ,sequence)))
+ (declare (ignorable ,sequence))
+ ,array-form)))))
+
+(sb!xc:defmacro %make-sequence-like (sequence length)
#!+sb-doc
"Return a sequence of the same type as SEQUENCE and the given LENGTH."
- `(if (typep ,sequence 'list)
- (make-list ,length)
- (progn
- ;; This is only called from places which have already deduced
- ;; that the SEQUENCE argument is actually a sequence. So
- ;; this would be a candidate place for (AVER (TYPEP ,SEQUENCE
- ;; 'VECTOR)), except that this seems to be a performance
- ;; hotspot.
- (make-array ,length
- :element-type (array-element-type ,sequence)))))
+ `(seq-dispatch ,sequence
+ (make-list ,length)
+ (make-array ,length :element-type (array-element-type ,sequence))
+ (sb!sequence:make-sequence-like ,sequence ,length)))
(sb!xc:defmacro bad-sequence-type-error (type-spec)
`(error 'simple-type-error
:datum ,type-spec
- ;; FIXME: This is actually wrong, and should be something
- ;; like (SATISFIES IS-A-VALID-SEQUENCE-TYPE-SPECIFIER-P).
- :expected-type 'sequence
+ :expected-type '(satisfies is-a-valid-sequence-type-specifier-p)
:format-control "~S is a bad type specifier for sequences."
:format-arguments (list ,type-spec)))
;; ANSI. Essentially, we are justified in throwing this on
;; e.g. '(OR SIMPLE-VECTOR (VECTOR FIXNUM)), but maybe not (by ANSI)
;; on '(CONS * (CONS * NULL)) -- CSR, 2002-10-18
- `(error 'simple-type-error
- :datum ,type-spec
- ;; FIXME: as in BAD-SEQUENCE-TYPE-ERROR, this is wrong.
- :expected-type 'sequence
+
+ ;; On the other hand, I'm not sure it deserves to be a type-error,
+ ;; either. -- bem, 2005-08-10
+ `(error 'simple-program-error
:format-control "~S is too hairy for sequence functions."
:format-arguments (list ,type-spec)))
) ; EVAL-WHEN
+(defun is-a-valid-sequence-type-specifier-p (type)
+ (let ((type (specifier-type type)))
+ (or (csubtypep type (specifier-type 'list))
+ (csubtypep type (specifier-type 'vector)))))
+
;;; It's possible with some sequence operations to declare the length
;;; of a result vector, and to be safe, we really ought to verify that
;;; the actual result has the declared length.
"Vector length (~W) doesn't match declared length (~W)."
:format-arguments (list actual-length declared-length))))
vector)
+
(defun sequence-of-checked-length-given-type (sequence result-type)
(let ((ctype (specifier-type result-type)))
(if (not (array-type-p ctype))
;; 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 emptyp (sequence)
+ #!+sb-doc
+ "Returns T if SEQUENCE is an empty sequence and NIL
+ otherwise. Signals an error if SEQUENCE is not a sequence."
+ (seq-dispatch sequence
+ (null sequence)
+ (zerop (length sequence))
+ (sb!sequence:emptyp sequence)))
+
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
- (etypecase sequence
- (list
- (do ((count index (1- count))
- (list sequence (cdr list)))
- ((= count 0)
- (if (endp list)
- (signal-index-too-large-error sequence index)
- (car list)))
- (declare (type (integer 0) count))))
- (vector
- (when (>= index (length sequence))
- (signal-index-too-large-error sequence index))
- (aref sequence index))))
+ (seq-dispatch sequence
+ (do ((count index (1- count))
+ (list sequence (cdr list)))
+ ((= count 0)
+ (if (endp list)
+ (signal-index-too-large-error sequence index)
+ (car list)))
+ (declare (type (integer 0) count)))
+ (progn
+ (when (>= index (length sequence))
+ (signal-index-too-large-error sequence index))
+ (aref sequence index))
+ (sb!sequence:elt sequence index)))
(defun %setelt (sequence index newval)
#!+sb-doc "Store NEWVAL as the component of SEQUENCE specified by INDEX."
- (etypecase sequence
- (list
- (do ((count index (1- count))
- (seq sequence))
- ((= count 0) (rplaca seq newval) newval)
- (declare (fixnum count))
- (if (atom (cdr seq))
- (signal-index-too-large-error sequence index)
- (setq seq (cdr seq)))))
- (vector
- (when (>= index (length sequence))
- (signal-index-too-large-error sequence index))
- (setf (aref sequence index) newval))))
+ (seq-dispatch sequence
+ (do ((count index (1- count))
+ (seq sequence))
+ ((= count 0) (rplaca seq newval) newval)
+ (declare (fixnum count))
+ (if (atom (cdr seq))
+ (signal-index-too-large-error sequence index)
+ (setq seq (cdr seq))))
+ (progn
+ (when (>= index (length sequence))
+ (signal-index-too-large-error sequence index))
+ (setf (aref sequence index) newval))
+ (setf (sb!sequence:elt sequence index) newval)))
(defun length (sequence)
#!+sb-doc "Return an integer that is the length of SEQUENCE."
- (etypecase sequence
- (vector (length (truly-the vector sequence)))
- (list (length (truly-the list sequence)))))
+ (seq-dispatch sequence
+ (length sequence)
+ (length sequence)
+ (sb!sequence:length sequence)))
(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."
(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
:initial-element initial-element)
(make-array length :element-type etype)))))
(t (sequence-type-too-hairy (type-specifier type)))))
+ ((and (csubtypep type (specifier-type 'sequence))
+ (find-class adjusted-type nil))
+ (let* ((class (find-class adjusted-type nil)))
+ (unless (sb!mop:class-finalized-p class)
+ (sb!mop:finalize-inheritance class))
+ (if iep
+ (sb!sequence:make-sequence-like
+ (sb!mop:class-prototype class) length
+ :initial-element initial-element)
+ (sb!sequence:make-sequence-like
+ (sb!mop:class-prototype class) length))))
(t (bad-sequence-type-error (type-specifier type))))))
\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))))
-
-(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)
+ (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 ()
+ (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
"Return a copy of a subsequence of SEQUENCE starting with element number
START and continuing to the end of SEQUENCE or the optional END."
(seq-dispatch sequence
- (list-subseq* sequence start end)
- (vector-subseq* sequence start end)))
+ (list-subseq* sequence start end)
+ (vector-subseq* sequence start end)
+ (sb!sequence:subseq sequence start end)))
\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)))
-
-;;; internal frobs
+ (list-copy-seq* sequence)
+ (vector-subseq* sequence 0 nil)
+ (sb!sequence:copy-seq sequence)))
(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 &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)))
+ (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
(mumble-replace-from-mumble))
(define-sequence-traverser replace
- (sequence1 sequence2 &key start1 end1 start2 end2)
+ (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."
+ "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
(target-end (or end1 length1))
(source-end (or end2 length2)))
(seq-dispatch target-sequence
- (seq-dispatch source-sequence
- (list-replace-from-list)
- (list-replace-from-mumble))
- (seq-dispatch source-sequence
- (mumble-replace-from-list)
- (mumble-replace-from-mumble)))))
+ (seq-dispatch source-sequence
+ (list-replace-from-list)
+ (list-replace-from-mumble)
+ (apply #'sb!sequence:replace sequence1 sequence2 args))
+ (seq-dispatch source-sequence
+ (mumble-replace-from-list)
+ (mumble-replace-from-mumble)
+ (apply #'sb!sequence:replace sequence1 sequence2 args))
+ (apply #'sb!sequence:replace sequence1 sequence2 args))))
\f
;;;; REVERSE
(declare (fixnum length))
(do ((forward-index 0 (1+ forward-index))
(backward-index (1- length) (1- backward-index))
- (new-sequence (make-sequence-like sequence length)))
+ (new-sequence (%make-sequence-like sequence length)))
((= forward-index length) new-sequence)
(declare (fixnum forward-index backward-index))
(setf (aref new-sequence forward-index)
#!+sb-doc
"Return a new sequence containing the same elements but in reverse order."
(seq-dispatch sequence
- (list-reverse* sequence)
- (vector-reverse* sequence)))
+ (list-reverse* sequence)
+ (vector-reverse* sequence)
+ (sb!sequence:reverse sequence)))
;;; internal frobs
"Return a sequence of the same elements in reverse order; the argument
is destroyed."
(seq-dispatch sequence
- (list-nreverse* sequence)
- (vector-nreverse* sequence)))
+ (list-nreverse* sequence)
+ (vector-nreverse* sequence)
+ (sb!sequence:nreverse sequence)))
\f
;;;; CONCATENATE
-(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)))
- ;; FIXME: It appears to me that this and CONCATENATE-TO-MUMBLE
- ;; could benefit from a DO-SEQUENCE macro.
- (seq-dispatch sequence
- (do ((sequence sequence (cdr sequence)))
- ((atom sequence))
- (setq splice
- (cdr (rplacd splice (list (car sequence))))))
- (do ((index 0 (1+ index))
- (length (length sequence)))
- ((= index length))
- (declare (fixnum index length))
- (setq splice
- (cdr (rplacd splice
- (list (aref sequence index)))))))))))
-
-(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)))
- (seq-dispatch sequence
- (do ((sequence sequence (cdr sequence)))
- ((atom sequence))
- (setf (aref result index) (car sequence))
- (setq index (1+ index)))
- (do ((jndex 0 (1+ jndex))
- (this-length (car lengths)))
- ((= jndex this-length))
- (declare (fixnum jndex this-length))
- (setf (aref result index)
- (aref sequence jndex))
- (setq index (1+ index)))))))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (setq lengths (nconc lengths (list length)))
- (setq total-length (+ total-length length)))))
-
-) ; EVAL-WHEN
+(defmacro sb!sequence:dosequence ((element sequence &optional return) &body body)
+ #!+sb-doc
+ "Executes BODY with ELEMENT subsequently bound to each element of
+ SEQUENCE, then returns RETURN."
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (let ((s sequence)
+ (sequence (gensym "SEQUENCE")))
+ `(block nil
+ (let ((,sequence ,s))
+ (seq-dispatch ,sequence
+ (dolist (,element ,sequence ,return) ,@body)
+ (do-vector-data (,element ,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)))
+ ((funcall endp ,sequence state limit from-end)
+ (let ((,element nil))
+ ,@(filter-dolist-declarations decls)
+ ,element
+ ,return))
+ (let ((,element (funcall elt ,sequence state)))
+ ,@decls
+ (tagbody
+ ,@forms))))))))))
\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))
- (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))
+ (unless (every #'emptyp sequences)
+ (sequence-type-length-mismatch-error
+ type (reduce #'+ sequences :key #'length))) ; FIXME: circular list issues.
+ '())
+ ((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))
(declaim (ftype (function (function sequence) simple-vector)
%map-simple-vector-arity-1))
-(macrolet ((dosequence ((i sequence) &body body)
- (once-only ((sequence sequence))
- `(etypecase ,sequence
- (list (dolist (,i ,sequence) ,@body))
- (simple-vector (dovector (,i sequence) ,@body))
- (vector (dovector (,i sequence) ,@body))))))
- (defun %map-to-list-arity-1 (fun sequence)
- (let ((reversed-result nil)
- (really-fun (%coerce-callable-to-fun fun)))
- (dosequence (element sequence)
- (push (funcall really-fun element)
- reversed-result))
- (nreverse reversed-result)))
- (defun %map-to-simple-vector-arity-1 (fun sequence)
- (let ((result (make-array (length sequence)))
- (index 0)
- (really-fun (%coerce-callable-to-fun fun)))
- (declare (type index index))
- (dosequence (element sequence)
- (setf (aref result index)
- (funcall really-fun element))
- (incf index))
- result))
- (defun %map-for-effect-arity-1 (fun sequence)
- (let ((really-fun (%coerce-callable-to-fun fun)))
- (dosequence (element sequence)
- (funcall really-fun element)))
- nil))
-
-;;; helper functions to handle arity-N subcases of MAP
-;;;
-;;; KLUDGE: This is hairier, and larger, than need be, because we
-;;; don't have DYNAMIC-EXTENT. With DYNAMIC-EXTENT, we could define
-;;; %MAP-FOR-EFFECT, and then implement the
-;;; other %MAP-TO-FOO functions reasonably efficiently by passing closures to
-;;; %MAP-FOR-EFFECT. (DYNAMIC-EXTENT would help a little by avoiding
-;;; consing each closure, and would help a lot by allowing us to define
-;;; a closure (LAMBDA (&REST REST) <do something with (APPLY FUN REST)>)
-;;; with the REST list allocated with DYNAMIC-EXTENT. -- WHN 20000920
-(macrolet (;; Execute BODY in a context where the machinery for
- ;; UPDATED-MAP-APPLY-ARGS has been set up.
- (with-map-state (sequences &body body)
- `(let* ((%sequences ,sequences)
- (%iters (mapcar (lambda (sequence)
- (etypecase sequence
- (list sequence)
- (vector 0)))
- %sequences))
- (%apply-args (make-list (length %sequences))))
- (declare (type list %sequences %iters %apply-args))
- ,@body))
- ;; Return a list of args to pass to APPLY for the next
- ;; function call in the mapping, or NIL if no more function
- ;; calls should be made (because we've reached the end of a
- ;; sequence arg).
- (updated-map-apply-args ()
- '(do ((in-sequences %sequences (cdr in-sequences))
- (in-iters %iters (cdr in-iters))
- (in-apply-args %apply-args (cdr in-apply-args)))
- ((null in-sequences)
- %apply-args)
- (declare (type list in-sequences in-iters in-apply-args))
- (let ((i (car in-iters)))
- (declare (type (or list index) i))
- (if (listp i)
- (if (null i) ; if end of this sequence
- (return nil)
- (setf (car in-apply-args) (car i)
- (car in-iters) (cdr i)))
- (let ((v (the vector (car in-sequences))))
- (if (>= i (length v)) ; if end of this sequence
- (return nil)
- (setf (car in-apply-args) (aref v i)
- (car in-iters) (1+ i)))))))))
- (defun %map-to-list (func sequences)
- (declare (type function func))
- (declare (type list sequences))
- (with-map-state sequences
- (loop with updated-map-apply-args
- while (setf updated-map-apply-args (updated-map-apply-args))
- collect (apply func updated-map-apply-args))))
- (defun %map-to-vector (output-type-spec func sequences)
- (declare (type function func))
- (declare (type list sequences))
- (let ((min-len (with-map-state sequences
- (do ((counter 0 (1+ counter)))
- ;; Note: Doing everything in
- ;; UPDATED-MAP-APPLY-ARGS here is somewhat
- ;; wasteful; we even do some extra consing.
- ;; And stepping over every element of
- ;; VECTORs, instead of just grabbing their
- ;; LENGTH, is also wasteful. But it's easy
- ;; and safe. (If you do rewrite it, please
- ;; try to make sure that
- ;; (MAP NIL #'F SOME-CIRCULAR-LIST #(1))
- ;; does the right thing.)
- ((not (updated-map-apply-args))
- counter)
- (declare (type index counter))))))
- (declare (type index min-len))
- (with-map-state sequences
- (let ((result (make-sequence output-type-spec min-len))
- (index 0))
- (declare (type index index))
- (loop with updated-map-apply-args
- while (setf updated-map-apply-args (updated-map-apply-args))
- do
- (setf (aref result index)
- (apply func updated-map-apply-args))
- (incf index))
- result))))
- (defun %map-for-effect (func sequences)
- (declare (type function func))
- (declare (type list sequences))
- (with-map-state sequences
- (loop with updated-map-apply-args
- while (setf updated-map-apply-args (updated-map-apply-args))
- do
- (apply func updated-map-apply-args))
- nil)))
-
- "FUNCTION must take as many arguments as there are sequences provided.
- The result is a sequence of type OUTPUT-TYPE-SPEC such that element I
- is the result of applying FUNCTION to element I of each of the argument
- sequences."
+(defun %map-to-list-arity-1 (fun sequence)
+ (let ((reversed-result nil)
+ (really-fun (%coerce-callable-to-fun fun)))
+ (sb!sequence:dosequence (element sequence)
+ (push (funcall really-fun element)
+ reversed-result))
+ (nreverse reversed-result)))
+(defun %map-to-simple-vector-arity-1 (fun sequence)
+ (let ((result (make-array (length sequence)))
+ (index 0)
+ (really-fun (%coerce-callable-to-fun fun)))
+ (declare (type index index))
+ (sb!sequence:dosequence (element sequence)
+ (setf (aref result index)
+ (funcall really-fun element))
+ (incf index))
+ result))
+(defun %map-for-effect-arity-1 (fun sequence)
+ (let ((really-fun (%coerce-callable-to-fun fun)))
+ (sb!sequence:dosequence (element sequence)
+ (funcall really-fun element)))
+ nil)
+
+(declaim (maybe-inline %map-for-effect))
+(defun %map-for-effect (fun sequences)
+ (declare (type function fun) (type list sequences))
+ (let ((%sequences sequences)
+ (%iters (mapcar (lambda (s)
+ (seq-dispatch s
+ s
+ 0
+ (multiple-value-list
+ (sb!sequence:make-sequence-iterator s))))
+ sequences))
+ (%apply-args (make-list (length sequences))))
+ ;; this is almost efficient (except in the general case where we
+ ;; trampoline to MAKE-SEQUENCE-ITERATOR; if we had DX allocation
+ ;; of MAKE-LIST, the whole of %MAP would be cons-free.
+ (declare (type list %sequences %iters %apply-args))
+ (loop
+ (do ((in-sequences %sequences (cdr in-sequences))
+ (in-iters %iters (cdr in-iters))
+ (in-apply-args %apply-args (cdr in-apply-args)))
+ ((null in-sequences) (apply fun %apply-args))
+ (let ((i (car in-iters)))
+ (declare (type (or list index) i))
+ (cond
+ ((listp (car in-sequences))
+ (if (null i)
+ (return-from %map-for-effect nil)
+ (setf (car in-apply-args) (car i)
+ (car in-iters) (cdr i))))
+ ((typep i 'index)
+ (let ((v (the vector (car in-sequences))))
+ (if (>= i (length v))
+ (return-from %map-for-effect nil)
+ (setf (car in-apply-args) (aref v i)
+ (car in-iters) (1+ i)))))
+ (t
+ (destructuring-bind (state limit from-end step endp elt &rest ignore)
+ i
+ (declare (type function step endp elt)
+ (ignore ignore))
+ (let ((s (car in-sequences)))
+ (if (funcall endp s state limit from-end)
+ (return-from %map-for-effect nil)
+ (progn
+ (setf (car in-apply-args) (funcall elt s state))
+ (setf (caar in-iters) (funcall step s state from-end)))))))))))))
+(defun %map-to-list (fun sequences)
+ (declare (type function fun)
+ (type list sequences))
+ (let ((result nil))
+ (flet ((f (&rest args)
+ (declare (truly-dynamic-extent args))
+ (push (apply fun args) result)))
+ (declare (truly-dynamic-extent #'f))
+ (%map-for-effect #'f sequences))
+ (nreverse result)))
+(defun %map-to-vector (output-type-spec fun sequences)
+ (declare (type function fun)
+ (type list sequences))
+ (let ((min-len 0))
+ (flet ((f (&rest args)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore args))
+ (incf min-len)))
+ (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 (truly-dynamic-extent args))
+ (setf (aref result i) (apply fun args))
+ (incf i)))
+ (declare (truly-dynamic-extent #'f))
+ (%map-for-effect #'f sequences))
+ result)))
+(defun %map-to-sequence (result-type fun sequences)
+ (declare (type function fun)
+ (type list sequences))
+ (let ((min-len 0))
+ (flet ((f (&rest args)
+ (declare (truly-dynamic-extent args))
+ (declare (ignore args))
+ (incf min-len)))
+ (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 (truly-dynamic-extent args))
+ (funcall setelt (apply fun args) result state)
+ (setq state (funcall step result state from-end))))
+ (declare (truly-dynamic-extent #'f))
+ (%map-for-effect #'f sequences)))
+ result)))
;;; %MAP is just MAP without the final just-to-be-sure check that
;;; length of the output sequence matches any length specified
(%map-to-list really-fun sequences))
((csubtypep type (specifier-type 'vector))
(%map-to-vector result-type really-fun sequences))
+ ((and (csubtypep type (specifier-type 'sequence))
+ (find-class result-type nil))
+ (%map-to-sequence result-type really-fun sequences))
(t
(bad-sequence-type-error result-type)))))))
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"))
+ (wrapper (sb!xc:gensym "WRAPPER")))
(once-only ((pred pred))
`(block ,blockname
- (map nil
- (lambda (,@elements)
- (let ((pred-value (funcall ,pred ,@elements)))
- (,',found-test pred-value
- (return-from ,blockname
- ,',found-result))))
- ,first-seq
- ,@more-seqs)
+ (flet ((,wrapper (,@elements)
+ (declare (optimize (sb!c::check-tag-existence 0)))
+ (let ((pred-value (funcall ,pred ,@elements)))
+ (,',found-test pred-value
+ (return-from ,blockname
+ ,',found-result)))))
+ (declare (inline ,wrapper)
+ (dynamic-extent #',wrapper))
+ (map nil #',wrapper ,first-seq
+ ,@more-seqs))
,',unfound-result)))))))
(defquantifier some when pred-value :unfound-result nil :doc
"Apply PREDICATE to the 0-indexed elements of the sequences, then
) ; EVAL-WHEN
-(define-sequence-traverser reduce
- (function sequence &key key from-end start end (initial-value nil ivp))
- (declare (type index start))
- (let ((start start)
- (end (or end length)))
- (declare (type index start end))
- (cond ((= end start)
- (if ivp initial-value (funcall function)))
- ((listp sequence)
- (if from-end
- (list-reduce-from-end function sequence key start end
- initial-value ivp)
- (list-reduce function sequence key start end
- initial-value ivp)))
- (from-end
- (when (not ivp)
- (setq end (1- (the fixnum end)))
- (setq initial-value (apply-key key (aref sequence end))))
- (mumble-reduce-from-end function sequence key start end
- initial-value aref))
- (t
- (when (not ivp)
- (setq initial-value (apply-key key (aref sequence start)))
- (setq start (1+ start)))
- (mumble-reduce function sequence key start end
- initial-value aref)))))
+(define-sequence-traverser reduce (function sequence &rest args &key key
+ from-end start end (initial-value nil ivp))
+ (declare (type index start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if (= end start)
+ (if ivp initial-value (funcall function))
+ (if from-end
+ (list-reduce-from-end function sequence key start end
+ initial-value ivp)
+ (list-reduce function sequence key start end
+ initial-value ivp))))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if (= end start)
+ (if ivp initial-value (funcall function))
+ (if from-end
+ (progn
+ (when (not ivp)
+ (setq end (1- (the fixnum end)))
+ (setq initial-value (apply-key key (aref sequence end))))
+ (mumble-reduce-from-end function sequence key start end
+ initial-value aref))
+ (progn
+ (when (not ivp)
+ (setq initial-value (apply-key key (aref sequence start)))
+ (setq start (1+ start)))
+ (mumble-reduce function sequence key start end
+ initial-value aref)))))
+ (apply #'sb!sequence:reduce function sequence args)))
\f
;;;; DELETE
) ; EVAL-WHEN
(define-sequence-traverser delete
- (item sequence &key from-end test test-not start
- end count key)
+ (item sequence &rest args &key from-end test test-not start
+ end count key)
#!+sb-doc
"Return a sequence formed by destructively removing the specified ITEM from
the given SEQUENCE."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (type index end))
- (seq-dispatch sequence
- (if from-end
- (normal-list-delete-from-end)
- (normal-list-delete))
- (if from-end
- (normal-mumble-delete-from-end)
- (normal-mumble-delete)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (normal-list-delete-from-end)
+ (normal-list-delete)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (normal-mumble-delete-from-end)
+ (normal-mumble-delete)))
+ (apply #'sb!sequence:delete item sequence args)))
(eval-when (:compile-toplevel :execute)
) ; EVAL-WHEN
(define-sequence-traverser delete-if
- (predicate sequence &key from-end start key end count)
+ (predicate sequence &rest args &key from-end start key end count)
#!+sb-doc
"Return a sequence formed by destructively removing the elements satisfying
the specified PREDICATE from the given SEQUENCE."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (type index end))
- (seq-dispatch sequence
- (if from-end
- (if-list-delete-from-end)
- (if-list-delete))
- (if from-end
- (if-mumble-delete-from-end)
- (if-mumble-delete)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-list-delete-from-end)
+ (if-list-delete)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-mumble-delete-from-end)
+ (if-mumble-delete)))
+ (apply #'sb!sequence:delete-if predicate sequence args)))
(eval-when (:compile-toplevel :execute)
) ; EVAL-WHEN
(define-sequence-traverser delete-if-not
- (predicate sequence &key from-end start end key count)
+ (predicate sequence &rest args &key from-end start end key count)
#!+sb-doc
"Return a sequence formed by destructively removing the elements not
satisfying the specified PREDICATE from the given SEQUENCE."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (type index end))
- (seq-dispatch sequence
- (if from-end
- (if-not-list-delete-from-end)
- (if-not-list-delete))
- (if from-end
- (if-not-mumble-delete-from-end)
- (if-not-mumble-delete)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-not-list-delete-from-end)
+ (if-not-list-delete)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-not-mumble-delete-from-end)
+ (if-not-mumble-delete)))
+ (apply #'sb!sequence:delete-if-not predicate sequence args)))
\f
;;;; REMOVE
`(do ((index ,begin (,bump index))
(result
(do ((index ,left (,bump index))
- (result (make-sequence-like sequence length)))
+ (result (%make-sequence-like sequence length)))
((= index (the fixnum ,begin)) result)
(declare (fixnum index))
(setf (aref result index) (aref sequence index))))
(= number-zapped count))
(do ((index index (,bump index))
(new-index new-index (,bump new-index)))
- ((= index (the fixnum ,right)) (shrink-vector result new-index))
+ ((= index (the fixnum ,right)) (%shrink-vector result new-index))
(declare (fixnum index new-index))
(setf (aref result new-index) (aref sequence index))))
(declare (fixnum index new-index number-zapped))
) ; EVAL-WHEN
(define-sequence-traverser remove
- (item sequence &key from-end test test-not start
- end count key)
+ (item sequence &rest args &key from-end test test-not start
+ end count key)
#!+sb-doc
"Return a copy of SEQUENCE with elements satisfying the test (default is
EQL) with ITEM removed."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (type index end))
- (seq-dispatch sequence
- (if from-end
- (normal-list-remove-from-end)
- (normal-list-remove))
- (if from-end
- (normal-mumble-remove-from-end)
- (normal-mumble-remove)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (normal-list-remove-from-end)
+ (normal-list-remove)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (normal-mumble-remove-from-end)
+ (normal-mumble-remove)))
+ (apply #'sb!sequence:remove item sequence args)))
(define-sequence-traverser remove-if
- (predicate sequence &key from-end start end count key)
+ (predicate sequence &rest args &key from-end start end count key)
#!+sb-doc
"Return a copy of sequence with elements satisfying PREDICATE removed."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (type index end))
- (seq-dispatch sequence
- (if from-end
- (if-list-remove-from-end)
- (if-list-remove))
- (if from-end
- (if-mumble-remove-from-end)
- (if-mumble-remove)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-list-remove-from-end)
+ (if-list-remove)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-mumble-remove-from-end)
+ (if-mumble-remove)))
+ (apply #'sb!sequence:remove-if predicate sequence args)))
(define-sequence-traverser remove-if-not
- (predicate sequence &key from-end start end count key)
+ (predicate sequence &rest args &key from-end start end count key)
#!+sb-doc
"Return a copy of sequence with elements not satisfying PREDICATE removed."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (type index end))
- (seq-dispatch sequence
- (if from-end
- (if-not-list-remove-from-end)
- (if-not-list-remove))
- (if from-end
- (if-not-mumble-remove-from-end)
- (if-not-mumble-remove)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-not-list-remove-from-end)
+ (if-not-list-remove)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (if-not-mumble-remove-from-end)
+ (if-not-mumble-remove)))
+ (apply #'sb!sequence:remove-if-not predicate sequence args)))
\f
;;;; REMOVE-DUPLICATES
(let* ((result (list ())) ; Put a marker on the beginning to splice with.
(splice result)
(current list)
- (hash (and test
- (not key)
- (not test-not)
- (or (eql test #'eql)
- (eql test #'eq)
- (eql test #'equal)
- (eql test #'equalp))
- ; (> (if end (- end start) (- (length list) start)) 20)
- (make-hash-table :test test))))
+ (end (or end (length list)))
+ (hash (and (> (- end start) 20)
+ test
+ (not key)
+ (not test-not)
+ (or (eql test #'eql)
+ (eql test #'eq)
+ (eql test #'equal)
+ (eql test #'equalp))
+ (make-hash-table :test test :size (- end start)))))
(do ((index 0 (1+ index)))
((= index start))
(declare (fixnum index))
- ;; (if hash (setf (gethash (car current) hash) splice))
(setq splice (cdr (rplacd splice (list (car current)))))
(setq current (cdr current)))
- (do ((index start (1+ index)))
- ((or (and end (= index (the fixnum end)))
- (atom current)))
- (declare (fixnum index))
- (cond
- (hash
- (let ((prev (gethash (car current) hash)))
- (cond
- ((not prev)
- (setf (gethash (car current) hash) splice)
- (setq splice (cdr (rplacd splice (list (car current))))))
- (from-end nil)
- (t
- (let ((old (cdr prev)))
- (let ((next (cdr old)))
- (when next
- (let ((next-val (car next)))
- ;; (assert (eq (gethash next-val hash) old))
- (setf (cdr prev) next
- (gethash next-val hash) prev
- (gethash (car current) hash) splice
- splice (cdr (rplacd splice (list (car current)))))))))))))
- (t
- (if (or (and from-end
- (not (if test-not
- (member (apply-key key (car current))
- (nthcdr (1+ start) result)
- :test-not test-not
- :key key)
- (member (apply-key key (car current))
- (nthcdr (1+ start) result)
- :test test
- :key key))))
- (and (not from-end)
- (not (do ((it (apply-key key (car current)))
- (l (cdr current) (cdr l))
- (i (1+ index) (1+ i)))
- ((or (atom l) (and end (= i (the fixnum end))))
- ())
- (declare (fixnum i))
- (if (if test-not
- (not (funcall test-not
- it
- (apply-key key (car l))))
- (funcall test it (apply-key key (car l))))
- (return t))))))
- (setq splice (cdr (rplacd splice (list (car current))))))))
- (setq current (cdr current)))
+ (if hash
+ (do ((index start (1+ index)))
+ ((or (and end (= index (the fixnum end)))
+ (atom current)))
+ (declare (fixnum index))
+ ;; The hash table contains links from values that are
+ ;; already in result to the cons cell *preceding* theirs
+ ;; in the list. That is, for each value v in the list,
+ ;; v and (cadr (gethash v hash)) are equal under TEST.
+ (let ((prev (gethash (car current) hash)))
+ (cond
+ ((not prev)
+ (setf (gethash (car current) hash) splice)
+ (setq splice (cdr (rplacd splice (list (car current))))))
+ ((not from-end)
+ (let* ((old (cdr prev))
+ (next (cdr old)))
+ (if next
+ (let ((next-val (car next)))
+ ;; (assert (eq (gethash next-val hash) old))
+ (setf (cdr prev) next
+ (gethash next-val hash) prev
+ (gethash (car current) hash) splice
+ splice (cdr (rplacd splice (list (car current))))))
+ (setf (car old) (car current)))))))
+ (setq current (cdr current)))
+ (do ((index start (1+ index)))
+ ((or (and end (= index (the fixnum end)))
+ (atom current)))
+ (declare (fixnum index))
+ (if (or (and from-end
+ (not (if test-not
+ (member (apply-key key (car current))
+ (nthcdr (1+ start) result)
+ :test-not test-not
+ :key key)
+ (member (apply-key key (car current))
+ (nthcdr (1+ start) result)
+ :test test
+ :key key))))
+ (and (not from-end)
+ (not (do ((it (apply-key key (car current)))
+ (l (cdr current) (cdr l))
+ (i (1+ index) (1+ i)))
+ ((or (atom l) (and end (= i (the fixnum end))))
+ ())
+ (declare (fixnum i))
+ (if (if test-not
+ (not (funcall test-not
+ it
+ (apply-key key (car l))))
+ (funcall test it (apply-key key (car l))))
+ (return t))))))
+ (setq splice (cdr (rplacd splice (list (car current))))))
+ (setq current (cdr current))))
(do ()
((atom current))
(setq splice (cdr (rplacd splice (list (car current)))))
&optional (length (length vector)))
(declare (vector vector) (fixnum start length))
(when (null end) (setf end (length vector)))
- (let ((result (make-sequence-like vector length))
+ (let ((result (%make-sequence-like vector length))
(index 0)
(jndex start))
(declare (fixnum index jndex))
(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)))
(setf (aref result jndex) (aref vector index))
(setq index (1+ index))
(setq jndex (1+ jndex)))
- (shrink-vector result jndex)))
+ (%shrink-vector result jndex)))
(define-sequence-traverser remove-duplicates
- (sequence &key test test-not start end from-end key)
+ (sequence &rest args &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
sequence is returned.
The :TEST-NOT argument is deprecated."
- (declare (fixnum start))
+ (declare (fixnum start)
+ (truly-dynamic-extent args))
(seq-dispatch sequence
- (if sequence
- (list-remove-duplicates* sequence test test-not
- start end key from-end))
- (vector-remove-duplicates* sequence test test-not
- start end key from-end)))
+ (if sequence
+ (list-remove-duplicates* sequence test test-not
+ start end key from-end))
+ (vector-remove-duplicates* sequence test test-not start end key from-end)
+ (apply #'sb!sequence:remove-duplicates sequence args)))
\f
;;;; DELETE-DUPLICATES
(do ((index index (1+ index)) ; copy the rest of the vector
(jndex jndex (1+ jndex)))
((= index length)
- (shrink-vector vector jndex)
- vector)
+ (shrink-vector vector jndex))
(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
- (sequence &key test test-not start end from-end key)
+ (sequence &rest args &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
given sequence, is returned.
The :TEST-NOT argument is deprecated."
+ (declare (truly-dynamic-extent args))
(seq-dispatch sequence
- (if sequence
- (list-delete-duplicates* sequence test test-not key from-end start end))
- (vector-delete-duplicates* sequence test test-not key from-end start end)))
+ (when sequence
+ (list-delete-duplicates* sequence test test-not
+ key from-end start end))
+ (vector-delete-duplicates* sequence test test-not key from-end start end)
+ (apply #'sb!sequence:delete-duplicates sequence args)))
\f
;;;; SUBSTITUTE
(defun vector-substitute* (pred new sequence incrementer left right length
start end count key test test-not old)
(declare (fixnum start count end incrementer right))
- (let ((result (make-sequence-like sequence length))
+ (let ((result (%make-sequence-like sequence length))
(index left))
(declare (fixnum index))
(do ()
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro subst-dispatch (pred)
- `(if (listp sequence)
+ `(seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
(if from-end
(nreverse (list-substitute* ,pred
new
count key test test-not old))
(list-substitute* ,pred
new sequence start end count key test test-not
- old))
- (if from-end
- (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
- -1 length (1- (the fixnum end))
- (1- (the fixnum start))
- count key test test-not old)
- (vector-substitute* ,pred new sequence 1 0 length length
- start end count key test test-not old))))
+ old)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
+ -1 length (1- (the fixnum end))
+ (1- (the fixnum start))
+ count key test test-not old)
+ (vector-substitute* ,pred new sequence 1 0 length length
+ start end count key test test-not old)))
+
+ ;; FIXME: wow, this is an odd way to implement the dispatch. PRED
+ ;; here is (QUOTE [NORMAL|IF|IF-NOT]). Not only is this pretty
+ ;; pointless, but also LIST-SUBSTITUTE* and VECTOR-SUBSTITUTE*
+ ;; dispatch once per element on PRED's run-time identity.
+ ,(ecase (cadr pred)
+ ((normal) `(apply #'sb!sequence:substitute new old sequence args))
+ ((if) `(apply #'sb!sequence:substitute-if new predicate sequence args))
+ ((if-not) `(apply #'sb!sequence:substitute-if-not new predicate sequence args)))))
) ; EVAL-WHEN
(define-sequence-traverser substitute
- (new old sequence &key from-end test test-not
+ (new old sequence &rest args &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,
except that all elements equal to OLD are replaced with NEW."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (type index end))
- (subst-dispatch 'normal)))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (subst-dispatch 'normal))
\f
;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
(define-sequence-traverser substitute-if
- (new predicate sequence &key from-end start end count key)
+ (new predicate sequence &rest args &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."
- (declare (fixnum start))
- (let ((end (or end length))
- (test predicate)
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (let ((test predicate)
(test-not nil)
old)
- (declare (type index length end))
(subst-dispatch 'if)))
(define-sequence-traverser substitute-if-not
- (new predicate sequence &key from-end start end count key)
+ (new predicate sequence &rest args &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."
- (declare (fixnum start))
- (let ((end (or end length))
- (test predicate)
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (let ((test predicate)
(test-not nil)
old)
- (declare (type index length end))
(subst-dispatch 'if-not)))
\f
;;;; NSUBSTITUTE
(define-sequence-traverser nsubstitute
- (new old sequence &key from-end test test-not
+ (new old sequence &rest args &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
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)
- (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)))
- (nlist-substitute* new old sequence
- test test-not start end count key))
- (if from-end
- (nvector-substitute* new old sequence -1
- test test-not (1- end) (1- start) count key)
- (nvector-substitute* new old sequence 1
- test test-not start end count key)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (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)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (nvector-substitute* new old sequence -1
+ test test-not (1- end) (1- start) count key)
+ (nvector-substitute* new old sequence 1
+ test test-not start end count key)))
+ (apply #'sb!sequence:nsubstitute new old sequence args)))
(defun nlist-substitute* (new old sequence test test-not start end count key)
(declare (fixnum start count end))
;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
(define-sequence-traverser nsubstitute-if
- (new predicate sequence &key from-end start end count key)
+ (new predicate sequence &rest args &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 PREDICATE are replaced with NEW.
SEQUENCE may be destructively modified."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (fixnum end))
- (if (listp sequence)
- (if from-end
- (let ((length (length sequence)))
- (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
- (nvector-substitute-if* new predicate sequence -1
- (1- end) (1- start) count key)
- (nvector-substitute-if* new predicate sequence 1
- start end count key)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (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)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (nvector-substitute-if* new predicate sequence -1
+ (1- end) (1- start) count key)
+ (nvector-substitute-if* new predicate sequence 1
+ start end count key)))
+ (apply #'sb!sequence:nsubstitute-if new predicate sequence args)))
(defun nlist-substitute-if* (new test sequence start end count key)
- (declare (fixnum end))
+ (declare (type fixnum end)
+ (type function test)) ; coercion is done by caller
(do ((list (nthcdr start sequence) (cdr list))
(index start (1+ index)))
((or (= index end) (null list) (= count 0)) sequence)
(defun nvector-substitute-if* (new test sequence incrementer
start end count key)
+ (declare (type fixnum end)
+ (type function test)) ; coercion is done by caller
(do ((index start (+ index incrementer)))
((or (= index end) (= count 0)) sequence)
(when (funcall test (apply-key key (aref sequence index)))
(setq count (1- count)))))
(define-sequence-traverser nsubstitute-if-not
- (new predicate sequence &key from-end start end count key)
+ (new predicate sequence &rest args &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 PREDICATE are replaced with NEW.
SEQUENCE may be destructively modified."
- (declare (fixnum start))
- (let ((end (or end length)))
- (declare (fixnum end))
- (if (listp 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)))
- (nlist-substitute-if-not* new predicate sequence
- start end count key))
- (if from-end
- (nvector-substitute-if-not* new predicate sequence -1
- (1- end) (1- start) count key)
- (nvector-substitute-if-not* new predicate sequence 1
- start end count key)))))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (fixnum end))
+ (if from-end
+ (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)))
+ (let ((end (or end length)))
+ (declare (fixnum end))
+ (if from-end
+ (nvector-substitute-if-not* new predicate sequence -1
+ (1- end) (1- start) count key)
+ (nvector-substitute-if-not* new predicate sequence 1
+ start end count key)))
+ (apply #'sb!sequence:nsubstitute-if-not new predicate sequence args)))
(defun nlist-substitute-if-not* (new test sequence start end count key)
- (declare (fixnum end))
+ (declare (type fixnum end)
+ (type function test)) ; coercion is done by caller
(do ((list (nthcdr start sequence) (cdr list))
(index start (1+ index)))
((or (= index end) (null list) (= count 0)) sequence)
(defun nvector-substitute-if-not* (new test sequence incrementer
start end count key)
+ (declare (type fixnum end)
+ (type function test)) ; coercion is done by caller
(do ((index start (+ index incrementer)))
((or (= index end) (= count 0)) sequence)
(when (not (funcall test (apply-key key (aref sequence index))))
(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 ()
- `(etypecase sequence-arg
- (list (frob sequence-arg from-end))
- (vector
- (with-array-data ((sequence sequence-arg :offset-var offset)
- (start start)
- (end (%check-vector-sequence-bounds
- sequence-arg start end)))
- (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))
- (t (vector*-frob sequence))))
- (declare (type (or index null) p))
- (values f (and p (the index (- p offset))))))))))
+ (frobs (&optional bit-frob)
+ `(seq-dispatch sequence-arg
+ (frob sequence-arg from-end)
+ (with-array-data ((sequence sequence-arg :offset-var offset)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (multiple-value-bind (f p)
+ (macrolet ((frob2 () `(if from-end
+ (frob sequence t)
+ (frob sequence nil))))
+ (typecase 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)
(macrolet ((frob (sequence from-end)
`(%find-position item ,sequence
(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
from-end start end key)))
(frobs))))
-;;; the user interface to FIND and POSITION: just interpreter stubs,
-;;; nowadays.
-(defun find (item sequence &key from-end (start 0) end key test test-not)
- ;; FIXME: this can't be the way to go, surely?
- (find item sequence :from-end from-end :start start :end end :key key
- :test test :test-not test-not))
-(defun position (item sequence &key from-end (start 0) end key test test-not)
- (position item sequence :from-end from-end :start start :end end :key key
- :test test :test-not test-not))
-
-;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
-;;; to the interface to FIND and POSITION
-(defun find-if (predicate sequence &key from-end (start 0) end key)
- (find-if predicate sequence :from-end from-end :start start
- :end end :key key))
-(defun position-if (predicate sequence &key from-end (start 0) end key)
- (position-if predicate sequence :from-end from-end :start start
- :end end :key key))
-
-(defun find-if-not (predicate sequence &key from-end (start 0) end key)
- (find-if-not predicate sequence :from-end from-end :start start
- :end end :key key))
-(defun position-if-not (predicate sequence &key from-end (start 0) end key)
- (position-if-not predicate sequence :from-end from-end :start start
- :end end :key key))
+(defun find
+ (item sequence &rest args &key from-end (start 0) end key test test-not)
+ (declare (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (nth-value 0 (%find-position
+ item sequence from-end start end
+ (effective-find-position-key key)
+ (effective-find-position-test test test-not)))
+ (nth-value 0 (%find-position
+ item sequence from-end start end
+ (effective-find-position-key key)
+ (effective-find-position-test test test-not)))
+ (apply #'sb!sequence:find item sequence args)))
+(defun position
+ (item sequence &rest args &key from-end (start 0) end key test test-not)
+ (declare (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (nth-value 1 (%find-position
+ item sequence from-end start end
+ (effective-find-position-key key)
+ (effective-find-position-test test test-not)))
+ (nth-value 1 (%find-position
+ item sequence from-end start end
+ (effective-find-position-key key)
+ (effective-find-position-test test test-not)))
+ (apply #'sb!sequence:position item sequence args)))
+
+(defun find-if (predicate sequence &rest args &key from-end (start 0) end key)
+ (declare (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (nth-value 0 (%find-position-if
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (nth-value 0 (%find-position-if
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (apply #'sb!sequence:find-if predicate sequence args)))
+(defun position-if
+ (predicate sequence &rest args &key from-end (start 0) end key)
+ (declare (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (nth-value 1 (%find-position-if
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (nth-value 1 (%find-position-if
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (apply #'sb!sequence:position-if predicate sequence args)))
+
+(defun find-if-not
+ (predicate sequence &rest args &key from-end (start 0) end key)
+ (declare (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (nth-value 0 (%find-position-if-not
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (nth-value 0 (%find-position-if-not
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (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 (truly-dynamic-extent args))
+ (seq-dispatch sequence
+ (nth-value 1 (%find-position-if-not
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (nth-value 1 (%find-position-if-not
+ (%coerce-callable-to-fun predicate)
+ sequence from-end start end
+ (effective-find-position-key key)))
+ (apply #'sb!sequence:position-if-not predicate sequence args)))
\f
;;;; COUNT-IF, COUNT-IF-NOT, and COUNT
) ; EVAL-WHEN
-(define-sequence-traverser count-if (pred sequence &key from-end start end key)
+(define-sequence-traverser count-if
+ (pred sequence &rest args &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE satisfying PRED(el)."
- (declare (fixnum start))
- (let ((end (or end length))
- (pred (%coerce-callable-to-fun pred)))
- (declare (type index end))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (let ((pred (%coerce-callable-to-fun pred)))
(seq-dispatch sequence
- (if from-end
- (list-count-if nil t pred sequence)
- (list-count-if nil nil pred sequence))
- (if from-end
- (vector-count-if nil t pred sequence)
- (vector-count-if nil nil pred sequence)))))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (list-count-if nil t pred sequence)
+ (list-count-if nil nil pred sequence)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (vector-count-if nil t pred sequence)
+ (vector-count-if nil nil pred sequence)))
+ (apply #'sb!sequence:count-if pred sequence args))))
(define-sequence-traverser count-if-not
- (pred sequence &key from-end start end key)
+ (pred sequence &rest args &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE not satisfying TEST(el)."
- (declare (fixnum start))
- (let ((end (or end length))
- (pred (%coerce-callable-to-fun pred)))
- (declare (type index end))
+ (declare (type fixnum start)
+ (truly-dynamic-extent args))
+ (let ((pred (%coerce-callable-to-fun pred)))
(seq-dispatch sequence
- (if from-end
- (list-count-if t t pred sequence)
- (list-count-if t nil pred sequence))
- (if from-end
- (vector-count-if t t pred sequence)
- (vector-count-if t nil pred sequence)))))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (list-count-if t t pred sequence)
+ (list-count-if t nil pred sequence)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (vector-count-if t t pred sequence)
+ (vector-count-if t nil pred sequence)))
+ (apply #'sb!sequence:count-if-not pred sequence args))))
(define-sequence-traverser count
- (item sequence &key from-end start end
+ (item sequence &rest args &key from-end start end
key (test #'eql test-p) (test-not nil test-not-p))
#!+sb-doc
"Return the number of elements in SEQUENCE satisfying a test with ITEM,
which defaults to EQL."
- (declare (fixnum start))
+ (declare (type fixnum start)
+ (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)
(error ":TEST and :TEST-NOT are both present."))
- (let ((end (or end length)))
- (declare (type index end))
- (let ((%test (if test-not-p
- (lambda (x)
- (not (funcall test-not item x)))
- (lambda (x)
- (funcall test item x)))))
- (seq-dispatch sequence
- (if from-end
- (list-count-if nil t %test sequence)
- (list-count-if nil nil %test sequence))
- (if from-end
- (vector-count-if nil t %test sequence)
- (vector-count-if nil nil %test sequence))))))
-
-
+ (let ((%test (if test-not-p
+ (lambda (x)
+ (not (funcall test-not item x)))
+ (lambda (x)
+ (funcall test item x)))))
+ (seq-dispatch sequence
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (list-count-if nil t %test sequence)
+ (list-count-if nil nil %test sequence)))
+ (let ((end (or end length)))
+ (declare (type index end))
+ (if from-end
+ (vector-count-if nil t %test sequence)
+ (vector-count-if nil nil %test sequence)))
+ (apply #'sb!sequence:count item sequence args))))
\f
;;;; MISMATCH
) ; EVAL-WHEN
(define-sequence-traverser mismatch
- (sequence1 sequence2
- &key from-end test test-not
- start1 end1 start2 end2 key)
+ (sequence1 sequence2 &rest args &key from-end test test-not
+ start1 end1 start2 end2 key)
#!+sb-doc
"The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
element-wise. If they are of equal length and match in every element, the
SEQUENCE1 beyond the last position tested is returned. If a non-NIL
: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))
- (let* ((end1 (or end1 length1))
- (end2 (or end2 length2)))
- (declare (type index end1 end2))
- (match-vars
- (seq-dispatch sequence1
- (matchify-list (sequence1 start1 length1 end1)
- (seq-dispatch sequence2
+ (declare (type fixnum start1 start2))
+ (declare (truly-dynamic-extent args))
+ (seq-dispatch sequence1
+ (seq-dispatch sequence2
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
+ (declare (type index end1 end2))
+ (match-vars
+ (matchify-list (sequence1 start1 length1 end1)
(matchify-list (sequence2 start2 length2 end2)
- (list-list-mismatch))
- (list-mumble-mismatch)))
- (seq-dispatch sequence2
+ (list-list-mismatch)))))
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
+ (declare (type index end1 end2))
+ (match-vars
+ (matchify-list (sequence1 start1 length1 end1)
+ (list-mumble-mismatch))))
+ (apply #'sb!sequence:mismatch sequence1 sequence2 args))
+ (seq-dispatch sequence2
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
+ (declare (type index end1 end2))
+ (match-vars
(matchify-list (sequence2 start2 length2 end2)
- (mumble-list-mismatch))
- (mumble-mumble-mismatch))))))
+ (mumble-list-mismatch))))
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
+ (declare (type index end1 end2))
+ (match-vars
+ (mumble-mumble-mismatch)))
+ (apply #'sb!sequence:mismatch sequence1 sequence2 args))
+ (apply #'sb!sequence:mismatch sequence1 sequence2 args)))
+
\f
;;; search comparison functions
(sb!xc:defmacro search-compare (main-type main sub index)
(if (eq main-type 'list)
`(seq-dispatch ,sub
- (search-compare-list-list ,main ,sub)
- (search-compare-list-vector ,main ,sub))
+ (search-compare-list-list ,main ,sub)
+ (search-compare-list-vector ,main ,sub)
+ ;; KLUDGE: just hack it together so that it works
+ (return-from search (apply #'sb!sequence:search sequence1 sequence2 args)))
`(seq-dispatch ,sub
- (search-compare-vector-list ,main ,sub ,index)
- (search-compare-vector-vector ,main ,sub ,index))))
+ (search-compare-vector-list ,main ,sub ,index)
+ (search-compare-vector-vector ,main ,sub ,index)
+ (return-from search (apply #'sb!sequence:search sequence1 sequence2 args)))))
) ; EVAL-WHEN
\f
) ; EVAL-WHEN
(define-sequence-traverser search
- (sequence1 sequence2
- &key from-end test test-not
- start1 end1 start2 end2 key)
- (declare (fixnum start1 start2))
- (let ((end1 (or end1 length1))
- (end2 (or end2 length2)))
- (seq-dispatch sequence2
- (list-search sequence2 sequence1)
- (vector-search sequence2 sequence1))))
+ (sequence1 sequence2 &rest args &key
+ from-end test test-not start1 end1 start2 end2 key)
+ (declare (type fixnum start1 start2)
+ (truly-dynamic-extent args))
+ (seq-dispatch sequence2
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
+ (declare (type index end1 end2))
+ (list-search sequence2 sequence1))
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
+ (declare (type index end1 end2))
+ (vector-search sequence2 sequence1))
+ (apply #'sb!sequence:search sequence1 sequence2 args)))
+
+;;; 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.
+(defun fill-data-vector (vector dimensions initial-contents)
+ (let ((index 0))
+ (labels ((frob (axis dims contents)
+ (cond ((null dims)
+ (setf (aref vector index) contents)
+ (incf index))
+ (t
+ (unless (typep contents 'sequence)
+ (error "malformed :INITIAL-CONTENTS: ~S is not a ~
+ sequence, but ~W more layer~:P needed."
+ contents
+ (- (length dimensions) axis)))
+ (unless (= (length contents) (car dims))
+ (error "malformed :INITIAL-CONTENTS: Dimension of ~
+ axis ~W is ~W, but ~S is ~W long."
+ axis (car dims) contents (length contents)))
+ (sb!sequence:dosequence (content contents)
+ (frob (1+ axis) (cdr dims) content))))))
+ (frob 0 dimensions initial-contents))))
projects / sbcl.git / blobdiff