source: trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp @ 14207

Last change on this file since 14207 was 12928, checked in by astalla, 10 years ago

Fixes in java collections support (iterators) and dosequence (wrong call to parse-body)

File size: 46.0 KB
Line 
1;;;Extensible Sequences for ABCL based on the SBCL API
2
3(in-package :sequence)
4
5(require "CLOS")
6(require "EXTENSIBLE-SEQUENCES-BASE")
7(require "LOOP")
8
9#||
10We specify generic functions length, elt and (setf elt)
11to correspond to the Common Lisp functions with the same
12name. In each case, there are two primary methods with the
13sequence argument specialized on list and on vector, pro-
14viding the standard-defined behaviour for the Common Lisp
15operator, and a third method with the sequence argument
16specialized on sequence, which signals an error of type type-
17error, for compatibility with the standard requirement of
18the sequence argument to be a proper sequence.
19||#
20
21(fmakunbound 'length)
22(defgeneric length (sequence)
23  (:documentation "Extension point for user-defined sequences. Invoked by cl:length."))
24
25(defmethod length ((sequence sequence))
26  (error 'type-error :datum sequence :expected-type 'proper-sequence))
27
28(defmethod length ((sequence vector))
29  (sys::%length sequence))
30
31(defmethod length ((sequence list))
32  (sys::%length sequence))
33
34(defmethod length (sequence)
35  (error 'type-error :datum sequence :expected-type 'sequence))
36
37(defun cl:length (sequence)
38  (seq-dispatch sequence
39    (sys::%length sequence)
40    (sys::%length sequence)
41    (length sequence)))
42
43(defgeneric elt (sequence index))
44
45(defmethod elt ((sequence vector) index)
46  (sys::%elt sequence index))
47
48(defmethod elt ((sequence list) index)
49  (sys::%elt sequence index))
50
51(defmethod elt ((sequence sequence) index)
52  (declare (ignore index))
53  (error 'type-error :datum sequence :expected-type 'proper-sequence))
54
55(defmethod elt (sequence index)
56  (declare (ignore index))
57  (error 'type-error :datum sequence :expected-type 'sequence))
58
59(defun cl:elt (sequence index)
60  (seq-dispatch sequence
61    (sys::%elt sequence index)
62    (sys::%elt sequence index)
63    (elt sequence index)))
64
65(defgeneric (setf elt) (value sequence index))
66
67(defmethod (setf elt) (value (sequence vector) index)
68  (sys::%set-elt sequence index value))
69
70(defmethod (setf elt) (value (sequence list) index)
71  (sys::%set-elt sequence index value))
72
73(defmethod (setf elt) (value (sequence sequence) index)
74  (declare (ignore index value))
75  (error 'type-error :datum sequence :expected-type 'proper-sequence))
76
77(defmethod (setf elt) (value sequence index)
78  (declare (ignore index value))
79  (error 'type-error :datum sequence :expected-type 'sequence))
80
81(defun cl:subseq (sequence start &optional end)
82  "Return a copy of a subsequence of SEQUENCE starting with element number
83   START and continuing to the end of SEQUENCE or the optional END."
84  (seq-dispatch sequence
85    (sys::%subseq sequence start end)
86    (sys::%subseq sequence start end)
87    (sequence:subseq sequence start end)))
88
89(defun cl:reverse (sequence)
90  (seq-dispatch sequence
91    (sys::%reverse sequence)
92    (sys::%reverse sequence)
93    (sequence:reverse sequence)))
94
95(defun cl:nreverse (sequence)
96  (seq-dispatch sequence
97    (sys::%nreverse sequence)
98    (sys::%nreverse sequence)
99    (sequence:nreverse sequence)))
100
101;;;Adapted from SBCL
102(define-condition sequence::protocol-unimplemented (type-error)
103  ())
104
105(defun sequence::protocol-unimplemented (sequence)
106  (error 'sequence::protocol-unimplemented
107         :datum sequence :expected-type '(or list vector)))
108
109(defgeneric sequence:make-sequence-like
110    (sequence length &key initial-element initial-contents)
111  (:method ((s list) length &key
112            (initial-element nil iep) (initial-contents nil icp))
113    (cond
114      ((and icp iep) (error "Can't specify both :initial-element and :initial-contents"))
115      (iep (make-list length :initial-element initial-element))
116      (icp (unless (= (length initial-contents) length)
117             (error "initial-contents is of length ~S but should be of the same length of the input sequence (~S)" (length initial-contents) length))
118           (let ((result (make-list length)))
119             (replace result initial-contents)
120             result))
121      (t (make-list length))))
122  (:method ((s vector) length &key
123            (initial-element nil iep) (initial-contents nil icp))
124    (cond
125      ((and icp iep) (error "Can't specify both :initial-element and :initial-contents"))
126      (iep (make-array length :element-type (array-element-type s)
127                       :initial-element initial-element))
128      (icp (make-array length :element-type (array-element-type s)
129                       :initial-contents initial-contents))
130      (t (make-array length :element-type (array-element-type s)))))
131  (:method ((s sequence) length &key initial-element initial-contents)
132    (declare (ignore initial-element initial-contents))
133    (sequence::protocol-unimplemented s)))
134
135(defgeneric sequence:adjust-sequence
136    (sequence length &key initial-element initial-contents)
137  (:method ((s list) length &key initial-element (initial-contents nil icp))
138    (if (eql length 0)
139        nil
140        (let ((olength (length s)))
141          (cond
142            ((eql length olength) (if icp (replace s initial-contents) s))
143            ((< length olength)
144             (rplacd (nthcdr (1- length) s) nil)
145             (if icp (replace s initial-contents) s))
146            ((null s)
147             (let ((return (make-list length :initial-element initial-element)))
148               (if icp (replace return initial-contents) return)))
149            (t (rplacd (nthcdr (1- olength) s)
150                       (make-list (- length olength)
151                                  :initial-element initial-element))
152               (if icp (replace s initial-contents) s))))))
153  (:method ((s vector) length &rest args &key (initial-contents nil icp) initial-element)
154    (declare (ignore initial-element))
155    (cond
156      ((and (array-has-fill-pointer-p s)
157            (>= (array-total-size s) length))
158       (setf (fill-pointer s) length)
159       (if icp (replace s initial-contents) s))
160      ((eql (length s) length)
161       (if icp (replace s initial-contents) s))
162      (t (apply #'adjust-array s length args))))
163  (:method (new-value (s sequence) &rest args)
164    (declare (ignore args))
165    (sequence::protocol-unimplemented s)))
166
167;;;; iterator protocol
168
169;;; The general protocol
170
171(defgeneric sequence:make-sequence-iterator (sequence &key from-end start end)
172  (:method ((s sequence) &key from-end (start 0) end)
173    (multiple-value-bind (iterator limit from-end)
174        (sequence:make-simple-sequence-iterator
175         s :from-end from-end :start start :end end)
176      (values iterator limit from-end
177              #'sequence:iterator-step #'sequence:iterator-endp
178              #'sequence:iterator-element #'(setf sequence:iterator-element)
179              #'sequence:iterator-index #'sequence:iterator-copy)))
180  (:method ((s t) &key from-end start end)
181    (declare (ignore from-end start end))
182    (error 'type-error
183           :datum s
184           :expected-type 'sequence)))
185
186;;; the simple protocol: the simple iterator returns three values,
187;;; STATE, LIMIT and FROM-END.
188
189;;; magic termination value for list :from-end t
190(defvar *exhausted* (cons nil nil))
191
192(defgeneric sequence:make-simple-sequence-iterator
193    (sequence &key from-end start end)
194  (:method ((s list) &key from-end (start 0) end)
195    (if from-end
196        (let* ((termination (if (= start 0) *exhausted* (nthcdr (1- start) s)))
197               (init (if (<= (or end (length s)) start)
198                         termination
199                         (if end (last s (- (length s) (1- end))) (last s)))))
200          (values init termination t))
201        (cond
202          ((not end) (values (nthcdr start s) nil nil))
203          (t (let ((st (nthcdr start s)))
204               (values st (nthcdr (- end start) st) nil))))))
205  (:method ((s vector) &key from-end (start 0) end)
206    (let ((end (or end (length s))))
207      (if from-end
208          (values (1- end) (1- start) t)
209          (values start end nil))))
210  (:method ((s sequence) &key from-end (start 0) end)
211    (let ((end (or end (length s))))
212      (if from-end
213          (values (1- end) (1- start) from-end)
214          (values start end nil)))))
215
216(defgeneric sequence:iterator-step (sequence iterator from-end)
217  (:method ((s list) iterator from-end)
218    (if from-end
219        (if (eq iterator s)
220            *exhausted*
221            (do* ((xs s (cdr xs)))
222                 ((eq (cdr xs) iterator) xs)))
223        (cdr iterator)))
224  (:method ((s vector) iterator from-end)
225    (if from-end
226        (1- iterator)
227        (1+ iterator)))
228  (:method ((s sequence) iterator from-end)
229    (if from-end
230        (1- iterator)
231        (1+ iterator))))
232
233(defgeneric sequence:iterator-endp (sequence iterator limit from-end)
234  (:method ((s list) iterator limit from-end)
235    (eq iterator limit))
236  (:method ((s vector) iterator limit from-end)
237    (= iterator limit))
238  (:method ((s sequence) iterator limit from-end)
239    (= iterator limit)))
240
241(defgeneric sequence:iterator-element (sequence iterator)
242  (:method ((s list) iterator)
243    (car iterator))
244  (:method ((s vector) iterator)
245    (aref s iterator))
246  (:method ((s sequence) iterator)
247    (elt s iterator)))
248
249(defgeneric (setf sequence:iterator-element) (new-value sequence iterator)
250  (:method (o (s list) iterator)
251    (setf (car iterator) o))
252  (:method (o (s vector) iterator)
253    (setf (aref s iterator) o))
254  (:method (o (s sequence) iterator)
255    (setf (elt s iterator) o)))
256
257(defgeneric sequence:iterator-index (sequence iterator)
258  (:method ((s list) iterator)
259    ;; FIXME: this sucks.  (In my defence, it is the equivalent of the
260    ;; Apple implementation in Dylan...)
261    (loop for l on s for i from 0 when (eq l iterator) return i))
262  (:method ((s vector) iterator) iterator)
263  (:method ((s sequence) iterator) iterator))
264
265(defgeneric sequence:iterator-copy (sequence iterator)
266  (:method ((s list) iterator) iterator)
267  (:method ((s vector) iterator) iterator)
268  (:method ((s sequence) iterator) iterator))
269
270(defmacro sequence:with-sequence-iterator
271    ((&rest vars) (s &rest args &key from-end start end) &body body)
272  (declare (ignore from-end start end))
273  `(multiple-value-bind (,@vars) (sequence:make-sequence-iterator ,s ,@args)
274    (declare (type function ,@(nthcdr 3 vars)))
275    ,@body))
276
277(defmacro sequence:with-sequence-iterator-functions
278    ((step endp elt setf index copy)
279     (s &rest args &key from-end start end)
280     &body body)
281  (declare (ignore from-end start end))
282  (let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
283        (nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
284        (nendp (gensym "ENDP")) (nelt (gensym "ELT"))
285        (nsetf (gensym "SETF")) (nindex (gensym "INDEX"))
286        (ncopy (gensym "COPY")))
287    `(sequence:with-sequence-iterator
288         (,nstate ,nlimit ,nfrom-end ,nstep ,nendp ,nelt ,nsetf ,nindex ,ncopy)
289       (,s ,@args)
290       (flet ((,step () (setq ,nstate (funcall ,nstep ,s ,nstate ,nfrom-end)))
291              (,endp () (funcall ,nendp ,s ,nstate ,nlimit ,nfrom-end))
292              (,elt () (funcall ,nelt ,s ,nstate))
293              (,setf (new-value) (funcall ,nsetf new-value ,s ,nstate))
294              (,index () (funcall ,nindex ,s ,nstate))
295              (,copy () (funcall ,ncopy ,s ,nstate)))
296         (declare (truly-dynamic-extent #',step #',endp #',elt
297                                  #',setf #',index #',copy))
298         ,@body))))
299
300(defun sequence:canonize-test (test test-not)
301  (cond
302    (test (if (functionp test) test (fdefinition test)))
303    (test-not (if (functionp test-not)
304                  (complement test-not)
305                  (complement (fdefinition test-not))))
306    (t #'eql)))
307
308(defun sequence:canonize-key (key)
309  (or (and key (if (functionp key) key (fdefinition key))) #'identity))
310
311;;;; generic implementations for sequence functions.
312
313;;; FIXME: COUNT, POSITION and FIND share an awful lot of structure.
314;;; They could usefully be defined in an OAOO way.
315(defgeneric sequence:count
316    (item sequence &key from-end start end test test-not key)
317  (:argument-precedence-order sequence item))
318(defmethod sequence:count
319    (item (sequence sequence) &key from-end (start 0) end test test-not key)
320  (let ((test (sequence:canonize-test test test-not))
321        (key (sequence:canonize-key key)))
322    (sequence:with-sequence-iterator (state limit from-end step endp elt)
323        (sequence :from-end from-end :start start :end end)
324      (do ((count 0))
325          ((funcall endp sequence state limit from-end) count)
326        (let ((o (funcall elt sequence state)))
327          (when (funcall test item (funcall key o))
328            (incf count))
329          (setq state (funcall step sequence state from-end)))))))
330
331(defgeneric sequence:count-if (pred sequence &key from-end start end key)
332  (:argument-precedence-order sequence pred))
333(defmethod sequence:count-if
334    (pred (sequence sequence) &key from-end (start 0) end key)
335  (let ((key (sequence:canonize-key key)))
336    (sequence:with-sequence-iterator (state limit from-end step endp elt)
337        (sequence :from-end from-end :start start :end end)
338      (do ((count 0))
339          ((funcall endp sequence state limit from-end) count)
340        (let ((o (funcall elt sequence state)))
341          (when (funcall pred (funcall key o))
342            (incf count))
343          (setq state (funcall step sequence state from-end)))))))
344
345(defgeneric sequence:count-if-not (pred sequence &key from-end start end key)
346  (:argument-precedence-order sequence pred))
347(defmethod sequence:count-if-not
348    (pred (sequence sequence) &key from-end (start 0) end key)
349  (let ((key (sequence:canonize-key key)))
350    (sequence:with-sequence-iterator (state limit from-end step endp elt)
351        (sequence :from-end from-end :start start :end end)
352      (do ((count 0))
353          ((funcall endp sequence state limit from-end) count)
354        (let ((o (funcall elt sequence state)))
355          (unless (funcall pred (funcall key o))
356            (incf count))
357          (setq state (funcall step sequence state from-end)))))))
358
359(defgeneric sequence:find
360    (item sequence &key from-end start end test test-not key)
361  (:argument-precedence-order sequence item))
362(defmethod sequence:find
363    (item (sequence sequence) &key from-end (start 0) end test test-not key)
364  (let ((test (sequence:canonize-test test test-not))
365        (key (sequence:canonize-key key)))
366    (sequence:with-sequence-iterator (state limit from-end step endp elt)
367        (sequence :from-end from-end :start start :end end)
368      (do ()
369          ((funcall endp sequence state limit from-end) nil)
370        (let ((o (funcall elt sequence state)))
371          (when (funcall test item (funcall key o))
372            (return o))
373          (setq state (funcall step sequence state from-end)))))))
374
375(defgeneric sequence:find-if (pred sequence &key from-end start end key)
376  (:argument-precedence-order sequence pred))
377(defmethod sequence:find-if
378    (pred (sequence sequence) &key from-end (start 0) end key)
379  (let ((key (sequence:canonize-key key)))
380    (sequence:with-sequence-iterator (state limit from-end step endp elt)
381        (sequence :from-end from-end :start start :end end)
382      (do ()
383          ((funcall endp sequence state limit from-end) nil)
384        (let ((o (funcall elt sequence state)))
385          (when (funcall pred (funcall key o))
386            (return o))
387          (setq state (funcall step sequence state from-end)))))))
388
389(defgeneric sequence:find-if-not (pred sequence &key from-end start end key)
390  (:argument-precedence-order sequence pred))
391(defmethod sequence:find-if-not
392    (pred (sequence sequence) &key from-end (start 0) end key)
393  (let ((key (sequence:canonize-key key)))
394    (sequence:with-sequence-iterator (state limit from-end step endp elt)
395        (sequence :from-end from-end :start start :end end)
396      (do ()
397          ((funcall endp sequence state limit from-end) nil)
398        (let ((o (funcall elt sequence state)))
399          (unless (funcall pred (funcall key o))
400            (return o))
401          (setq state (funcall step sequence state from-end)))))))
402
403(defgeneric sequence:position
404    (item sequence &key from-end start end test test-not key)
405  (:argument-precedence-order sequence item))
406(defmethod sequence:position
407    (item (sequence sequence) &key from-end (start 0) end test test-not key)
408  (let ((test (sequence:canonize-test test test-not))
409        (key (sequence:canonize-key key)))
410    (sequence:with-sequence-iterator (state limit from-end step endp elt)
411        (sequence :from-end from-end :start start :end end)
412      (do ((s (if from-end -1 1))
413           (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
414          ((funcall endp sequence state limit from-end) nil)
415        (let ((o (funcall elt sequence state)))
416          (when (funcall test item (funcall key o))
417            (return pos))
418          (setq state (funcall step sequence state from-end)))))))
419
420(defgeneric sequence:position-if (pred sequence &key from-end start end key)
421  (:argument-precedence-order sequence pred))
422(defmethod sequence:position-if
423    (pred (sequence sequence) &key from-end (start 0) end key)
424  (let ((key (sequence:canonize-key key)))
425    (sequence:with-sequence-iterator (state limit from-end step endp elt)
426        (sequence :from-end from-end :start start :end end)
427      (do ((s (if from-end -1 1))
428           (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
429          ((funcall endp sequence state limit from-end) nil)
430        (let ((o (funcall elt sequence state)))
431          (when (funcall pred (funcall key o))
432            (return pos))
433          (setq state (funcall step sequence state from-end)))))))
434
435(defgeneric sequence:position-if-not
436    (pred sequence &key from-end start end key)
437  (:argument-precedence-order sequence pred))
438(defmethod sequence:position-if-not
439    (pred (sequence sequence) &key from-end (start 0) end key)
440  (let ((key (sequence:canonize-key key)))
441    (sequence:with-sequence-iterator (state limit from-end step endp elt)
442        (sequence :from-end from-end :start start :end end)
443      (do ((s (if from-end -1 1))
444           (pos (if from-end (1- (or end (length sequence))) start) (+ pos s)))
445          ((funcall endp sequence state limit from-end) nil)
446        (let ((o (funcall elt sequence state)))
447          (unless (funcall pred (funcall key o))
448            (return pos))
449          (setq state (funcall step sequence state from-end)))))))
450
451(defgeneric sequence:subseq (sequence start &optional end))
452(defmethod sequence:subseq ((sequence sequence) start &optional end)
453  (let* ((end (or end (length sequence)))
454         (length (- end start))
455         (result (sequence:make-sequence-like sequence length)))
456    (sequence:with-sequence-iterator (state limit from-end step endp elt)
457        (sequence :start start :end end)
458      (declare (ignore limit endp))
459      (sequence:with-sequence-iterator (rstate rlimit rfrom-end rstep rendp relt rsetelt)
460          (result)
461        (declare (ignore rlimit rendp relt))
462        (do ((i 0 (+ i 1)))
463            ((>= i length) result)
464          (funcall rsetelt (funcall elt sequence state) result rstate)
465          (setq state (funcall step sequence state from-end))
466          (setq rstate (funcall rstep result rstate rfrom-end)))))))
467
468(defgeneric sequence:copy-seq (sequence))
469(defmethod sequence:copy-seq ((sequence sequence))
470  (sequence:subseq sequence 0))
471
472(fmakunbound 'sequence:fill)
473(defgeneric sequence:fill (sequence item &key start end))
474(defmethod sequence:fill ((sequence sequence) item &key (start 0) end)
475  (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
476      (sequence :start start :end end)
477    (declare (ignore elt))
478    (do ()
479        ((funcall endp sequence state limit from-end) sequence)
480      (funcall setelt item sequence state)
481      (setq state (funcall step sequence state from-end)))))
482
483(defgeneric sequence:nsubstitute
484    (new old sequence &key start end from-end test test-not count key)
485  (:argument-precedence-order sequence new old))
486(defmethod sequence:nsubstitute (new old (sequence sequence) &key (start 0)
487                                 end from-end test test-not count key)
488  (let ((test (sequence:canonize-test test test-not))
489        (key (sequence:canonize-key key)))
490    (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
491        (sequence :start start :end end :from-end from-end)
492      (do ((c 0))
493          ((or (and count (>= c count))
494               (funcall endp sequence state limit from-end))
495           sequence)
496        (when (funcall test old (funcall key (funcall elt sequence state)))
497          (incf c)
498          (funcall setelt new sequence state))
499        (setq state (funcall step sequence state from-end))))))
500
501(defgeneric sequence:nsubstitute-if
502    (new predicate sequence &key start end from-end count key)
503  (:argument-precedence-order sequence new predicate))
504(defmethod sequence:nsubstitute-if
505    (new predicate (sequence sequence) &key (start 0) end from-end count key)
506  (let ((key (sequence:canonize-key key)))
507    (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
508        (sequence :start start :end end :from-end from-end)
509      (do ((c 0))
510          ((or (and count (>= c count))
511               (funcall endp sequence state limit from-end))
512           sequence)
513        (when (funcall predicate (funcall key (funcall elt sequence state)))
514          (incf c)
515          (funcall setelt new sequence state))
516        (setq state (funcall step sequence state from-end))))))
517
518(defgeneric sequence:nsubstitute-if-not
519    (new predicate sequence &key start end from-end count key)
520  (:argument-precedence-order sequence new predicate))
521(defmethod sequence:nsubstitute-if-not
522    (new predicate (sequence sequence) &key (start 0) end from-end count key)
523  (let ((key (sequence:canonize-key key)))
524    (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
525        (sequence :start start :end end :from-end from-end)
526      (do ((c 0))
527          ((or (and count (>= c count))
528               (funcall endp sequence state limit from-end))
529           sequence)
530        (unless (funcall predicate (funcall key (funcall elt sequence state)))
531          (incf c)
532          (funcall setelt new sequence state))
533        (setq state (funcall step sequence state from-end))))))
534
535(defgeneric sequence:substitute
536    (new old sequence &key start end from-end test test-not count key)
537  (:argument-precedence-order sequence new old))
538(defmethod sequence:substitute (new old (sequence sequence) &rest args &key
539                                (start 0) end from-end test test-not count key)
540  (declare (truly-dynamic-extent args))
541  (declare (ignore start end from-end test test-not count key))
542  (let ((result (copy-seq sequence)))
543    (apply #'sequence:nsubstitute new old result args)))
544
545(defgeneric sequence:substitute-if
546    (new predicate sequence &key start end from-end count key)
547  (:argument-precedence-order sequence new predicate))
548(defmethod sequence:substitute-if (new predicate (sequence sequence) &rest args
549                                   &key (start 0) end from-end count key)
550  (declare (truly-dynamic-extent args))
551  (declare (ignore start end from-end count key))
552  (let ((result (copy-seq sequence)))
553    (apply #'sequence:nsubstitute-if new predicate result args)))
554
555(defgeneric sequence:substitute-if-not
556    (new predicate sequence &key start end from-end count key)
557  (:argument-precedence-order sequence new predicate))
558(defmethod sequence:substitute-if-not
559    (new predicate (sequence sequence) &rest args &key
560     (start 0) end from-end count key)
561  (declare (truly-dynamic-extent args))
562  (declare (ignore start end from-end count key))
563  (let ((result (copy-seq sequence)))
564    (apply #'sequence:nsubstitute-if-not new predicate result args)))
565
566(defun %sequence-replace (sequence1 sequence2 start1 end1 start2 end2)
567  (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
568      (sequence1 :start start1 :end end1)
569    (declare (ignore elt1))
570    (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
571        (sequence2 :start start2 :end end2)
572      (do ()
573          ((or (funcall endp1 sequence1 state1 limit1 from-end1)
574               (funcall endp2 sequence2 state2 limit2 from-end2))
575           sequence1)
576        (funcall setelt1 (funcall elt2 sequence2 state2) sequence1 state1)
577        (setq state1 (funcall step1 sequence1 state1 from-end1))
578        (setq state2 (funcall step2 sequence2 state2 from-end2))))))
579
580(defgeneric sequence:replace
581    (sequence1 sequence2 &key start1 end1 start2 end2)
582  (:argument-precedence-order sequence2 sequence1))
583(defmethod sequence:replace
584    ((sequence1 sequence) (sequence2 sequence) &key
585     (start1 0) end1 (start2 0) end2)
586  (print sequence1)
587  (print sequence2)
588  (cond
589    ((eq sequence1 sequence2)
590     (let ((replaces (subseq sequence2 start2 end2)))
591       (%sequence-replace sequence1 replaces start1 end1 0 nil)))
592    (t (%sequence-replace sequence1 sequence2 start1 end1 start2 end2))))
593
594(defgeneric sequence:nreverse (sequence))
595(defmethod sequence:nreverse ((sequence sequence))
596  ;; FIXME: this, in particular the :from-end iterator, will suck
597  ;; mightily if the user defines a list-like structure.
598  (let ((length (length sequence)))
599    (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
600        (sequence :end (floor length 2))
601      (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2 setelt2)
602          (sequence :start (ceiling length 2) :from-end t)
603        (declare (ignore limit2 endp2))
604        (do ()
605            ((funcall endp1 sequence state1 limit1 from-end1) sequence)
606          (let ((x (funcall elt1 sequence state1))
607                (y (funcall elt2 sequence state2)))
608            (funcall setelt1 y sequence state1)
609            (funcall setelt2 x sequence state2))
610          (setq state1 (funcall step1 sequence state1 from-end1))
611          (setq state2 (funcall step2 sequence state2 from-end2)))))))
612
613(defgeneric sequence:reverse (sequence))
614(defmethod sequence:reverse ((sequence sequence))
615  (let ((result (copy-seq sequence)))
616    (sequence:nreverse result)))
617
618(defgeneric sequence:reduce
619    (function sequence &key from-end start end initial-value)
620  (:argument-precedence-order sequence function))
621(defmethod sequence:reduce
622    (function (sequence sequence) &key from-end (start 0) end key
623     (initial-value nil ivp))
624  (let ((key (sequence:canonize-key key)))
625    (sequence:with-sequence-iterator (state limit from-end step endp elt)
626        (sequence :start start :end end :from-end from-end)
627      (if (funcall endp sequence state limit from-end)
628          (if ivp initial-value (funcall function))
629          (do* ((state state (funcall step sequence state from-end))
630                (value (cond
631                         (ivp initial-value)
632                         (t (prog1
633                                (funcall key (funcall elt sequence state))
634                              (setq state (funcall step sequence state from-end)))))))
635               ((funcall endp sequence state limit from-end) value)
636            (let ((e (funcall key (funcall elt sequence state))))
637              (if from-end
638                  (setq value (funcall function e value))
639                  (setq value (funcall function value e)))))))))
640
641(defgeneric sequence:mismatch (sequence1 sequence2 &key from-end start1 end1
642                               start2 end2 test test-not key))
643(defmethod sequence:mismatch
644    ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
645     (start2 0) end2 test test-not key)
646  (let ((test (sequence:canonize-test test test-not))
647        (key (sequence:canonize-key key)))
648    (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
649        (sequence1 :start start1 :end end1 :from-end from-end)
650      (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
651          (sequence2 :start start2 :end end2 :from-end from-end)
652        (if from-end
653            (do ((result (or end1 (length sequence1)) (1- result))
654                 (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
655                     (funcall endp1 sequence1 state1 limit1 from-end1))
656                 (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
657                     (funcall endp2 sequence2 state2 limit2 from-end2)))
658                ((or e1 e2) (if (and e1 e2) nil result))
659              (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
660                    (o2 (funcall key (funcall elt2 sequence2 state2))))
661                (unless (funcall test o1 o2)
662                  (return result))
663                (setq state1 (funcall step1 sequence1 state1 from-end1))
664                (setq state2 (funcall step2 sequence2 state2 from-end2))))
665            (do ((result start1 (1+ result))
666                 (e1 (funcall endp1 sequence1 state1 limit1 from-end1)
667                     (funcall endp1 sequence1 state1 limit1 from-end1))
668                 (e2 (funcall endp2 sequence2 state2 limit2 from-end2)
669                     (funcall endp2 sequence2 state2 limit2 from-end2)))
670                ((or e1 e2) (if (and e1 e2) nil result))
671              (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
672                    (o2 (funcall key (funcall elt2 sequence2 state2))))
673                (unless (funcall test o1 o2)
674                  (return result)))
675              (setq state1 (funcall step1 sequence1 state1 from-end1))
676              (setq state2 (funcall step2 sequence2 state2 from-end2))))))))
677
678(defgeneric sequence:search (sequence1 sequence2 &key from-end start1 end1
679                             start2 end2 test test-not key))
680(defmethod sequence:search
681    ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
682     (start2 0) end2 test test-not key)
683  (let ((test (sequence:canonize-test test test-not))
684        (key (sequence:canonize-key key))
685        (mainend2 (- (or end2 (length sequence2))
686                     (- (or end1 (length sequence1)) start1))))
687    (when (< mainend2 0)
688      (return-from sequence:search nil))
689    (sequence:with-sequence-iterator (statem limitm from-endm stepm endpm)
690        (sequence2 :start start2 :end mainend2 :from-end from-end)
691      (do ((s2 (if from-end mainend2 0) (if from-end (1- s2) (1+ s2))))
692          (nil)
693        (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
694            (sequence1 :start start1 :end end1)
695          (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
696              (sequence2 :start s2)
697            (declare (ignore limit2 endp2))
698            (when (do ()
699                      ((funcall endp1 sequence1 state1 limit1 from-end1) t)
700                    (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
701                          (o2 (funcall key (funcall elt2 sequence2 state2))))
702                      (unless (funcall test o1 o2)
703                        (return nil)))
704                    (setq state1 (funcall step1 sequence1 state1 from-end1))
705                    (setq state2 (funcall step2 sequence2 state2 from-end2)))
706              (return-from sequence:search s2))))
707        (when (funcall endpm sequence2 statem limitm from-endm)
708          (return nil))
709        (setq statem (funcall stepm sequence2 statem from-endm))))))
710
711(defgeneric sequence:delete
712    (item sequence &key from-end test test-not start end count key)
713  (:argument-precedence-order sequence item))
714(defmethod sequence:delete (item (sequence sequence) &key
715                            from-end test test-not (start 0) end count key)
716  (let ((test (sequence:canonize-test test test-not))
717        (key (sequence:canonize-key key))
718        (c 0))
719    (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
720        (sequence :start start :end end :from-end from-end)
721      (declare (ignore limit1 endp1 elt1))
722      (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
723          (sequence :start start :end end :from-end from-end)
724        (flet ((finish ()
725                 (if from-end
726                     (replace sequence sequence
727                              :start1 start :end1 (- (length sequence) c)
728                              :start2 (+ start c) :end2 (length sequence))
729                     (unless (or (null end) (= end (length sequence)))
730                       (replace sequence sequence :start2 end :start1 (- end c)
731                                :end1 (- (length sequence) c))))
732                 (sequence:adjust-sequence sequence (- (length sequence) c))))
733          (declare (truly-dynamic-extent #'finish))
734          (do ()
735              ((funcall endp2 sequence state2 limit2 from-end2) (finish))
736            (let ((e (funcall elt2 sequence state2)))
737              (loop
738               (when (and count (>= c count))
739                 (return))
740               (if (funcall test item (funcall key e))
741                   (progn
742                     (incf c)
743                     (setq state2 (funcall step2 sequence state2 from-end2))
744                     (when (funcall endp2 sequence state2 limit2 from-end2)
745                       (return-from sequence:delete (finish)))
746                     (setq e (funcall elt2 sequence state2)))
747                   (return)))
748              (funcall setelt1 e sequence state1))
749            (setq state1 (funcall step1 sequence state1 from-end1))
750            (setq state2 (funcall step2 sequence state2 from-end2))))))))
751
752(defgeneric sequence:delete-if
753    (predicate sequence &key from-end start end count key)
754  (:argument-precedence-order sequence predicate))
755(defmethod sequence:delete-if (predicate (sequence sequence) &key
756                               from-end (start 0) end count key)
757  (let ((key (sequence:canonize-key key))
758        (c 0))
759    (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
760        (sequence :start start :end end :from-end from-end)
761      (declare (ignore limit1 endp1 elt1))
762      (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
763          (sequence :start start :end end :from-end from-end)
764        (flet ((finish ()
765                 (if from-end
766                     (replace sequence sequence
767                              :start1 start :end1 (- (length sequence) c)
768                              :start2 (+ start c) :end2 (length sequence))
769                     (unless (or (null end) (= end (length sequence)))
770                       (replace sequence sequence :start2 end :start1 (- end c)
771                                :end1 (- (length sequence) c))))
772                 (sequence:adjust-sequence sequence (- (length sequence) c))))
773          (declare (truly-dynamic-extent #'finish))
774          (do ()
775              ((funcall endp2 sequence state2 limit2 from-end2) (finish))
776            (let ((e (funcall elt2 sequence state2)))
777              (loop
778               (when (and count (>= c count))
779                 (return))
780               (if (funcall predicate (funcall key e))
781                   (progn
782                     (incf c)
783                     (setq state2 (funcall step2 sequence state2 from-end2))
784                     (when (funcall endp2 sequence state2 limit2 from-end2)
785                       (return-from sequence:delete-if (finish)))
786                     (setq e (funcall elt2 sequence state2)))
787                   (return)))
788              (funcall setelt1 e sequence state1))
789            (setq state1 (funcall step1 sequence state1 from-end1))
790            (setq state2 (funcall step2 sequence state2 from-end2))))))))
791
792(defgeneric sequence:delete-if-not
793    (predicate sequence &key from-end start end count key)
794  (:argument-precedence-order sequence predicate))
795(defmethod sequence:delete-if-not (predicate (sequence sequence) &key
796                                   from-end (start 0) end count key)
797  (let ((key (sequence:canonize-key key))
798        (c 0))
799    (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
800        (sequence :start start :end end :from-end from-end)
801      (declare (ignore limit1 endp1 elt1))
802      (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
803          (sequence :start start :end end :from-end from-end)
804        (flet ((finish ()
805                 (if from-end
806                     (replace sequence sequence
807                              :start1 start :end1 (- (length sequence) c)
808                              :start2 (+ start c) :end2 (length sequence))
809                     (unless (or (null end) (= end (length sequence)))
810                       (replace sequence sequence :start2 end :start1 (- end c)
811                                :end1 (- (length sequence) c))))
812                 (sequence:adjust-sequence sequence (- (length sequence) c))))
813          (declare (truly-dynamic-extent #'finish))
814          (do ()
815              ((funcall endp2 sequence state2 limit2 from-end2) (finish))
816            (let ((e (funcall elt2 sequence state2)))
817              (loop
818               (when (and count (>= c count))
819                 (return))
820               (if (funcall predicate (funcall key e))
821                   (return)
822                   (progn
823                     (incf c)
824                     (setq state2 (funcall step2 sequence state2 from-end2))
825                     (when (funcall endp2 sequence state2 limit2 from-end2)
826                       (return-from sequence:delete-if-not (finish)))
827                     (setq e (funcall elt2 sequence state2)))))
828              (funcall setelt1 e sequence state1))
829            (setq state1 (funcall step1 sequence state1 from-end1))
830            (setq state2 (funcall step2 sequence state2 from-end2))))))))
831
832(defgeneric sequence:remove
833    (item sequence &key from-end test test-not start end count key)
834  (:argument-precedence-order sequence item))
835(defmethod sequence:remove (item (sequence sequence) &rest args &key
836                            from-end test test-not (start 0) end count key)
837  (declare (dynamic-extent args))
838  (declare (ignore from-end test test-not start end count key))
839  (let ((result (copy-seq sequence)))
840    (apply #'sequence:delete item result args)))
841
842(defgeneric sequence:remove-if
843    (predicate sequence &key from-end start end count key)
844  (:argument-precedence-order sequence predicate))
845(defmethod sequence:remove-if (predicate (sequence sequence) &rest args &key
846                               from-end (start 0) end count key)
847  (declare (truly-dynamic-extent args))
848  (declare (ignore from-end start end count key))
849  (let ((result (copy-seq sequence)))
850    (apply #'sequence:delete-if predicate result args)))
851
852(defgeneric sequence:remove-if-not
853    (predicate sequence &key from-end start end count key)
854  (:argument-precedence-order sequence predicate))
855(defmethod sequence:remove-if-not (predicate (sequence sequence) &rest args
856                                   &key from-end (start 0) end count key)
857  (declare (truly-dynamic-extent args))
858  (declare (ignore from-end start end count key))
859  (let ((result (copy-seq sequence)))
860    (apply #'sequence:delete-if-not predicate result args)))
861
862(defgeneric sequence:delete-duplicates
863    (sequence &key from-end test test-not start end key))
864(defmethod sequence:delete-duplicates
865    ((sequence sequence) &key from-end test test-not (start 0) end key)
866  (let ((test (sequence:canonize-test test test-not))
867        (key (sequence:canonize-key key))
868        (c 0))
869    (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
870        (sequence :start start :end end :from-end from-end)
871      (declare (ignore limit1 endp1 elt1))
872      (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
873          (sequence :start start :end end :from-end from-end)
874        (flet ((finish ()
875                 (if from-end
876                     (replace sequence sequence
877                              :start1 start :end1 (- (length sequence) c)
878                              :start2 (+ start c) :end2 (length sequence))
879                     (unless (or (null end) (= end (length sequence)))
880                       (replace sequence sequence :start2 end :start1 (- end c)
881                                :end1 (- (length sequence) c))))
882                 (sequence:adjust-sequence sequence (- (length sequence) c))))
883          (declare (truly-dynamic-extent #'finish))
884          (do ((end (or end (length sequence)))
885               (step 0 (1+ step)))
886              ((funcall endp2 sequence state2 limit2 from-end2) (finish))
887            (let ((e (funcall elt2 sequence state2)))
888              (loop
889               ;; FIXME: replace with POSITION once position is
890               ;; working
891               (if (> (count (funcall key e) sequence :test test :key key
892                             :start (if from-end start (+ start step 1))
893                             :end (if from-end (- end step 1) end))
894                      0)
895                   (progn
896                     (incf c)
897                     (incf step)
898                     (setq state2 (funcall step2 sequence state2 from-end2))
899                     (when (funcall endp2 sequence state2 limit2 from-end2)
900                       (return-from sequence:delete-duplicates (finish)))
901                     (setq e (funcall elt2 sequence state2)))
902                   (progn
903                     (return))))
904              (funcall setelt1 e sequence state1))
905            (setq state1 (funcall step1 sequence state1 from-end1))
906            (setq state2 (funcall step2 sequence state2 from-end2))))))))
907
908(defgeneric sequence:remove-duplicates
909    (sequence &key from-end test test-not start end key))
910(defmethod sequence:remove-duplicates
911    ((sequence sequence) &rest args &key from-end test test-not (start 0) end key)
912  (declare (truly-dynamic-extent args))
913  (declare (ignore from-end test test-not start end key))
914  (let ((result (copy-seq sequence)))
915    (apply #'sequence:delete-duplicates result args)))
916
917(defgeneric sequence:sort (sequence predicate &key key))
918(defmethod sequence:sort ((sequence sequence) predicate &rest args &key key)
919  (declare (dynamic-extent args))
920  (declare (ignore key))
921  (let* ((length (length sequence))
922         (vector (make-array length)))
923    (sequence:with-sequence-iterator (state limit from-end step endp elt)
924        (sequence)
925      (declare (ignore limit endp))
926      (do ((i 0 (1+ i)))
927          ((>= i length))
928        (setf (aref vector i) (funcall elt sequence state))
929        (setq state (funcall step sequence state from-end))))
930    (apply #'cl:sort vector predicate args)
931    (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
932        (sequence)
933      (declare (ignore limit endp elt))
934      (do ((i 0 (1+ i)))
935          ((>= i length) sequence)
936        (funcall setelt (aref vector i) sequence state)
937        (setq state (funcall step sequence state from-end))))))
938
939(defgeneric sequence:stable-sort (sequence predicate &key key))
940(defmethod sequence:stable-sort
941    ((sequence sequence) predicate &rest args &key key)
942  (declare (dynamic-extent args))
943  (declare (ignore key))
944  (let* ((length (length sequence))
945         (vector (make-array length)))
946    (sequence:with-sequence-iterator (state limit from-end step endp elt)
947        (sequence)
948      (declare (ignore limit  endp))
949      (do ((i 0 (1+ i)))
950          ((>= i length))
951        (setf (aref vector i) (funcall elt sequence state))
952        (setq state (funcall step sequence state from-end))))
953    (apply #'cl:stable-sort vector predicate args)
954    (sequence:with-sequence-iterator (state limit from-end step endp elt setelt)
955        (sequence)
956      (declare (ignore limit endp elt))
957      (do ((i 0 (1+ i)))
958          ((>= i length) sequence)
959        (funcall setelt (aref vector i) sequence state)
960        (setq state (funcall step sequence state from-end))))))
961
962;;LOOP extension
963(defun loop-elements-iteration-path (variable data-type prep-phrases)
964  (let (of-phrase)
965    (loop for (prep . rest) in prep-phrases do
966          (ecase prep
967            ((:of :in) (if of-phrase
968                           (loop::loop-error "Too many prepositions")
969                           (setq of-phrase rest)))))
970    (destructuring-bind (it lim f-e step endp elt seq)
971        (loop repeat 7 collect (gensym))
972      (push `(let ((,seq ,(car of-phrase)))) loop::*loop-wrappers*)
973      (push `(sequence:with-sequence-iterator (,it ,lim ,f-e ,step ,endp ,elt) (,seq))
974            loop::*loop-wrappers*)
975    `(((,variable nil ,data-type)) () () nil (funcall ,endp ,seq ,it ,lim ,f-e)
976      (,variable (funcall ,elt ,seq ,it) ,it (funcall ,step ,seq ,it ,f-e))))))
977
978(loop::add-loop-path
979 '(element elements) 'loop-elements-iteration-path loop::*loop-ansi-universe*
980 :preposition-groups '((:of :in)) :inclusive-permitted nil)
981
982;;;DOSEQUENCE
983
984;;From SBCL
985(eval-when (:compile-toplevel :load-toplevel :execute)
986  (defun filter-dolist-declarations (decls)
987    (mapcar (lambda (decl)
988        `(declare ,@(remove-if
989         (lambda (clause)
990           (and (consp clause)
991          (or (eq (car clause) 'type)
992              (eq (car clause) 'ignore))))
993         (cdr decl))))
994      decls)))
995
996;; just like DOLIST, but with one-dimensional arrays
997(defmacro dovector ((elt vector &optional result) &body body)
998  (multiple-value-bind (forms decls)
999      (sys:parse-body body nil)
1000    (let ((index (gensym "INDEX")) (length (gensym "LENGTH")) (vec (gensym "VEC")))
1001      `(let ((,vec ,vector))
1002        (declare (type vector ,vec))
1003        (do ((,index 0 (1+ ,index))
1004             (,length (length ,vec)))
1005            ((>= ,index ,length) (let ((,elt nil))
1006                                   ,@(filter-dolist-declarations decls)
1007                                   ,elt
1008                                   ,result))
1009          (let ((,elt (aref ,vec ,index)))
1010            ,@decls
1011            (tagbody
1012               ,@forms)))))))
1013
1014(defmacro sequence:dosequence ((e sequence &optional return &rest args &key
1015          from-end start end) &body body)
1016  (declare (ignore from-end start end))
1017  (multiple-value-bind (forms decls)
1018      (sys:parse-body body nil)
1019    (let ((s sequence)
1020          (sequence (gensym "SEQUENCE")))
1021      `(block nil
1022        (let ((,sequence ,s))
1023          (seq-dispatch ,sequence
1024            (dolist (,e ,sequence ,return) ,@body)
1025            (dovector (,e ,sequence ,return) ,@body)
1026            (multiple-value-bind (state limit from-end step endp elt)
1027                (sequence:make-sequence-iterator ,sequence ,@args)
1028              (do ((state state (funcall step ,sequence state from-end)))
1029                  ((funcall endp ,sequence state limit from-end)
1030                   (let ((,e nil))
1031                     ,@(filter-dolist-declarations decls)
1032                     ,e
1033                     ,return))
1034                (let ((,e (funcall elt ,sequence state)))
1035                  ,@decls
1036                  (tagbody
1037                     ,@forms))))))))))
1038
1039(provide "EXTENSIBLE-SEQUENCES")
Note: See TracBrowser for help on using the repository browser.