and special variables (who-binds, who-sets, who-references) for code
compiled with (< SPACE 3). This information is available through the
sb-introspect contrib.
+ * new feature: users may subclass SEQUENCE, and have instances of
+ these classes interoperate with standard Common Lisp functions if
+ a number of methods are defined. (This feature is experimental
+ and the interface subject to change based on feedback from SBCL
+ users and the general community)
* improvement: sb-sprof traces call stacks to an arbitrary depth on
x86/x86-64, rather than the previous fixed depth of 8
* bug fix: non-ascii command-line arguments are processed correctly
"RUN-PENDING-FINALIZERS"
"SCALE-DOUBLE-FLOAT"
#!+long-float "SCALE-LONG-FLOAT"
- "SCALE-SINGLE-FLOAT" "SEQUENCE-COUNT" "SEQUENCE-END"
+ "SCALE-SINGLE-FLOAT"
+ "SEQUENCEP" "SEQUENCE-COUNT" "SEQUENCE-END"
"SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE"
"SET-ARRAY-HEADER" "SET-HEADER-DATA" "SHIFT-TOWARDS-END"
"SHIFT-TOWARDS-START" "SHRINK-VECTOR" "%SHRINK-VECTOR"
:export ("PROFILE" "REPORT" "RESET" "UNPROFILE"))
#s(sb-cold:package-data
+ :name "SB!SEQUENCE"
+ :doc "semi-public: implements something which might eventually
+be submitted as a CDR"
+ :use ()
+ :export ("DOSEQUENCE"
+
+ "MAKE-SEQUENCE-ITERATOR" "MAKE-SIMPLE-SEQUENCE-ITERATOR"
+
+ "ITERATOR-STEP" "ITERATOR-ENDP" "ITERATOR-ELEMENT"
+ "ITERATOR-INDEX" "ITERATOR-COPY"
+
+ "WITH-SEQUENCE-ITERATOR" "WITH-SEQUENCE-ITERATOR-FUNCTIONS"
+
+ "CANONIZE-TEST" "CANONIZE-KEY"
+
+ "LENGTH" "ELT"
+ "MAKE-SEQUENCE-LIKE" "ADJUST-SEQUENCE"
+
+ "COUNT" "COUNT-IF" "COUNT-IF-NOT"
+ "FIND" "FIND-IF" "FIND-IF-NOT"
+ "POSITION" "POSITION-IF" "POSITION-IF-NOT"
+ "SUBSEQ" "COPY-SEQ" "FILL"
+ "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT"
+ "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT"
+ "REPLACE" "REVERSE" "NREVERSE" "REDUCE"
+ "MISMATCH" "SEARCH"
+ "DELETE" "DELETE-IF" "DELETE-IF-NOT"
+ "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT"
+ "DELETE-DUPLICATES" "REMOVE-DUPLICATES" "SORT" "STABLE-SORT"))
+
+ #s(sb-cold:package-data
:name "SB!SYS"
:doc
"private: In theory, this \"contains functions and information
(fill-data-vector data dimensions initial-contents)))
data))
-(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)))
- (if (listp contents)
- (dolist (content contents)
- (frob (1+ axis) (cdr dims) content))
- (dotimes (i (length contents))
- (frob (1+ axis) (cdr dims) (aref contents i))))))))
- (frob 0 dimensions initial-contents))))
-
(defun vector (&rest objects)
#!+sb-doc
"Construct a SIMPLE-VECTOR from the given objects."
;; uncertain, since a subclass of both might be defined
nil)))
+;;; KLUDGE: we need this for the special-case SEQUENCE type, which
+;;; (because of multiple inheritance with ARRAY for the VECTOR types)
+;;; doesn't have the nice hierarchical properties we want. This is
+;;; basically DELEGATE-COMPLEX-INTERSECTION2 with a special-case for
+;;; SEQUENCE/ARRAY interactions.
+(!define-type-method (classoid :complex-intersection2) (type1 class2)
+ (cond
+ ((and (eq class2 (find-classoid 'sequence))
+ (array-type-p type1))
+ (type-intersection2 (specifier-type 'vector) type1))
+ (t
+ (let ((method (type-class-complex-intersection2 (type-class-info type1))))
+ (if (and method (not (eq method #'delegate-complex-intersection2)))
+ :call-other-method
+ (hierarchical-intersection2 type1 class2))))))
+
;;; KLUDGE: we need this to deal with the special-case INSTANCE and
;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
;;; discovered that this was incompatible with the MOP class
:inherits (array)
:prototype-form (make-array nil))
(sequence
- :translation (or cons (member nil) vector))
+ :state :read-only
+ :depth 2)
(vector
:translation vector :codes (#.sb!vm:complex-vector-widetag)
:direct-superclasses (array sequence)
(do* ((index 0 (1+ index))
(length (length (the ,(ecase src-type
(:list 'list)
- (:vector 'vector))
+ (:vector 'vector)
+ (:sequence 'sequence))
object)))
(result ,result)
(in-object object))
(setf (,access result index)
,(ecase src-type
(:list '(pop in-object))
- (:vector '(aref in-object index))))))))
+ (:vector '(aref in-object index))
+ (:sequence '(elt in-object index))))))))
(def list-to-vector* (make-sequence type length)
aref :list t)
(def vector-to-vector* (make-sequence type length)
- aref :vector t))
+ aref :vector t)
+
+ (def sequence-to-vector* (make-sequence type length)
+ aref :sequence t))
(defun vector-to-list* (object)
(let ((result (list nil))
(coerce-error))
((csubtypep type (specifier-type 'character))
(character object))
- ((csubtypep type (specifier-type 'function))
- (when (and (legal-fun-name-p object)
- (not (fboundp object)))
- (error 'simple-type-error
- :datum object
- ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken
- ;; type specifier, since the set of values it describes
- ;; isn't in general constant in time. Maybe we could
- ;; find a better way of expressing this error? (Maybe
- ;; with the UNDEFINED-FUNCTION condition?)
- :expected-type '(satisfies fboundp)
- :format-control "~S isn't fbound."
- :format-arguments (list object)))
- (when (and (symbolp object)
- (sb!xc:macro-function object))
- (error 'simple-type-error
- :datum object
- :expected-type '(not (satisfies sb!xc:macro-function))
- :format-control "~S is a macro."
- :format-arguments (list object)))
- (when (and (symbolp object)
- (special-operator-p object))
- (error 'simple-type-error
- :datum object
- :expected-type '(not (satisfies special-operator-p))
- :format-control "~S is a special operator."
- :format-arguments (list object)))
- (eval `#',object))
((numberp object)
(cond
((csubtypep type (specifier-type 'single-float))
(sequence-type-length-mismatch-error type length)))
(vector-to-list* object))))
(t (sequence-type-too-hairy (type-specifier type))))
- (coerce-error)))
+ (if (sequencep object)
+ (cond
+ ((type= type (specifier-type 'list))
+ (sb!sequence:make-sequence-like
+ nil (length object) :initial-contents object))
+ ((type= type (specifier-type 'null))
+ (if (= (length object) 0)
+ 'nil
+ (sequence-type-length-mismatch-error type
+ (length object))))
+ ((cons-type-p type)
+ (multiple-value-bind (min exactp)
+ (sb!kernel::cons-type-length-info type)
+ (let ((length (length object)))
+ (if exactp
+ (unless (= length min)
+ (sequence-type-length-mismatch-error type length))
+ (unless (>= length min)
+ (sequence-type-length-mismatch-error type length)))
+ (sb!sequence:make-sequence-like
+ nil length :initial-contents object))))
+ (t (sequence-type-too-hairy (type-specifier type))))
+ (coerce-error))))
((csubtypep type (specifier-type 'vector))
(typecase object
;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length
;; errors are caught there. -- CSR, 2002-10-18
(list (list-to-vector* object output-type-spec))
(vector (vector-to-vector* object output-type-spec))
+ (sequence (sequence-to-vector* object output-type-spec))
(t
(coerce-error))))
+ ((and (csubtypep type (specifier-type 'sequence))
+ (find-class output-type-spec nil))
+ (let ((class (find-class output-type-spec)))
+ (sb!sequence:make-sequence-like
+ (sb!mop:class-prototype class)
+ (length object) :initial-contents object)))
+ ((csubtypep type (specifier-type 'function))
+ (when (and (legal-fun-name-p object)
+ (not (fboundp object)))
+ (error 'simple-type-error
+ :datum object
+ ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken
+ ;; type specifier, since the set of values it describes
+ ;; isn't in general constant in time. Maybe we could
+ ;; find a better way of expressing this error? (Maybe
+ ;; with the UNDEFINED-FUNCTION condition?)
+ :expected-type '(satisfies fboundp)
+ :format-control "~S isn't fbound."
+ :format-arguments (list object)))
+ (when (and (symbolp object)
+ (sb!xc:macro-function object))
+ (error 'simple-type-error
+ :datum object
+ :expected-type '(not (satisfies sb!xc:macro-function))
+ :format-control "~S is a macro."
+ :format-arguments (list object)))
+ (when (and (symbolp object)
+ (special-operator-p object))
+ (error 'simple-type-error
+ :datum object
+ :expected-type '(not (satisfies special-operator-p))
+ :format-control "~S is a special operator."
+ :format-arguments (list object)))
+ (eval `#',object))
(t
(coerce-error))))))
(target-type-is-in
'(array simple-string simple-vector string vector))
(values (typep host-object target-type) t))
+ (;; sequence is not guaranteed to be an exhaustive
+ ;; partition, but it includes at least lists and vectors.
+ (target-type-is-in '(sequence))
+ (if (or (vectorp host-object) (listp host-object))
+ (values t t)
+ (if (typep host-object target-type)
+ (warn-and-give-up)
+ (values nil t))))
(;; general cases of vectors
(and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:vector))
(declare (type unsigned-byte ,var))
,@body)))))
-(defun filter-dolist-declarations (decls)
- (mapcar (lambda (decl)
- `(declare ,@(remove-if
- (lambda (clause)
- (and (consp clause)
- (or (eq (car clause) 'type)
- (eq (car clause) 'ignore))))
- (cdr decl))))
- decls))
-
(defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
;; We repeatedly bind the var instead of setting it so that we never
;; have to give the var an arbitrary value such as NIL (which might
(sb!xc:deftype char-code () `(integer 0 (,sb!xc:char-code-limit)))
;;; a consed sequence result. If a vector, is a simple array.
-(sb!xc:deftype consed-sequence () '(or list (simple-array * (*))))
+(sb!xc:deftype consed-sequence ()
+ '(or (simple-array * (*)) (and sequence (not vector))))
;;; the :END arg to a sequence
(sb!xc:deftype sequence-end () '(or null index))
`(labels ((,name ,(mapcar #'first binds) ,@body))
(,name ,@(mapcar #'second binds))))
+(defun filter-dolist-declarations (decls)
+ (mapcar (lambda (decl)
+ `(declare ,@(remove-if
+ (lambda (clause)
+ (and (consp clause)
+ (or (eq (car clause) 'type)
+ (eq (car clause) 'ignore))))
+ (cdr decl))))
+ decls))
+
;;; just like DOLIST, but with one-dimensional arrays
-(defmacro dovector ((elt vector &optional result) &rest forms)
- (let ((index (gensym))
- (length (gensym))
- (vec (gensym)))
- `(let ((,vec ,vector))
- (declare (type vector ,vec))
- (do ((,index 0 (1+ ,index))
- (,length (length ,vec)))
- ((>= ,index ,length) ,result)
- (let ((,elt (aref ,vec ,index)))
- ,@forms)))))
+(defmacro dovector ((elt vector &optional result) &body body)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (with-unique-names (index length vec)
+ `(let ((,vec ,vector))
+ (declare (type vector ,vec))
+ (do ((,index 0 (1+ ,index))
+ (,length (length ,vec)))
+ ((>= ,index ,length) (let ((,elt nil))
+ ,@(filter-dolist-declarations decls)
+ ,elt
+ ,result))
+ (let ((,elt (aref ,vec ,index)))
+ ,@decls
+ (tagbody
+ ,@forms)))))))
;;; Iterate over the entries in a HASH-TABLE.
(defmacro dohash ((key-var value-var table &optional result) &body body)
((eq (info :type :kind spec) :instance)
(find-classoid spec))
((typep spec 'classoid)
- ;; There doesn't seem to be any way to translate
- ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be
- ;; executed on the host Common Lisp at cross-compilation time.
- #+sb-xc-host (error
- "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host")
(if (typep spec 'built-in-classoid)
(or (built-in-classoid-translation spec) spec)
spec))
(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond ((eq type2 *universal-type*)
(values t t))
- ((or (type-might-contain-other-types-p type1)
- ;; some CONS types can conceal danger
- (and (cons-type-p type1)
- (cons-type-might-be-empty-type type1)))
+ ;; some CONS types can conceal danger
+ ((and (cons-type-p type1) (cons-type-might-be-empty-type type1))
+ (values nil nil))
+ ((type-might-contain-other-types-p type1)
;; those types can be other types in disguise. So we'd
;; better delegate.
(invoke-complex-subtypep-arg1-method type1 type2))
(typecase type1
(structure-classoid *empty-type*)
(classoid
- (if (and (not (member type1 *non-instance-classoid-types*
- :key #'find-classoid))
- (find (classoid-layout (find-classoid 'function))
- (layout-inherits (classoid-layout type1))))
- type1
- (if (type= type1 (find-classoid 'function))
- type2
- nil)))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ *empty-type*
+ (if (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ (if (type= type1 (find-classoid 'function))
+ type2
+ nil))))
(fun-type nil)
(t
(if (or (type-might-contain-other-types-p type1)
(array-type-specialized-element-type type2))
t)))))
-;;; FIXME: is this dead?
(!define-superclasses array
- ((base-string base-string)
- (vector vector)
- (array))
+ ((vector vector) (array))
!cold-init-forms)
(defun array-types-intersect (type1 type2)
(type-intersection (cons-type-car-type type1)
(cons-type-car-type type2))
cdr-int2)))))
+
+(!define-superclasses cons ((cons)) !cold-init-forms)
\f
;;;; CHARACTER-SET types
(and (complex-vector-p x)
(do ((data (%array-data-vector x) (%array-data-vector data)))
((not (array-header-p data)) (simple-vector-p data))))))
+
+;;; Is X a SEQUENCE? Harder than just (OR VECTOR LIST)
+(defun sequencep (x)
+ (or (listp x)
+ (vectorp x)
+ (let* ((slayout #.(info :type :compiler-layout 'sequence))
+ (depthoid #.(layout-depthoid (info :type :compiler-layout 'sequence)))
+ (layout (layout-of x)))
+ (when (layout-invalid layout)
+ (setq layout (update-object-layout-or-invalid x slayout)))
+ (if (eq layout slayout)
+ t
+ (let ((inherits (layout-inherits layout)))
+ (declare (optimize (safety 0)))
+ (and (> (length inherits) depthoid)
+ (eq (svref inherits depthoid) slayout)))))))
\f
;;;; primitive predicates. These must be supported directly by the
;;;; compiler.
\f
;;;; utilities
-(eval-when (:compile-toplevel)
+(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *sequence-keyword-info*
;; (name default supplied-p adjustment new-type)
;; FIXME: make this robust. And clean.
((sequence)
(new-args arg)
- (adjustments '(length (etypecase sequence
- (list (length sequence))
- (vector (length sequence)))))
+ (adjustments '(length (length sequence)))
(new-declarations '(type index length)))
((sequence1)
(new-args arg)
- (adjustments '(length1 (etypecase sequence1
- (list (length sequence1))
- (vector (length sequence1)))))
+ (adjustments '(length1 (length sequence1)))
(new-declarations '(type index length1)))
((sequence2)
(new-args arg)
- (adjustments '(length2 (etypecase sequence2
- (list (length sequence2))
- (vector (length sequence2)))))
+ (adjustments '(length2 (length sequence2)))
(new-declarations '(type index length2)))
((function predicate)
(new-args arg)
;;; 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
\f
(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
: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
(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))))
+ (copy (%make-sequence-like sequence (- end start))))
((= old-index end) copy)
(declare (fixnum old-index new-index))
(setf (aref copy new-index)
"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
`(let ((length (length (the vector ,sequence))))
(declare (fixnum length))
(do ((index 0 (1+ index))
- (copy (make-sequence-like ,sequence length)))
+ (copy (%make-sequence-like ,sequence length)))
((= index length) copy)
(declare (fixnum index))
(setf (aref copy index) (aref ,sequence index)))))
(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)))
+ (list-copy-seq* sequence)
+ (vector-copy-seq* sequence)
+ (sb!sequence:copy-seq sequence)))
;;; internal frobs
(when (null end) (setq end (length sequence)))
(vector-fill sequence item start end))
-(define-sequence-traverser fill (sequence item &key start end)
+(define-sequence-traverser fill (sequence item &rest args &key start 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)
+ (apply #'sb!sequence:fill sequence item args)))
\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."
+ (declare (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
+(defmacro sb!sequence:dosequence ((e sequence &optional return) &body body)
+ (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 (,e ,sequence ,return) ,@body)
+ (dovector (,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)))
+ ((funcall endp ,sequence state limit from-end)
+ (let ((,e nil))
+ ,@(filter-dolist-declarations decls)
+ ,e
+ ,return))
+ (let ((,e (funcall elt ,sequence state)))
+ ,@decls
+ (tagbody
+ ,@forms))))))))))
+
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro concatenate-to-list (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!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))
((= 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)))))))
+ (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)))
(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)))))
(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 (dynamic-extent args))
+ (push (apply fun args) result)))
+ (declare (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 (dynamic-extent args))
+ (declare (ignore args))
+ (incf min-len)))
+ (declare (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))
+ (setf (aref result i) (apply fun args))
+ (incf i)))
+ (declare (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 (dynamic-extent args))
+ (declare (ignore args))
+ (incf min-len)))
+ (declare (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))
+ (funcall setelt (apply fun args) result state)
+ (setq state (funcall step result state from-end))))
+ (declare (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)))))))
) ; EVAL-WHEN
-(define-sequence-traverser reduce
- (function sequence &key key from-end start end (initial-value nil ivp))
+(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))
(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)))))
+ (seq-dispatch sequence
+ (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)))
+ (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))
+ (declare (dynamic-extent args))
(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)))))
+ (if from-end
+ (normal-list-delete-from-end)
+ (normal-list-delete))
+ (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))
+ (declare (dynamic-extent args))
(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)))))
+ (if from-end
+ (if-list-delete-from-end)
+ (if-list-delete))
+ (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))
+ (declare (dynamic-extent args))
(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)))))
+ (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))
+ (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))))
) ; 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))
+ (declare (dynamic-extent args))
(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)))))
+ (if from-end
+ (normal-list-remove-from-end)
+ (normal-list-remove))
+ (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))
+ (declare (dynamic-extent args))
(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)))))
+ (if from-end
+ (if-list-remove-from-end)
+ (if-list-remove))
+ (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))
+ (declare (dynamic-extent args))
(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)))))
+ (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))
+ (apply #'sb!sequence:remove-if-not predicate sequence args))))
\f
;;;; REMOVE-DUPLICATES
&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))
(%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
The :TEST-NOT argument is deprecated."
(declare (fixnum start))
+ (declare (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
(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 (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)))
+ (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)
- (if from-end
- (nreverse (list-substitute* ,pred
- new
- (reverse sequence)
- (- (the fixnum length)
- (the fixnum end))
- (- (the fixnum length)
- (the fixnum start))
- 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))))
-
+ `(seq-dispatch sequence
+ (if from-end
+ (nreverse (list-substitute* ,pred
+ new
+ (reverse sequence)
+ (- (the fixnum length)
+ (the fixnum end))
+ (- (the fixnum length)
+ (the fixnum start))
+ 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))
+ ;; 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))
+ (declare (dynamic-extent args))
(let ((end (or end length)))
(declare (type index end))
(subst-dispatch 'normal)))
;;;; 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 (dynamic-extent args))
(declare (fixnum start))
(let ((end (or end length))
(test predicate)
(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 (dynamic-extent args))
(declare (fixnum start))
(let ((end (or end length))
(test predicate)
;;;; 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))
+ (declare (dynamic-extent args))
(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
+ (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)))
+ (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))
- (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))
+ (declare (dynamic-extent args))
(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
+ (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)))
+ (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))
- (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))
(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))
+ (declare (dynamic-extent args))
(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
+ (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)))
+ (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))
- (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))
;; %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))))))))))
+ `(seq-dispatch sequence-arg
+ (frob sequence-arg from-end)
+ (with-array-data ((sequence sequence-arg :offset-var offset)
+ (start start)
+ (end (%check-vector-sequence-bounds
+ sequence-arg start end)))
+ (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)))))))))
(defun %find-position (item sequence-arg from-end start end key test)
(macrolet ((frob (sequence from-end)
`(%find-position item ,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 (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 (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 (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 (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 (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 (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))
+ (declare (dynamic-extent args))
(let ((end (or end length))
(pred (%coerce-callable-to-fun pred)))
(declare (type index end))
(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)))))
+ (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))
+ (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))
+ (declare (dynamic-extent args))
(let ((end (or end length))
(pred (%coerce-callable-to-fun pred)))
(declare (type index end))
(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)))))
+ (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))
+ (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 (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)
(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))))))
-
-
+ (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))
+ (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
: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))
(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
+ (seq-dispatch sequence2
+ (matchify-list (sequence1 start1 length1 end1)
(matchify-list (sequence2 start2 length2 end2)
- (list-list-mismatch))
- (list-mumble-mismatch)))
+ (list-list-mismatch)))
+ (matchify-list (sequence1 start1 length1 end1)
+ (list-mumble-mismatch))
+ (apply #'sb!sequence:mismatch sequence1 sequence2 args))
(seq-dispatch sequence2
(matchify-list (sequence2 start2 length2 end2)
(mumble-list-mismatch))
- (mumble-mumble-mismatch))))))
+ (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)
+ (sequence1 sequence2 &rest args &key
+ from-end test test-not start1 end1 start2 end2 key)
(declare (fixnum start1 start2))
+ (declare (dynamic-extent args))
(let ((end1 (or end1 length1))
(end2 (or end2 length2)))
(seq-dispatch sequence2
- (list-search sequence2 sequence1)
- (vector-search sequence2 sequence1))))
+ (list-search sequence2 sequence1)
+ (vector-search sequence2 sequence1)
+ (apply #'sb!sequence:search sequence1 sequence2 args))))
(sb!xc:defmacro string-dispatch ((&rest types) var &body body)
(let ((fun (gensym "STRING-DISPATCH-FUN-")))
(etypecase ,var
,@(loop for type in types
collect `(,type (,fun (the ,type ,var))))))))
+
+;;; originally in array.lisp; probably best to put it back there and
+;;; make DOSEQUENCE and SEQ-DISPATCH be in early-seq.lisp.
+(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))))
\ No newline at end of file
;;; allows the compiler to make enough optimizations that it might be
;;; worth the (large) cost in space.
(declaim (maybe-inline sort))
-(defun sort (sequence predicate &key key)
+(defun sort (sequence predicate &rest args &key key)
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
+ (declare (dynamic-extent args))
(let ((predicate-fun (%coerce-callable-to-fun predicate)))
- (typecase sequence
- (list
- (stable-sort-list sequence
- predicate-fun
- (if key (%coerce-callable-to-fun key) #'identity)))
- (vector
- (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
- (with-array-data ((vector (the vector sequence))
- (start 0)
- (end (length sequence)))
- (sort-vector vector start end predicate-fun key-fun-or-nil)))
- sequence)
- (t
- (error 'simple-type-error
- :datum sequence
- :expected-type 'sequence
- :format-control "~S is not a sequence."
- :format-arguments (list sequence))))))
+ (seq-dispatch sequence
+ (stable-sort-list sequence
+ predicate-fun
+ (if key (%coerce-callable-to-fun key) #'identity))
+ (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
+ (with-array-data ((vector (the vector sequence))
+ (start 0)
+ (end (length sequence)))
+ (sort-vector vector start end predicate-fun key-fun-or-nil))
+ sequence)
+ (apply #'sb!sequence:sort sequence predicate args))))
\f
;;;; stable sorting
-
-(defun stable-sort (sequence predicate &key key)
+(defun stable-sort (sequence predicate &rest args &key key)
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
+ (declare (dynamic-extent args))
(let ((predicate-fun (%coerce-callable-to-fun predicate)))
- (typecase sequence
- (simple-vector
- (stable-sort-simple-vector sequence
- predicate-fun
- (and key (%coerce-callable-to-fun key))))
- (list
- (stable-sort-list sequence
- predicate-fun
- (if key (%coerce-callable-to-fun key) #'identity)))
- (vector
- (stable-sort-vector sequence
- predicate-fun
- (and key (%coerce-callable-to-fun key))))
- (t
- (error 'simple-type-error
- :datum sequence
- :expected-type 'sequence
- :format-control "~S is not a sequence."
- :format-arguments (list sequence))))))
- \f
+ (seq-dispatch sequence
+ (stable-sort-list sequence
+ predicate-fun
+ (if key (%coerce-callable-to-fun key) #'identity))
+ (if (typep sequence 'simple-vector)
+ (stable-sort-simple-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key)))
+ (stable-sort-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key))))
+ (apply #'sb!sequence:stable-sort sequence predicate args))))
+\f
;;; FUNCALL-USING-KEY saves us a function call sometimes.
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro funcall2-using-key (pred key one two)
(vector-2 (coerce sequence2 'vector))
(length-1 (length vector-1))
(length-2 (length vector-2))
- (result (make-sequence result-type
- (+ length-1 length-2))))
+ (result (make-sequence result-type (+ length-1 length-2))))
(declare (vector vector-1 vector-2)
(fixnum length-1 length-2))
(if (and (simple-vector-p result)
result predicate key svref)
(merge-vectors vector-1 length-1 vector-2 length-2
result predicate key aref))))
+ ((and (csubtypep type (specifier-type 'sequence))
+ (find-class result-type nil))
+ (let* ((vector-1 (coerce sequence1 'vector))
+ (vector-2 (coerce sequence2 'vector))
+ (length-1 (length vector-1))
+ (length-2 (length vector-2))
+ (temp (make-array (+ length-1 length-2)))
+ (result (make-sequence result-type (+ length-1 length-2))))
+ (declare (vector vector-1 vector-2) (fixnum length-1 length-2))
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ temp predicate key aref)
+ (replace result temp)
+ result))
(t (bad-sequence-type-error result-type)))))
(rename-package package
(package-name package)
(cons "SB-C-CALL" (package-nicknames package))))
+
+(let ((package (find-package "SB-SEQUENCE")))
+ (rename-package package (package-name package) (list "SEQUENCE")))
\f
;;;; compiling and loading more of the system
"SRC;PCL;GRAY-STREAMS-CLASS"
"SRC;PCL;GRAY-STREAMS"
+ ;; CLOS-level support for User-extensible sequences.
+ "SRC;PCL;SEQUENCE"
+
;; other functionality not needed for cold init, moved
;; to warm init to reduce peak memory requirement in
;; cold init
(foldable unsafely-flushable call))
;;; unsafe for :INITIAL-VALUE...
-(defknown reduce (callable
- sequence
- &key
- (:from-end t)
- (:start index)
- (:end sequence-end)
- (:initial-value t)
- (:key callable))
+(defknown reduce (callable sequence &rest t &key (:from-end t) (:start index)
+ (:end sequence-end) (:initial-value t) (:key callable))
t
(foldable flushable call unsafe))
-(defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence
+(defknown fill (sequence t &rest t &key
+ (:start index) (:end sequence-end)) sequence
(unsafe)
:derive-type #'result-type-first-arg
:destroyed-constant-args (nth-constant-nonempty-sequence-args 1))
-(defknown replace (sequence
- sequence
- &key
- (:start1 index)
- (:end1 sequence-end)
- (:start2 index)
- (:end2 sequence-end))
+(defknown replace (sequence sequence &rest t &key (:start1 index)
+ (:end1 sequence-end) (:start2 index) (:end2 sequence-end))
sequence ()
:derive-type #'result-type-first-arg
:destroyed-constant-args (nth-constant-nonempty-sequence-args 1))
(defknown remove
- (t sequence &key (:from-end t) (:test callable)
+ (t sequence &rest t &key (:from-end t) (:test callable)
(:test-not callable) (:start index) (:end sequence-end)
(:count sequence-count) (:key callable))
consed-sequence
:derive-type (sequence-result-nth-arg 2))
(defknown substitute
- (t t sequence &key (:from-end t) (:test callable)
+ (t t sequence &rest t &key (:from-end t) (:test callable)
(:test-not callable) (:start index) (:end sequence-end)
(:count sequence-count) (:key callable))
consed-sequence
:derive-type (sequence-result-nth-arg 3))
(defknown (remove-if remove-if-not)
- (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:count sequence-count) (:key callable))
+ (callable sequence &rest t &key (:from-end t) (:start index)
+ (:end sequence-end) (:count sequence-count) (:key callable))
consed-sequence
(flushable call)
:derive-type (sequence-result-nth-arg 2))
(defknown (substitute-if substitute-if-not)
- (t callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:count sequence-count) (:key callable))
+ (t callable sequence &rest t &key (:from-end t) (:start index)
+ (:end sequence-end) (:count sequence-count) (:key callable))
consed-sequence
(flushable call)
:derive-type (sequence-result-nth-arg 3))
(defknown delete
- (t sequence &key (:from-end t) (:test callable)
+ (t sequence &rest t &key (:from-end t) (:test callable)
(:test-not callable) (:start index) (:end sequence-end)
(:count sequence-count) (:key callable))
sequence
:destroyed-constant-args (nth-constant-nonempty-sequence-args 2))
(defknown nsubstitute
- (t t sequence &key (:from-end t) (:test callable)
+ (t t sequence &rest t &key (:from-end t) (:test callable)
(:test-not callable) (:start index) (:end sequence-end)
(:count sequence-count) (:key callable))
sequence
:destroyed-constant-args (nth-constant-nonempty-sequence-args 3))
(defknown (delete-if delete-if-not)
- (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:count sequence-count) (:key callable))
+ (callable sequence &rest t &key (:from-end t) (:start index)
+ (:end sequence-end) (:count sequence-count) (:key callable))
sequence
(flushable call important-result)
:derive-type (sequence-result-nth-arg 2)
:destroyed-constant-args (nth-constant-nonempty-sequence-args 2))
(defknown (nsubstitute-if nsubstitute-if-not)
- (t callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:count sequence-count) (:key callable))
+ (t callable sequence &rest t &key (:from-end t) (:start index)
+ (:end sequence-end) (:count sequence-count) (:key callable))
sequence
(flushable call)
:derive-type (sequence-result-nth-arg 3)
:destroyed-constant-args (nth-constant-nonempty-sequence-args 3))
(defknown remove-duplicates
- (sequence &key (:test callable) (:test-not callable) (:start index)
+ (sequence &rest t &key (:test callable) (:test-not callable) (:start index)
(:from-end t) (:end sequence-end) (:key callable))
consed-sequence
(unsafely-flushable call)
:derive-type (sequence-result-nth-arg 1))
(defknown delete-duplicates
- (sequence &key (:test callable) (:test-not callable) (:start index)
+ (sequence &rest t &key (:test callable) (:test-not callable) (:start index)
(:from-end t) (:end sequence-end) (:key callable))
sequence
(unsafely-flushable call important-result)
:derive-type (sequence-result-nth-arg 1)
:destroyed-constant-args (nth-constant-nonempty-sequence-args 1))
-(defknown find (t sequence &key (:test callable) (:test-not callable)
- (:start index) (:from-end t) (:end sequence-end)
- (:key callable))
+(defknown find (t sequence &rest t &key (:test callable)
+ (:test-not callable) (:start index) (:from-end t)
+ (:end sequence-end) (:key callable))
t
(foldable flushable call))
(defknown (find-if find-if-not)
- (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:key callable))
+ (callable sequence &rest t &key (:from-end t) (:start index)
+ (:end sequence-end) (:key callable))
t
(foldable flushable call))
-(defknown position (t sequence &key (:test callable) (:test-not callable)
- (:start index) (:from-end t) (:end sequence-end)
- (:key callable))
+(defknown position (t sequence &rest t &key (:test callable)
+ (:test-not callable) (:start index) (:from-end t)
+ (:end sequence-end) (:key callable))
(or index null)
(foldable flushable call))
(defknown (position-if position-if-not)
- (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:key callable))
+ (callable sequence &rest t &key (:from-end t) (:start index)
+ (:end sequence-end) (:key callable))
(or index null)
(foldable flushable call))
-(defknown count (t sequence &key (:test callable) (:test-not callable)
- (:start index) (:from-end t) (:end sequence-end)
- (:key callable))
+(defknown count (t sequence &rest t &key
+ (:test callable) (:test-not callable) (:start index)
+ (:from-end t) (:end sequence-end) (:key callable))
index
(foldable flushable call))
(defknown (count-if count-if-not)
- (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:key callable))
+ (callable sequence &rest t &key
+ (:from-end t) (:start index) (:end sequence-end) (:key callable))
index
(foldable flushable call))
(defknown (mismatch search)
- (sequence sequence &key (:from-end t) (:test callable) (:test-not callable)
- (:start1 index) (:end1 sequence-end)
- (:start2 index) (:end2 sequence-end)
- (:key callable))
+ (sequence sequence &rest t &key (:from-end t) (:test callable)
+ (:test-not callable) (:start1 index) (:end1 sequence-end)
+ (:start2 index) (:end2 sequence-end) (:key callable))
(or index null)
(foldable flushable call))
;;; not FLUSHABLE, since vector sort guaranteed in-place...
-(defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence
+(defknown (stable-sort sort) (sequence callable &rest t &key (:key callable))
+ sequence
(call)
:derive-type (sequence-result-nth-arg 1)
:destroyed-constant-args (nth-constant-nonempty-sequence-args 1))
#!+sb-unicode character-string-p
#!+sb-unicode simple-character-string-p
array-header-p
+ sequencep
simple-array-p simple-array-nil-p vector-nil-p
simple-array-unsigned-byte-2-p
simple-array-unsigned-byte-4-p simple-array-unsigned-byte-7-p
'list)
(t
(give-up-ir1-transform
- "can't determine result type")))))
+ "result type unsuitable")))))
(cond ((and result-type-value (null seqs))
;; The consing arity-1 cases can be implemented
;; reasonably efficiently as function calls, and the cost
(macrolet ((define-find-position (fun-name values-index)
`(deftransform ,fun-name ((item sequence &key
from-end (start 0) end
- key test test-not))
+ key test test-not)
+ (t (or list vector) &rest t))
'(nth-value ,values-index
(%find-position item sequence
from-end start
(macrolet ((define-find-position-if (fun-name values-index)
`(deftransform ,fun-name ((predicate sequence &key
from-end (start 0)
- end key))
+ end key)
+ (t (or list vector) &rest t))
'(nth-value
,values-index
(%find-position-if (%coerce-callable-to-fun predicate)
(macrolet ((define-find-position-if-not (fun-name values-index)
`(deftransform ,fun-name ((predicate sequence &key
from-end (start 0)
- end key))
+ end key)
+ (t (or list vector) &rest t))
'(nth-value
,values-index
(%find-position-if-not (%coerce-callable-to-fun predicate)
;;;; predicates so complex that the only reasonable implentation is
;;;; via function call.
;;;;
-;;;; Some standard types (such as SEQUENCE) are best tested by letting
-;;;; the TYPEP source transform do its thing with the expansion. These
+;;;; Some standard types (such as ATOM) are best tested by letting the
+;;;; TYPEP source transform do its thing with the expansion. These
;;;; types (and corresponding predicates) are not maintained in this
;;;; association. In this case, there need not be any predicate
;;;; function unless it is required by the Common Lisp specification.
(define-type-predicate numberp number)
(define-type-predicate rationalp rational)
(define-type-predicate realp real)
+ (define-type-predicate sequencep sequence)
(define-type-predicate simple-bit-vector-p simple-bit-vector)
(define-type-predicate simple-string-p simple-string)
(define-type-predicate simple-vector-p simple-vector)
--- /dev/null
+;;;; Extensible sequences, based on the proposal by Christophe Rhodes.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "SB-IMPL")
+\f
+;;;; basic protocol
+(define-condition sequence::protocol-unimplemented (type-error)
+ ())
+
+(defun sequence::protocol-unimplemented (sequence)
+ (error 'sequence::protocol-unimplemented
+ :datum sequence :expected-type '(or list vector)))
+
+(defgeneric sequence:length (sequence)
+ (:method ((s list)) (length s))
+ (:method ((s vector)) (length s))
+ (:method ((s sequence)) (sequence::protocol-unimplemented s)))
+
+(defgeneric sequence:elt (sequence index)
+ (:method ((s list) index) (elt s index))
+ (:method ((s vector) index) (elt s index))
+ (:method ((s sequence) index) (sequence::protocol-unimplemented s)))
+
+(defgeneric (setf sequence:elt) (new-value sequence index)
+ (:argument-precedence-order sequence new-value index)
+ (:method (new-value (s list) index) (setf (elt s index) new-value))
+ (:method (new-value (s vector) index) (setf (elt s index) new-value))
+ (:method (new-value (s sequence) index)
+ (sequence::protocol-unimplemented s)))
+
+(defgeneric sequence:make-sequence-like
+ (sequence length &key initial-element initial-contents)
+ (:method ((s list) length &key
+ (initial-element nil iep) (initial-contents nil icp))
+ (cond
+ ((and icp iep) (error "bar"))
+ (iep (make-list length :initial-element initial-element))
+ (icp (unless (= (length initial-contents) length)
+ (error "foo"))
+ (let ((result (make-list length)))
+ (replace result initial-contents)
+ result))
+ (t (make-list length))))
+ (:method ((s vector) length &key
+ (initial-element nil iep) (initial-contents nil icp))
+ (cond
+ ((and icp iep) (error "foo"))
+ (iep (make-array length :element-type (array-element-type s)
+ :initial-element initial-element))
+ (icp (make-array length :element-type (array-element-type s)
+ :initial-contents initial-contents))
+ (t (make-array length :element-type (array-element-type s)))))
+ (:method ((s sequence) length &key initial-element initial-contents)
+ (declare (ignore initial-element initial-contents))
+ (sequence::protocol-unimplemented s)))
+
+(defgeneric sequence:adjust-sequence
+ (sequence length &key initial-element initial-contents)
+ (:method ((s list) length &key initial-element (initial-contents nil icp))
+ (if (eql length 0)
+ nil
+ (let ((olength (length s)))
+ (cond
+ ((eql length olength) (if icp (replace s initial-contents) s))
+ ((< length olength)
+ (rplacd (nthcdr (1- length) s) nil)
+ (if icp (replace s initial-contents) s))
+ ((null s)
+ (let ((return (make-list length :initial-element initial-element)))
+ (if icp (replace return initial-contents) return)))
+ (t (rplacd (nthcdr (1- olength) s)
+ (make-list (- length olength)
+ :initial-element initial-element))
+ (if icp (replace s initial-contents) s))))))
+ (:method ((s vector) length &rest args &key (initial-contents nil icp) initial-element)
+ (declare (ignore initial-element))
+ (cond
+ ((and (array-has-fill-pointer-p s)
+ (>= (array-total-size s) length))
+ (setf (fill-pointer s) length)
+ (if icp (replace s initial-contents) s))
+ ((eql (length s) length)
+ (if icp (replace s initial-contents) s))
+ (t (apply #'adjust-array s length args))))
+ (:method (new-value (s sequence) &rest args)
+ (declare (ignore args))
+ (sequence::protocol-unimplemented s)))
+\f
+;;;; iterator protocol
+
+;;; The general protocol
+
+(defgeneric sequence:make-sequence-iterator (sequence &key from-end start end)
+ (:method ((s sequence) &key from-end (start 0) end)
+ (multiple-value-bind (iterator limit from-end)
+ (sequence:make-simple-sequence-iterator
+ s :from-end from-end :start start :end end)
+ (values iterator limit from-end
+ #'sequence:iterator-step #'sequence:iterator-endp
+ #'sequence:iterator-element #'(setf sequence:iterator-element)
+ #'sequence:iterator-index #'sequence:iterator-copy))))
+
+;;; the simple protocol: the simple iterator returns three values,
+;;; STATE, LIMIT and FROM-END.
+
+;;; magic termination value for list :from-end t
+(defvar *exhausted* (cons nil nil))
+
+(defgeneric sequence:make-simple-sequence-iterator
+ (sequence &key from-end start end)
+ (:method ((s list) &key from-end (start 0) end)
+ (if from-end
+ (let* ((termination (if (= start 0) *exhausted* (nthcdr (1- start) s)))
+ (init (if (<= (or end (length s)) start)
+ termination
+ (if end (last s (- (length s) (1- end))) (last s)))))
+ (values init termination t))
+ (cond
+ ((not end) (values (nthcdr start s) nil nil))
+ (t (let ((st (nthcdr start s)))
+ (values st (nthcdr (- end start) st) nil))))))
+ (:method ((s vector) &key from-end (start 0) end)
+ (let ((end (or end (length s))))
+ (if from-end
+ (values (1- end) (1- start) t)
+ (values start end nil))))
+ (:method ((s sequence) &key from-end (start 0) end)
+ (let ((end (or end (length s))))
+ (if from-end
+ (values (1- end) (1- start) from-end)
+ (values start end nil)))))
+
+(defgeneric sequence:iterator-step (sequence iterator from-end)
+ (:method ((s list) iterator from-end)
+ (if from-end
+ (if (eq iterator s)
+ *exhausted*
+ (do* ((xs s (cdr xs)))
+ ((eq (cdr xs) iterator) xs)))
+ (cdr iterator)))
+ (:method ((s vector) iterator from-end)
+ (if from-end
+ (1- iterator)
+ (1+ iterator)))
+ (:method ((s sequence) iterator from-end)
+ (if from-end
+ (1- iterator)
+ (1+ iterator))))
+
+(defgeneric sequence:iterator-endp (sequence iterator limit from-end)
+ (:method ((s list) iterator limit from-end)
+ (eq iterator limit))
+ (:method ((s vector) iterator limit from-end)
+ (= iterator limit))
+ (:method ((s sequence) iterator limit from-end)
+ (= iterator limit)))
+
+(defgeneric sequence:iterator-element (sequence iterator)
+ (:method ((s list) iterator)
+ (car iterator))
+ (:method ((s vector) iterator)
+ (aref s iterator))
+ (:method ((s sequence) iterator)
+ (elt s iterator)))
+
+(defgeneric (setf sequence:iterator-element) (new-value sequence iterator)
+ (:method (o (s list) iterator)
+ (setf (car iterator) o))
+ (:method (o (s vector) iterator)
+ (setf (aref s iterator) o))
+ (:method (o (s sequence) iterator)
+ (setf (elt s iterator) o)))
+
+(defgeneric sequence:iterator-index (sequence iterator)
+ (:method ((s list) iterator)
+ ;; FIXME: this sucks. (In my defence, it is the equivalent of the
+ ;; Apple implementation in Dylan...)
+ (loop for l on s for i from 0 when (eq l iterator) return i))
+ (:method ((s vector) iterator) iterator)
+ (:method ((s sequence) iterator) iterator))
+
+(defgeneric sequence:iterator-copy (sequence iterator)
+ (:method ((s list) iterator) iterator)
+ (:method ((s vector) iterator) iterator)
+ (:method ((s sequence) iterator) iterator))
+
+(defmacro sequence:with-sequence-iterator
+ ((&rest vars) (s &rest args &key from-end start end) &body body)
+ (declare (ignore from-end start end))
+ `(multiple-value-bind (,@vars) (sequence:make-sequence-iterator ,s ,@args)
+ (declare (type function ,@(nthcdr 3 vars)))
+ ,@body))
+
+(defmacro sequence:with-sequence-iterator-functions
+ ((step endp elt setf index copy)
+ (s &rest args &key from-end start end)
+ &body body)
+ (declare (ignore from-end start end))
+ (let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
+ (nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
+ (nendp (gensym "ENDP")) (nelt (gensym "ELT"))
+ (nsetf (gensym "SETF")) (nindex (gensym "INDEX"))
+ (ncopy (gensym "COPY")))
+ `(sequence:with-sequence-iterator
+ (,nstate ,nlimit ,nfrom-end ,nstep ,nendp ,nelt ,nsetf ,nindex ,ncopy)
+ (,s ,@args)
+ (flet ((,step () (setq ,nstate (funcall ,nstep ,s ,nstate ,nfrom-end)))
+ (,endp () (funcall ,nendp ,s ,nstate ,nlimit ,nfrom-end))
+ (,elt () (funcall ,nelt ,s ,nstate))
+ (,setf (new-value) (funcall ,nsetf new-value ,s ,nstate))
+ (,index () (funcall ,nindex ,s ,nstate))
+ (,copy () (funcall ,ncopy ,s ,nstate)))
+ (declare (dynamic-extent #',step #',endp #',elt
+ #',setf #',index #',copy))
+ ,@body))))
+
+(defun sequence:canonize-test (test test-not)
+ (cond
+ (test (if (functionp test) test (fdefinition test)))
+ (test-not (if (functionp test-not)
+ (complement test-not)
+ (complement (fdefinition test-not))))
+ (t #'eql)))
+
+(defun sequence:canonize-key (key)
+ (or (and key (if (functionp key) key (fdefinition key))) #'identity))
+\f
+;;;; LOOP support. (DOSEQUENCE support is present in the core SBCL
+;;;; code).
+(defun loop-elements-iteration-path (variable data-type prep-phrases)
+ (let (of-phrase)
+ (loop for (prep . rest) in prep-phrases do
+ (ecase prep
+ ((:of :in) (if of-phrase
+ (sb-loop::loop-error "Too many prepositions")
+ (setq of-phrase rest)))))
+ (destructuring-bind (it lim f-e step endp elt seq)
+ (loop repeat 7 collect (gensym))
+ (push `(let ((,seq ,(car of-phrase)))) sb-loop::*loop-wrappers*)
+ (push `(sequence:with-sequence-iterator (,it ,lim ,f-e ,step ,endp ,elt) (,seq))
+ sb-loop::*loop-wrappers*)
+ `(((,variable nil ,data-type)) () () nil (funcall ,endp ,seq ,it ,lim ,f-e)
+ (,variable (funcall ,elt ,seq ,it) ,it (funcall ,step ,seq ,it ,f-e))))))
+(sb-loop::add-loop-path
+ '(element elements) 'loop-elements-iteration-path sb-loop::*loop-ansi-universe*
+ :preposition-groups '((:of :in)) :inclusive-permitted nil)
+\f
+;;;; generic implementations for sequence functions.
+
+;;; FIXME: COUNT, POSITION and FIND share an awful lot of structure.
+;;; They could usefully be defined in an OAOO way.
+(defgeneric sequence:count
+ (item sequence &key from-end start end test test-not key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:count
+ (item (sequence sequence) &key from-end (start 0) end test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((count 0))
+ ((funcall endp sequence state limit from-end) count)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall test item (funcall key o))
+ (incf count))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:count-if (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:count-if
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((count 0))
+ ((funcall endp sequence state limit from-end) count)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall pred (funcall key o))
+ (incf count))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:count-if-not (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:count-if-not
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((count 0))
+ ((funcall endp sequence state limit from-end) count)
+ (let ((o (funcall elt sequence state)))
+ (unless (funcall pred (funcall key o))
+ (incf count))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:find
+ (item sequence &key from-end start end test test-not key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:find
+ (item (sequence sequence) &key from-end (start 0) end test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ()
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall test item (funcall key o))
+ (return o))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:find-if (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:find-if
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ()
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall pred (funcall key o))
+ (return o))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:find-if-not (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:find-if-not
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ()
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (unless (funcall pred (funcall key o))
+ (return o))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:position
+ (item sequence &key from-end start end test test-not key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:position
+ (item (sequence sequence) &key from-end (start 0) end test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((s (if from-end -1 1))
+ (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall test item (funcall key o))
+ (return pos))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:position-if (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:position-if
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((s (if from-end -1 1))
+ (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (when (funcall pred (funcall key o))
+ (return pos))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:position-if-not
+ (pred sequence &key from-end start end key)
+ (:argument-precedence-order sequence pred))
+(defmethod sequence:position-if-not
+ (pred (sequence sequence) &key from-end (start 0) end key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :from-end from-end :start start :end end)
+ (do ((s (if from-end -1 1))
+ (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
+ ((funcall endp sequence state limit from-end) nil)
+ (let ((o (funcall elt sequence state)))
+ (unless (funcall pred (funcall key o))
+ (return pos))
+ (setq state (funcall step sequence state from-end)))))))
+
+(defgeneric sequence:subseq (sequence start &optional end))
+(defmethod sequence:subseq ((sequence sequence) start &optional end)
+ (let* ((end (or end (length sequence)))
+ (length (- end start))
+ (result (sequence:make-sequence-like sequence length)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :start start :end end)
+ (declare (ignore limit endp))
+ (sequence:with-sequence-iterator (rstate rlimit rfrom-end rstep rendp relt rsetelt)
+ (result)
+ (declare (ignore rlimit rendp relt))
+ (do ((i 0 (+ i 1)))
+ ((>= i length) result)
+ (funcall rsetelt (funcall elt sequence state) result rstate)
+ (setq state (funcall step sequence state from-end))
+ (setq rstate (funcall rstep result rstate rfrom-end)))))))
+
+(defgeneric sequence:copy-seq (sequence))
+(defmethod sequence:copy-seq ((sequence sequence))
+ (sequence:subseq sequence 0))
+
+(defgeneric sequence:fill (sequence item &key start end))
+(defmethod sequence:fill ((sequence sequence) item &key (start 0) end)
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end)
+ (declare (ignore elt))
+ (do ()
+ ((funcall endp sequence state limit from-end) sequence)
+ (funcall setelt item sequence state)
+ (setq state (funcall step sequence state from-end)))))
+
+(defgeneric sequence:nsubstitute
+ (new old sequence &key start end from-end test test-not count key)
+ (:argument-precedence-order sequence new old))
+(defmethod sequence:nsubstitute (new old (sequence sequence) &key (start 0)
+ end from-end test test-not count key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end :from-end from-end)
+ (do ((c 0))
+ ((or (and count (>= c count))
+ (funcall endp sequence state limit from-end))
+ sequence)
+ (when (funcall test old (funcall key (funcall elt sequence state)))
+ (incf c)
+ (funcall setelt new sequence state))
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:nsubstitute-if
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:nsubstitute-if
+ (new predicate (sequence sequence) &key (start 0) end from-end count key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end :from-end from-end)
+ (do ((c 0))
+ ((or (and count (>= c count))
+ (funcall endp sequence state limit from-end))
+ sequence)
+ (when (funcall predicate (funcall key (funcall elt sequence state)))
+ (incf c)
+ (funcall setelt new sequence state))
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:nsubstitute-if-not
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:nsubstitute-if-not
+ (new predicate (sequence sequence) &key (start 0) end from-end count key)
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence :start start :end end :from-end from-end)
+ (do ((c 0))
+ ((or (and count (>= c count))
+ (funcall endp sequence state limit from-end))
+ sequence)
+ (unless (funcall predicate (funcall key (funcall elt sequence state)))
+ (incf c)
+ (funcall setelt new sequence state))
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:substitute
+ (new old sequence &key start end from-end test test-not count key)
+ (:argument-precedence-order sequence new old))
+(defmethod sequence:substitute (new old (sequence sequence) &rest args &key
+ (start 0) end from-end test test-not count key)
+ (declare (dynamic-extent args))
+ (declare (ignore start end from-end test test-not count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:nsubstitute new old result args)))
+
+(defgeneric sequence:substitute-if
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:substitute-if (new predicate (sequence sequence) &rest args
+ &key (start 0) end from-end count key)
+ (declare (dynamic-extent args))
+ (declare (ignore start end from-end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:nsubstitute-if new predicate result args)))
+
+(defgeneric sequence:substitute-if-not
+ (new predicate sequence &key start end from-end count key)
+ (:argument-precedence-order sequence new predicate))
+(defmethod sequence:substitute-if-not
+ (new predicate (sequence sequence) &rest args &key
+ (start 0) end from-end count key)
+ (declare (dynamic-extent args))
+ (declare (ignore start end from-end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:nsubstitute-if-not new predicate result args)))
+
+(defun %sequence-replace (sequence1 sequence2 start1 end1 start2 end2)
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence1 :start start1 :end end1)
+ (declare (ignore elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence2 :start start2 :end end2)
+ (do ()
+ ((or (funcall endp1 sequence1 state1 limit1 from-end1)
+ (funcall endp2 sequence2 state2 limit2 from-end2))
+ sequence1)
+ (funcall setelt1 (funcall elt2 sequence2 state2) sequence1 state1)
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2))))))
+
+(defgeneric sequence:replace
+ (sequence1 sequence2 &key start1 end1 start2 end2)
+ (:argument-precedence-order sequence2 sequence1))
+(defmethod sequence:replace
+ ((sequence1 sequence) (sequence2 sequence) &key
+ (start1 0) end1 (start2 0) end2)
+ (cond
+ ((eq sequence1 sequence2)
+ (let ((replaces (subseq sequence2 start2 end2)))
+ (%sequence-replace sequence1 replaces start1 end1 0 nil)))
+ (t (%sequence-replace sequence1 sequence2 start1 end1 start2 end2))))
+
+(defgeneric sequence:nreverse (sequence))
+(defmethod sequence:nreverse ((sequence sequence))
+ ;; FIXME: this, in particular the :from-end iterator, will suck
+ ;; mightily if the user defines a list-like structure.
+ (let ((length (length sequence)))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :end (floor length 2))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2 setelt2)
+ (sequence :start (ceiling length 2) :from-end t)
+ (declare (ignore limit2 endp2))
+ (do ()
+ ((funcall endp1 sequence state1 limit1 from-end1) sequence)
+ (let ((x (funcall elt1 sequence state1))
+ (y (funcall elt2 sequence state2)))
+ (funcall setelt1 y sequence state1)
+ (funcall setelt2 x sequence state2))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2)))))))
+
+(defgeneric sequence:reverse (sequence))
+(defmethod sequence:reverse ((sequence sequence))
+ (let ((result (copy-seq sequence)))
+ (sequence:nreverse result)))
+
+(defgeneric sequence:reduce
+ (function sequence &key from-end start end initial-value)
+ (:argument-precedence-order sequence function))
+(defmethod sequence:reduce
+ (function (sequence sequence) &key from-end (start 0) end key
+ (initial-value nil ivp))
+ (let ((key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence :start start :end end :from-end from-end)
+ (if (funcall endp sequence state limit from-end)
+ (if ivp initial-value (funcall function))
+ (do* ((state state (funcall step sequence state from-end))
+ (value (cond
+ (ivp initial-value)
+ (t (prog1
+ (funcall key (funcall elt sequence state))
+ (setq state (funcall step sequence state from-end)))))))
+ ((funcall endp sequence state limit from-end) value)
+ (let ((e (funcall key (funcall elt sequence state))))
+ (if from-end
+ (setq value (funcall function e value))
+ (setq value (funcall function value e)))))))))
+
+(defgeneric sequence:mismatch (sequence1 sequence2 &key from-end start1 end1
+ start2 end2 test test-not key))
+(defmethod sequence:mismatch
+ ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
+ (start2 0) end2 test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key)))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
+ (sequence1 :start start1 :end end1 :from-end from-end)
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence2 :start start2 :end end2 :from-end from-end)
+ (if from-end
+ (do ((result (or end1 (length sequence1)) (1- result))
+ (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
+ (funcall endp1 sequence1 state1 limit1 from-end1))
+ (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
+ (funcall endp2 sequence2 state2 limit2 from-end2)))
+ ((or e1 e2) (if (and e1 e2) nil result))
+ (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
+ (o2 (funcall key (funcall elt2 sequence2 state2))))
+ (unless (funcall test o1 o2)
+ (return result))
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2))))
+ (do ((result start1 (1+ result))
+ (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
+ (funcall endp1 sequence1 state1 limit1 from-end1))
+ (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
+ (funcall endp2 sequence2 state2 limit2 from-end2)))
+ ((or e1 e2) (if (and e1 e2) nil result))
+ (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
+ (o2 (funcall key (funcall elt2 sequence2 state2))))
+ (unless (funcall test o1 o2)
+ (return result)))
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2))))))))
+
+(defgeneric sequence:search (sequence1 sequence2 &key from-end start1 end1
+ start2 end2 test test-not key))
+(defmethod sequence:search
+ ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
+ (start2 0) end2 test test-not key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key))
+ (mainend2 (- (or end2 (length sequence2))
+ (- (or end1 (length sequence1)) start1))))
+ (when (< mainend2 0)
+ (return-from sequence:search nil))
+ (sequence:with-sequence-iterator (statem limitm from-endm stepm endpm)
+ (sequence2 :start start2 :end mainend2 :from-end from-end)
+ (do ((s2 (if from-end mainend2 0) (if from-end (1- s2) (1+ s2))))
+ (nil)
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
+ (sequence1 :start start1 :end end1)
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence2 :start s2)
+ (declare (ignore limit2 endp2))
+ (when (do ()
+ ((funcall endp1 sequence1 state1 limit1 from-end1) t)
+ (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
+ (o2 (funcall key (funcall elt2 sequence2 state2))))
+ (unless (funcall test o1 o2)
+ (return nil)))
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2)))
+ (return-from sequence:search s2))))
+ (when (funcall endpm sequence2 statem limitm from-endm)
+ (return nil))
+ (setq statem (funcall stepm sequence2 statem from-endm))))))
+
+(defgeneric sequence:delete
+ (item sequence &key from-end test test-not start end count key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:delete (item (sequence sequence) &key
+ from-end test test-not (start 0) end count key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (dynamic-extent #'finish))
+ (do ()
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ (when (and count (>= c count))
+ (return))
+ (if (funcall test item (funcall key e))
+ (progn
+ (incf c)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete (finish)))
+ (setq e (funcall elt2 sequence state2)))
+ (return)))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:delete-if
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:delete-if (predicate (sequence sequence) &key
+ from-end (start 0) end count key)
+ (let ((key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (dynamic-extent #'finish))
+ (do ()
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ (when (and count (>= c count))
+ (return))
+ (if (funcall predicate (funcall key e))
+ (progn
+ (incf c)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete-if (finish)))
+ (setq e (funcall elt2 sequence state2)))
+ (return)))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:delete-if-not
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:delete-if-not (predicate (sequence sequence) &key
+ from-end (start 0) end count key)
+ (let ((key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (dynamic-extent #'finish))
+ (do ()
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ (when (and count (>= c count))
+ (return))
+ (if (funcall predicate (funcall key e))
+ (return)
+ (progn
+ (incf c)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete-if-not (finish)))
+ (setq e (funcall elt2 sequence state2)))))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:remove
+ (item sequence &key from-end test test-not start end count key)
+ (:argument-precedence-order sequence item))
+(defmethod sequence:remove (item (sequence sequence) &rest args &key
+ from-end test test-not (start 0) end count key)
+ (declare (dynamic-extent args))
+ (declare (ignore from-end test test-not start end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete item result args)))
+
+(defgeneric sequence:remove-if
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:remove-if (predicate (sequence sequence) &rest args &key
+ from-end (start 0) end count key)
+ (declare (dynamic-extent args))
+ (declare (ignore from-end start end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete-if predicate result args)))
+
+(defgeneric sequence:remove-if-not
+ (predicate sequence &key from-end start end count key)
+ (:argument-precedence-order sequence predicate))
+(defmethod sequence:remove-if-not (predicate (sequence sequence) &rest args
+ &key from-end (start 0) end count key)
+ (declare (dynamic-extent args))
+ (declare (ignore from-end start end count key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete-if-not predicate result args)))
+
+(defgeneric sequence:delete-duplicates
+ (sequence &key from-end test test-not start end key))
+(defmethod sequence:delete-duplicates
+ ((sequence sequence) &key from-end test test-not (start 0) end key)
+ (let ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key))
+ (c 0))
+ (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
+ (sequence :start start :end end :from-end from-end)
+ (declare (ignore limit1 endp1 elt1))
+ (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
+ (sequence :start start :end end :from-end from-end)
+ (flet ((finish ()
+ (if from-end
+ (replace sequence sequence
+ :start1 start :end1 (- (length sequence) c)
+ :start2 (+ start c) :end2 (length sequence))
+ (unless (or (null end) (= end (length sequence)))
+ (replace sequence sequence :start2 end :start1 (- end c)
+ :end1 (- (length sequence) c))))
+ (sequence:adjust-sequence sequence (- (length sequence) c))))
+ (declare (dynamic-extent #'finish))
+ (do ((end (or end (length sequence)))
+ (step 0 (1+ step)))
+ ((funcall endp2 sequence state2 limit2 from-end2) (finish))
+ (let ((e (funcall elt2 sequence state2)))
+ (loop
+ ;; FIXME: replace with POSITION once position is
+ ;; working
+ (if (> (count (funcall key e) sequence :test test :key key
+ :start (if from-end start (+ start step 1))
+ :end (if from-end (- end step 1) end))
+ 0)
+ (progn
+ (incf c)
+ (incf step)
+ (setq state2 (funcall step2 sequence state2 from-end2))
+ (when (funcall endp2 sequence state2 limit2 from-end2)
+ (return-from sequence:delete-duplicates (finish)))
+ (setq e (funcall elt2 sequence state2)))
+ (progn
+ (return))))
+ (funcall setelt1 e sequence state1))
+ (setq state1 (funcall step1 sequence state1 from-end1))
+ (setq state2 (funcall step2 sequence state2 from-end2))))))))
+
+(defgeneric sequence:remove-duplicates
+ (sequence &key from-end test test-not start end key))
+(defmethod sequence:remove-duplicates
+ ((sequence sequence) &rest args &key from-end test test-not (start 0) end key)
+ (declare (dynamic-extent args))
+ (declare (ignore from-end test test-not start end key))
+ (let ((result (copy-seq sequence)))
+ (apply #'sequence:delete-duplicates result args)))
+
+(defgeneric sequence:sort (sequence predicate &key key))
+(defmethod sequence:sort ((sequence sequence) predicate &rest args &key key)
+ (declare (dynamic-extent args))
+ (declare (ignore key))
+ (let* ((length (length sequence))
+ (vector (make-array length)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence)
+ (declare (ignore limit endp))
+ (do ((i 0 (1+ i)))
+ ((>= i length))
+ (setf (aref vector i) (funcall elt sequence state))
+ (setq state (funcall step sequence state from-end))))
+ (apply #'sort vector predicate args)
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence)
+ (declare (ignore limit endp elt))
+ (do ((i 0 (1+ i)))
+ ((>= i length) sequence)
+ (funcall setelt (aref vector i) sequence state)
+ (setq state (funcall step sequence state from-end))))))
+
+(defgeneric sequence:stable-sort (sequence predicate &key key))
+(defmethod sequence:stable-sort
+ ((sequence sequence) predicate &rest args &key key)
+ (declare (dynamic-extent args))
+ (declare (ignore key))
+ (let* ((length (length sequence))
+ (vector (make-array length)))
+ (sequence:with-sequence-iterator (state limit from-end step endp elt)
+ (sequence)
+ (declare (ignore limit endp))
+ (do ((i 0 (1+ i)))
+ ((>= i length))
+ (setf (aref vector i) (funcall elt sequence state))
+ (setq state (funcall step sequence state from-end))))
+ (apply #'stable-sort vector predicate args)
+ (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
+ (sequence)
+ (declare (ignore limit endp elt))
+ (do ((i 0 (1+ i)))
+ ((>= i length) sequence)
+ (funcall setelt (aref vector i) sequence state)
+ (setq state (funcall step sequence state from-end))))))
;; FILE-STREAM and STRING-STREAM (as they have the same
;; layout-depthoid). Is there any way we can provide a useful
;; error message? -- CSR, 2005-05-03
- (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)))
+ (eq s *the-class-file-stream*) (eq s *the-class-string-stream*)
+ ;; TODO
+ (eq s *the-class-sequence*)))
\f
;;; Some necessary methods for FORWARD-REFERENCED-CLASS
(defmethod class-direct-slots ((class forward-referenced-class)) ())
(assert (type= (specifier-type 'cons)
(type-intersection (specifier-type 'sequence)
(specifier-type '(or cons number)))))
+(assert (type= (specifier-type '(simple-array character (*)))
+ (type-intersection (specifier-type 'sequence)
+ (specifier-type '(simple-array character)))))
+(assert (type= (specifier-type 'list)
+ (type-intersection (specifier-type 'sequence)
+ (specifier-type 'list))))
(assert (eql *empty-type*
(type-intersection (specifier-type '(satisfies keywordp))
*empty-type*)))
(type-union (specifier-type 'cons) (specifier-type 'null))))
(assert (type= (specifier-type 'list)
(type-union (specifier-type 'null) (specifier-type 'cons))))
+#+nil ; not any more
(assert (type= (specifier-type 'sequence)
(type-union (specifier-type 'list) (specifier-type 'vector))))
+#+nil ; not any more
(assert (type= (specifier-type 'sequence)
(type-union (specifier-type 'vector) (specifier-type 'list))))
(assert (type= (specifier-type 'list)
(assert yes)
(assert win))
+(assert (type= (specifier-type 'nil)
+ (specifier-type '(and symbol funcallable-instance))))
(/show "done with tests/type.before-xc.lisp")
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.0.21"
+"1.0.0.22"
projects / sbcl.git / commitdiff