?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Moved ATA driver into its own package
[movitz-core.git] / losp / muerte / sequences.lisp
blobffc1a6c41e1ca0f2971c16d89eb18b149e4f68b2
1 ;;;;------------------------------------------------------------------
2 ;;;;
3 ;;;; Copyright (C) 2001-2005,
4 ;;;; Department of Computer Science, University of Tromso, Norway.
5 ;;;;
6 ;;;; For distribution policy, see the accompanying file COPYING.
7 ;;;;
8 ;;;; Filename: sequences.lisp
9 ;;;; Description:
10 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
11 ;;;; Created at: Tue Sep 11 14:19:23 2001
12 ;;;;
13 ;;;; $Id: sequences.lisp,v 1.37 2007/04/07 20:14:45 ffjeld Exp $
14 ;;;;
15 ;;;;------------------------------------------------------------------
16
17 (require :muerte/basic-macros)
18 (provide :muerte/sequences)
19
20 (in-package muerte)
21
22 (defun sequencep (x)
23 (or (typep x 'vector)
24 (typep x 'cons)))
25
26 (defmacro sequence-dispatch (sequence-var (type0 &body forms0) (type1 &body forms1))
27 (cond
28 ((and (eq 'list type0) (eq 'vector type1))
29 `(if (typep ,sequence-var 'list)
30 (progn ,@forms0)
31 (progn (check-type ,sequence-var vector)
32 ,@forms1)))
33 ((and (eq 'vector type0) (eq 'list type1))
34 `(if (not (typep ,sequence-var 'list))
35 (progn (check-type ,sequence-var vector)
36 ,@forms0)
37 (progn ,@forms1)))
38 (t (error "sequence-dispatch only understands list and vector types, not ~W and ~W."
39 type0 type1))))
40
41 (defun sequence-double-dispatch-error (seq0 seq1)
42 (error "The type-set (~A, ~A) has not been implemented in this sequence-double-dispatch."
43 (type-of seq0)
44 (type-of seq1)))
45
46 (defmacro sequence-double-dispatch ((seq0 seq1) &rest clauses)
47 `(case (logior (if (typep ,seq0 'list) 2 0)
48 (if (typep ,seq1 'list) 1 0))
49 ,@(loop for ((type0 type1) . forms) in clauses
50 as index = (logior (ecase type0 (list 2) (vector 0))
51 (ecase type1 (list 1) (vector 0)))
52 collect
53 `(,index ,@forms))
54 (t (sequence-double-dispatch-error ,seq0 ,seq1))))
55
56 (defun length (sequence)
57 (etypecase sequence
58 (list
59 (do ((x sequence (cdr x))
60 (length 0 (1+ length)))
61 ((null x) length)
62 (declare (index length))))
63 (indirect-vector
64 (memref sequence (movitz-type-slot-offset 'movitz-basic-vector 'data)
65 :index 2))
66 ((simple-array * 1)
67 (macrolet
68 ((do-it ()
69 `(with-inline-assembly (:returns :eax)
70 (:compile-form (:result-mode :ebx) sequence)
71 (:movl (:ebx (:offset movitz-basic-vector num-elements))
72 :eax)
73 (:testl ,(logxor #xffffffff (1- (expt 2 14))) :eax)
74 (:jnz 'basic-vector-length-ok)
75 (:movzxw (:ebx (:offset movitz-basic-vector fill-pointer))
76 :eax)
77 basic-vector-length-ok)))
78 (do-it)))))
79
80 (defun length%list (sequence)
81 (do ((length 0 (1+ length))
82 (x sequence (cdr x)))
83 ((null x) length)
84 (declare (type index length))))
85
86 (defun elt (sequence index)
87 (sequence-dispatch sequence
88 (vector (aref sequence index))
89 (list (nth index sequence))))
90
91 (defun (setf elt) (value sequence index)
92 (sequence-dispatch sequence
93 (vector (setf (aref sequence index) value))
94 (list (setf (nth index sequence) value))))
95
96 (defun reduce (function sequence &key (key 'identity) from-end
97 (start 0) (end (length sequence))
98 (initial-value nil initial-value-p))
99 (numargs-case
100 (2 (function sequence)
101 (with-funcallable (funcall-function function)
102 (sequence-dispatch sequence
103 (list
104 (cond
105 ((null sequence)
106 (funcall-function))
107 ((null (cdr sequence))
108 (car sequence))
109 (t (do* ((list sequence)
110 (result (funcall-function (pop list) (pop list))
111 (funcall-function result (pop list))))
112 ((endp list)
113 result)))))
114 (vector
115 (let ((end (length sequence)))
116 (case end
117 (0 (funcall-function))
118 (1 (aref sequence 0))
119 (t (with-subvector-accessor (sequence-ref sequence 0 end)
120 (do* ((index 0)
121 (result (funcall-function (sequence-ref (prog1 index (incf index)))
122 (sequence-ref (prog1 index (incf index))))
123 (funcall-function result (sequence-ref (prog1 index (incf index))))))
124 ((= index end) result)
125 (declare (index index)))))))))))
126 (t (function sequence &key (key 'identity) from-end
127 (start 0) end
128 (initial-value nil initial-value-p))
129 (let ((start (check-the index start)))
130 (with-funcallable (funcall-function function)
131 (with-funcallable (key)
132 (sequence-dispatch sequence
133 (list
134 (let ((list (nthcdr start sequence)))
135 (cond
136 ((null list)
137 (if initial-value-p
138 initial-value
139 (funcall-function)))
140 ((null (cdr list))
141 (if initial-value-p
142 (funcall-function initial-value (key (car list)))
143 (key (car list))))
144 ((not from-end)
145 (if (not end)
146 (do ((result (funcall-function (if initial-value-p
147 initial-value
148 (key (pop list)))
149 (key (pop list)))
150 (funcall-function result (key (pop list)))))
151 ((null list) result))
152 (do ((counter (1+ start) (1+ counter))
153 (result (funcall-function (if initial-value-p
154 initial-value
155 (key (pop list)))
156 (key (pop list)))
157 (funcall-function result (key (pop list)))))
158 ((or (null list)
159 (= end counter))
160 result)
161 (declare (index counter)))))
162 (from-end
163 (do* ((end (or end (+ start (length list))))
164 (counter (1+ start) (1+ counter))
165 (list (nreverse (subseq sequence start end)))
166 (result (funcall-function (key (pop list))
167 (if initial-value-p
168 initial-value
169 (key (pop list))))
170 (funcall-function (key (pop list)) result)))
171 ((or (null list)
172 (= end counter))
173 result)
174 (declare (index counter)))))))
175 (vector
176 (when from-end
177 (error "REDUCE from-end on vectors is not implemented."))
178 (let ((end (or (check-the index end)
179 (length sequence))))
180 (case (- end start)
181 (0 (if initial-value-p
182 initial-value
183 (funcall-function)))
184 (1 (if initial-value-p
185 (funcall-function initial-value (key (elt sequence start)))
186 (key (elt sequence start))))
187 (t (with-subvector-accessor (sequence-ref sequence start end)
188 (do* ((index start)
189 (result (funcall-function (if initial-value-p
190 initial-value
191 (key (sequence-ref (prog1 index (incf index)))))
192 (key (sequence-ref (prog1 index (incf index)))))
193 (funcall-function result (sequence-ref (prog1 index (incf index))))))
194 ((= index end) result)
195 (declare (index index)))))))))))))))
196
197 (defun subseq (sequence start &optional end)
198 (sequence-dispatch sequence
199 (vector
200 (unless end
201 (setf end (length sequence)))
202 (with-subvector-accessor (old-ref sequence start end)
203 (let ((new-vector (make-array (- end start) :element-type (array-element-type sequence))))
204 (replace new-vector sequence :start2 start :end2 end)
205 #+ignore (with-subvector-accessor (new-ref new-vector)
206 (do ((i start (1+ i))
207 (j 0 (1+ j)))
208 ((>= i end) new-vector)
209 (setf (new-ref j) (old-ref i))))
210 )))
211 (list
212 (let ((list-start (nthcdr start sequence)))
213 (cond
214 ((not end)
215 (copy-list list-start))
216 ((> start end)
217 (error "Start ~A is greater than end ~A." start end))
218 ((endp list-start) nil)
219 ((= start end) nil)
220 (t (do* ((p (cdr list-start) (cdr p))
221 (i (1+ start) (1+ i))
222 (head (cons (car list-start) nil))
223 (tail head))
224 ((or (endp p) (>= i end)) head)
225 (declare (index i))
226 (setf (cdr tail) (cons (car p) nil)
227 tail (cdr tail)))))))))
228
229 (defsetf subseq (sequence start &optional (end nil end-p)) (new-sequence)
230 `(progn (replace ,sequence ,new-sequence :start1 ,start
231 ,@(when end-p `(:end1 ,end)))
232 ,new-sequence))
233
234 (defun copy-seq (sequence)
235 (subseq sequence 0))
236
237 (defun position (item sequence &key from-end (test #'eql) test-not (start 0) end (key 'identity))
238 (numargs-case
239 (2 (item sequence)
240 (sequence-dispatch sequence
241 (vector
242 (with-subvector-accessor (sequence-ref sequence)
243 (do ((end (length sequence))
244 (i 0 (1+ i)))
245 ((>= i end))
246 (declare (index i end))
247 (when (eql (sequence-ref i) item)
248 (return i)))))
249 (list
250 (do ((i 0 (1+ i)))
251 ((null sequence) nil)
252 (declare (index i))
253 (when (eql (pop sequence) item)
254 (return i))))))
255 (t (item sequence &key from-end (test #'eql) test-not (start 0) end (key 'identity))
256 (with-funcallable (key)
257 (with-funcallable (test)
258 (sequence-dispatch sequence
259 (vector
260 (unless end
261 (setf end (length sequence)))
262 (with-subvector-accessor (sequence-ref sequence start end)
263 (cond
264 ((not from-end)
265 (do ((i start (1+ i)))
266 ((>= i end))
267 (declare (index i))
268 (when (test (key (sequence-ref i)) item)
269 (return i))))
270 (t (do ((i (1- end) (1- i)))
271 ((< i start))
272 (declare (index i))
273 (when (test (key (sequence-ref i)) item)
274 (return i)))))))
275 (list
276 (cond
277 ((not end)
278 (do ((p (nthcdr start sequence))
279 (i start (1+ i)))
280 ((null p) nil)
281 (declare (index i))
282 (when (test (key (pop p)) item)
283 (return (if (not from-end)
284 i
285 (let ((next-i (position item p :key key :from-end t
286 :test test :test-not test-not)))
287 (if next-i (+ i 1 next-i ) i)))))))
288 (t (do ((p (nthcdr start sequence))
289 (i start (1+ i)))
290 ((or (null p) (>= i end)) nil)
291 (declare (index i))
292 (when (test (key (pop p)) item)
293 (return (if (not from-end) i
294 (let ((next-i (position item p :end (- end 1 i) :from-end t
295 :key key :test test :test-not test-not)))
296 (if next-i (+ i 1 next-i ) i)))))))))))))))
297
298 (defun position-if (predicate sequence &key (start 0) end (key 'identity) from-end)
299 (numargs-case
300 (2 (predicate sequence)
301 (with-funcallable (predicate)
302 (sequence-dispatch sequence
303 (vector
304 (with-subvector-accessor (sequence-ref sequence)
305 (do ((end (length sequence))
306 (i 0 (1+ i)))
307 ((>= i end))
308 (declare (index i end))
309 (when (predicate (sequence-ref i))
310 (return i)))))
311 (list
312 (do ((p sequence)
313 (i 0 (1+ i)))
314 ((null p))
315 (declare (index i))
316 (when (predicate (pop p))
317 (return i)))))))
318 (t (predicate sequence &key (start 0) end (key 'identity) from-end)
319 (with-funcallable (predicate)
320 (with-funcallable (key)
321 (sequence-dispatch sequence
322 (vector
323 (setf end (or end (length sequence)))
324 (with-subvector-accessor (sequence-ref sequence start end)
325 (cond
326 ((not from-end)
327 (do ((i start (1+ i)))
328 ((>= i end))
329 (declare (index i))
330 (when (predicate (key (sequence-ref i)))
331 (return i))))
332 (t (do ((i (1- end) (1- i)))
333 ((< i start))
334 (declare (index i))
335 (when (predicate (key (sequence-ref i)))
336 (return i)))))))
337 (list
338 (cond
339 (end
340 (do ((p (nthcdr start sequence))
341 (i start (1+ i)))
342 ((or (>= i end) (null p)))
343 (declare (index i))
344 (when (predicate (key (pop p)))
345 (return (if (not from-end) i
346 (let ((next-i (position-if predicate p :key key
347 :from-end t :end (- end i 1))))
348 (if next-i (+ i 1 next-i) i)))))))
349 (t (do ((p (nthcdr start sequence))
350 (i start (1+ i)))
351 ((null p))
352 (declare (index i))
353 (when (predicate (key (pop p)))
354 (return (if (not from-end) i
355 (let ((next-i (position-if predicate p :key key :from-end t)))
356 (if next-i (+ i 1 next-i) i)))))))))))))))
357
358 (defun position-if-not (predicate sequence &rest key-args)
359 (declare (dynamic-extent key-args))
360 (apply #'position-if (complement predicate) sequence key-args))
361
362 (defun nreverse (sequence)
363 (sequence-dispatch sequence
364 (list
365 (do ((prev-cons nil current-cons)
366 (next-cons (cdr sequence) (cdr next-cons))
367 (current-cons sequence next-cons))
368 ((null current-cons) prev-cons)
369 (setf (cdr current-cons) prev-cons)))
370 (vector
371 (with-subvector-accessor (sequence-ref sequence)
372 (do ((i 0 (1+ i))
373 (j (1- (length sequence)) (1- j)))
374 ((<= j i))
375 (declare (index i j))
376 (let ((x (sequence-ref i)))
377 (setf (sequence-ref i) (sequence-ref j)
378 (sequence-ref j) x))))
379 sequence)))
380
381 (defun reverse (sequence)
382 (sequence-dispatch sequence
383 (list
384 (let ((result nil))
385 (dolist (x sequence)
386 (push x result))
387 result))
388 (vector
389 (nreverse (copy-seq sequence)))))
390
391 (defun mismatch-eql-identity (sequence-1 sequence-2 start1 start2 end1 end2)
392 (sequence-dispatch sequence-1
393 (vector
394 (unless end1 (setf end1 (length sequence-1)))
395 (with-subvector-accessor (seq1-ref sequence-1 start1 end1)
396 (sequence-dispatch sequence-2
397 (vector
398 (unless end2 (setf end2 (length sequence-2)))
399 (with-subvector-accessor (seq2-ref sequence-2 start2 end2)
400 (macrolet ((test-return (index1 index2)
401 `(unless (eql (seq1-ref ,index1) (seq2-ref ,index2))
402 (return ,index1))))
403 (let ((length1 (- end1 start1))
404 (length2 (- end2 start2)))
405 (cond
406 ((= length1 length2)
407 (do* ((i start1 (1+ i))
408 (j start2 (1+ j)))
409 ((>= i end1) nil)
410 (declare (index i j))
411 (test-return i j)))
412 ((< length1 length2)
413 (do* ((i start1 (1+ i))
414 (j start2 (1+ j)))
415 ((>= i end1) end1)
416 (declare (index i j))
417 (test-return i j)))
418 ((> length1 length2)
419 (do* ((i start1 (1+ i))
420 (j start2 (1+ j)))
421 ((>= j end2) i)
422 (declare (index i j))
423 (test-return i j))))))))
424 (list
425 (let ((length1 (- end1 start1))
426 (start-cons2 (nthcdr start2 sequence-2)))
427 (cond
428 ((and (zerop length1) (null start-cons2))
429 (if (and end2 (> end2 start2)) start1 nil))
430 ((not end2)
431 (do ((i1 start1 (1+ i1))
432 (p2 start-cons2 (cdr p2)))
433 ((>= i1 end1) (if (null p2) nil i1))
434 (declare (index i1))
435 (unless (and p2 (eql (seq1-ref i1) (car p2)))
436 (return i1))))
437 ((< length1 (- end2 start2))
438 (do ((i1 start1 (1+ i1))
439 (p2 start-cons2 (cdr p2)))
440 ((>= i1 end1) end1)
441 (declare (index i1))
442 (unless (eql (seq1-ref i1) (car p2))
443 (return i1))))
444 ((> length1 (- end2 start2))
445 (do ((i1 start1 (1+ i1))
446 (p2 start-cons2 (cdr p2)))
447 ((null p2) end1)
448 (declare (index i1))
449 (unless (eql (seq1-ref i1) (car p2))
450 (return i1))))
451 (t (do ((i1 start1 (1+ i1))
452 (p2 start-cons2 (cdr p2)))
453 ((null p2) nil)
454 (declare (index i1))
455 (unless (eql (seq1-ref i1) (car p2))
456 (return i1))))))))))
457 (list
458 (sequence-dispatch sequence-2
459 (vector
460 (let ((mismatch-2 (mismatch-eql-identity sequence-2 sequence-1 start2 start1 end2 end1)))
461 (if (not mismatch-2)
462 nil
463 (+ start1 (- mismatch-2 start2)))))
464 (list
465 (let ((start-cons1 (nthcdr start1 sequence-1))
466 (start-cons2 (nthcdr start2 sequence-2)))
467 (assert (and start-cons1 start-cons2) (start1 start2) "Illegal bounding indexes.")
468 (cond
469 ((and (not end1) (not end2))
470 (do ((p1 start-cons1 (cdr p1))
471 (p2 start-cons2 (cdr p2))
472 (i1 start1 (1+ i1)))
473 ((null p1) (if (null p2) nil i1))
474 (declare (index i1))
475 (unless (and p2 (eql (car p1) (car p2)))
476 (return i1))))
477 (t (do ((p1 start-cons1 (cdr p1))
478 (p2 start-cons2 (cdr p2))
479 (i1 start1 (1+ i1))
480 (i2 start2 (1+ i2)))
481 ((if end1 (>= i1 end1) (null p1))
482 (if (if end2 (>= i2 end2) (null p2)) nil i1))
483 (declare (index i1 i2))
484 (unless (and (or (not end2) (< i1 end2))
485 (eql (car p1) (car p2)))
486 (return i1)))))))))))
487
488 (define-compiler-macro mismatch (&whole form sequence-1 sequence-2
489 &key (start1 0) (start2 0) end1 end2
490 (test 'eql test-p) (key 'identity key-p) from-end)
491 (declare (ignore key test))
492 (cond
493 ((and (not test-p) (not key-p))
494 (assert (not from-end) ()
495 "Mismatch :from-end not implemented.")
496 `(mismatch-eql-identity ,sequence-1 ,sequence-2 ,start1 ,start2 ,end1 ,end2))
497 (t form)))
498
499 (defun mismatch (sequence-1 sequence-2 &key (start1 0) (start2 0) end1 end2
500 (test 'eql) (key 'identity) from-end)
501 (numargs-case
502 (2 (s1 s2)
503 (mismatch-eql-identity s1 s2 0 0 nil nil))
504 (t (sequence-1 sequence-2 &key (start1 0) (start2 0) end1 end2
505 (test 'eql) (key 'identity) from-end)
506 (assert (not from-end) ()
507 "Mismatch :from-end not implemented.")
508 (with-funcallable (test)
509 (with-funcallable (key)
510 (sequence-dispatch sequence-1
511 (vector
512 (unless end1 (setf end1 (length sequence-1)))
513 (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
514 (sequence-dispatch sequence-2
515 (vector
516 (let ((end2 (check-the index (or end2 (length sequence-2)))))
517 (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
518 (macrolet ((test-return (index1 index2)
519 `(unless (test (key (sequence-1-ref ,index1))
520 (key (sequence-2-ref ,index2)))
521 (return-from mismatch ,index1))))
522 (let ((length1 (- end1 start1))
523 (length2 (- end2 start2)))
524 (cond
525 ((< length1 length2)
526 (dotimes (i length1)
527 (declare (index i))
528 (test-return (+ start1 i) (+ start2 i)))
529 end1)
530 ((> length1 length2)
531 (dotimes (i length2)
532 (declare (index i))
533 (test-return (+ start1 i) (+ start2 i)))
534 (+ start1 length2))
535 (t (dotimes (i length1)
536 (declare (index i))
537 (test-return (+ start1 i) (+ start2 i)))
538 nil)))))))
539 (list
540 (let ((length1 (- end1 start1))
541 (start-cons2 (nthcdr start2 sequence-2)))
542 (cond
543 ((and (zerop length1) (null start-cons2))
544 (if (and end2 (> end2 start2)) start1 nil))
545 ((not end2)
546 (do ((i1 start1 (1+ i1))
547 (p2 start-cons2 (cdr p2)))
548 ((>= i1 end1) (if (null p2) nil i1))
549 (declare (index i1))
550 (unless (and p2 (test (key (sequence-1-ref i1)) (key (car p2))))
551 (return-from mismatch i1))))
552 ((< length1 (- end2 start2))
553 (do ((i1 start1 (1+ i1))
554 (p2 start-cons2 (cdr p2)))
555 ((>= i1 end1) end1)
556 (declare (index i1))
557 (unless (test (key (sequence-1-ref i1)) (key (car p2)))
558 (return-from mismatch i1))))
559 ((> length1 (- end2 start2))
560 (do ((i1 start1 (1+ i1))
561 (p2 start-cons2 (cdr p2)))
562 ((null p2) end1)
563 (declare (index i1))
564 (unless (test (key (sequence-1-ref i1)) (key (car p2)))
565 (return-from mismatch i1))))
566 (t (do ((i1 start1 (1+ i1))
567 (p2 start-cons2 (cdr p2)))
568 ((null p2) nil)
569 (declare (index i1))
570 (unless (test (key (sequence-1-ref i1)) (key (car p2)))
571 (return-from mismatch i1))))))))))
572 (list
573 (sequence-dispatch sequence-2
574 (vector
575 (let ((mismatch-2 (mismatch sequence-2 sequence-1 :from-end from-end :test test :key key
576 :start1 start2 :end1 end2 :start2 start1 :end2 end1)))
577 (if (not mismatch-2)
578 nil
579 (+ start1 (- mismatch-2 start2)))))
580 (list
581 (let ((start-cons1 (nthcdr start1 sequence-1))
582 (start-cons2 (nthcdr start2 sequence-2)))
583 (assert (and start-cons1 start-cons2) (start1 start2) "Illegal bounding indexes.")
584 (cond
585 ((and (not end1) (not end2))
586 (do ((p1 start-cons1 (cdr p1))
587 (p2 start-cons2 (cdr p2))
588 (i1 start1 (1+ i1)))
589 ((null p1) (if (null p2) nil i1))
590 (declare (index i1))
591 (unless (and p2 (test (key (car p1)) (key (car p2))))
592 (return i1))))
593 (t (do ((p1 start-cons1 (cdr p1))
594 (p2 start-cons2 (cdr p2))
595 (i1 start1 (1+ i1))
596 (i2 start2 (1+ i2)))
597 ((if end1 (>= i1 end1) (null p1))
598 (if (if end2 (>= i2 end2) (null p2)) nil i1))
599 (declare (index i1 i2))
600 (unless p2
601 (if end2
602 (error "Illegal end2 bounding index.")
603 (return i1)))
604 (unless (and (or (not end2) (< i1 end2))
605 (test (key (car p1)) (key (car p2))))
606 (return i1)))))))))))))))
607
608 (defun map-into (result-sequence function first-sequence &rest more-sequences)
609 (declare (dynamic-extent more-sequences))
610 (assert (null more-sequences) ()
611 "MAP-INTO not implemented.")
612 (with-funcallable (map function)
613 (sequence-double-dispatch (result-sequence first-sequence)
614 ((vector vector)
615 (let ((length (min (length result-sequence)
616 (length first-sequence))))
617 (with-subvector-accessor (result-ref result-sequence 0 length)
618 (with-subvector-accessor (first-sequence-ref first-sequence 0 length)
619 (dotimes (i length result-sequence)
620 (setf (result-ref i)
621 (map (first-sequence-ref i))))))))
622 ((list list)
623 (do ((p result-sequence (cdr p))
624 (q first-sequence (cdr q)))
625 ((or (null p) (null q))
626 result-sequence)
627 (setf (car p) (map (car q)))))
628 ((vector list)
629 (with-subvector-accessor (result-ref result-sequence)
630 (do ((end (length result-sequence))
631 (i 0 (1+ i))
632 (p first-sequence (cdr p)))
633 ((or (endp p) (>= i end)) result-sequence)
634 (declare (index i))
635 (setf (result-ref i) (map (car p))))))
636 ((list vector)
637 (with-subvector-accessor (first-ref first-sequence)
638 (do ((end (length first-sequence))
639 (i 0 (1+ i))
640 (p result-sequence (cdr p)))
641 ((or (endp p) (>= i end)) result-sequence)
642 (declare (index i))
643 (setf (car p) (map (first-ref i)))))))))
644
645 (defun map-for-nil (function first-sequence &rest more-sequences)
646 (numargs-case
647 (2 (function first-sequence)
648 (with-funcallable (mapf function)
649 (sequence-dispatch first-sequence
650 (list
651 (dolist (x first-sequence)
652 (mapf x)))
653 (vector
654 (with-subvector-accessor (sequence-ref first-sequence)
655 (dotimes (i (length first-sequence))
656 (mapf (sequence-ref i))))))))
657 (3 (function first-sequence second-sequence)
658 (with-funcallable (mapf function)
659 (sequence-double-dispatch (first-sequence second-sequence)
660 ((list list)
661 (do ((p first-sequence (cdr p))
662 (q second-sequence (cdr q)))
663 ((or (endp p) (endp q)))
664 (mapf (car p) (car q))))
665 ((vector vector)
666 (with-subvector-accessor (first-sequence-ref first-sequence)
667 (with-subvector-accessor (second-sequence-ref second-sequence)
668 (do ((len1 (length first-sequence))
669 (len2 (length second-sequence))
670 (i 0 (1+ i))
671 (j 0 (1+ j)))
672 ((or (>= i len1)
673 (>= j len2)))
674 (declare (index i j))
675 (mapf (first-sequence-ref i) (second-sequence-ref j))))))
676 )))
677 (t (function first-sequence &rest more-sequences)
678 (declare (ignore function first-sequence more-sequences))
679 (error "MAP not implemented."))))
680
681 (defun map-for-list (function first-sequence &rest more-sequences)
682 (numargs-case
683 (2 (function first-sequence)
684 (with-funcallable (mapf function)
685 (sequence-dispatch first-sequence
686 (list
687 (mapcar function first-sequence))
688 (vector
689 (with-subvector-accessor (sequence-ref first-sequence)
690 (let ((result nil))
691 (dotimes (i (length first-sequence))
692 (push (mapf (sequence-ref i))
693 result))
694 (nreverse result)))))))
695 (3 (function first-sequence second-sequence)
696 (sequence-double-dispatch (first-sequence second-sequence)
697 ((list list)
698 (mapcar function first-sequence second-sequence))
699 ((vector vector)
700 (with-funcallable (mapf function)
701 (with-subvector-accessor (first-sequence-ref first-sequence)
702 (with-subvector-accessor (second-sequence-ref second-sequence)
703 (do ((result nil)
704 (len1 (length first-sequence))
705 (len2 (length second-sequence))
706 (i 0 (1+ i))
707 (j 0 (1+ j)))
708 ((or (>= i len1)
709 (>= j len2))
710 (nreverse result))
711 (declare (index i j))
712 (push (mapf (first-sequence-ref i) (second-sequence-ref j))
713 result))))))
714 ((list vector)
715 (with-funcallable (mapf function)
716 (with-subvector-accessor (second-sequence-ref second-sequence)
717 (do ((result nil)
718 (len2 (length second-sequence))
719 (p first-sequence (cdr p))
720 (j 0 (1+ j)))
721 ((or (endp p) (>= j len2))
722 (nreverse result))
723 (declare (index j))
724 (push (mapf (car p) (second-sequence-ref j))
725 result)))))
726 ((vector list)
727 (with-funcallable (mapf function)
728 (with-subvector-accessor (first-sequence-ref first-sequence)
729 (do ((result nil)
730 (len1 (length first-sequence))
731 (p second-sequence (cdr p))
732 (j 0 (1+ j)))
733 ((or (endp p) (>= j len1))
734 (nreverse result))
735 (declare (index j))
736 (push (mapf (first-sequence-ref j) (car p))
737 result)))))))
738 (t (function first-sequence &rest more-sequences)
739 (declare (dynamic-extent more-sequences)
740 (ignore function first-sequence more-sequences))
741 (error "MAP not implemented."))))
742
743 (defun map-for-vector (result function first-sequence &rest more-sequences)
744 (numargs-case
745 (3 (result function first-sequence)
746 (with-funcallable (mapf function)
747 (sequence-dispatch first-sequence
748 (vector
749 (do ((i 0 (1+ i)))
750 ((>= i (length result)) result)
751 (declare (index i))
752 (setf (aref result i) (mapf (aref first-sequence i)))))
753 (list
754 (do ((i 0 (1+ i)))
755 ((>= i (length result)) result)
756 (declare (index i))
757 (setf (aref result i) (mapf (pop first-sequence))))))))
758 (t (function first-sequence &rest more-sequences)
759 (declare (ignore function first-sequence more-sequences))
760 (error "MAP not implemented."))))
761
762
763 (defun map (result-type function first-sequence &rest more-sequences)
764 "=> result"
765 (declare (dynamic-extent more-sequences))
766 (cond
767 ((null result-type)
768 (apply 'map-for-nil function first-sequence more-sequences))
769 ((eq 'list result-type)
770 (apply 'map-for-list function first-sequence more-sequences))
771 ((member result-type '(string simple-string))
772 (apply 'map-for-vector
773 (make-string (length first-sequence))
774 function first-sequence more-sequences))
775 ((member result-type '(vector simple-vector))
776 (apply 'map-for-vector
777 (make-array (length first-sequence))
778 function first-sequence more-sequences))
779 (t (error "MAP not implemented."))))
780
781 (defun fill (sequence item &key (start 0) end)
782 "=> sequence"
783 (let ((start (check-the index start)))
784 (etypecase sequence
785 (list
786 (do ((p (nthcdr start sequence) (cdr p))
787 (i start (1+ i)))
788 ((or (null p) (and end (>= i end))))
789 (declare (index i))
790 (setf (car p) item)))
791 ((simple-array (unsigned-byte 32) 1)
792 (let* ((length (array-dimension sequence 0))
793 (end (or end length)))
794 (unless (<= 0 end length)
795 (error 'index-out-of-range :index end :range length))
796 (do ((i start (1+ i)))
797 ((>= i end))
798 (declare (index i))
799 (setf (memref sequence (movitz-type-slot-offset 'movitz-basic-vector 'data)
800 :index i
801 :type :unsigned-byte32)
802 item))))
803 (vector
804 (let ((end (or end (length sequence))))
805 (with-subvector-accessor (sequence-ref sequence start end)
806 (do ((i start (1+ i)))
807 ((>= i end))
808 (declare (index i))
809 (setf (sequence-ref i) item)))))))
810 sequence)
811
812 (defun replace (sequence-1 sequence-2 &key (start1 0) end1 (start2 0) end2)
813 (let ((start1 (check-the index start1))
814 (start2 (check-the index start2)))
815 (cond
816 ((and (eq sequence-1 sequence-2)
817 (<= start2 start1 (or end2 start1)))
818 (if (= start1 start2)
819 sequence-1 ; no need to copy anything
820 ;; must copy in reverse direction
821 (sequence-dispatch sequence-1
822 (vector
823 (let ((l (length sequence-1)))
824 (setf end1 (or end1 l)
825 end2 (or end2 l))
826 (assert (<= 0 start2 end2 l)))
827 (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
828 (do* ((length (min (- end1 start1) (- end2 start2)))
829 (i (+ start1 length -1) (1- i))
830 (j (+ start2 length -1) (1- j)))
831 ((< i start1) sequence-1)
832 (declare (index i j length))
833 (setf (sequence-1-ref i)
834 (sequence-1-ref j)))))
835 (list
836 (let* ((length (length sequence-1))
837 (reverse-list (nreverse sequence-1))
838 (size (min (- (or end1 length) start1) (- (or end2 length) start2))))
839 (do ((p (nthcdr (- length start1 size) reverse-list) (cdr p))
840 (q (nthcdr (- length start2 size) reverse-list) (cdr q))
841 (i 0 (1+ i)))
842 ((>= i size) (nreverse reverse-list))
843 (declare (index i))
844 (setf (car p) (car q))))))))
845 ;; (not (eq sequence-1 sequence-2)) ..
846 (t (sequence-dispatch sequence-1
847 (vector
848 (setf end1 (or end1 (length sequence-1)))
849 (sequence-dispatch sequence-2
850 (vector
851 (setf end2 (or end2 (length sequence-2)))
852 (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
853 (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
854 (cond
855 ((< (- end1 start1) (- end2 start2))
856 (do ((i start1 (1+ i))
857 (j start2 (1+ j)))
858 ((>= i end1) sequence-1)
859 (declare (index i j))
860 (setf (sequence-1-ref i) (sequence-2-ref j))))
861 (t (do ((i start1 (1+ i))
862 (j start2 (1+ j)))
863 ((>= j end2) sequence-1)
864 (declare (index i j))
865 (setf (sequence-1-ref i) (sequence-2-ref j))))))))
866 (list
867 (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
868 (if (not end2)
869 (do ((i start1 (1+ i))
870 (p (nthcdr start2 sequence-2) (cdr p)))
871 ((or (null p) (>= i end1)) sequence-1)
872 (declare (index i))
873 (setf (sequence-1-ref i) (car p)))
874 (do ((i start1 (1+ i))
875 (j start2 (1+ j))
876 (p (nthcdr start2 sequence-2) (cdr p)))
877 ((or (>= i end1) (endp p) (>= j end2)) sequence-1)
878 (declare (index i j))
879 (setf (sequence-1-ref i) (car p))))))))
880 (list
881 (sequence-dispatch sequence-2
882 (vector
883 (setf end2 (or end2 (length sequence-2)))
884 (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
885 (do ((p (nthcdr start1 sequence-1) (cdr p))
886 (i start1 (1+ i))
887 (j start2 (1+ j)))
888 ((or (endp p) (>= j end2) (and end1 (>= i end1)))
889 sequence-1)
890 (declare (index i j))
891 (setf (car p) (sequence-2-ref j)))))
892 (list
893 (do ((i start1 (1+ i))
894 (j start2 (1+ j))
895 (p (nthcdr start1 sequence-1) (cdr p))
896 (q (nthcdr start2 sequence-2) (cdr q)))
897 ((or (endp p) (endp q)
898 (and end1 (>= i end1))
899 (and end2 (>= j end2)))
900 sequence-1)
901 (declare (index i j))
902 (setf (car p) (car q)))))))
903 sequence-1))))
904
905 (defun find (item sequence &key from-end (test 'eql) (start 0) end (key 'identity))
906 (numargs-case
907 (2 (item sequence)
908 (sequence-dispatch sequence
909 (vector
910 (with-subvector-accessor (sequence-ref sequence)
911 (dotimes (i (length sequence))
912 (when (eql item (sequence-ref i))
913 (return item)))))
914 (list
915 (dolist (x sequence)
916 (when (eql item x)
917 (return x))))))
918 (t (item sequence &key from-end (test 'eql) (start 0) end (key 'identity))
919 (let ((start (check-the index start)))
920 (with-funcallable (test)
921 (with-funcallable (key)
922 (sequence-dispatch sequence
923 (vector
924 (setf end (or end (length sequence)))
925 (with-subvector-accessor (sequence-ref sequence start end)
926 (if (not from-end)
927 (do ((i start (1+ i)))
928 ((>= i end) nil)
929 (declare (index i))
930 (when (test item (key (aref sequence i)))
931 (return (sequence-ref i))))
932 (do ((i (1- end) (1- i)))
933 ((< i start) nil)
934 (declare (index i))
935 (when (test item (key (sequence-ref i)))
936 (return (sequence-ref i)))))))
937 (list
938 (if end
939 (do ((p (nthcdr start sequence) (cdr p))
940 (i start (1+ i)))
941 ((or (>= i end) (endp p)) nil)
942 (declare (index i))
943 (when (test item (key (car p)))
944 (return (or (and from-end
945 (find item (cdr p)
946 :from-end t :test test
947 :key key :end (- end i 1)))
948 (car p)))))
949 (do ((p (nthcdr start sequence) (cdr p)))
950 ((endp p) nil)
951 (when (test item (key (car p)))
952 (return (or (and from-end (find item (cdr p) :from-end t :test test :key key))
953 (car p))))))))))))))
954
955
956 (defun find-if (predicate sequence &key from-end (start 0) end (key 'identity))
957 (numargs-case
958 (2 (predicate sequence)
959 (with-funcallable (predicate)
960 (sequence-dispatch sequence
961 (vector
962 (let ((end (length sequence)))
963 (with-subvector-accessor (sequence-ref sequence 0 end)
964 (do ((i 0 (1+ i)))
965 ((>= i end))
966 (declare (index i))
967 (let ((x (sequence-ref i)))
968 (when (predicate x) (return x)))))))
969 (list
970 (do ((p sequence (cdr p)))
971 ((endp p) nil)
972 (let ((x (car p)))
973 (when (predicate x) (return x))))))))
974 (t (predicate sequence &key from-end (start 0) end (key 'identity))
975 (let ((start (check-the index start)))
976 (with-funcallable (predicate)
977 (with-funcallable (key)
978 (sequence-dispatch sequence
979 (vector
980 (setf end (or end (length sequence)))
981 (with-subvector-accessor (sequence-ref sequence start end)
982 (cond
983 ((not from-end)
984 (do ((i start (1+ i)))
985 ((>= i end))
986 (declare (index i))
987 (when (predicate (key (sequence-ref i)))
988 (return (sequence-ref i)))))
989 (t (do ((i (1- end) (1- i)))
990 ((< i start))
991 (declare (index i))
992 (when (predicate (key (sequence-ref i)))
993 (return (sequence-ref i))))))))
994 (list
995 (cond
996 (end
997 (do ((p (nthcdr start sequence) (cdr p))
998 (i start (1+ i)))
999 ((or (>= i end) (endp p)) nil)
1000 (declare (index i))
1001 (when (predicate (key (car p)))
1002 (return (or (and from-end
1003 (find-if predicate (cdr p) :end (- end i 1) :key key :from-end t))
1004 (car p))))))
1005 (t (do ((p (nthcdr start sequence) (cdr p)))
1006 ((endp p) nil)
1007 (when (predicate (key (car p)))
1008 (return (or (and from-end
1009 (find-if predicate (cdr p) :key key :from-end t))
1010 (car p)))))))))))))))
1011
1012 (defun find-if-not (predicate sequence &rest key-args)
1013 (declare (dynamic-extent key-args))
1014 (apply (complement predicate) sequence key-args))
1015
1016 (defun count (item sequence &key (start 0) end (test 'eql) (key 'identity) test-not from-end)
1017 (declare (ignore test-not))
1018 (let ((start (check-the index start)))
1019 (with-funcallable (test)
1020 (with-funcallable (key)
1021 (sequence-dispatch sequence
1022 (vector
1023 (let ((end (check-the index (or end (length sequence)))))
1024 (with-subvector-accessor (sequence-ref sequence start end)
1025 (cond
1026 ((not from-end)
1027 (do ((i start (1+ i))
1028 (n 0))
1029 ((>= i end) n)
1030 (declare (index i n))
1031 (when (test item (key (sequence-ref i)))
1032 (incf n))))
1033 (t (do ((i (1- end) (1- i))
1034 (n 0))
1035 ((< i start) n)
1036 (declare (index i n))
1037 (when (test item (key (sequence-ref i)))
1038 (incf n))))))))
1039 (list
1040 (cond
1041 ((not end)
1042 (do ((p (nthcdr start sequence) (cdr p))
1043 (n 0))
1044 ((endp p) n)
1045 (declare (index n))
1046 (when (test item (key (car p)))
1047 (incf n))))
1048 (t (do ((p (nthcdr start sequence) (cdr p))
1049 (i start (1+ i))
1050 (n 0))
1051 ((or (endp p) (>= i end)) n)
1052 (declare (index i n))
1053 (when (test item (key (car p)))
1054 (incf n)))))))))))
1055
1056 (defun count-if (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end)
1057 (numargs-case
1058 (2 (predicate sequence)
1059 (with-funcallable (predicate)
1060 (sequence-dispatch sequence
1061 (list
1062 (let ((count 0))
1063 (declare (index count))
1064 (dolist (x sequence)
1065 (when (predicate x)
1066 (incf count)))
1067 count))
1068 (vector
1069 (with-subvector-accessor (sequence-ref sequence)
1070 (let ((count 0))
1071 (declare (index count))
1072 (dotimes (i (length sequence))
1073 (when (predicate (sequence-ref i))
1074 (incf count)))
1075 count))))))
1076 (t (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end)
1077 (let ((start (check-the index start)))
1078 (with-funcallable (predicate)
1079 (with-funcallable (key)
1080 (sequence-dispatch sequence
1081 (list
1082 (if (not end)
1083 (do ((n 0)
1084 (p (nthcdr start sequence) (cdr p)))
1085 ((endp p) n)
1086 (declare (index n))
1087 (when (predicate (key (car p)))
1088 (incf n)))
1089 (let ((end (check-the index end)))
1090 (do ((n 0)
1091 (i start (1+ i))
1092 (p (nthcdr start sequence) (cdr p)))
1093 ((or (endp p) (>= i end)) n)
1094 (declare (index i n))
1095 (when (predicate (key (car p)))
1096 (incf n))))))
1097 (vector
1098 (error "vector count-if not implemented.")))))))))
1099
1100
1101 (macrolet ((every-some-body ()
1102 "This function body is shared between every and some."
1103 `(with-funcallable (predicate)
1104 (cond
1105 ((null more-sequences) ; 1 sequence case
1106 (sequence-dispatch first-sequence
1107 (list
1108 (do ((p first-sequence (cdr p)))
1109 ((null p) (default-value))
1110 (test-return (predicate (car p)))))
1111 (vector
1112 (do* ((l (length first-sequence))
1113 (i 0 (1+ i)))
1114 ((= l i) (default-value))
1115 (declare (index i l))
1116 (test-return (predicate (aref first-sequence i)))))))
1117 ((null (cdr more-sequences)) ; 2 sequences case
1118 (let ((second-sequence (first more-sequences)))
1119 (sequence-double-dispatch (first-sequence second-sequence)
1120 ((list list)
1121 (do ((p0 first-sequence (cdr p0))
1122 (p1 second-sequence (cdr p1)))
1123 ((or (endp p0) (endp p1)) (default-value))
1124 (test-return (predicate (car p0) (car p1)))))
1125 ((vector vector)
1126 (do ((end (min (length first-sequence) (length second-sequence)))
1127 (i 0 (1+ i)))
1128 ((>= i end) (default-value))
1129 (declare (index i))
1130 (test-return (predicate (aref first-sequence i)
1131 (aref second-sequence i)))))
1132 ((list vector)
1133 (do ((end (length second-sequence))
1134 (i 0 (1+ i))
1135 (p first-sequence (cdr p)))
1136 ((or (endp p) (>= i end)) (default-value))
1137 (declare (index i))
1138 (test-return (predicate (car p) (aref second-sequence i)))))
1139 ((vector list)
1140 (do ((end (length first-sequence))
1141 (i 0 (1+ i))
1142 (p second-sequence (cdr p)))
1143 ((or (endp p) (>= i end)) (default-value))
1144 (declare (index i))
1145 (test-return (predicate (aref first-sequence i) (car p))))))))
1146 (t (flet ((next (p)
1147 (sequence-dispatch p
1148 (list (cdr p))
1149 (vector p)))
1150 (seqend (p i)
1151 (sequence-dispatch p
1152 (list (null p))
1153 (vector (>= i (length p)))))
1154 (seqelt (p i)
1155 (sequence-dispatch p
1156 (list (car p))
1157 (vector (aref p i)))))
1158 (do* ((i 0 (1+ i)) ; 3 or more sequences, conses at 4 or more.
1159 (p0 first-sequence (next p0))
1160 (p1 (car more-sequences) (next p1))
1161 (p2 (cadr more-sequences) (next p2))
1162 (p3+ (cddr more-sequences) (map-into p3+ #'next p3+)) ;a list of pointers
1163 (arg3+ (make-list (length p3+))))
1164 ((or (seqend p0 i)
1165 (seqend p1 i)
1166 (seqend p2 i)
1167 (dolist (p p3+ nil)
1168 (when (seqend p i)
1169 (return t))))
1170 (default-value))
1171 (declare (index i))
1172 (do ((x arg3+ (cdr x))
1173 (y p3+ (cdr y)))
1174 ((null x))
1175 (setf (car x) (seqelt (car y) i)))
1176 (test-return (apply predicate (seqelt p0 i) (seqelt p1 i)
1177 (seqelt p2 i) arg3+)))))))))
1178 (defun some (predicate first-sequence &rest more-sequences)
1179 (declare (dynamic-extent more-sequences))
1180 (macrolet ((test-return (form)
1181 `(let ((x ,form)) (when x (return x))))
1182 (default-value () nil))
1183 (every-some-body)))
1184 (defun every (predicate first-sequence &rest more-sequences)
1185 (declare (dynamic-extent more-sequences))
1186 (macrolet ((test-return (form)
1187 `(unless ,form (return nil)))
1188 (default-value () t))
1189 (every-some-body))))
1190
1191 (defun notany (predicate first-sequence &rest more-sequences)
1192 (declare (dynamic-extent more-sequences))
1193 (not (apply 'some predicate first-sequence more-sequences)))
1194
1195 (defun list-remove (item list test key end count)
1196 "Implements remove for lists. Assumes (not from-end)."
1197 (cond
1198 ((endp list)
1199 nil)
1200 ((eq 0 count)
1201 list)
1202 (t (with-funcallable (test)
1203 (with-funcallable (key)
1204 (if (test item (key (car list)))
1205 (list-remove item (cdr list) test key
1206 (when end (1- end))
1207 (when count (1- count)))
1208 (do ((i 1 (1+ i))
1209 (p0 list (cdr p0))
1210 (p1 (cdr list) (cdr p1)))
1211 ((or (endp p1) (and end (>= i end))) list)
1212 (declare (index i))
1213 (when (test item (key (car p1)))
1214 (return
1215 ;; reiterate from <list> to <p1>, consing up a copy, with
1216 ;; the copy's tail being the recursive call to list-remove.
1217 (do* ((new-list (cons (car list) nil))
1218 (x (cdr list) (cdr x))
1219 (new-x new-list))
1220 ((eq x p1)
1221 (setf (cdr new-x) (list-remove item (cdr p1) test key
1222 (when end (- end i 1))
1223 (when count (1- count))))
1224 new-list)
1225 (setf new-x
1226 (setf (cdr new-x)
1227 (cons (car x) nil)))))))))))))
1228
1229 (defun list-remove-simple (item list)
1230 "The same as list-remove, without count, end, or key, with test=eql."
1231 (cond
1232 ((endp list)
1233 nil)
1234 ((eql item (car list))
1235 (list-remove-simple item (cdr list)))
1236 (t (do ((i 1 (1+ i))
1237 (p0 list (cdr p0))
1238 (p1 (cdr list) (cdr p1)))
1239 ((endp p1) list)
1240 (declare (index i))
1241 (when (eql item (car p1))
1242 (return
1243 ;; reiterate from <list> to <p1>, consing up a copy, with
1244 ;; the copy's tail being the recursive call to list-remove.
1245 (do* ((new-list (cons (car list) nil))
1246 (x (cdr list) (cdr x))
1247 (new-x new-list))
1248 ((eq x p1)
1249 (setf (cdr new-x) (list-remove-simple item (cdr p1)))
1250 new-list)
1251 (setf new-x
1252 (setf (cdr new-x)
1253 (cons (car x) nil))))))))))
1254
1255 (defun remove (item sequence &key (test 'eql) (start 0) end count (key 'identity) test-not from-end)
1256 (when test-not
1257 (setf test (complement test-not)))
1258 (sequence-dispatch sequence
1259 (list
1260 (setf sequence (nthcdr start sequence))
1261 (when end (decf end start))
1262 (cond
1263 ((endp sequence)
1264 nil)
1265 ((not from-end)
1266 (if (and (eq test 'eql)
1267 (not end)
1268 (not count)
1269 (eq key 'identity))
1270 (list-remove-simple item sequence)
1271 (list-remove item sequence test key end count)))
1272 (t (error "from-end not implemented."))))
1273 (vector
1274 (error "vector remove not implemented."))))
1275
1276 (defun list-remove-if (test list key end count)
1277 "Implements remove-if for lists. Assumes (not from-end)."
1278 (cond
1279 ((endp list)
1280 nil)
1281 ((eq 0 count)
1282 list)
1283 (t (with-funcallable (test)
1284 (with-funcallable (key)
1285 (and (do () ((or (endp list)
1286 (and end (<= end 0))
1287 (not (test (key (car list))))
1288 (and count (<= (decf count) 0)))
1289 list)
1290 (when end (decf end))
1291 (setf list (cdr list)))
1292 (do ((i 1 (1+ i))
1293 (p0 list (cdr p0))
1294 (p1 (cdr list) (cdr p1)))
1295 ((or (endp p1) (and end (>= i end))) list)
1296 (declare (index i))
1297 (when (test (key (car p1)))
1298 (return
1299 ;; reiterate from <list> to <p1>, consing up a copy, with
1300 ;; the copy's tail being the recursive call to list-remove.
1301 (do* ((new-list (cons (car list) nil))
1302 (x (cdr list) (cdr x))
1303 (new-x new-list))
1304 ((eq x p1)
1305 (setf (cdr new-x) (list-remove-if test (cdr p1) key
1306 (when end (- end i 1))
1307 (when count (1- count))))
1308 new-list)
1309 (setf new-x
1310 (setf (cdr new-x)
1311 (cons (car x) nil)))))))))))))
1312
1313 (defun remove-if (test sequence &key from-end (start 0) end count (key 'identity))
1314 (sequence-dispatch sequence
1315 (list
1316 (setf sequence (nthcdr start sequence))
1317 (when end (decf end start))
1318 (cond
1319 ((endp sequence)
1320 nil)
1321 ((not from-end)
1322 (list-remove-if test sequence key end count))
1323 (t (error "from-end not implemented."))))
1324 (vector
1325 (error "vector remove not implemented."))))
1326
1327 (defun remove-if-not (test sequence &rest args)
1328 (declare (dynamic-extent args))
1329 (apply 'remove-if (complement test) sequence args))
1330
1331 (defun list-delete (item list test key start end count)
1332 "Implements delete-if for lists. Assumes (not from-end)."
1333 (cond
1334 ((null list)
1335 nil)
1336 ((eq 0 count)
1337 list)
1338 ((eq start end)
1339 list)
1340 (t (with-funcallable (test)
1341 (with-funcallable (key)
1342 (let ((i 0) ; for end checking
1343 (c 0)) ; for count checking
1344 (declare (index i c))
1345 (cond
1346 ((= 0 start)
1347 ;; delete from head..
1348 (do ()
1349 ((not (test item (key (car list)))))
1350 (when (or (endp (setf list (cdr list)))
1351 (eq (incf i) end)
1352 (eq (incf c) count))
1353 (return-from list-delete list)))
1354 (setq start 1))
1355 (t (incf i (1- start))))
1356 ;; now delete "inside" list
1357 (do* ((p (nthcdr (1- start) list))
1358 (q (cdr p)))
1359 ((or (endp q)
1360 (eq (incf i) end))
1361 list)
1362 (cond
1363 ((test item (key (car q)))
1364 (setf q (cdr q)
1365 (cdr p) q)
1366 (when (eq (incf c) count)
1367 (return list)))
1368 (t (setf p q
1369 q (cdr q)))))))))))
1370
1371
1372 (defun list-delete-if (test list key start end count)
1373 "Implements delete-if for lists. Assumes (not from-end)."
1374 (cond
1375 ((null list)
1376 nil)
1377 ((eq 0 count)
1378 list)
1379 ((eq start end)
1380 list)
1381 (t (with-funcallable (test)
1382 (with-funcallable (key)
1383 (let ((i 0) ; for end checking
1384 (c 0)) ; for count checking
1385 (declare (index i c))
1386 (cond
1387 ((= 0 start)
1388 ;; delete from head..
1389 (do ()
1390 ((not (test (key (car list)))))
1391 (when (or (endp (setf list (cdr list)))
1392 (eq (incf i) end)
1393 (eq (incf c) count))
1394 (return-from list-delete-if list)))
1395 (setq start 1))
1396 (t (incf i (1- start))))
1397 ;; now delete "inside" list
1398 (do* ((p (nthcdr (1- start) list))
1399 (q (cdr p)))
1400 ((or (endp q)
1401 (eq (incf i) end))
1402 list)
1403 (cond
1404 ((test (key (car q)))
1405 (setf q (cdr q)
1406 (cdr p) q)
1407 (when (eq (incf c) count)
1408 (return list)))
1409 (t (setf p q
1410 q (cdr q)))))))))))
1411
1412 (defun delete (item sequence &key (test 'eql) from-end (start 0) end count (key 'identity))
1413 (sequence-dispatch sequence
1414 (list
1415 (when from-end
1416 (error "from-end not implemented."))
1417 (list-delete item sequence test key start end count))
1418 (vector
1419 (error "vector delete not implemented."))))
1420
1421 (defun delete-if (test sequence &key from-end (start 0) end count (key 'identity))
1422 (sequence-dispatch sequence
1423 (list
1424 (when from-end
1425 (error "from-end not implemented."))
1426 (list-delete-if test sequence key start end count))
1427 (vector
1428 (error "vector delete-if not implemented."))))
1429
1430 (defun delete-if-not (test sequence &rest key-args)
1431 (declare (dynamic-extent key-args))
1432 (apply 'delete-if (complement test) sequence key-args))
1433
1434 (defun remove-duplicates (sequence &key (test 'eql) (key 'identity) (start 0) end test-not from-end)
1435 (when test-not
1436 (setf test (complement test-not)))
1437 (sequence-dispatch sequence
1438 (list
1439 (let ((list (nthcdr start sequence)))
1440 (cond
1441 ((endp list)
1442 nil)
1443 ((and (not end) (not from-end))
1444 (do ((r nil))
1445 ((endp list) (nreverse r))
1446 (let ((x (pop list)))
1447 (unless (member x list :key key :test test)
1448 (push x r)))))
1449 (t (error "remove-duplicates not implemented.")))))
1450 (vector
1451 (error "vector remove-duplicates not implemented."))))
1452
1453 (defun delete-duplicates (sequence &key from-end (test 'eql) (key 'identity) test-not (start 0) end)
1454 (let ((test (if test-not
1455 (complement test-not)
1456 test)))
1457 (sequence-dispatch sequence
1458 (list
1459 (cond
1460 (from-end
1461 (error "from-end not implemented."))
1462 ((not end)
1463 (when (not (endp sequence))
1464 (when (= 0 start)
1465 ;; delete from head
1466 (do ()
1467 ((not (find (car sequence) (cdr sequence) :test test :key key)))
1468 (setf sequence (cdr sequence))))
1469 (do* ((p (nthcdr start sequence))
1470 (q (cdr p) (cdr p)))
1471 ((endp q) sequence)
1472 (if (find (car q) (cdr q) :test test :key key)
1473 (setf (cdr p) (cdr q))
1474 (setf p (cdr p))))))
1475 (t (error "delete-duplicates end parameter not implemented."))))
1476 (vector
1477 ;;; (unless end
1478 ;;; (setf end (length sequence)))
1479 ;;; (do ((i start (1+ i))
1480 ;;; (c 0))
1481 ;;; ((>= i end)
1482 ;;; (cond
1483 ;;; ((= 0 c) sequence)
1484
1485 (error "vector delete-duplicates not implemented.")))))
1486
1487
1488 (defun search (sequence-1 sequence-2 &key (test 'eql) (key 'identity)
1489 (start1 0) end1 (start2 0) end2 test-not from-end)
1490 (let ((test (if test-not
1491 (complement test-not)
1492 test)))
1493 (declare (dynamic-extent test))
1494 (let ((start1 (check-the index start1))
1495 (start2 (check-the index start2)))
1496 (sequence-dispatch sequence-2
1497 (vector
1498 (let ((end1 (check-the index (or end1 (length sequence-1))))
1499 (end2 (check-the index (or end2 (length sequence-2)))))
1500 (do ((stop (- end2 (- end1 start1 1)))
1501 (i start2 (1+ i)))
1502 ((>= i stop) nil)
1503 (declare (index i))
1504 (let ((mismatch-position (mismatch sequence-1 sequence-2
1505 :start1 start1 :end1 end1
1506 :start2 i :end2 end2
1507 :key key :test test)))
1508 (when (or (not mismatch-position)
1509 (= mismatch-position end1))
1510 (return (or (and from-end
1511 (search sequence-1 sequence-2
1512 :from-end t :test test :key key
1513 :start1 start1 :end1 end1
1514 :start2 (1+ i) :end2 end2))
1515 i)))))))
1516 (list
1517 (let ((end1 (check-the index (or end1 (length sequence-1)))))
1518 (do ((stop (and end2 (- end2 start2 (- end1 start1 1))))
1519 (p (nthcdr start2 sequence-2) (cdr p))
1520 (i 0 (1+ i)))
1521 ((or (endp p) (and stop (>= i stop))) nil)
1522 (declare (index i))
1523 (let ((mismatch-position (mismatch sequence-1 p
1524 :start1 start1 :end1 end1
1525 :key key :test test)))
1526 (when (or (not mismatch-position)
1527 (= mismatch-position end1))
1528 (return (+ start2 i
1529 (or (and from-end
1530 (search sequence-1 p
1531 :start2 1 :end2 (and end2 (- end2 i start2))
1532 :from-end t :test test :key key
1533 :start1 start1 :end1 end1))
1534 0))))))))))))
1535
1536 (defun insertion-sort (vector predicate key start end)
1537 "Insertion-sort is used for stable-sort, and as a finalizer for
1538 quick-sort with cut-off greater than 1."
1539 (let ((start (check-the index start))
1540 (end (check-the index end)))
1541 (with-funcallable (predicate)
1542 (with-subvector-accessor (vector-ref vector start end)
1543 (if (not key)
1544 (do ((i (1+ start) (1+ i)))
1545 ((>= i end))
1546 (declare (index i))
1547 ;; insert vector[i] into [start...i-1]
1548 (let ((v (vector-ref i))
1549 (j (1- i)))
1550 (when (predicate v (vector-ref j))
1551 (setf (vector-ref i) (vector-ref j))
1552 (do* ((j+1 j (1- j+1))
1553 (j (1- j) (1- j)))
1554 ((or (< j start)
1555 (not (predicate v (vector-ref j))))
1556 (setf (vector-ref j+1) v))
1557 (declare (index j j+1))
1558 (setf (vector-ref j+1) (vector-ref j))))))
1559 (with-funcallable (key)
1560 (do ((i (1+ start) (1+ i))) ; the same, only with a key-function..
1561 ((>= i end))
1562 (declare (index i))
1563 ;; insert vector[i] into [start...i-1]
1564 (do* ((v (vector-ref i))
1565 (vk (key v))
1566 (j (1- i) (1- j))
1567 (j+1 i (1- j+1)))
1568 ((or (<= j+1 start)
1569 (not (predicate vk (key (vector-ref j)))))
1570 (setf (vector-ref j+1) v))
1571 (declare (index j j+1))
1572 (setf (vector-ref j+1) (vector-ref j)))))))))
1573 vector)
1574
1575 (defun quick-sort (vector predicate key start end cut-off)
1576 (let ((start (check-the index start))
1577 (end (check-the index end)))
1578 (macrolet ((do-while (p &body body)
1579 `(do () ((not ,p)) ,@body)))
1580 (when (> (- end start) cut-off)
1581 (with-subvector-accessor (vector-ref vector start end)
1582 (with-funcallable (predicate)
1583 (with-funcallable (key)
1584 (prog* ((pivot (vector-ref start)) ; should do median-of-three here..
1585 (keyed-pivot (key pivot))
1586 (left (1+ start))
1587 (right (1- end))
1588 left-item right-item)
1589 (declare (index left right))
1590 ;; do median-of-three..
1591 (let ((p1 (vector-ref start))
1592 (p2 (vector-ref (+ start cut-off -1)))
1593 (p3 (vector-ref (1- end))))
1594 (let ((kp1 (key p1))
1595 (kp2 (key p2))
1596 (kp3 (key p3)))
1597 (cond
1598 ((predicate p1 p2)
1599 (if (predicate p2 p3)
1600 (setf pivot p2 keyed-pivot kp2)
1601 (if (predicate p1 p3)
1602 (setf pivot p3 keyed-pivot kp3)
1603 (setf pivot p1 keyed-pivot kp1))))
1604 ((predicate p2 p3)
1605 (if (predicate p1 p3)
1606 (setf pivot p1 keyed-pivot kp1)
1607 (setf pivot p3 keyed-pivot kp3)))
1608 (t (setf pivot p2 keyed-pivot kp2)))))
1609 partitioning-loop
1610 (do-while (not (predicate keyed-pivot (key (setf left-item (vector-ref left)))))
1611 (incf left)
1612 (when (>= left end)
1613 (setf right-item (vector-ref right))
1614 (go partitioning-complete)))
1615 (do-while (predicate keyed-pivot (key (setf right-item (vector-ref right))))
1616 (decf right))
1617 (when (< left right)
1618 (setf (vector-ref left) right-item
1619 (vector-ref right) left-item)
1620 (incf left)
1621 (decf right)
1622 (go partitioning-loop))
1623 partitioning-complete
1624 (setf (vector-ref start) right-item ; (aref vector right)
1625 (vector-ref right) pivot)
1626 (when (and (> cut-off (- right start))
1627 (> cut-off (- end right)))
1628 (quick-sort vector predicate key start right cut-off)
1629 (quick-sort vector predicate key (1+ right) end cut-off)))))))))
1630 vector)
1631
1632 (defun sort (sequence predicate &key (key 'identity))
1633 (sequence-dispatch sequence
1634 (list
1635 (sort-list sequence predicate key))
1636 (vector
1637 (quick-sort sequence predicate key 0 (length sequence) 9)
1638 (insertion-sort sequence predicate key 0 (length sequence)))))
1639
1640 (defun stable-sort (sequence predicate &key key)
1641 (sequence-dispatch sequence
1642 (list
1643 (error "Stable-sort not implemented for lists."))
1644 (vector
1645 (insertion-sort sequence predicate key 0 (length sequence)))))
1646
1647
1648 (defun merge (result-type sequence-1 sequence-2 predicate &key (key 'identity))
1649 (ecase result-type
1650 (list
1651 (sequence-double-dispatch (sequence-1 sequence-2)
1652 ((list list)
1653 (merge-list-list sequence-1 sequence-2 predicate key))))))
1654
1655 (defun merge-list-list (list1 list2 predicate key)
1656 (cond
1657 ((null list1)
1658 list2)
1659 ((null list2)
1660 list1)
1661 (t (with-funcallable (predicate)
1662 (with-funcallable (key)
1663 (macrolet ((xpop (var)
1664 `(let ((x ,var)) (setf ,var (cdr x)) x)))
1665 (do* ((result (if (predicate (key (car list1)) (key (car list2)))
1666 (xpop list1)
1667 (xpop list2)))
1668 (r result))
1669 ((null (setf r
1670 (setf (cdr r)
1671 (cond
1672 ((null list1) (xpop list2))
1673 ((null list2) (xpop list1))
1674 ((predicate (key (car list1)) (key (car list2)))
1675 (xpop list1))
1676 (t (xpop list2))))))
1677 result))))))))
1678
1679
1680 ;;; Most of list-sorting snipped from cmucl.
1681
1682 ;;; MERGE-LISTS* originally written by Jim Large.
1683 ;;; modified to return a pointer to the end of the result
1684 ;;; and to not cons header each time its called.
1685 ;;; It destructively merges list-1 with list-2. In the resulting
1686 ;;; list, elements of list-2 are guaranteed to come after equal elements
1687 ;;; of list-1.
1688 (defun merge-lists* (list-1 list-2 predicate key merge-lists-header)
1689 (with-funcallable (predicate)
1690 (with-funcallable (key)
1691 (do* ((result merge-lists-header)
1692 (P result)) ; P points to last cell of result
1693 ((or (null list-1) (null list-2)) ; done when either list used up
1694 (if (null list-1) ; in which case, append the
1695 (rplacd p list-2) ; other list
1696 (rplacd p list-1))
1697 (do ((drag p lead)
1698 (lead (cdr p) (cdr lead)))
1699 ((null lead)
1700 (values (prog1 (cdr result) ; return the result sans header
1701 (rplacd result nil)) ; (free memory, be careful)
1702 drag)))) ; and return pointer to last element
1703 (cond ((predicate (key (car list-2)) (key (car list-1)))
1704 (rplacd p list-2) ; append the lesser list to last cell of
1705 (setq p (cdr p)) ; result. Note: test must bo done for
1706 (pop list-2)) ; list-2 < list-1 so merge will be
1707 (t (rplacd p list-1) ; stable for list-1
1708 (setq p (cdr p))
1709 (pop list-1)))))))
1710
1711
1712 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over
1713 ;;; the list grabbing one element at a time and merging it with the next one
1714 ;;; form pairs of sorted elements. Then n is doubled, and elements are taken
1715 ;;; in runs of two, merging one run with the next to form quadruples of sorted
1716 ;;; elements. This continues until n is large enough that the inner loop only
1717 ;;; runs for one iteration; that is, there are only two runs that can be merged,
1718 ;;; the first run starting at the beginning of the list, and the second being
1719 ;;; the remaining elements.
1720
1721 (defun sort-list (list pred key)
1722 (let ((head (cons :header list)) ; head holds on to everything
1723 (n 1) ; bottom-up size of lists to be merged
1724 unsorted ; unsorted is the remaining list to be
1725 ; broken into n size lists and merged
1726 list-1 ; list-1 is one length n list to be merged
1727 last ; last points to the last visited cell
1728 (merge-lists-header (list :header)))
1729 (declare (index n))
1730 (do () (nil)
1731 ;; start collecting runs of n at the first element
1732 (setf unsorted (cdr head))
1733 ;; tack on the first merge of two n-runs to the head holder
1734 (setf last head)
1735 (let ((n-1 (1- n)))
1736 (do () (nil)
1737 (setf list-1 unsorted)
1738 (let ((temp (nthcdr n-1 list-1))
1739 list-2)
1740 (cond (temp
1741 ;; there are enough elements for a second run
1742 (setf list-2 (cdr temp))
1743 (setf (cdr temp) nil)
1744 (setf temp (nthcdr n-1 list-2))
1745 (cond (temp
1746 (setf unsorted (cdr temp))
1747 (setf (cdr temp) nil))
1748 ;; the second run goes off the end of the list
1749 (t (setf unsorted nil)))
1750 (multiple-value-bind (merged-head merged-last)
1751 (merge-lists* list-1 list-2 pred key
1752 merge-lists-header)
1753 (setf (cdr last) merged-head)
1754 (setf last merged-last))
1755 (if (null unsorted) (return)))
1756 ;; if there is only one run, then tack it on to the end
1757 (t (setf (cdr last) list-1)
1758 (return)))))
1759 (setf n (+ n n))
1760 ;; If the inner loop only executed once, then there were only enough
1761 ;; elements for two runs given n, so all the elements have been merged
1762 ;; into one list. This may waste one outer iteration to realize.
1763 (if (eq list-1 (cdr head))
1764 (return list-1))))))
1765
1766 (defun make-sequence (result-type size &key (initial-element nil initial-element-p))
1767 "=> sequence"
1768 (ecase result-type
1769 (string
1770 (if (not initial-element-p)
1771 (make-string size)
1772 (make-string size :initial-element initial-element)))
1773 (vector
1774 (make-array size :initial-element initial-element))
1775 (list
1776 (make-list size :initial-element initial-element))))
1777
1778 (defun concatenate (result-type &rest sequences)
1779 "=> result-sequence"
1780 (declare (dynamic-extent sequences))
1781 (cond
1782 ((null sequences)
1783 (make-sequence result-type 0))
1784 ((and (null (rest sequences))
1785 (typep (first sequences) result-type))
1786 (copy-seq (first sequences)))
1787 ((= 0 (length (first sequences)))
1788 (apply #'concatenate result-type (cdr sequences)))
1789 ((member result-type '(vector string))
1790 (let* ((r (make-sequence result-type
1791 (let ((length 0))
1792 (dolist (s sequences length)
1793 (incf length (length s))))))
1794 (i 0))
1795 (declare (index i))
1796 (dolist (s sequences)
1797 (replace r s :start1 i)
1798 (incf i (length s)))
1799 r))
1800 (t (error "Can't concatenate ~S yet: ~:S" result-type sequences))))
1801
1802
1803 (defun substitute (newitem olditem sequence
1804 &key (test 'eql) test-not (start 0) end count (key 'identity) from-end)
1805 "=> result-sequence"
1806 (when test-not
1807 (setf test (complement test-not)))
1808 (with-funcallable (test (if test-not (complement test-not) test))
1809 (substitute-if newitem (lambda (x) (test olditem x)) sequence
1810 :start start :end end
1811 :count count :key key
1812 :from-end from-end)))
1813
1814 (defun nsubstitute (newitem olditem sequence
1815 &key (test 'eql) test-not (start 0) end count (key 'identity) from-end)
1816 "=> result-sequence"
1817 (when test-not
1818 (setf test (complement test-not)))
1819 (with-funcallable (test (if test-not (complement test-not) test))
1820 (nsubstitute-if newitem (lambda (x) (test olditem x)) sequence
1821 :start start :end end
1822 :count count :key key
1823 :from-end from-end)))
1824
1825 (defun substitute-if (newitem predicate sequence &rest args
1826 &key (start 0) end count (key 'identity) from-end)
1827 "=> result-sequence"
1828 (declare (dynamic-extent args))
1829 (with-funcallable (predicate)
1830 (with-funcallable (key)
1831 (sequence-dispatch sequence
1832 (vector
1833 (apply 'nsubstitute-if newitem predicate (copy-seq sequence) args))
1834 (list
1835 (if from-end
1836 (apply 'nsubstitute-if newitem predicate (copy-list sequence) args)
1837 (if (or (null sequence)
1838 (and end (<= end start)))
1839 nil
1840 (multiple-value-bind (new-list new-tail)
1841 (if (= 0 start)
1842 (let ((new-list (list #0=(let ((x (pop sequence)))
1843 (if (predicate (key x))
1844 newitem
1845 x)))))
1846 (values new-list new-list))
1847 (do* ((new-list (list (pop sequence)))
1848 (new-tail new-list (cdr new-tail))
1849 (i 1 (1+ i)))
1850 ((or (endp sequence) (>= i start))
1851 (values new-list new-tail))
1852 (setf (cdr new-tail) (list (pop sequence)))))
1853 (cond
1854 ((and (not end) (not count))
1855 (do ()
1856 ((endp sequence) new-list)
1857 (setf new-tail
1858 (setf (cdr new-tail) (list #0#)))))
1859 ((and end (not count))
1860 (do ((i (- end start 1) (1- i)))
1861 ((or (endp sequence) (<= i 0))
1862 (setf (cdr new-tail) (copy-list sequence))
1863 new-list)
1864 (setf new-tail
1865 (setf (cdr new-tail) (list #0#)))))
1866 ((and (not end) count)
1867 (do ((c 0))
1868 ((or (endp sequence) (>= c count))
1869 (setf (cdr new-tail) (copy-list sequence))
1870 new-list)
1871 (setf new-tail
1872 (setf (cdr new-tail) #1=(list (let ((x (pop sequence)))
1873 (if (predicate (key x))
1874 (progn (incf c) newitem)
1875 x)))))))
1876 ((and end count)
1877 (do ((i (- end start 1) (1- i))
1878 (c 0))
1879 ((or (endp sequence) (<= i 0) (>= c count))
1880 (setf (cdr new-tail)
1881 (copy-list sequence))
1882 new-list)
1883 (setf new-tail
1884 (setf (cdr new-tail) #1#))))
1885 ((error 'program-error)))))))))))
1886
1887 (defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end)
1888 "=> sequence"
1889 (if (<= count 0)
1890 sequence
1891 (with-funcallable (predicate)
1892 (with-funcallable (key)
1893 (sequence-dispatch sequence
1894 (vector
1895 (let ((end (or end (length sequence))))
1896 (with-subvector-accessor (ref sequence start end)
1897 (cond
1898 ((and (not count) (not from-end))
1899 (do ((i start (1+ i)))
1900 ((>= i end) sequence)
1901 (declare (index i))
1902 (when (predicate (key (ref i)))
1903 (setf (ref i) newitem))))
1904 ((and count (not from-end))
1905 (do ((c 0)
1906 (i start (1+ i)))
1907 ((>= i end) sequence)
1908 (declare (index i c))
1909 (when (predicate (key (ref i)))
1910 (setf (ref i) newitem)
1911 (when (>= (incf c) count)
1912 (return sequence)))))
1913 ((and (not count) from-end)
1914 (do ((i (1- end) (1- i)))
1915 ((< i start) sequence)
1916 (declare (index i))
1917 (when (predicate (key (ref i)))
1918 (setf (ref i) newitem))))
1919 ((and count from-end)
1920 (do ((c 0)
1921 (i (1- end) (1- i)))
1922 ((< i start) sequence)
1923 (declare (index c i))
1924 (when (predicate (key (ref i)))
1925 (setf (ref i) newitem)
1926 (when (>= (incf c) count)
1927 (return sequence)))))
1928 ((error 'program-error))))))
1929 (list
1930 (let ((p (nthcdr start sequence)))
1931 (cond
1932 (from-end
1933 (nreverse (nsubstitute-if newitem predicate (nreverse sequence)
1934 :start (if (not end) 0 (- (length sequence) end))
1935 :end (if (plusp start) nil (- (length sequence) start))
1936 :count count :key key)))
1937 #+ignore ((and from-end count)
1938 (let* ((end (and end (- end start)))
1939 (existing-count (count-if predicate p :key key :end end)))
1940 (do ((i count))
1941 ((>= i existing-count)
1942 (nsubstitute-if newitem predicate p :end end :key key)
1943 sequence)
1944 (declare (index i))
1945 (when (predicate (key (car p)))
1946 (incf i))
1947 (setf p (cdr p)))))
1948 ((and (not end) (not count))
1949 (do ((p p (cdr p)))
1950 ((endp p) sequence)
1951 (when (predicate (key (car p)))
1952 (setf (car p) newitem))))
1953 ((and end (not count))
1954 (do ((i start (1+ i))
1955 (p p (cdr p)))
1956 ((or (endp p) (>= i end)) sequence)
1957 (declare (index i))
1958 (when (predicate (key (car p)))
1959 (setf (car p) newitem))))
1960 ((and (not end) count)
1961 (do ((c 0)
1962 (p p (cdr p)))
1963 ((endp p) sequence)
1964 (declare (index c))
1965 (when (predicate (key (car p)))
1966 (setf (car p) newitem)
1967 (when (>= (incf c) count)
1968 (return sequence)))))
1969 ((and end count)
1970 (do ((c 0)
1971 (i start (1+ i))
1972 (p p (cdr p)))
1973 ((or (endp p) (>= i end)) sequence)
1974 (declare (index c i))
1975 (when (predicate (key (car p)))
1976 (setf (car p) newitem)
1977 (when (>= (incf c) count)
1978 (return sequence)))))
1979 ((error 'program-error))))))))))
1980
1981 (defun nsubstitute-if-not (newitem predicate sequence &rest keyargs)
1982 (declare (dynamic-extent keyargs))
1983 (apply #'nsubstitute-if newitem (complement predicate) sequence keyargs))
git repository of the movitz source code