1 ;;;; Extensible sequences, based on the proposal by Christophe Rhodes.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is in the public domain and is provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 (in-package "SB-IMPL")
13 (define-condition sequence
::protocol-unimplemented
(type-error)
16 (defun sequence::protocol-unimplemented
(sequence)
17 (error 'sequence
::protocol-unimplemented
18 :datum sequence
:expected-type
'(or list vector
)))
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
)))
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
)))
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
)))
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
))
42 ((and icp iep
) (error "bar"))
43 (iep (make-list length
:initial-element initial-element
))
44 (icp (unless (= (length initial-contents
) length
)
46 (let ((result (make-list length
)))
47 (replace result initial-contents
)
49 (t (make-list length
))))
50 (:method
((s vector
) length
&key
51 (initial-element nil iep
) (initial-contents nil icp
))
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
)))
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
))
68 (let ((olength (length s
)))
70 ((eql length olength
) (if icp
(replace s initial-contents
) s
))
72 (rplacd (nthcdr (1- length
) s
) nil
)
73 (if icp
(replace s initial-contents
) 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
))
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
)))
95 ;;;; iterator protocol
97 ;;; The general protocol
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 (:method
((s t
) &key from-end start end
)
109 (declare (ignore from-end start end
))
112 :expected-type
'sequence
)))
114 ;;; the simple protocol: the simple iterator returns three values,
115 ;;; STATE, LIMIT and FROM-END.
117 ;;; magic termination value for list :from-end t
118 (defvar *exhausted
* (cons nil nil
))
120 (defgeneric sequence
:make-simple-sequence-iterator
121 (sequence &key from-end start end
)
122 (:method
((s list
) &key from-end
(start 0) end
)
124 (let* ((termination (if (= start
0) *exhausted
* (nthcdr (1- start
) s
)))
125 (init (if (<= (or end
(length s
)) start
)
127 (if end
(last s
(- (length s
) (1- end
))) (last s
)))))
128 (values init termination t
))
130 ((not end
) (values (nthcdr start s
) nil nil
))
131 (t (let ((st (nthcdr start s
)))
132 (values st
(nthcdr (- end start
) st
) nil
))))))
133 (:method
((s vector
) &key from-end
(start 0) end
)
134 (let ((end (or end
(length s
))))
136 (values (1- end
) (1- start
) t
)
137 (values start end nil
))))
138 (:method
((s sequence
) &key from-end
(start 0) end
)
139 (let ((end (or end
(length s
))))
141 (values (1- end
) (1- start
) from-end
)
142 (values start end nil
)))))
144 (defgeneric sequence
:iterator-step
(sequence iterator from-end
)
145 (:method
((s list
) iterator from-end
)
149 (do* ((xs s
(cdr xs
)))
150 ((eq (cdr xs
) iterator
) xs
)))
152 (:method
((s vector
) iterator from-end
)
156 (:method
((s sequence
) iterator from-end
)
161 (defgeneric sequence
:iterator-endp
(sequence iterator limit from-end
)
162 (:method
((s list
) iterator limit from-end
)
164 (:method
((s vector
) iterator limit from-end
)
166 (:method
((s sequence
) iterator limit from-end
)
169 (defgeneric sequence
:iterator-element
(sequence iterator
)
170 (:method
((s list
) iterator
)
172 (:method
((s vector
) iterator
)
174 (:method
((s sequence
) iterator
)
177 (defgeneric (setf sequence
:iterator-element
) (new-value sequence iterator
)
178 (:method
(o (s list
) iterator
)
179 (setf (car iterator
) o
))
180 (:method
(o (s vector
) iterator
)
181 (setf (aref s iterator
) o
))
182 (:method
(o (s sequence
) iterator
)
183 (setf (elt s iterator
) o
)))
185 (defgeneric sequence
:iterator-index
(sequence iterator
)
186 (:method
((s list
) iterator
)
187 ;; FIXME: this sucks. (In my defence, it is the equivalent of the
188 ;; Apple implementation in Dylan...)
189 (loop for l on s for i from
0 when
(eq l iterator
) return i
))
190 (:method
((s vector
) iterator
) iterator
)
191 (:method
((s sequence
) iterator
) iterator
))
193 (defgeneric sequence
:iterator-copy
(sequence iterator
)
194 (:method
((s list
) iterator
) iterator
)
195 (:method
((s vector
) iterator
) iterator
)
196 (:method
((s sequence
) iterator
) iterator
))
198 (defmacro sequence
:with-sequence-iterator
199 ((&rest vars
) (s &rest args
&key from-end start end
) &body body
)
200 (declare (ignore from-end start end
))
201 `(multiple-value-bind (,@vars
) (sequence:make-sequence-iterator
,s
,@args
)
202 (declare (type function
,@(nthcdr 3 vars
)))
205 (defmacro sequence
:with-sequence-iterator-functions
206 ((step endp elt setf index copy
)
207 (s &rest args
&key from-end start end
)
209 (declare (ignore from-end start end
))
210 (let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
211 (nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
212 (nendp (gensym "ENDP")) (nelt (gensym "ELT"))
213 (nsetf (gensym "SETF")) (nindex (gensym "INDEX"))
214 (ncopy (gensym "COPY")))
215 `(sequence:with-sequence-iterator
216 (,nstate
,nlimit
,nfrom-end
,nstep
,nendp
,nelt
,nsetf
,nindex
,ncopy
)
218 (flet ((,step
() (setq ,nstate
(funcall ,nstep
,s
,nstate
,nfrom-end
)))
219 (,endp
() (funcall ,nendp
,s
,nstate
,nlimit
,nfrom-end
))
220 (,elt
() (funcall ,nelt
,s
,nstate
))
221 (,setf
(new-value) (funcall ,nsetf new-value
,s
,nstate
))
222 (,index
() (funcall ,nindex
,s
,nstate
))
223 (,copy
() (funcall ,ncopy
,s
,nstate
)))
224 (declare (truly-dynamic-extent #',step
#',endp
#',elt
225 #',setf
#',index
#',copy
))
228 (defun sequence:canonize-test
(test test-not
)
230 (test (if (functionp test
) test
(fdefinition test
)))
231 (test-not (if (functionp test-not
)
232 (complement test-not
)
233 (complement (fdefinition test-not
))))
236 (defun sequence:canonize-key
(key)
237 (or (and key
(if (functionp key
) key
(fdefinition key
))) #'identity
))
239 ;;;; LOOP support. (DOSEQUENCE support is present in the core SBCL
241 (defun loop-elements-iteration-path (variable data-type prep-phrases
)
243 (loop for
(prep . rest
) in prep-phrases do
245 ((:of
:in
) (if of-phrase
246 (sb-loop::loop-error
"Too many prepositions")
247 (setq of-phrase rest
)))))
248 (destructuring-bind (it lim f-e step endp elt seq
)
249 (loop repeat
7 collect
(gensym))
250 (push `(let ((,seq
,(car of-phrase
)))) sb-loop
::*loop-wrappers
*)
251 (push `(sequence:with-sequence-iterator
(,it
,lim
,f-e
,step
,endp
,elt
) (,seq
))
252 sb-loop
::*loop-wrappers
*)
253 `(((,variable nil
,data-type
)) () () nil
(funcall ,endp
,seq
,it
,lim
,f-e
)
254 (,variable
(funcall ,elt
,seq
,it
) ,it
(funcall ,step
,seq
,it
,f-e
))))))
255 (sb-loop::add-loop-path
256 '(element elements
) 'loop-elements-iteration-path sb-loop
::*loop-ansi-universe
*
257 :preposition-groups
'((:of
:in
)) :inclusive-permitted nil
)
259 ;;;; generic implementations for sequence functions.
261 ;;; FIXME: COUNT, POSITION and FIND share an awful lot of structure.
262 ;;; They could usefully be defined in an OAOO way.
263 (defgeneric sequence
:count
264 (item sequence
&key from-end start end test test-not key
)
265 (:argument-precedence-order sequence item
))
266 (defmethod sequence:count
267 (item (sequence sequence
) &key from-end
(start 0) end test test-not key
)
268 (let ((test (sequence:canonize-test test test-not
))
269 (key (sequence:canonize-key key
)))
270 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
271 (sequence :from-end from-end
:start start
:end end
)
273 ((funcall endp sequence state limit from-end
) count
)
274 (let ((o (funcall elt sequence state
)))
275 (when (funcall test item
(funcall key o
))
277 (setq state
(funcall step sequence state from-end
)))))))
279 (defgeneric sequence
:count-if
(pred sequence
&key from-end start end key
)
280 (:argument-precedence-order sequence pred
))
281 (defmethod sequence:count-if
282 (pred (sequence sequence
) &key from-end
(start 0) end key
)
283 (let ((key (sequence:canonize-key key
)))
284 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
285 (sequence :from-end from-end
:start start
:end end
)
287 ((funcall endp sequence state limit from-end
) count
)
288 (let ((o (funcall elt sequence state
)))
289 (when (funcall pred
(funcall key o
))
291 (setq state
(funcall step sequence state from-end
)))))))
293 (defgeneric sequence
:count-if-not
(pred sequence
&key from-end start end key
)
294 (:argument-precedence-order sequence pred
))
295 (defmethod sequence:count-if-not
296 (pred (sequence sequence
) &key from-end
(start 0) end key
)
297 (let ((key (sequence:canonize-key key
)))
298 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
299 (sequence :from-end from-end
:start start
:end end
)
301 ((funcall endp sequence state limit from-end
) count
)
302 (let ((o (funcall elt sequence state
)))
303 (unless (funcall pred
(funcall key o
))
305 (setq state
(funcall step sequence state from-end
)))))))
307 (defgeneric sequence
:find
308 (item sequence
&key from-end start end test test-not key
)
309 (:argument-precedence-order sequence item
))
310 (defmethod sequence:find
311 (item (sequence sequence
) &key from-end
(start 0) end test test-not key
)
312 (let ((test (sequence:canonize-test test test-not
))
313 (key (sequence:canonize-key key
)))
314 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
315 (sequence :from-end from-end
:start start
:end end
)
317 ((funcall endp sequence state limit from-end
) nil
)
318 (let ((o (funcall elt sequence state
)))
319 (when (funcall test item
(funcall key o
))
321 (setq state
(funcall step sequence state from-end
)))))))
323 (defgeneric sequence
:find-if
(pred sequence
&key from-end start end key
)
324 (:argument-precedence-order sequence pred
))
325 (defmethod sequence:find-if
326 (pred (sequence sequence
) &key from-end
(start 0) end key
)
327 (let ((key (sequence:canonize-key key
)))
328 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
329 (sequence :from-end from-end
:start start
:end end
)
331 ((funcall endp sequence state limit from-end
) nil
)
332 (let ((o (funcall elt sequence state
)))
333 (when (funcall pred
(funcall key o
))
335 (setq state
(funcall step sequence state from-end
)))))))
337 (defgeneric sequence
:find-if-not
(pred sequence
&key from-end start end key
)
338 (:argument-precedence-order sequence pred
))
339 (defmethod sequence:find-if-not
340 (pred (sequence sequence
) &key from-end
(start 0) end key
)
341 (let ((key (sequence:canonize-key key
)))
342 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
343 (sequence :from-end from-end
:start start
:end end
)
345 ((funcall endp sequence state limit from-end
) nil
)
346 (let ((o (funcall elt sequence state
)))
347 (unless (funcall pred
(funcall key o
))
349 (setq state
(funcall step sequence state from-end
)))))))
351 (defgeneric sequence
:position
352 (item sequence
&key from-end start end test test-not key
)
353 (:argument-precedence-order sequence item
))
354 (defmethod sequence:position
355 (item (sequence sequence
) &key from-end
(start 0) end test test-not key
)
356 (let ((test (sequence:canonize-test test test-not
))
357 (key (sequence:canonize-key key
)))
358 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
359 (sequence :from-end from-end
:start start
:end end
)
360 (do ((s (if from-end -
1 1))
361 (pos (if from-end
(1- (or end
(length sequence
))) start
) (+ pos s
)))
362 ((funcall endp sequence state limit from-end
) nil
)
363 (let ((o (funcall elt sequence state
)))
364 (when (funcall test item
(funcall key o
))
366 (setq state
(funcall step sequence state from-end
)))))))
368 (defgeneric sequence
:position-if
(pred sequence
&key from-end start end key
)
369 (:argument-precedence-order sequence pred
))
370 (defmethod sequence:position-if
371 (pred (sequence sequence
) &key from-end
(start 0) end key
)
372 (let ((key (sequence:canonize-key key
)))
373 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
374 (sequence :from-end from-end
:start start
:end end
)
375 (do ((s (if from-end -
1 1))
376 (pos (if from-end
(1- (or end
(length sequence
))) start
) (+ pos s
)))
377 ((funcall endp sequence state limit from-end
) nil
)
378 (let ((o (funcall elt sequence state
)))
379 (when (funcall pred
(funcall key o
))
381 (setq state
(funcall step sequence state from-end
)))))))
383 (defgeneric sequence
:position-if-not
384 (pred sequence
&key from-end start end key
)
385 (:argument-precedence-order sequence pred
))
386 (defmethod sequence:position-if-not
387 (pred (sequence sequence
) &key from-end
(start 0) end key
)
388 (let ((key (sequence:canonize-key key
)))
389 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
390 (sequence :from-end from-end
:start start
:end end
)
391 (do ((s (if from-end -
1 1))
392 (pos (if from-end
(1- (or end
(length sequence
))) start
) (+ pos s
)))
393 ((funcall endp sequence state limit from-end
) nil
)
394 (let ((o (funcall elt sequence state
)))
395 (unless (funcall pred
(funcall key o
))
397 (setq state
(funcall step sequence state from-end
)))))))
399 (defgeneric sequence
:subseq
(sequence start
&optional end
))
400 (defmethod sequence:subseq
((sequence sequence
) start
&optional end
)
401 (let* ((end (or end
(length sequence
)))
402 (length (- end start
))
403 (result (sequence:make-sequence-like sequence length
)))
404 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
405 (sequence :start start
:end end
)
406 (declare (ignore limit endp
))
407 (sequence:with-sequence-iterator
(rstate rlimit rfrom-end rstep rendp relt rsetelt
)
409 (declare (ignore rlimit rendp relt
))
411 ((>= i length
) result
)
412 (funcall rsetelt
(funcall elt sequence state
) result rstate
)
413 (setq state
(funcall step sequence state from-end
))
414 (setq rstate
(funcall rstep result rstate rfrom-end
)))))))
416 (defgeneric sequence
:copy-seq
(sequence))
417 (defmethod sequence:copy-seq
((sequence sequence
))
418 (sequence:subseq sequence
0))
420 (defgeneric sequence
:fill
(sequence item
&key start end
))
421 (defmethod sequence:fill
((sequence sequence
) item
&key
(start 0) end
)
422 (sequence:with-sequence-iterator
(state limit from-end step endp elt setelt
)
423 (sequence :start start
:end end
)
424 (declare (ignore elt
))
426 ((funcall endp sequence state limit from-end
) sequence
)
427 (funcall setelt item sequence state
)
428 (setq state
(funcall step sequence state from-end
)))))
430 (defgeneric sequence
:nsubstitute
431 (new old sequence
&key start end from-end test test-not count key
)
432 (:argument-precedence-order sequence new old
))
433 (defmethod sequence:nsubstitute
(new old
(sequence sequence
) &key
(start 0)
434 end from-end test test-not count key
)
435 (let ((test (sequence:canonize-test test test-not
))
436 (key (sequence:canonize-key key
)))
437 (sequence:with-sequence-iterator
(state limit from-end step endp elt setelt
)
438 (sequence :start start
:end end
:from-end from-end
)
440 ((or (and count
(>= c count
))
441 (funcall endp sequence state limit from-end
))
443 (when (funcall test old
(funcall key
(funcall elt sequence state
)))
445 (funcall setelt new sequence state
))
446 (setq state
(funcall step sequence state from-end
))))))
448 (defgeneric sequence
:nsubstitute-if
449 (new predicate sequence
&key start end from-end count key
)
450 (:argument-precedence-order sequence new predicate
))
451 (defmethod sequence:nsubstitute-if
452 (new predicate
(sequence sequence
) &key
(start 0) end from-end count key
)
453 (let ((key (sequence:canonize-key key
)))
454 (sequence:with-sequence-iterator
(state limit from-end step endp elt setelt
)
455 (sequence :start start
:end end
:from-end from-end
)
457 ((or (and count
(>= c count
))
458 (funcall endp sequence state limit from-end
))
460 (when (funcall predicate
(funcall key
(funcall elt sequence state
)))
462 (funcall setelt new sequence state
))
463 (setq state
(funcall step sequence state from-end
))))))
465 (defgeneric sequence
:nsubstitute-if-not
466 (new predicate sequence
&key start end from-end count key
)
467 (:argument-precedence-order sequence new predicate
))
468 (defmethod sequence:nsubstitute-if-not
469 (new predicate
(sequence sequence
) &key
(start 0) end from-end count key
)
470 (let ((key (sequence:canonize-key key
)))
471 (sequence:with-sequence-iterator
(state limit from-end step endp elt setelt
)
472 (sequence :start start
:end end
:from-end from-end
)
474 ((or (and count
(>= c count
))
475 (funcall endp sequence state limit from-end
))
477 (unless (funcall predicate
(funcall key
(funcall elt sequence state
)))
479 (funcall setelt new sequence state
))
480 (setq state
(funcall step sequence state from-end
))))))
482 (defgeneric sequence
:substitute
483 (new old sequence
&key start end from-end test test-not count key
)
484 (:argument-precedence-order sequence new old
))
485 (defmethod sequence:substitute
(new old
(sequence sequence
) &rest args
&key
486 (start 0) end from-end test test-not count key
)
487 (declare (truly-dynamic-extent args
))
488 (declare (ignore start end from-end test test-not count key
))
489 (let ((result (copy-seq sequence
)))
490 (apply #'sequence
:nsubstitute new old result args
)))
492 (defgeneric sequence
:substitute-if
493 (new predicate sequence
&key start end from-end count key
)
494 (:argument-precedence-order sequence new predicate
))
495 (defmethod sequence:substitute-if
(new predicate
(sequence sequence
) &rest args
496 &key
(start 0) end from-end count key
)
497 (declare (truly-dynamic-extent args
))
498 (declare (ignore start end from-end count key
))
499 (let ((result (copy-seq sequence
)))
500 (apply #'sequence
:nsubstitute-if new predicate result args
)))
502 (defgeneric sequence
:substitute-if-not
503 (new predicate sequence
&key start end from-end count key
)
504 (:argument-precedence-order sequence new predicate
))
505 (defmethod sequence:substitute-if-not
506 (new predicate
(sequence sequence
) &rest args
&key
507 (start 0) end from-end count key
)
508 (declare (truly-dynamic-extent args
))
509 (declare (ignore start end from-end count key
))
510 (let ((result (copy-seq sequence
)))
511 (apply #'sequence
:nsubstitute-if-not new predicate result args
)))
513 (defun %sequence-replace
(sequence1 sequence2 start1 end1 start2 end2
)
514 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1 setelt1
)
515 (sequence1 :start start1
:end end1
)
516 (declare (ignore elt1
))
517 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2
)
518 (sequence2 :start start2
:end end2
)
520 ((or (funcall endp1 sequence1 state1 limit1 from-end1
)
521 (funcall endp2 sequence2 state2 limit2 from-end2
))
523 (funcall setelt1
(funcall elt2 sequence2 state2
) sequence1 state1
)
524 (setq state1
(funcall step1 sequence1 state1 from-end1
))
525 (setq state2
(funcall step2 sequence2 state2 from-end2
))))))
527 (defgeneric sequence
:replace
528 (sequence1 sequence2
&key start1 end1 start2 end2
)
529 (:argument-precedence-order sequence2 sequence1
))
530 (defmethod sequence:replace
531 ((sequence1 sequence
) (sequence2 sequence
) &key
532 (start1 0) end1
(start2 0) end2
)
534 ((eq sequence1 sequence2
)
535 (let ((replaces (subseq sequence2 start2 end2
)))
536 (%sequence-replace sequence1 replaces start1 end1
0 nil
)))
537 (t (%sequence-replace sequence1 sequence2 start1 end1 start2 end2
))))
539 (defgeneric sequence
:nreverse
(sequence))
540 (defmethod sequence:nreverse
((sequence sequence
))
541 ;; FIXME: this, in particular the :from-end iterator, will suck
542 ;; mightily if the user defines a list-like structure.
543 (let ((length (length sequence
)))
544 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1 setelt1
)
545 (sequence :end
(floor length
2))
546 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2 setelt2
)
547 (sequence :start
(ceiling length
2) :from-end t
)
548 (declare (ignore limit2 endp2
))
550 ((funcall endp1 sequence state1 limit1 from-end1
) sequence
)
551 (let ((x (funcall elt1 sequence state1
))
552 (y (funcall elt2 sequence state2
)))
553 (funcall setelt1 y sequence state1
)
554 (funcall setelt2 x sequence state2
))
555 (setq state1
(funcall step1 sequence state1 from-end1
))
556 (setq state2
(funcall step2 sequence state2 from-end2
)))))))
558 (defgeneric sequence
:reverse
(sequence))
559 (defmethod sequence:reverse
((sequence sequence
))
560 (let ((result (copy-seq sequence
)))
561 (sequence:nreverse result
)))
563 (defgeneric sequence
:reduce
564 (function sequence
&key from-end start end initial-value
)
565 (:argument-precedence-order sequence function
))
566 (defmethod sequence:reduce
567 (function (sequence sequence
) &key from-end
(start 0) end key
568 (initial-value nil ivp
))
569 (let ((key (sequence:canonize-key key
)))
570 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
571 (sequence :start start
:end end
:from-end from-end
)
572 (if (funcall endp sequence state limit from-end
)
573 (if ivp initial-value
(funcall function
))
574 (do* ((state state
(funcall step sequence state from-end
))
578 (funcall key
(funcall elt sequence state
))
579 (setq state
(funcall step sequence state from-end
)))))))
580 ((funcall endp sequence state limit from-end
) value
)
581 (let ((e (funcall key
(funcall elt sequence state
))))
583 (setq value
(funcall function e value
))
584 (setq value
(funcall function value e
)))))))))
586 (defgeneric sequence
:mismatch
(sequence1 sequence2
&key from-end start1 end1
587 start2 end2 test test-not key
))
588 (defmethod sequence:mismatch
589 ((sequence1 sequence
) (sequence2 sequence
) &key from-end
(start1 0) end1
590 (start2 0) end2 test test-not key
)
591 (let ((test (sequence:canonize-test test test-not
))
592 (key (sequence:canonize-key key
)))
593 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1
)
594 (sequence1 :start start1
:end end1
:from-end from-end
)
595 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2
)
596 (sequence2 :start start2
:end end2
:from-end from-end
)
598 (do ((result (or end1
(length sequence1
)) (1- result
))
599 (e1 (funcall endp1 sequence1 state1 limit1 from-end1
)
600 (funcall endp1 sequence1 state1 limit1 from-end1
))
601 (e2 (funcall endp2 sequence2 state2 limit2 from-end2
)
602 (funcall endp2 sequence2 state2 limit2 from-end2
)))
603 ((or e1 e2
) (if (and e1 e2
) nil result
))
604 (let ((o1 (funcall key
(funcall elt1 sequence1 state1
)))
605 (o2 (funcall key
(funcall elt2 sequence2 state2
))))
606 (unless (funcall test o1 o2
)
608 (setq state1
(funcall step1 sequence1 state1 from-end1
))
609 (setq state2
(funcall step2 sequence2 state2 from-end2
))))
610 (do ((result start1
(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
)
620 (setq state1
(funcall step1 sequence1 state1 from-end1
))
621 (setq state2
(funcall step2 sequence2 state2 from-end2
))))))))
623 (defgeneric sequence
:search
(sequence1 sequence2
&key from-end start1 end1
624 start2 end2 test test-not key
))
625 (defmethod sequence:search
626 ((sequence1 sequence
) (sequence2 sequence
) &key from-end
(start1 0) end1
627 (start2 0) end2 test test-not key
)
628 (let ((test (sequence:canonize-test test test-not
))
629 (key (sequence:canonize-key key
))
630 (mainend2 (- (or end2
(length sequence2
))
631 (- (or end1
(length sequence1
)) start1
))))
633 (return-from sequence
:search nil
))
634 (sequence:with-sequence-iterator
(statem limitm from-endm stepm endpm
)
635 (sequence2 :start start2
:end mainend2
:from-end from-end
)
636 (do ((s2 (if from-end mainend2
0) (if from-end
(1- s2
) (1+ s2
))))
638 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1
)
639 (sequence1 :start start1
:end end1
)
640 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2
)
641 (sequence2 :start s2
)
642 (declare (ignore limit2 endp2
))
644 ((funcall endp1 sequence1 state1 limit1 from-end1
) t
)
645 (let ((o1 (funcall key
(funcall elt1 sequence1 state1
)))
646 (o2 (funcall key
(funcall elt2 sequence2 state2
))))
647 (unless (funcall test o1 o2
)
649 (setq state1
(funcall step1 sequence1 state1 from-end1
))
650 (setq state2
(funcall step2 sequence2 state2 from-end2
)))
651 (return-from sequence
:search s2
))))
652 (when (funcall endpm sequence2 statem limitm from-endm
)
654 (setq statem
(funcall stepm sequence2 statem from-endm
))))))
656 (defgeneric sequence
:delete
657 (item sequence
&key from-end test test-not start end count key
)
658 (:argument-precedence-order sequence item
))
659 (defmethod sequence:delete
(item (sequence sequence
) &key
660 from-end test test-not
(start 0) end count key
)
661 (let ((test (sequence:canonize-test test test-not
))
662 (key (sequence:canonize-key key
))
664 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1 setelt1
)
665 (sequence :start start
:end end
:from-end from-end
)
666 (declare (ignore limit1 endp1 elt1
))
667 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2
)
668 (sequence :start start
:end end
:from-end from-end
)
671 (replace sequence sequence
672 :start1 start
:end1
(- (length sequence
) c
)
673 :start2
(+ start c
) :end2
(length sequence
))
674 (unless (or (null end
) (= end
(length sequence
)))
675 (replace sequence sequence
:start2 end
:start1
(- end c
)
676 :end1
(- (length sequence
) c
))))
677 (sequence:adjust-sequence sequence
(- (length sequence
) c
))))
678 (declare (truly-dynamic-extent #'finish
))
680 ((funcall endp2 sequence state2 limit2 from-end2
) (finish))
681 (let ((e (funcall elt2 sequence state2
)))
683 (when (and count
(>= c count
))
685 (if (funcall test item
(funcall key e
))
688 (setq state2
(funcall step2 sequence state2 from-end2
))
689 (when (funcall endp2 sequence state2 limit2 from-end2
)
690 (return-from sequence
:delete
(finish)))
691 (setq e
(funcall elt2 sequence state2
)))
693 (funcall setelt1 e sequence state1
))
694 (setq state1
(funcall step1 sequence state1 from-end1
))
695 (setq state2
(funcall step2 sequence state2 from-end2
))))))))
697 (defgeneric sequence
:delete-if
698 (predicate sequence
&key from-end start end count key
)
699 (:argument-precedence-order sequence predicate
))
700 (defmethod sequence:delete-if
(predicate (sequence sequence
) &key
701 from-end
(start 0) end count key
)
702 (let ((key (sequence:canonize-key key
))
704 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1 setelt1
)
705 (sequence :start start
:end end
:from-end from-end
)
706 (declare (ignore limit1 endp1 elt1
))
707 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2
)
708 (sequence :start start
:end end
:from-end from-end
)
711 (replace sequence sequence
712 :start1 start
:end1
(- (length sequence
) c
)
713 :start2
(+ start c
) :end2
(length sequence
))
714 (unless (or (null end
) (= end
(length sequence
)))
715 (replace sequence sequence
:start2 end
:start1
(- end c
)
716 :end1
(- (length sequence
) c
))))
717 (sequence:adjust-sequence sequence
(- (length sequence
) c
))))
718 (declare (truly-dynamic-extent #'finish
))
720 ((funcall endp2 sequence state2 limit2 from-end2
) (finish))
721 (let ((e (funcall elt2 sequence state2
)))
723 (when (and count
(>= c count
))
725 (if (funcall predicate
(funcall key e
))
728 (setq state2
(funcall step2 sequence state2 from-end2
))
729 (when (funcall endp2 sequence state2 limit2 from-end2
)
730 (return-from sequence
:delete-if
(finish)))
731 (setq e
(funcall elt2 sequence state2
)))
733 (funcall setelt1 e sequence state1
))
734 (setq state1
(funcall step1 sequence state1 from-end1
))
735 (setq state2
(funcall step2 sequence state2 from-end2
))))))))
737 (defgeneric sequence
:delete-if-not
738 (predicate sequence
&key from-end start end count key
)
739 (:argument-precedence-order sequence predicate
))
740 (defmethod sequence:delete-if-not
(predicate (sequence sequence
) &key
741 from-end
(start 0) end count key
)
742 (let ((key (sequence:canonize-key key
))
744 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1 setelt1
)
745 (sequence :start start
:end end
:from-end from-end
)
746 (declare (ignore limit1 endp1 elt1
))
747 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2
)
748 (sequence :start start
:end end
:from-end from-end
)
751 (replace sequence sequence
752 :start1 start
:end1
(- (length sequence
) c
)
753 :start2
(+ start c
) :end2
(length sequence
))
754 (unless (or (null end
) (= end
(length sequence
)))
755 (replace sequence sequence
:start2 end
:start1
(- end c
)
756 :end1
(- (length sequence
) c
))))
757 (sequence:adjust-sequence sequence
(- (length sequence
) c
))))
758 (declare (truly-dynamic-extent #'finish
))
760 ((funcall endp2 sequence state2 limit2 from-end2
) (finish))
761 (let ((e (funcall elt2 sequence state2
)))
763 (when (and count
(>= c count
))
765 (if (funcall predicate
(funcall key e
))
769 (setq state2
(funcall step2 sequence state2 from-end2
))
770 (when (funcall endp2 sequence state2 limit2 from-end2
)
771 (return-from sequence
:delete-if-not
(finish)))
772 (setq e
(funcall elt2 sequence state2
)))))
773 (funcall setelt1 e sequence state1
))
774 (setq state1
(funcall step1 sequence state1 from-end1
))
775 (setq state2
(funcall step2 sequence state2 from-end2
))))))))
777 (defgeneric sequence
:remove
778 (item sequence
&key from-end test test-not start end count key
)
779 (:argument-precedence-order sequence item
))
780 (defmethod sequence:remove
(item (sequence sequence
) &rest args
&key
781 from-end test test-not
(start 0) end count key
)
782 (declare (truly-dynamic-extent args
))
783 (declare (ignore from-end test test-not start end count key
))
784 (let ((result (copy-seq sequence
)))
785 (apply #'sequence
:delete item result args
)))
787 (defgeneric sequence
:remove-if
788 (predicate sequence
&key from-end start end count key
)
789 (:argument-precedence-order sequence predicate
))
790 (defmethod sequence:remove-if
(predicate (sequence sequence
) &rest args
&key
791 from-end
(start 0) end count key
)
792 (declare (truly-dynamic-extent args
))
793 (declare (ignore from-end start end count key
))
794 (let ((result (copy-seq sequence
)))
795 (apply #'sequence
:delete-if predicate result args
)))
797 (defgeneric sequence
:remove-if-not
798 (predicate sequence
&key from-end start end count key
)
799 (:argument-precedence-order sequence predicate
))
800 (defmethod sequence:remove-if-not
(predicate (sequence sequence
) &rest args
801 &key from-end
(start 0) end count key
)
802 (declare (truly-dynamic-extent args
))
803 (declare (ignore from-end start end count key
))
804 (let ((result (copy-seq sequence
)))
805 (apply #'sequence
:delete-if-not predicate result args
)))
807 (defgeneric sequence
:delete-duplicates
808 (sequence &key from-end test test-not start end key
))
809 (defmethod sequence:delete-duplicates
810 ((sequence sequence
) &key from-end test test-not
(start 0) end key
)
811 (let ((test (sequence:canonize-test test test-not
))
812 (key (sequence:canonize-key key
))
814 (sequence:with-sequence-iterator
(state1 limit1 from-end1 step1 endp1 elt1 setelt1
)
815 (sequence :start start
:end end
:from-end from-end
)
816 (declare (ignore limit1 endp1 elt1
))
817 (sequence:with-sequence-iterator
(state2 limit2 from-end2 step2 endp2 elt2
)
818 (sequence :start start
:end end
:from-end from-end
)
821 (replace sequence sequence
822 :start1 start
:end1
(- (length sequence
) c
)
823 :start2
(+ start c
) :end2
(length sequence
))
824 (unless (or (null end
) (= end
(length sequence
)))
825 (replace sequence sequence
:start2 end
:start1
(- end c
)
826 :end1
(- (length sequence
) c
))))
827 (sequence:adjust-sequence sequence
(- (length sequence
) c
))))
828 (declare (truly-dynamic-extent #'finish
))
829 (do ((end (or end
(length sequence
)))
831 ((funcall endp2 sequence state2 limit2 from-end2
) (finish))
832 (let ((e (funcall elt2 sequence state2
)))
834 ;; FIXME: replace with POSITION once position is
836 (if (> (count (funcall key e
) sequence
:test test
:key key
837 :start
(if from-end start
(+ start step
1))
838 :end
(if from-end
(- end step
1) end
))
843 (setq state2
(funcall step2 sequence state2 from-end2
))
844 (when (funcall endp2 sequence state2 limit2 from-end2
)
845 (return-from sequence
:delete-duplicates
(finish)))
846 (setq e
(funcall elt2 sequence state2
)))
849 (funcall setelt1 e sequence state1
))
850 (setq state1
(funcall step1 sequence state1 from-end1
))
851 (setq state2
(funcall step2 sequence state2 from-end2
))))))))
853 (defgeneric sequence
:remove-duplicates
854 (sequence &key from-end test test-not start end key
))
855 (defmethod sequence:remove-duplicates
856 ((sequence sequence
) &rest args
&key from-end test test-not
(start 0) end key
)
857 (declare (truly-dynamic-extent args
))
858 (declare (ignore from-end test test-not start end key
))
859 (let ((result (copy-seq sequence
)))
860 (apply #'sequence
:delete-duplicates result args
)))
862 (defgeneric sequence
:sort
(sequence predicate
&key key
))
863 (defmethod sequence:sort
((sequence sequence
) predicate
&rest args
&key key
)
864 (declare (truly-dynamic-extent args
))
865 (declare (ignore key
))
866 (let* ((length (length sequence
))
867 (vector (make-array length
)))
868 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
870 (declare (ignore limit endp
))
873 (setf (aref vector i
) (funcall elt sequence state
))
874 (setq state
(funcall step sequence state from-end
))))
875 (apply #'sort vector predicate args
)
876 (sequence:with-sequence-iterator
(state limit from-end step endp elt setelt
)
878 (declare (ignore limit endp elt
))
880 ((>= i length
) sequence
)
881 (funcall setelt
(aref vector i
) sequence state
)
882 (setq state
(funcall step sequence state from-end
))))))
884 (defgeneric sequence
:stable-sort
(sequence predicate
&key key
))
885 (defmethod sequence:stable-sort
886 ((sequence sequence
) predicate
&rest args
&key key
)
887 (declare (truly-dynamic-extent args
))
888 (declare (ignore key
))
889 (let* ((length (length sequence
))
890 (vector (make-array length
)))
891 (sequence:with-sequence-iterator
(state limit from-end step endp elt
)
893 (declare (ignore limit endp
))
896 (setf (aref vector i
) (funcall elt sequence state
))
897 (setq state
(funcall step sequence state from-end
))))
898 (apply #'stable-sort vector predicate args
)
899 (sequence:with-sequence-iterator
(state limit from-end step endp elt setelt
)
901 (declare (ignore limit endp elt
))
903 ((>= i length
) sequence
)
904 (funcall setelt
(aref vector i
) sequence state
)
905 (setq state
(funcall step sequence state from-end
))))))