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