src/pcl/sequence.lisp

   1 ;;;; Extensible sequences, based on the proposal by Christophe Rhodes.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is in the public domain and is provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
   8 ;;;; more information.
   9
  10 (in-package "SB-IMPL")
  11 \f
  12 ;;;; basic protocol
  13 (define-condition sequence:protocol-unimplemented (type-error
  14                                                    reference-condition)
  15   ((operation :initarg :operation
  16               :reader sequence:protocol-unimplemented-operation))
  17   (:default-initargs
  18    :operation (missing-arg)
  19    :references '((:sbcl :node "Extensible Sequences")))
  20   (:report
  21    (lambda (condition stream)
  22      (let ((operation (sequence::protocol-unimplemented-operation condition))
  23            (datum (type-error-datum condition)))
  24        (format stream "~@<The operation ~
  25                        ~/sb-impl:print-symbol-with-prefix/ is not ~
  26                        implemented for ~A which is an instance of the ~
  27                        ~/sb-impl:print-symbol-with-prefix/ subclass ~
  28                        ~S.~@:>"
  29                operation datum 'sequence (class-of datum)))))
  30   (:documentation
  31    "This error is signaled if a sequence operation is applied to an
  32    instance of a sequence class that does not support the
  33    operation."))
  34
  35 (defun sequence:protocol-unimplemented (operation sequence)
  36   (error 'sequence:protocol-unimplemented
  37          :datum sequence
  38          :expected-type '(or list vector)
  39          :operation operation))
  40
  41 (defgeneric sequence:emptyp (sequence)
  42   (:method ((s list)) (null s))
  43   (:method ((s vector)) (zerop (length s)))
  44   (:method ((s sequence)) (zerop (length s)))
  45   (:documentation
  46    "Returns T if SEQUENCE is an empty sequence and NIL
  47    otherwise. Signals an error if SEQUENCE is not a sequence."))
  48
  49 (defgeneric sequence:length (sequence)
  50   (:method ((s list)) (length s))
  51   (:method ((s vector)) (length s))
  52   (:method ((s sequence))
  53     (sequence:protocol-unimplemented 'sequence:length s))
  54   (:documentation
  55    "Returns the length of SEQUENCE or signals a PROTOCOL-UNIMPLEMENTED
  56    error if the sequence protocol is not implemented for the class of
  57    SEQUENCE."))
  58
  59 (defgeneric sequence:elt (sequence index)
  60   (:method ((s list) index) (elt s index))
  61   (:method ((s vector) index) (elt s index))
  62   (:method ((s sequence) index)
  63     (sequence:protocol-unimplemented 'sequence:elt s))
  64   (:documentation
  65    "Returns the element at position INDEX of SEQUENCE or signals a
  66    PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
  67    implemented for the class of SEQUENCE."))
  68
  69 (defgeneric (setf sequence:elt) (new-value sequence index)
  70   (:argument-precedence-order sequence new-value index)
  71   (:method (new-value (s list) index) (setf (elt s index) new-value))
  72   (:method (new-value (s vector) index) (setf (elt s index) new-value))
  73   (:method (new-value (s sequence) index)
  74     (sequence:protocol-unimplemented '(setf sequence:elt) s))
  75   (:documentation
  76    "Replaces the element at position INDEX of SEQUENCE with NEW-VALUE
  77    and returns NEW-VALUE or signals a PROTOCOL-UNIMPLEMENTED error if
  78    the sequence protocol is not implemented for the class of
  79    SEQUENCE."))
  80
  81 (defgeneric sequence:make-sequence-like
  82     (sequence length &key initial-element initial-contents)
  83   (:method ((s list) length &key
  84             (initial-element nil iep) (initial-contents nil icp))
  85     (cond
  86       ((and icp iep) (error "bar"))
  87       (iep (make-list length :initial-element initial-element))
  88       (icp (unless (= (length initial-contents) length)
  89              (error "foo"))
  90            (let ((result (make-list length)))
  91              (replace result initial-contents)
  92              result))
  93       (t (make-list length))))
  94   (:method ((s vector) length &key
  95             (initial-element nil iep) (initial-contents nil icp))
  96     (cond
  97       ((and icp iep) (error "foo"))
  98       (iep (make-array length :element-type (array-element-type s)
  99                        :initial-element initial-element))
 100       (icp (make-array length :element-type (array-element-type s)
 101                        :initial-contents initial-contents))
 102       (t (make-array length :element-type (array-element-type s)))))
 103   (:method ((s sequence) length &key initial-element initial-contents)
 104     (declare (ignore initial-element initial-contents))
 105     (sequence:protocol-unimplemented 'sequence:make-sequence-like s))
 106   (:documentation
 107    "Returns a freshly allocated sequence of length LENGTH and of the
 108    same class as SEQUENCE. Elements of the new sequence are
 109    initialized to INITIAL-ELEMENT, if supplied, initialized to
 110    INITIAL-CONTENTS if supplied, or identical to the elements of
 111    SEQUENCE if neither is supplied. Signals a PROTOCOL-UNIMPLEMENTED
 112    error if the sequence protocol is not implemented for the class of
 113    SEQUENCE."))
 114
 115 (defgeneric sequence:adjust-sequence
 116     (sequence length &key initial-element initial-contents)
 117   (:method ((s list) length &key initial-element (initial-contents nil icp))
 118     (if (eql length 0)
 119         nil
 120         (let ((olength (length s)))
 121           (cond
 122             ((eql length olength) (if icp (replace s initial-contents) s))
 123             ((< length olength)
 124              (rplacd (nthcdr (1- length) s) nil)
 125              (if icp (replace s initial-contents) s))
 126             ((null s)
 127              (let ((return (make-list length :initial-element initial-element)))
 128                (if icp (replace return initial-contents) return)))
 129             (t (rplacd (nthcdr (1- olength) s)
 130                        (make-list (- length olength)
 131                                   :initial-element initial-element))
 132                (if icp (replace s initial-contents) s))))))
 133   (:method ((s vector) length &rest args &key (initial-contents nil icp) initial-element)
 134     (declare (ignore initial-element))
 135     (cond
 136       ((and (array-has-fill-pointer-p s)
 137             (>= (array-total-size s) length))
 138        (setf (fill-pointer s) length)
 139        (if icp (replace s initial-contents) s))
 140       ((eql (length s) length)
 141        (if icp (replace s initial-contents) s))
 142       (t (apply #'adjust-array s length args))))
 143   (:method ((s sequence) length &rest args)
 144     (declare (ignore args))
 145     (sequence:protocol-unimplemented 'sequence:adjust-sequence s))
 146   (:documentation
 147    "Return destructively modified SEQUENCE or a freshly allocated
 148    sequence of the same class as SEQUENCE of length LENGTH. Elements
 149    of the returned sequence are initialized to INITIAL-ELEMENT, if
 150    supplied, initialized to INITIAL-CONTENTS if supplied, or identical
 151    to the elements of SEQUENCE if neither is supplied. Signals a
 152    PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
 153    implemented for the class of SEQUENCE."))
 154
 155 \f
 156 ;;;; iterator protocol
 157
 158 ;;; The general protocol
 159
 160 (defgeneric sequence:make-sequence-iterator (sequence &key from-end start end)
 161   (:method ((s sequence) &key from-end (start 0) end)
 162     (multiple-value-bind (iterator limit from-end)
 163         (sequence:make-simple-sequence-iterator
 164          s :from-end from-end :start start :end end)
 165       (values iterator limit from-end
 166               #'sequence:iterator-step #'sequence:iterator-endp
 167               #'sequence:iterator-element #'(setf sequence:iterator-element)
 168               #'sequence:iterator-index #'sequence:iterator-copy)))
 169   (:method ((s t) &key from-end start end)
 170     (declare (ignore from-end start end))
 171     (error 'type-error
 172            :datum s
 173            :expected-type 'sequence))
 174   (:documentation
 175    "Returns a sequence iterator for SEQUENCE or, if START and/or END
 176    are supplied, the subsequence bounded by START and END as nine
 177    values:
 178
 179    1. iterator state
 180    2. limit
 181    3. from-end
 182    4. step function
 183    5. endp function
 184    6. element function
 185    7. setf element function
 186    8. index function
 187    9. copy state function
 188
 189    If FROM-END is NIL, the constructed iterator visits the specified
 190    elements in the order in which they appear in SEQUENCE. Otherwise,
 191    the elements are visited in the opposite order."))
 192
 193 ;;; the simple protocol: the simple iterator returns three values,
 194 ;;; STATE, LIMIT and FROM-END.
 195
 196 ;;; magic termination value for list :from-end t
 197 (defvar *exhausted* (cons nil nil))
 198
 199 (defgeneric sequence:make-simple-sequence-iterator
 200     (sequence &key from-end start end)
 201   (:method ((s list) &key from-end (start 0) end)
 202     (if from-end
 203         (let* ((termination (if (= start 0) *exhausted* (nthcdr (1- start) s)))
 204                (init (if (<= (or end (length s)) start)
 205                          termination
 206                          (if end (last s (- (length s) (1- end))) (last s)))))
 207           (values init termination t))
 208         (cond
 209           ((not end) (values (nthcdr start s) nil nil))
 210           (t (let ((st (nthcdr start s)))
 211                (values st (nthcdr (- end start) st) nil))))))
 212   (:method ((s vector) &key from-end (start 0) end)
 213     (let ((end (or end (length s))))
 214       (if from-end
 215           (values (1- end) (1- start) t)
 216           (values start end nil))))
 217   (:method ((s sequence) &key from-end (start 0) end)
 218     (let ((end (or end (length s))))
 219       (if from-end
 220           (values (1- end) (1- start) from-end)
 221           (values start end nil))))
 222   (:documentation
 223    "Returns a sequence iterator for SEQUENCE, START, END and FROM-END
 224    as three values:
 225
 226    1. iterator state
 227    2. limit
 228    3. from-end
 229
 230    The returned iterator can be used with the generic iterator
 231    functions ITERATOR-STEP, ITERATOR-ENDP, ITERATOR-ELEMENT, (SETF
 232    ITERATOR-ELEMENT), ITERATOR-INDEX and ITERATOR-COPY."))
 233
 234 (defgeneric sequence:iterator-step (sequence iterator from-end)
 235   (:method ((s list) iterator from-end)
 236     (if from-end
 237         (if (eq iterator s)
 238             *exhausted*
 239             (do* ((xs s (cdr xs)))
 240                  ((eq (cdr xs) iterator) xs)))
 241         (cdr iterator)))
 242   (:method ((s vector) iterator from-end)
 243     (if from-end
 244         (1- iterator)
 245         (1+ iterator)))
 246   (:method ((s sequence) iterator from-end)
 247     (if from-end
 248         (1- iterator)
 249         (1+ iterator)))
 250   (:documentation
 251    "Moves ITERATOR one position forward or backward in SEQUENCE
 252    depending on the iteration direction encoded in FROM-END."))
 253
 254 (defgeneric sequence:iterator-endp (sequence iterator limit from-end)
 255   (:method ((s list) iterator limit from-end)
 256     (eq iterator limit))
 257   (:method ((s vector) iterator limit from-end)
 258     (= iterator limit))
 259   (:method ((s sequence) iterator limit from-end)
 260     (= iterator limit))
 261   (:documentation
 262    "Returns non-NIL when ITERATOR has reached LIMIT (which may
 263    correspond to the end of SEQUENCE) with respect to the iteration
 264    direction encoded in FROM-END."))
 265
 266 (defgeneric sequence:iterator-element (sequence iterator)
 267   (:method ((s list) iterator)
 268     (car iterator))
 269   (:method ((s vector) iterator)
 270     (aref s iterator))
 271   (:method ((s sequence) iterator)
 272     (sequence:elt s iterator))
 273   (:documentation
 274    "Returns the element of SEQUENCE associated to the position of
 275    ITERATOR."))
 276
 277 (defgeneric (setf sequence:iterator-element) (new-value sequence iterator)
 278   (:method (o (s list) iterator)
 279     (setf (car iterator) o))
 280   (:method (o (s vector) iterator)
 281     (setf (aref s iterator) o))
 282   (:method (o (s sequence) iterator)
 283     (setf (sequence:elt s iterator) o))
 284   (:documentation
 285    "Destructively modifies SEQUENCE by replacing the sequence element
 286    associated to position of ITERATOR with NEW-VALUE."))
 287
 288 (defgeneric sequence:iterator-index (sequence iterator)
 289   (:method ((s list) iterator)
 290     ;; FIXME: this sucks.  (In my defence, it is the equivalent of the
 291     ;; Apple implementation in Dylan...)
 292     (loop for l on s for i from 0 when (eq l iterator) return i))
 293   (:method ((s vector) iterator) iterator)
 294   (:method ((s sequence) iterator) iterator)
 295   (:documentation
 296    "Returns the position of ITERATOR in SEQUENCE."))
 297
 298 (defgeneric sequence:iterator-copy (sequence iterator)
 299   (:method ((s list) iterator) iterator)
 300   (:method ((s vector) iterator) iterator)
 301   (:method ((s sequence) iterator) iterator)
 302   (:documentation
 303    "Returns a copy of ITERATOR which also traverses SEQUENCE but can
 304    be mutated independently of ITERATOR."))
 305
 306 (defmacro sequence:with-sequence-iterator
 307     ((&rest vars) (sequence &rest args &key from-end start end) &body body)
 308   "Executes BODY with the elements of VARS bound to the iteration
 309   state returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE and
 310   ARGS. Elements of VARS may be NIL in which case the corresponding
 311   value returned by MAKE-SEQUENCE-ITERATOR is ignored."
 312   (declare (ignore from-end start end))
 313   (let* ((ignored '())
 314          (vars (mapcar (lambda (x)
 315                          (or x (let ((name (gensym)))
 316                                  (push name ignored)
 317                                  name)))
 318                        vars)))
 319    `(multiple-value-bind (,@vars) (sequence:make-sequence-iterator ,sequence ,@args)
 320       (declare (type function ,@(nthcdr 3 vars))
 321                (ignore ,@ignored))
 322       ,@body)))
 323
 324 (defmacro sequence:with-sequence-iterator-functions
 325     ((step endp elt setf index copy)
 326      (sequence &rest args &key from-end start end)
 327      &body body)
 328   "Executes BODY with the names STEP, ENDP, ELT, SETF, INDEX and COPY
 329   bound to local functions which execute the iteration state query and
 330   mutation functions returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE
 331   and ARGS. STEP, ENDP, ELT, SETF, INDEX and COPY have dynamic
 332   extent."
 333   (declare (ignore from-end start end))
 334   (let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
 335         (nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
 336         (nendp (gensym "ENDP")) (nelt (gensym "ELT"))
 337         (nsetf (gensym "SETF")) (nindex (gensym "INDEX"))
 338         (ncopy (gensym "COPY")))
 339     `(sequence:with-sequence-iterator
 340          (,nstate ,nlimit ,nfrom-end ,nstep ,nendp ,nelt ,nsetf ,nindex ,ncopy)
 341        (,sequence,@args)
 342        (flet ((,step () (setq ,nstate (funcall ,nstep ,sequence,nstate ,nfrom-end)))
 343               (,endp () (funcall ,nendp ,sequence,nstate ,nlimit ,nfrom-end))
 344               (,elt () (funcall ,nelt ,sequence,nstate))
 345               (,setf (new-value) (funcall ,nsetf new-value ,sequence,nstate))
 346               (,index () (funcall ,nindex ,sequence,nstate))
 347               (,copy () (funcall ,ncopy ,sequence,nstate)))
 348          (declare (truly-dynamic-extent #',step #',endp #',elt
 349                                   #',setf #',index #',copy))
 350          ,@body))))
 351
 352 (defun sequence:canonize-test (test test-not)
 353   (cond
 354     (test (if (functionp test) test (fdefinition test)))
 355     (test-not (if (functionp test-not)
 356                   (complement test-not)
 357                   (complement (fdefinition test-not))))
 358     (t #'eql)))
 359
 360 (defun sequence:canonize-key (key)
 361   (or (and key (if (functionp key) key (fdefinition key))) #'identity))
 362 \f
 363 ;;;; LOOP support.  (DOSEQUENCE support is present in the core SBCL
 364 ;;;; code).
 365 (defun loop-elements-iteration-path (variable data-type prep-phrases)
 366   (let (of-phrase)
 367     (loop for (prep . rest) in prep-phrases do
 368           (ecase prep
 369             ((:of :in) (if of-phrase
 370                            (sb-loop::loop-error "Too many prepositions")
 371                            (setq of-phrase rest)))))
 372     (destructuring-bind (it lim f-e step endp elt seq)
 373         (loop repeat 7 collect (gensym))
 374       (push `(let ((,seq ,(car of-phrase)))) sb-loop::*loop-wrappers*)
 375       (push `(sequence:with-sequence-iterator (,it ,lim ,f-e ,step ,endp ,elt) (,seq))
 376             sb-loop::*loop-wrappers*)
 377     `(((,variable nil ,data-type)) () () nil (funcall ,endp ,seq ,it ,lim ,f-e)
 378       (,variable (funcall ,elt ,seq ,it) ,it (funcall ,step ,seq ,it ,f-e))))))
 379 (sb-loop::add-loop-path
 380  '(element elements) 'loop-elements-iteration-path sb-loop::*loop-ansi-universe*
 381  :preposition-groups '((:of :in)) :inclusive-permitted nil)
 382 \f
 383 ;;;; generic implementations for sequence functions.
 384
 385 (defgeneric sequence:map (result-prototype function sequence &rest sequences)
 386   (:documentation
 387    "Implements CL:MAP for extended sequences.
 388
 389     RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:MAP but
 390     receives a prototype instance of an extended sequence class
 391     instead of a type specifier. By dispatching on RESULT-PROTOTYPE,
 392     methods on this generic function specify how extended sequence
 393     classes act when they are specified as the result type in a CL:MAP
 394     call. RESULT-PROTOTYPE may not be fully initialized and thus
 395     should only be used for dispatch and to determine its class.
 396
 397     Another difference to CL:MAP is that FUNCTION is a function, not a
 398     function designator."))
 399
 400 (defmethod sequence:map ((result-prototype sequence) (function function)
 401                          (sequence sequence) &rest sequences)
 402   (let ((sequences (list* sequence sequences))
 403         (min-length 0))
 404     (declare (dynamic-extent sequences))
 405     ;; Visit elements of SEQUENCES in parallel to determine length of
 406     ;; the result. Determining the length of the result like this
 407     ;; allows cases like
 408     ;;
 409     ;;   (map 'my-sequence 'my-fun (circular-list 1 2 3) '(4 5 6))
 410     ;;
 411     ;; to return a sequence with three elements.
 412     (flet ((counting-visit (&rest args)
 413              (declare (truly-dynamic-extent args)
 414                       (ignore args))
 415              (incf min-length)))
 416       (declare (truly-dynamic-extent #'counting-visit))
 417       (%map-for-effect #'counting-visit sequences))
 418     ;; Map local function over SEQUENCES that steps through the result
 419     ;; sequence and stores results of applying FUNCTION.
 420     (binding* ((result (sequence:make-sequence-like result-prototype min-length))
 421                ((state nil from-end step nil nil setelt)
 422                 (sequence:make-sequence-iterator result)))
 423       (declare (type function step setelt))
 424       (flet ((one-element (&rest args)
 425                (declare (truly-dynamic-extent args))
 426                (funcall setelt (apply function args) result state)
 427                (setq state (funcall step result state from-end))))
 428         (declare (truly-dynamic-extent #'one-element))
 429         (%map-for-effect #'one-element sequences))
 430       result)))
 431
 432 ;;; FIXME: COUNT, POSITION and FIND share an awful lot of structure.
 433 ;;; They could usefully be defined in an OAOO way.
 434 (defgeneric sequence:count
 435     (item sequence &key from-end start end test test-not key)
 436   (:argument-precedence-order sequence item))
 437 (defmethod sequence:count
 438     (item (sequence sequence) &key from-end (start 0) end test test-not key)
 439   (let ((test (sequence:canonize-test test test-not))
 440         (key (sequence:canonize-key key)))
 441     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 442         (sequence :from-end from-end :start start :end end)
 443       (do ((count 0))
 444           ((funcall endp sequence state limit from-end) count)
 445         (let ((o (funcall elt sequence state)))
 446           (when (funcall test item (funcall key o))
 447             (incf count))
 448           (setq state (funcall step sequence state from-end)))))))
 449
 450 (defgeneric sequence:count-if (pred sequence &key from-end start end key)
 451   (:argument-precedence-order sequence pred))
 452 (defmethod sequence:count-if
 453     (pred (sequence sequence) &key from-end (start 0) end key)
 454   (let ((key (sequence:canonize-key key)))
 455     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 456         (sequence :from-end from-end :start start :end end)
 457       (do ((count 0))
 458           ((funcall endp sequence state limit from-end) count)
 459         (let ((o (funcall elt sequence state)))
 460           (when (funcall pred (funcall key o))
 461             (incf count))
 462           (setq state (funcall step sequence state from-end)))))))
 463
 464 (defgeneric sequence:count-if-not (pred sequence &key from-end start end key)
 465   (:argument-precedence-order sequence pred))
 466 (defmethod sequence:count-if-not
 467     (pred (sequence sequence) &key from-end (start 0) end key)
 468   (let ((key (sequence:canonize-key key)))
 469     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 470         (sequence :from-end from-end :start start :end end)
 471       (do ((count 0))
 472           ((funcall endp sequence state limit from-end) count)
 473         (let ((o (funcall elt sequence state)))
 474           (unless (funcall pred (funcall key o))
 475             (incf count))
 476           (setq state (funcall step sequence state from-end)))))))
 477
 478 (defgeneric sequence:find
 479     (item sequence &key from-end start end test test-not key)
 480   (:argument-precedence-order sequence item))
 481 (defmethod sequence:find
 482     (item (sequence sequence) &key from-end (start 0) end test test-not key)
 483   (let ((test (sequence:canonize-test test test-not))
 484         (key (sequence:canonize-key key)))
 485     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 486         (sequence :from-end from-end :start start :end end)
 487       (do ()
 488           ((funcall endp sequence state limit from-end) nil)
 489         (let ((o (funcall elt sequence state)))
 490           (when (funcall test item (funcall key o))
 491             (return o))
 492           (setq state (funcall step sequence state from-end)))))))
 493
 494 (defgeneric sequence:find-if (pred sequence &key from-end start end key)
 495   (:argument-precedence-order sequence pred))
 496 (defmethod sequence:find-if
 497     (pred (sequence sequence) &key from-end (start 0) end key)
 498   (let ((key (sequence:canonize-key key)))
 499     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 500         (sequence :from-end from-end :start start :end end)
 501       (do ()
 502           ((funcall endp sequence state limit from-end) nil)
 503         (let ((o (funcall elt sequence state)))
 504           (when (funcall pred (funcall key o))
 505             (return o))
 506           (setq state (funcall step sequence state from-end)))))))
 507
 508 (defgeneric sequence:find-if-not (pred sequence &key from-end start end key)
 509   (:argument-precedence-order sequence pred))
 510 (defmethod sequence:find-if-not
 511     (pred (sequence sequence) &key from-end (start 0) end key)
 512   (let ((key (sequence:canonize-key key)))
 513     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 514         (sequence :from-end from-end :start start :end end)
 515       (do ()
 516           ((funcall endp sequence state limit from-end) nil)
 517         (let ((o (funcall elt sequence state)))
 518           (unless (funcall pred (funcall key o))
 519             (return o))
 520           (setq state (funcall step sequence state from-end)))))))
 521
 522 (defgeneric sequence:position
 523     (item sequence &key from-end start end test test-not key)
 524   (:argument-precedence-order sequence item))
 525 (defmethod sequence:position
 526     (item (sequence sequence) &key from-end (start 0) end test test-not key)
 527   (let ((test (sequence:canonize-test test test-not))
 528         (key (sequence:canonize-key key)))
 529     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 530         (sequence :from-end from-end :start start :end end)
 531       (do ((s (if from-end -1 1))
 532            (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
 533           ((funcall endp sequence state limit from-end) nil)
 534         (let ((o (funcall elt sequence state)))
 535           (when (funcall test item (funcall key o))
 536             (return pos))
 537           (setq state (funcall step sequence state from-end)))))))
 538
 539 (defgeneric sequence:position-if (pred sequence &key from-end start end key)
 540   (:argument-precedence-order sequence pred))
 541 (defmethod sequence:position-if
 542     (pred (sequence sequence) &key from-end (start 0) end key)
 543   (let ((key (sequence:canonize-key key)))
 544     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 545         (sequence :from-end from-end :start start :end end)
 546       (do ((s (if from-end -1 1))
 547            (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
 548           ((funcall endp sequence state limit from-end) nil)
 549         (let ((o (funcall elt sequence state)))
 550           (when (funcall pred (funcall key o))
 551             (return pos))
 552           (setq state (funcall step sequence state from-end)))))))
 553
 554 (defgeneric sequence:position-if-not
 555     (pred sequence &key from-end start end key)
 556   (:argument-precedence-order sequence pred))
 557 (defmethod sequence:position-if-not
 558     (pred (sequence sequence) &key from-end (start 0) end key)
 559   (let ((key (sequence:canonize-key key)))
 560     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 561         (sequence :from-end from-end :start start :end end)
 562       (do ((s (if from-end -1 1))
 563            (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
 564           ((funcall endp sequence state limit from-end) nil)
 565         (let ((o (funcall elt sequence state)))
 566           (unless (funcall pred (funcall key o))
 567             (return pos))
 568           (setq state (funcall step sequence state from-end)))))))
 569
 570 (defgeneric sequence:subseq (sequence start &optional end))
 571 (defmethod sequence:subseq ((sequence sequence) start &optional end)
 572   (let* ((end (or end (length sequence)))
 573          (length (- end start))
 574          (result (sequence:make-sequence-like sequence length)))
 575     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 576         (sequence :start start :end end)
 577       (declare (ignore limit endp))
 578       (sequence:with-sequence-iterator (rstate rlimit rfrom-end rstep rendp relt rsetelt)
 579           (result)
 580         (declare (ignore rlimit rendp relt))
 581         (do ((i 0 (+ i 1)))
 582             ((>= i length) result)
 583           (funcall rsetelt (funcall elt sequence state) result rstate)
 584           (setq state (funcall step sequence state from-end))
 585           (setq rstate (funcall rstep result rstate rfrom-end)))))))
 586
 587 (defgeneric sequence:copy-seq (sequence))
 588 (defmethod sequence:copy-seq ((sequence sequence))
 589   (sequence:subseq sequence 0))
 590
 591 (defgeneric sequence:fill (sequence item &key start end))
 592 (defmethod sequence:fill ((sequence sequence) item &key (start 0) end)
 593   (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
 594       (sequence :start start :end end)
 595     (declare (ignore elt))
 596     (do ()
 597         ((funcall endp sequence state limit from-end) sequence)
 598       (funcall setelt item sequence state)
 599       (setq state (funcall step sequence state from-end)))))
 600
 601 (defgeneric sequence:nsubstitute
 602     (new old sequence &key start end from-end test test-not count key)
 603   (:argument-precedence-order sequence new old))
 604 (defmethod sequence:nsubstitute (new old (sequence sequence) &key (start 0)
 605                                  end from-end test test-not count key)
 606   (let ((test (sequence:canonize-test test test-not))
 607         (key (sequence:canonize-key key)))
 608     (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
 609         (sequence :start start :end end :from-end from-end)
 610       (do ((c 0))
 611           ((or (and count (>= c count))
 612                (funcall endp sequence state limit from-end))
 613            sequence)
 614         (when (funcall test old (funcall key (funcall elt sequence state)))
 615           (incf c)
 616           (funcall setelt new sequence state))
 617         (setq state (funcall step sequence state from-end))))))
 618
 619 (defgeneric sequence:nsubstitute-if
 620     (new predicate sequence &key start end from-end count key)
 621   (:argument-precedence-order sequence new predicate))
 622 (defmethod sequence:nsubstitute-if
 623     (new predicate (sequence sequence) &key (start 0) end from-end count key)
 624   (let ((key (sequence:canonize-key key)))
 625     (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
 626         (sequence :start start :end end :from-end from-end)
 627       (do ((c 0))
 628           ((or (and count (>= c count))
 629                (funcall endp sequence state limit from-end))
 630            sequence)
 631         (when (funcall predicate (funcall key (funcall elt sequence state)))
 632           (incf c)
 633           (funcall setelt new sequence state))
 634         (setq state (funcall step sequence state from-end))))))
 635
 636 (defgeneric sequence:nsubstitute-if-not
 637     (new predicate sequence &key start end from-end count key)
 638   (:argument-precedence-order sequence new predicate))
 639 (defmethod sequence:nsubstitute-if-not
 640     (new predicate (sequence sequence) &key (start 0) end from-end count key)
 641   (let ((key (sequence:canonize-key key)))
 642     (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
 643         (sequence :start start :end end :from-end from-end)
 644       (do ((c 0))
 645           ((or (and count (>= c count))
 646                (funcall endp sequence state limit from-end))
 647            sequence)
 648         (unless (funcall predicate (funcall key (funcall elt sequence state)))
 649           (incf c)
 650           (funcall setelt new sequence state))
 651         (setq state (funcall step sequence state from-end))))))
 652
 653 (defgeneric sequence:substitute
 654     (new old sequence &key start end from-end test test-not count key)
 655   (:argument-precedence-order sequence new old))
 656 (defmethod sequence:substitute (new old (sequence sequence) &rest args &key
 657                                 (start 0) end from-end test test-not count key)
 658   (declare (truly-dynamic-extent args))
 659   (declare (ignore start end from-end test test-not count key))
 660   (let ((result (copy-seq sequence)))
 661     (apply #'sequence:nsubstitute new old result args)))
 662
 663 (defgeneric sequence:substitute-if
 664     (new predicate sequence &key start end from-end count key)
 665   (:argument-precedence-order sequence new predicate))
 666 (defmethod sequence:substitute-if (new predicate (sequence sequence) &rest args
 667                                    &key (start 0) end from-end count key)
 668   (declare (truly-dynamic-extent args))
 669   (declare (ignore start end from-end count key))
 670   (let ((result (copy-seq sequence)))
 671     (apply #'sequence:nsubstitute-if new predicate result args)))
 672
 673 (defgeneric sequence:substitute-if-not
 674     (new predicate sequence &key start end from-end count key)
 675   (:argument-precedence-order sequence new predicate))
 676 (defmethod sequence:substitute-if-not
 677     (new predicate (sequence sequence) &rest args &key
 678      (start 0) end from-end count key)
 679   (declare (truly-dynamic-extent args))
 680   (declare (ignore start end from-end count key))
 681   (let ((result (copy-seq sequence)))
 682     (apply #'sequence:nsubstitute-if-not new predicate result args)))
 683
 684 (defun %sequence-replace (sequence1 sequence2 start1 end1 start2 end2)
 685   (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
 686       (sequence1 :start start1 :end end1)
 687     (declare (ignore elt1))
 688     (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
 689         (sequence2 :start start2 :end end2)
 690       (do ()
 691           ((or (funcall endp1 sequence1 state1 limit1 from-end1)
 692                (funcall endp2 sequence2 state2 limit2 from-end2))
 693            sequence1)
 694         (funcall setelt1 (funcall elt2 sequence2 state2) sequence1 state1)
 695         (setq state1 (funcall step1 sequence1 state1 from-end1))
 696         (setq state2 (funcall step2 sequence2 state2 from-end2))))))
 697
 698 (defgeneric sequence:replace
 699     (sequence1 sequence2 &key start1 end1 start2 end2)
 700   (:argument-precedence-order sequence2 sequence1))
 701 (defmethod sequence:replace
 702     ((sequence1 sequence) (sequence2 sequence) &key
 703      (start1 0) end1 (start2 0) end2)
 704   (cond
 705     ((eq sequence1 sequence2)
 706      (let ((replaces (subseq sequence2 start2 end2)))
 707        (%sequence-replace sequence1 replaces start1 end1 0 nil)))
 708     (t (%sequence-replace sequence1 sequence2 start1 end1 start2 end2))))
 709
 710 (defgeneric sequence:nreverse (sequence))
 711 (defmethod sequence:nreverse ((sequence sequence))
 712   ;; FIXME: this, in particular the :from-end iterator, will suck
 713   ;; mightily if the user defines a list-like structure.
 714   (let ((length (length sequence)))
 715     (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
 716         (sequence :end (floor length 2))
 717       (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2 setelt2)
 718           (sequence :start (ceiling length 2) :from-end t)
 719         (declare (ignore limit2 endp2))
 720         (do ()
 721             ((funcall endp1 sequence state1 limit1 from-end1) sequence)
 722           (let ((x (funcall elt1 sequence state1))
 723                 (y (funcall elt2 sequence state2)))
 724             (funcall setelt1 y sequence state1)
 725             (funcall setelt2 x sequence state2))
 726           (setq state1 (funcall step1 sequence state1 from-end1))
 727           (setq state2 (funcall step2 sequence state2 from-end2)))))))
 728
 729 (defgeneric sequence:reverse (sequence))
 730 (defmethod sequence:reverse ((sequence sequence))
 731   (let ((result (copy-seq sequence)))
 732     (sequence:nreverse result)))
 733
 734 (defgeneric sequence:concatenate (result-prototype &rest sequences)
 735   (:documentation
 736    "Implements CL:CONCATENATE for extended sequences.
 737
 738     RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:CONCATENATE
 739     but receives a prototype instance of an extended sequence class
 740     instead of a type specifier. By dispatching on RESULT-PROTOTYPE,
 741     methods on this generic function specify how extended sequence
 742     classes act when they are specified as the result type in a
 743     CL:CONCATENATE call. RESULT-PROTOTYPE may not be fully initialized
 744     and thus should only be used for dispatch and to determine its
 745     class."))
 746
 747 (defmethod sequence:concatenate ((result-prototype sequence) &rest sequences)
 748   (let* ((lengths (mapcar #'length sequences))
 749          (result (sequence:make-sequence-like
 750                   result-prototype (reduce #'+ lengths))))
 751     (loop with index = 0
 752        for sequence in sequences
 753        for length in lengths do
 754          (replace result sequence :start1 index)
 755          (incf index length))
 756     result))
 757
 758 (defgeneric sequence:reduce
 759     (function sequence &key from-end start end initial-value)
 760   (:argument-precedence-order sequence function))
 761 (defmethod sequence:reduce
 762     (function (sequence sequence) &key from-end (start 0) end key
 763      (initial-value nil ivp))
 764   (let ((key (sequence:canonize-key key)))
 765     (sequence:with-sequence-iterator (state limit from-end step endp elt)
 766         (sequence :start start :end end :from-end from-end)
 767       (if (funcall endp sequence state limit from-end)
 768           (if ivp initial-value (funcall function))
 769           (do* ((state state (funcall step sequence state from-end))
 770                 (value (cond
 771                          (ivp initial-value)
 772                          (t (prog1
 773                                 (funcall key (funcall elt sequence state))
 774                               (setq state (funcall step sequence state from-end)))))))
 775                ((funcall endp sequence state limit from-end) value)
 776             (let ((e (funcall key (funcall elt sequence state))))
 777               (if from-end
 778                   (setq value (funcall function e value))
 779                   (setq value (funcall function value e)))))))))
 780
 781 (defgeneric sequence:mismatch (sequence1 sequence2 &key from-end start1 end1
 782                                start2 end2 test test-not key))
 783 (defmethod sequence:mismatch
 784     ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
 785      (start2 0) end2 test test-not key)
 786   (let ((test (sequence:canonize-test test test-not))
 787         (key (sequence:canonize-key key)))
 788     (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
 789         (sequence1 :start start1 :end end1 :from-end from-end)
 790       (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
 791           (sequence2 :start start2 :end end2 :from-end from-end)
 792         (if from-end
 793             (do ((result (or end1 (length sequence1)) (1- result))
 794                  (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
 795                      (funcall endp1 sequence1 state1 limit1 from-end1))
 796                  (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
 797                      (funcall endp2 sequence2 state2 limit2 from-end2)))
 798                 ((or e1 e2) (if (and e1 e2) nil result))
 799               (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
 800                     (o2 (funcall key (funcall elt2 sequence2 state2))))
 801                 (unless (funcall test o1 o2)
 802                   (return result))
 803                 (setq state1 (funcall step1 sequence1 state1 from-end1))
 804                 (setq state2 (funcall step2 sequence2 state2 from-end2))))
 805             (do ((result start1 (1+ result))
 806                  (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
 807                      (funcall endp1 sequence1 state1 limit1 from-end1))
 808                  (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
 809                      (funcall endp2 sequence2 state2 limit2 from-end2)))
 810                 ((or e1 e2) (if (and e1 e2) nil result))
 811               (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
 812                     (o2 (funcall key (funcall elt2 sequence2 state2))))
 813                 (unless (funcall test o1 o2)
 814                   (return result)))
 815               (setq state1 (funcall step1 sequence1 state1 from-end1))
 816               (setq state2 (funcall step2 sequence2 state2 from-end2))))))))
 817
 818 (defgeneric sequence:search (sequence1 sequence2 &key from-end start1 end1
 819                              start2 end2 test test-not key))
 820 (defmethod sequence:search
 821     ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
 822      (start2 0) end2 test test-not key)
 823   (let* ((test (sequence:canonize-test test test-not))
 824          (key (sequence:canonize-key key))
 825          (range1 (- (or end1 (length sequence1)) start1))
 826          (range2 (- (or end2 (length sequence2)) start2))
 827          (count (1+ (- range2 range1))))
 828     (when (minusp count)
 829       (return-from sequence:search nil))
 830     ;; Create an iteration state for SEQUENCE1 for the interesting
 831     ;;range within SEQUENCE1. To compare this range against ranges in
 832     ;;SEQUENCE2, we copy START-STATE1 and then mutate the copy.
 833     (sequence:with-sequence-iterator (start-state1 nil from-end1 step1 nil elt1)
 834         (sequence1 :start start1 :end end1 :from-end from-end)
 835       ;; Create an iteration state for the interesting range within
 836       ;; SEQUENCE2.
 837       (sequence:with-sequence-iterator (start-state2 nil from-end2 step2 nil elt2 nil index2)
 838           (sequence2 :start start2 :end end2 :from-end from-end)
 839         ;; Copy both iterators at all COUNT possible match positions.
 840         (dotimes (i count)
 841           (let ((state1 (sequence:iterator-copy sequence1 start-state1))
 842                 (state2 (sequence:iterator-copy sequence2 start-state2)))
 843             ;; Determine whether there is a match at the current
 844             ;; position. Return immediately, if there is a match.
 845             (dotimes
 846                 (j range1
 847                    (return-from sequence:search
 848                      (let ((position (funcall index2 sequence2 start-state2)))
 849                        (if from-end (- position range1 -1) position))))
 850               (unless (funcall test
 851                                (funcall key (funcall elt1 sequence1 state1))
 852                                (funcall key (funcall elt2 sequence2 state2)))
 853                 (return nil))
 854               (setq state1 (funcall step1 sequence1 state1 from-end1))
 855               (setq state2 (funcall step2 sequence2 state2 from-end2))))
 856           (setq start-state2 (funcall step2 sequence2 start-state2 from-end2)))))))
 857
 858 (defgeneric sequence:delete
 859     (item sequence &key from-end test test-not start end count key)
 860   (:argument-precedence-order sequence item))
 861 (defmethod sequence:delete (item (sequence sequence) &key
 862                             from-end test test-not (start 0) end count key)
 863   (let ((test (sequence:canonize-test test test-not))
 864         (key (sequence:canonize-key key))
 865         (c 0))
 866     (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
 867         (sequence :start start :end end :from-end from-end)
 868       (declare (ignore limit1 endp1 elt1))
 869       (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
 870           (sequence :start start :end end :from-end from-end)
 871         (flet ((finish ()
 872                  (if from-end
 873                      (replace sequence sequence
 874                               :start1 start :end1 (- (length sequence) c)
 875                               :start2 (+ start c) :end2 (length sequence))
 876                      (unless (or (null end) (= end (length sequence)))
 877                        (replace sequence sequence :start2 end :start1 (- end c)
 878                                 :end1 (- (length sequence) c))))
 879                  (sequence:adjust-sequence sequence (- (length sequence) c))))
 880           (declare (truly-dynamic-extent #'finish))
 881           (do ()
 882               ((funcall endp2 sequence state2 limit2 from-end2) (finish))
 883             (let ((e (funcall elt2 sequence state2)))
 884               (loop
 885                (when (and count (>= c count))
 886                  (return))
 887                (if (funcall test item (funcall key e))
 888                    (progn
 889                      (incf c)
 890                      (setq state2 (funcall step2 sequence state2 from-end2))
 891                      (when (funcall endp2 sequence state2 limit2 from-end2)
 892                        (return-from sequence:delete (finish)))
 893                      (setq e (funcall elt2 sequence state2)))
 894                    (return)))
 895               (funcall setelt1 e sequence state1))
 896             (setq state1 (funcall step1 sequence state1 from-end1))
 897             (setq state2 (funcall step2 sequence state2 from-end2))))))))
 898
 899 (defgeneric sequence:delete-if
 900     (predicate sequence &key from-end start end count key)
 901   (:argument-precedence-order sequence predicate))
 902 (defmethod sequence:delete-if (predicate (sequence sequence) &key
 903                                from-end (start 0) end count key)
 904   (let ((key (sequence:canonize-key key))
 905         (c 0))
 906     (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
 907         (sequence :start start :end end :from-end from-end)
 908       (declare (ignore limit1 endp1 elt1))
 909       (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
 910           (sequence :start start :end end :from-end from-end)
 911         (flet ((finish ()
 912                  (if from-end
 913                      (replace sequence sequence
 914                               :start1 start :end1 (- (length sequence) c)
 915                               :start2 (+ start c) :end2 (length sequence))
 916                      (unless (or (null end) (= end (length sequence)))
 917                        (replace sequence sequence :start2 end :start1 (- end c)
 918                                 :end1 (- (length sequence) c))))
 919                  (sequence:adjust-sequence sequence (- (length sequence) c))))
 920           (declare (truly-dynamic-extent #'finish))
 921           (do ()
 922               ((funcall endp2 sequence state2 limit2 from-end2) (finish))
 923             (let ((e (funcall elt2 sequence state2)))
 924               (loop
 925                (when (and count (>= c count))
 926                  (return))
 927                (if (funcall predicate (funcall key e))
 928                    (progn
 929                      (incf c)
 930                      (setq state2 (funcall step2 sequence state2 from-end2))
 931                      (when (funcall endp2 sequence state2 limit2 from-end2)
 932                        (return-from sequence:delete-if (finish)))
 933                      (setq e (funcall elt2 sequence state2)))
 934                    (return)))
 935               (funcall setelt1 e sequence state1))
 936             (setq state1 (funcall step1 sequence state1 from-end1))
 937             (setq state2 (funcall step2 sequence state2 from-end2))))))))
 938
 939 (defgeneric sequence:delete-if-not
 940     (predicate sequence &key from-end start end count key)
 941   (:argument-precedence-order sequence predicate))
 942 (defmethod sequence:delete-if-not (predicate (sequence sequence) &key
 943                                    from-end (start 0) end count key)
 944   (let ((key (sequence:canonize-key key))
 945         (c 0))
 946     (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
 947         (sequence :start start :end end :from-end from-end)
 948       (declare (ignore limit1 endp1 elt1))
 949       (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
 950           (sequence :start start :end end :from-end from-end)
 951         (flet ((finish ()
 952                  (if from-end
 953                      (replace sequence sequence
 954                               :start1 start :end1 (- (length sequence) c)
 955                               :start2 (+ start c) :end2 (length sequence))
 956                      (unless (or (null end) (= end (length sequence)))
 957                        (replace sequence sequence :start2 end :start1 (- end c)
 958                                 :end1 (- (length sequence) c))))
 959                  (sequence:adjust-sequence sequence (- (length sequence) c))))
 960           (declare (truly-dynamic-extent #'finish))
 961           (do ()
 962               ((funcall endp2 sequence state2 limit2 from-end2) (finish))
 963             (let ((e (funcall elt2 sequence state2)))
 964               (loop
 965                (when (and count (>= c count))
 966                  (return))
 967                (if (funcall predicate (funcall key e))
 968                    (return)
 969                    (progn
 970                      (incf c)
 971                      (setq state2 (funcall step2 sequence state2 from-end2))
 972                      (when (funcall endp2 sequence state2 limit2 from-end2)
 973                        (return-from sequence:delete-if-not (finish)))
 974                      (setq e (funcall elt2 sequence state2)))))
 975               (funcall setelt1 e sequence state1))
 976             (setq state1 (funcall step1 sequence state1 from-end1))
 977             (setq state2 (funcall step2 sequence state2 from-end2))))))))
 978
 979 (defgeneric sequence:remove
 980     (item sequence &key from-end test test-not start end count key)
 981   (:argument-precedence-order sequence item))
 982 (defmethod sequence:remove (item (sequence sequence) &rest args &key
 983                             from-end test test-not (start 0) end count key)
 984   (declare (truly-dynamic-extent args))
 985   (declare (ignore from-end test test-not start end count key))
 986   (let ((result (copy-seq sequence)))
 987     (apply #'sequence:delete item result args)))
 988
 989 (defgeneric sequence:remove-if
 990     (predicate sequence &key from-end start end count key)
 991   (:argument-precedence-order sequence predicate))
 992 (defmethod sequence:remove-if (predicate (sequence sequence) &rest args &key
 993                                from-end (start 0) end count key)
 994   (declare (truly-dynamic-extent args))
 995   (declare (ignore from-end start end count key))
 996   (let ((result (copy-seq sequence)))
 997     (apply #'sequence:delete-if predicate result args)))
 998
 999 (defgeneric sequence:remove-if-not
1000     (predicate sequence &key from-end start end count key)
1001   (:argument-precedence-order sequence predicate))
1002 (defmethod sequence:remove-if-not (predicate (sequence sequence) &rest args
1003                                    &key from-end (start 0) end count key)
1004   (declare (truly-dynamic-extent args))
1005   (declare (ignore from-end start end count key))
1006   (let ((result (copy-seq sequence)))
1007     (apply #'sequence:delete-if-not predicate result args)))
1008
1009 (defgeneric sequence:delete-duplicates
1010     (sequence &key from-end test test-not start end key))
1011 (defmethod sequence:delete-duplicates
1012     ((sequence sequence) &key from-end test test-not (start 0) end key)
1013   (let ((test (sequence:canonize-test test test-not))
1014         (key (sequence:canonize-key key))
1015         (c 0))
1016     (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
1017         (sequence :start start :end end :from-end from-end)
1018       (declare (ignore limit1 endp1 elt1))
1019       (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
1020           (sequence :start start :end end :from-end from-end)
1021         (flet ((finish ()
1022                  (if from-end
1023                      (replace sequence sequence
1024                               :start1 start :end1 (- (length sequence) c)
1025                               :start2 (+ start c) :end2 (length sequence))
1026                      (unless (or (null end) (= end (length sequence)))
1027                        (replace sequence sequence :start2 end :start1 (- end c)
1028                                 :end1 (- (length sequence) c))))
1029                  (sequence:adjust-sequence sequence (- (length sequence) c))))
1030           (declare (truly-dynamic-extent #'finish))
1031           (do ((end (or end (length sequence)))
1032                (step 0 (1+ step)))
1033               ((funcall endp2 sequence state2 limit2 from-end2) (finish))
1034             (let ((e (funcall elt2 sequence state2)))
1035               (loop
1036                ;; FIXME: replace with POSITION once position is
1037                ;; working
1038                (if (> (count (funcall key e) sequence :test test :key key
1039                              :start (if from-end start (+ start step 1))
1040                              :end (if from-end (- end step 1) end))
1041                       0)
1042                    (progn
1043                      (incf c)
1044                      (incf step)
1045                      (setq state2 (funcall step2 sequence state2 from-end2))
1046                      (when (funcall endp2 sequence state2 limit2 from-end2)
1047                        (return-from sequence:delete-duplicates (finish)))
1048                      (setq e (funcall elt2 sequence state2)))
1049                    (progn
1050                      (return))))
1051               (funcall setelt1 e sequence state1))
1052             (setq state1 (funcall step1 sequence state1 from-end1))
1053             (setq state2 (funcall step2 sequence state2 from-end2))))))))
1054
1055 (defgeneric sequence:remove-duplicates
1056     (sequence &key from-end test test-not start end key))
1057 (defmethod sequence:remove-duplicates
1058     ((sequence sequence) &rest args &key from-end test test-not (start 0) end key)
1059   (declare (truly-dynamic-extent args))
1060   (declare (ignore from-end test test-not start end key))
1061   (let ((result (copy-seq sequence)))
1062     (apply #'sequence:delete-duplicates result args)))
1063
1064 (defun %sort-with-temp-vector (sorter sequence predicate &rest args)
1065   (declare (type function sorter))
1066   (let* ((length (length sequence))
1067          (vector (make-array length)))
1068     (sequence:with-sequence-iterator (state limit from-end step endp elt)
1069         (sequence)
1070       (declare (ignore limit  endp))
1071       (do ((i 0 (1+ i)))
1072           ((>= i length))
1073         (setf (aref vector i) (funcall elt sequence state))
1074         (setq state (funcall step sequence state from-end))))
1075     (apply sorter vector predicate args)
1076     (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
1077         (sequence)
1078       (declare (ignore limit endp elt))
1079       (do ((i 0 (1+ i)))
1080           ((>= i length) sequence)
1081         (funcall setelt (aref vector i) sequence state)
1082         (setq state (funcall step sequence state from-end))))))
1083
1084 (defgeneric sequence:sort (sequence predicate &key key))
1085 (defmethod sequence:sort ((sequence sequence) predicate &rest args &key key)
1086   (declare (truly-dynamic-extent args)
1087            (ignore key))
1088   (apply #'%sort-with-temp-vector #'sort sequence predicate args))
1089
1090 (defgeneric sequence:stable-sort (sequence predicate &key key))
1091 (defmethod sequence:stable-sort
1092     ((sequence sequence) predicate &rest args &key key)
1093   (declare (truly-dynamic-extent args)
1094            (ignore key))
1095   (apply #'%sort-with-temp-vector #'stable-sort sequence predicate args))
1096
1097 (defgeneric sequence:merge (result-prototype sequence1 sequence2 predicate &key key)
1098   (:documentation
1099    "Implements CL:MERGE for extended sequences.
1100
1101     RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:MERGE but
1102     receives a prototype instance of an extended sequence class
1103     instead of a type specifier. By dispatching on RESULT-PROTOTYPE,
1104     methods on this generic function specify how extended sequence
1105     classes act when they are specified as the result type in a
1106     CL:MERGE call. RESULT-PROTOTYPE may not be fully initialized and
1107     thus should only be used for dispatch and to determine its class.
1108
1109     Another difference to CL:MERGE is that PREDICATE is a function,
1110     not a function designator."))
1111
1112 (defmethod sequence:merge ((result-prototype sequence)
1113                            (sequence1 sequence) (sequence2 sequence)
1114                            (predicate function) &key key)
1115   (let ((key-function (when key
1116                         (%coerce-callable-to-fun key)))
1117         (result (sequence:make-sequence-like
1118                  result-prototype (+ (length sequence1) (length sequence2))))
1119         endp1 elt1 key1 endp2 elt2 key2)
1120     (sequence:with-sequence-iterator-functions
1121         (step-result endp-result elt-result setelt-result index-result copy-result) (result) ; TODO allow nil and fewer number of elements
1122       (declare (ignorable #'endp-result #'elt-result #'copy-result))
1123       (sequence:with-sequence-iterator-functions
1124           (step1 endp1 elt1 setelt1 index1 copy1) (sequence1)
1125           (declare (ignorable #'setelt1 #'copy1))
1126         (sequence:with-sequence-iterator-functions
1127             (step2 endp2 elt2 setelt2 index2 copy2) (sequence2)
1128           (declare (ignorable #'setelt2 #'copy2))
1129           (labels ((pop/no-key1 ()
1130                      (unless (setf endp1 (endp1))
1131                        (setf elt1 (elt1))))
1132                    (pop/no-key2 ()
1133                      (unless (setf endp2 (endp2))
1134                        (setf elt2 (elt2))))
1135                    (pop/key1 ()
1136                      (unless (setf endp1 (endp1))
1137                        (setf key1 (funcall (truly-the function key-function)
1138                                            (setf elt1 (elt1))))))
1139                    (pop/key2 ()
1140                      (unless (setf endp2 (endp2))
1141                        (setf key2 (funcall (truly-the function key-function)
1142                                            (setf elt2 (elt2))))))
1143                    (pop-one/no-key ()
1144                      (if (funcall predicate elt2 elt1) ; see comment in MERGE-LIST*
1145                          (prog1 elt2 (step2) (pop/no-key2))
1146                          (prog1 elt1 (step1) (pop/no-key1))))
1147                    (pop-one/key ()
1148                      (if (funcall predicate key2 key1)
1149                          (prog1 elt2 (step2) (pop/key2))
1150                          (prog1 elt1 (step1) (pop/key1)))))
1151             (declare (truly-dynamic-extent #'pop/no-key1 #'pop/no-key2
1152                                            #'pop/key1 #'pop/key2
1153                                            #'pop-one/no-key #'pop-one/key))
1154             ;; Populate ENDP{1,2}, ELT{1,2} and maybe KEY{1,2}.
1155             (cond (key-function (pop/key1) (pop/key2))
1156                   (t (pop/no-key1) (pop/no-key2)))
1157             (loop with pop-one = (if key-function #'pop-one/key #'pop-one/no-key) do
1158                  (cond
1159                    (endp2 ; batch-replace rest of SEQUENCE1 if SEQUENCE2 exhausted
1160                     (unless endp1
1161                       (replace result sequence1 :start1 (index-result) :start2 (index1)))
1162                     (return))
1163                    (endp1
1164                     (unless endp2
1165                       (replace result sequence2 :start1 (index-result) :start2 (index2)))
1166                     (return))
1167                    (t
1168                     (setelt-result (funcall pop-one))
1169                     (step-result))))))))
1170     result))