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