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