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