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