Lines Matching +defs:cl +defs:key
0 ;;; cl-seq.el --- Common Lisp features, part 3 -*-byte-compile-dynamic: t;-*-
34 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
43 ;; See cl.el for Change Log.
48 (or (memq 'cl-19 features)
49 (error "Tried to load `cl-seq' before `cl'!"))
53 ;;; this file independent from cl-macs.
55 (defmacro cl-parsing-keywords (kwords other-keys &rest body)
63 'cl-keys)))))
65 (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
67 (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
69 (format "cl-%s" (substring (symbol-name var) 1)))
75 (list 'let '((cl-keys-temp cl-keys))
76 (list 'while 'cl-keys-temp
77 (list 'or (list 'memq '(car cl-keys-temp)
87 cl-keys)))
89 (car cl-keys-temp)))
90 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
92 (put 'cl-parsing-keywords 'lisp-indent-function 2)
93 (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
95 (defmacro cl-check-key (x)
96 (list 'if 'cl-key (list 'funcall 'cl-key x) x))
98 (defmacro cl-check-test-nokey (item x)
100 (list 'cl-test
101 (list 'eq (list 'not (list 'funcall 'cl-test item x))
102 'cl-test-not))
103 (list 'cl-if
104 (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
108 (defmacro cl-check-test (item x)
109 (list 'cl-check-test-nokey item (list 'cl-check-key x)))
111 (defmacro cl-check-match (x y)
112 (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
113 (list 'if 'cl-test
114 (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
118 (put 'cl-check-key 'edebug-form-spec 'edebug-forms)
119 (put 'cl-check-test 'edebug-form-spec 'edebug-forms)
120 (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
121 (put 'cl-check-match 'edebug-form-spec 'edebug-forms)
123 (defvar cl-test) (defvar cl-test-not)
124 (defvar cl-if) (defvar cl-if-not)
125 (defvar cl-key)
128 (defun reduce (cl-func cl-seq &rest cl-keys)
130 \nKeywords supported: :start :end :from-end :initial-value :key
132 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
133 (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
134 (setq cl-seq (subseq cl-seq cl-start cl-end))
135 (if cl-from-end (setq cl-seq (nreverse cl-seq)))
136 (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value)
137 (cl-seq (cl-check-key (pop cl-seq)))
138 (t (funcall cl-func)))))
139 (if cl-from-end
140 (while cl-seq
141 (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq))
142 cl-accum)))
143 (while cl-seq
144 (setq cl-accum (funcall cl-func cl-accum
145 (cl-check-key (pop cl-seq))))))
146 cl-accum)))
148 (defun fill (seq item &rest cl-keys)
152 (cl-parsing-keywords ((:start 0) :end) ()
154 (let ((p (nthcdr cl-start seq))
155 (n (if cl-end (- cl-end cl-start) 8000000)))
159 (or cl-end (setq cl-end (length seq)))
160 (if (and (= cl-start 0) (= cl-end (length seq)))
162 (while (< cl-start cl-end)
163 (aset seq cl-start item)
164 (setq cl-start (1+ cl-start)))))
167 (defun replace (cl-seq1 cl-seq2 &rest cl-keys)
172 (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
173 (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
174 (or (= cl-start1 cl-start2)
175 (let* ((cl-len (length cl-seq1))
176 (cl-n (min (- (or cl-end1 cl-len) cl-start1)
177 (- (or cl-end2 cl-len) cl-start2))))
178 (while (>= (setq cl-n (1- cl-n)) 0)
179 (cl-set-elt cl-seq1 (+ cl-start1 cl-n)
180 (elt cl-seq2 (+ cl-start2 cl-n))))))
181 (if (listp cl-seq1)
182 (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
183 (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000)))
184 (if (listp cl-seq2)
185 (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
186 (cl-n (min cl-n1
187 (if cl-end2 (- cl-end2 cl-start2) 4000000))))
188 (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0))
189 (setcar cl-p1 (car cl-p2))
190 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
191 (setq cl-end2 (min (or cl-end2 (length cl-seq2))
192 (+ cl-start2 cl-n1)))
193 (while (and cl-p1 (< cl-start2 cl-end2))
194 (setcar cl-p1 (aref cl-seq2 cl-start2))
195 (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
196 (setq cl-end1 (min (or cl-end1 (length cl-seq1))
197 (+ cl-start1 (- (or cl-end2 (length cl-seq2))
198 cl-start2))))
199 (if (listp cl-seq2)
200 (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
201 (while (< cl-start1 cl-end1)
202 (aset cl-seq1 cl-start1 (car cl-p2))
203 (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
204 (while (< cl-start1 cl-end1)
205 (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
206 (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
207 cl-seq1))
209 (defun remove* (cl-item cl-seq &rest cl-keys)
213 \nKeywords supported: :test :test-not :key :count :start :end :from-end
215 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
217 (if (<= (or cl-count (setq cl-count 8000000)) 0)
218 cl-seq
219 (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
220 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
221 cl-from-end)))
222 (if cl-i
223 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
224 (append (if cl-from-end
225 (list :end (1+ cl-i))
226 (list :start cl-i))
227 cl-keys))))
228 (if (listp cl-seq) cl-res
229 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))
230 cl-seq))
231 (setq cl-end (- (or cl-end 8000000) cl-start))
232 (if (= cl-start 0)
233 (while (and cl-seq (> cl-end 0)
234 (cl-check-test cl-item (car cl-seq))
235 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
236 (> (setq cl-count (1- cl-count)) 0))))
237 (if (and (> cl-count 0) (> cl-end 0))
238 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
239 (setq cl-end (1- cl-end)) (cdr cl-seq))))
240 (while (and cl-p (> cl-end 0)
241 (not (cl-check-test cl-item (car cl-p))))
242 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
243 (if (and cl-p (> cl-end 0))
244 (nconc (ldiff cl-seq cl-p)
245 (if (= cl-count 1) (cdr cl-p)
246 (and (cdr cl-p)
247 (apply 'delete* cl-item
248 (copy-sequence (cdr cl-p))
249 :start 0 :end (1- cl-end)
250 :count (1- cl-count) cl-keys))))
251 cl-seq))
252 cl-seq)))))
254 (defun remove-if (cl-pred cl-list &rest cl-keys)
258 \nKeywords supported: :key :count :start :end :from-end
260 (apply 'remove* nil cl-list :if cl-pred cl-keys))
262 (defun remove-if-not (cl-pred cl-list &rest cl-keys)
266 \nKeywords supported: :key :count :start :end :from-end
268 (apply 'remove* nil cl-list :if-not cl-pred cl-keys))
270 (defun delete* (cl-item cl-seq &rest cl-keys)
273 \nKeywords supported: :test :test-not :key :count :start :end :from-end
275 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
277 (if (<= (or cl-count (setq cl-count 8000000)) 0)
278 cl-seq
279 (if (listp cl-seq)
280 (if (and cl-from-end (< cl-count 4000000))
281 (let (cl-i)
282 (while (and (>= (setq cl-count (1- cl-count)) 0)
283 (setq cl-i (cl-position cl-item cl-seq cl-start
284 cl-end cl-from-end)))
285 (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
286 (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
287 (setcdr cl-tail (cdr (cdr cl-tail)))))
288 (setq cl-end cl-i))
289 cl-seq)
290 (setq cl-end (- (or cl-end 8000000) cl-start))
291 (if (= cl-start 0)
293 (while (and cl-seq
294 (> cl-end 0)
295 (cl-check-test cl-item (car cl-seq))
296 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
297 (> (setq cl-count (1- cl-count)) 0)))
298 (setq cl-end (1- cl-end)))
299 (setq cl-start (1- cl-start)))
300 (if (and (> cl-count 0) (> cl-end 0))
301 (let ((cl-p (nthcdr cl-start cl-seq)))
302 (while (and (cdr cl-p) (> cl-end 0))
303 (if (cl-check-test cl-item (car (cdr cl-p)))
305 (setcdr cl-p (cdr (cdr cl-p)))
306 (if (= (setq cl-count (1- cl-count)) 0)
307 (setq cl-end 1)))
308 (setq cl-p (cdr cl-p)))
309 (setq cl-end (1- cl-end)))))
310 cl-seq)
311 (apply 'remove* cl-item cl-seq cl-keys)))))
313 (defun delete-if (cl-pred cl-list &rest cl-keys)
316 \nKeywords supported: :key :count :start :end :from-end
318 (apply 'delete* nil cl-list :if cl-pred cl-keys))
320 (defun delete-if-not (cl-pred cl-list &rest cl-keys)
323 \nKeywords supported: :key :count :start :end :from-end
325 (apply 'delete* nil cl-list :if-not cl-pred cl-keys))
327 (defun remove-duplicates (cl-seq &rest cl-keys)
329 \nKeywords supported: :test :test-not :key :start :end :from-end
331 (cl-delete-duplicates cl-seq cl-keys t))
333 (defun delete-duplicates (cl-seq &rest cl-keys)
335 \nKeywords supported: :test :test-not :key :start :end :from-end
337 (cl-delete-duplicates cl-seq cl-keys nil))
339 (defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
340 (if (listp cl-seq)
341 (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
343 (if cl-from-end
344 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
345 (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
346 (while (> cl-end 1)
347 (setq cl-i 0)
348 (while (setq cl-i (cl-position (cl-check-key (car cl-p))
349 (cdr cl-p) cl-i (1- cl-end)))
350 (if cl-copy (setq cl-seq (copy-sequence cl-seq)
351 cl-p (nthcdr cl-start cl-seq) cl-copy nil))
352 (let ((cl-tail (nthcdr cl-i cl-p)))
353 (setcdr cl-tail (cdr (cdr cl-tail))))
354 (setq cl-end (1- cl-end)))
355 (setq cl-p (cdr cl-p) cl-end (1- cl-end)
356 cl-start (1+ cl-start)))
357 cl-seq)
358 (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
359 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
360 (cl-position (cl-check-key (car cl-seq))
361 (cdr cl-seq) 0 (1- cl-end)))
362 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
363 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
364 (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
365 (while (and (cdr (cdr cl-p)) (> cl-end 1))
366 (if (cl-position (cl-check-key (car (cdr cl-p)))
367 (cdr (cdr cl-p)) 0 (1- cl-end))
369 (if cl-copy (setq cl-seq (copy-sequence cl-seq)
370 cl-p (nthcdr (1- cl-start) cl-seq)
371 cl-copy nil))
372 (setcdr cl-p (cdr (cdr cl-p))))
373 (setq cl-p (cdr cl-p)))
374 (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
375 cl-seq)))
376 (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil)))
377 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
379 (defun substitute (cl-new cl-old cl-seq &rest cl-keys)
383 \nKeywords supported: :test :test-not :key :count :start :end :from-end
385 (cl-parsing-keywords (:test :test-not :key :if :if-not :count
387 (if (or (eq cl-old cl-new)
388 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
389 cl-seq
390 (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end)))
391 (if (not cl-i)
392 cl-seq
393 (setq cl-seq (copy-sequence cl-seq))
394 (or cl-from-end
395 (progn (cl-set-elt cl-seq cl-i cl-new)
396 (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
397 (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count
398 :start cl-i cl-keys))))))
400 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
404 \nKeywords supported: :key :count :start :end :from-end
406 (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys))
408 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
412 \nKeywords supported: :key :count :start :end :from-end
414 (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys))
416 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
419 \nKeywords supported: :test :test-not :key :count :start :end :from-end
421 (cl-parsing-keywords (:test :test-not :key :if :if-not :count
423 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
424 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
425 (let ((cl-p (nthcdr cl-start cl-seq)))
426 (setq cl-end (- (or cl-end 8000000) cl-start))
427 (while (and cl-p (> cl-end 0) (> cl-count 0))
428 (if (cl-check-test cl-old (car cl-p))
430 (setcar cl-p cl-new)
431 (setq cl-count (1- cl-count))))
432 (setq cl-p (cdr cl-p) cl-end (1- cl-end))))
433 (or cl-end (setq cl-end (length cl-seq)))
434 (if cl-from-end
435 (while (and (< cl-start cl-end) (> cl-count 0))
436 (setq cl-end (1- cl-end))
437 (if (cl-check-test cl-old (elt cl-seq cl-end))
439 (cl-set-elt cl-seq cl-end cl-new)
440 (setq cl-count (1- cl-count)))))
441 (while (and (< cl-start cl-end) (> cl-count 0))
442 (if (cl-check-test cl-old (aref cl-seq cl-start))
444 (aset cl-seq cl-start cl-new)
445 (setq cl-count (1- cl-count))))
446 (setq cl-start (1+ cl-start))))))
447 cl-seq))
449 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
452 \nKeywords supported: :key :count :start :end :from-end
454 (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
456 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
459 \nKeywords supported: :key :count :start :end :from-end
461 (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
463 (defun find (cl-item cl-seq &rest cl-keys)
466 \nKeywords supported: :test :test-not :key :start :end :from-end
468 (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
469 (and cl-pos (elt cl-seq cl-pos))))
471 (defun find-if (cl-pred cl-list &rest cl-keys)
474 \nKeywords supported: :key :start :end :from-end
476 (apply 'find nil cl-list :if cl-pred cl-keys))
478 (defun find-if-not (cl-pred cl-list &rest cl-keys)
481 \nKeywords supported: :key :start :end :from-end
483 (apply 'find nil cl-list :if-not cl-pred cl-keys))
485 (defun position (cl-item cl-seq &rest cl-keys)
488 \nKeywords supported: :test :test-not :key :start :end :from-end
490 (cl-parsing-keywords (:test :test-not :key :if :if-not
492 (cl-position cl-item cl-seq cl-start cl-end cl-from-end)))
494 (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
495 (if (listp cl-seq)
496 (let ((cl-p (nthcdr cl-start cl-seq)))
497 (or cl-end (setq cl-end 8000000))
498 (let ((cl-res nil))
499 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
500 (if (cl-check-test cl-item (car cl-p))
501 (setq cl-res cl-start))
502 (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
503 cl-res))
504 (or cl-end (setq cl-end (length cl-seq)))
505 (if cl-from-end
507 (while (and (>= (setq cl-end (1- cl-end)) cl-start)
508 (not (cl-check-test cl-item (aref cl-seq cl-end)))))
509 (and (>= cl-end cl-start) cl-end))
510 (while (and (< cl-start cl-end)
511 (not (cl-check-test cl-item (aref cl-seq cl-start))))
512 (setq cl-start (1+ cl-start)))
513 (and (< cl-start cl-end) cl-start))))
515 (defun position-if (cl-pred cl-list &rest cl-keys)
518 \nKeywords supported: :key :start :end :from-end
520 (apply 'position nil cl-list :if cl-pred cl-keys))
522 (defun position-if-not (cl-pred cl-list &rest cl-keys)
525 \nKeywords supported: :key :start :end :from-end
527 (apply 'position nil cl-list :if-not cl-pred cl-keys))
529 (defun count (cl-item cl-seq &rest cl-keys)
531 \nKeywords supported: :test :test-not :key :start :end
533 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
534 (let ((cl-count 0) cl-x)
535 (or cl-end (setq cl-end (length cl-seq)))
536 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
537 (while (< cl-start cl-end)
538 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
539 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
540 (setq cl-start (1+ cl-start)))
541 cl-count)))
543 (defun count-if (cl-pred cl-list &rest cl-keys)
545 \nKeywords supported: :key :start :end
547 (apply 'count nil cl-list :if cl-pred cl-keys))
549 (defun count-if-not (cl-pred cl-list &rest cl-keys)
551 \nKeywords supported: :key :start :end
553 (apply 'count nil cl-list :if-not cl-pred cl-keys))
555 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
559 \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
561 (cl-parsing-keywords (:test :test-not :key :from-end
563 (or cl-end1 (setq cl-end1 (length cl-seq1)))
564 (or cl-end2 (setq cl-end2 (length cl-seq2)))
565 (if cl-from-end
567 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
568 (cl-check-match (elt cl-seq1 (1- cl-end1))
569 (elt cl-seq2 (1- cl-end2))))
570 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
571 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
572 (1- cl-end1)))
573 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
574 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
575 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
576 (cl-check-match (if cl-p1 (car cl-p1)
577 (aref cl-seq1 cl-start1))
578 (if cl-p2 (car cl-p2)
579 (aref cl-seq2 cl-start2))))
580 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
581 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
582 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
583 cl-start1)))))
585 (defun search (cl-seq1 cl-seq2 &rest cl-keys)
589 \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
591 (cl-parsing-keywords (:test :test-not :key :from-end
593 (or cl-end1 (setq cl-end1 (length cl-seq1)))
594 (or cl-end2 (setq cl-end2 (length cl-seq2)))
595 (if (>= cl-start1 cl-end1)
596 (if cl-from-end cl-end2 cl-start2)
597 (let* ((cl-len (- cl-end1 cl-start1))
598 (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
599 (cl-if nil) cl-pos)
600 (setq cl-end2 (- cl-end2 (1- cl-len)))
601 (while (and (< cl-start2 cl-end2)
602 (setq cl-pos (cl-position cl-first cl-seq2
603 cl-start2 cl-end2 cl-from-end))
604 (apply 'mismatch cl-seq1 cl-seq2
605 :start1 (1+ cl-start1) :end1 cl-end1
606 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
607 :from-end nil cl-keys))
608 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
609 (and (< cl-start2 cl-end2) cl-pos)))))
611 (defun sort* (cl-seq cl-pred &rest cl-keys)
614 \nKeywords supported: :key
616 (if (nlistp cl-seq)
617 (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
618 (cl-parsing-keywords (:key) ()
619 (if (memq cl-key '(nil identity))
620 (sort cl-seq cl-pred)
621 (sort cl-seq (function (lambda (cl-x cl-y)
622 (funcall cl-pred (funcall cl-key cl-x)
623 (funcall cl-key cl-y)))))))))
625 (defun stable-sort (cl-seq cl-pred &rest cl-keys)
628 \nKeywords supported: :key
630 (apply 'sort* cl-seq cl-pred cl-keys))
632 (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
636 \nKeywords supported: :key
638 (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil)))
639 (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil)))
640 (cl-parsing-keywords (:key) ()
641 (let ((cl-res nil))
642 (while (and cl-seq1 cl-seq2)
643 (if (funcall cl-pred (cl-check-key (car cl-seq2))
644 (cl-check-key (car cl-seq1)))
645 (push (pop cl-seq2) cl-res)
646 (push (pop cl-seq1) cl-res)))
647 (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
649 ;;; See compiler macro in cl-macs.el
650 (defun member* (cl-item cl-list &rest cl-keys)
653 \nKeywords supported: :test :test-not :key
655 (if cl-keys
656 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
657 (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
658 (setq cl-list (cdr cl-list)))
659 cl-list)
660 (if (and (numberp cl-item) (not (integerp cl-item)))
661 (member cl-item cl-list)
662 (memq cl-item cl-list))))
664 (defun member-if (cl-pred cl-list &rest cl-keys)
667 \nKeywords supported: :key
669 (apply 'member* nil cl-list :if cl-pred cl-keys))
671 (defun member-if-not (cl-pred cl-list &rest cl-keys)
674 \nKeywords supported: :key
676 (apply 'member* nil cl-list :if-not cl-pred cl-keys))
678 (defun cl-adjoin (cl-item cl-list &rest cl-keys)
679 (if (cl-parsing-keywords (:key) t
680 (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
681 cl-list
682 (cons cl-item cl-list)))
684 ;;; See compiler macro in cl-macs.el
685 (defun assoc* (cl-item cl-alist &rest cl-keys)
687 \nKeywords supported: :test :test-not :key
689 (if cl-keys
690 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
691 (while (and cl-alist
692 (or (not (consp (car cl-alist)))
693 (not (cl-check-test cl-item (car (car cl-alist))))))
694 (setq cl-alist (cdr cl-alist)))
695 (and cl-alist (car cl-alist)))
696 (if (and (numberp cl-item) (not (integerp cl-item)))
697 (assoc cl-item cl-alist)
698 (assq cl-item cl-alist))))
700 (defun assoc-if (cl-pred cl-list &rest cl-keys)
702 \nKeywords supported: :key
704 (apply 'assoc* nil cl-list :if cl-pred cl-keys))
706 (defun assoc-if-not (cl-pred cl-list &rest cl-keys)
708 \nKeywords supported: :key
710 (apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
712 (defun rassoc* (cl-item cl-alist &rest cl-keys)
714 \nKeywords supported: :test :test-not :key
716 (if (or cl-keys (numberp cl-item))
717 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
718 (while (and cl-alist
719 (or (not (consp (car cl-alist)))
720 (not (cl-check-test cl-item (cdr (car cl-alist))))))
721 (setq cl-alist (cdr cl-alist)))
722 (and cl-alist (car cl-alist)))
723 (rassq cl-item cl-alist)))
725 (defun rassoc-if (cl-pred cl-list &rest cl-keys)
727 \nKeywords supported: :key
729 (apply 'rassoc* nil cl-list :if cl-pred cl-keys))
731 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
733 \nKeywords supported: :key
735 (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
737 (defun union (cl-list1 cl-list2 &rest cl-keys)
742 \nKeywords supported: :test :test-not :key
744 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
745 ((equal cl-list1 cl-list2) cl-list1)
747 (or (>= (length cl-list1) (length cl-list2))
748 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
749 (while cl-list2
750 (if (or cl-keys (numberp (car cl-list2)))
751 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
752 (or (memq (car cl-list2) cl-list1)
753 (push (car cl-list2) cl-list1)))
754 (pop cl-list2))
755 cl-list1)))
757 (defun nunion (cl-list1 cl-list2 &rest cl-keys)
762 \nKeywords supported: :test :test-not :key
764 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
765 (t (apply 'union cl-list1 cl-list2 cl-keys))))
767 (defun intersection (cl-list1 cl-list2 &rest cl-keys)
772 \nKeywords supported: :test :test-not :key
774 (and cl-list1 cl-list2
775 (if (equal cl-list1 cl-list2) cl-list1
776 (cl-parsing-keywords (:key) (:test :test-not)
777 (let ((cl-res nil))
778 (or (>= (length cl-list1) (length cl-list2))
779 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
780 (while cl-list2
781 (if (if (or cl-keys (numberp (car cl-list2)))
782 (apply 'member* (cl-check-key (car cl-list2))
783 cl-list1 cl-keys)
784 (memq (car cl-list2) cl-list1))
785 (push (car cl-list2) cl-res))
786 (pop cl-list2))
787 cl-res)))))
789 (defun nintersection (cl-list1 cl-list2 &rest cl-keys)
794 \nKeywords supported: :test :test-not :key
796 (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
798 (defun set-difference (cl-list1 cl-list2 &rest cl-keys)
803 \nKeywords supported: :test :test-not :key
805 (if (or (null cl-list1) (null cl-list2)) cl-list1
806 (cl-parsing-keywords (:key) (:test :test-not)
807 (let ((cl-res nil))
808 (while cl-list1
809 (or (if (or cl-keys (numberp (car cl-list1)))
810 (apply 'member* (cl-check-key (car cl-list1))
811 cl-list2 cl-keys)
812 (memq (car cl-list1) cl-list2))
813 (push (car cl-list1) cl-res))
814 (pop cl-list1))
815 cl-res))))
817 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
822 \nKeywords supported: :test :test-not :key
824 (if (or (null cl-list1) (null cl-list2)) cl-list1
825 (apply 'set-difference cl-list1 cl-list2 cl-keys)))
827 (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
832 \nKeywords supported: :test :test-not :key
834 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
835 ((equal cl-list1 cl-list2) nil)
836 (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
837 (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
839 (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
844 \nKeywords supported: :test :test-not :key
846 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
847 ((equal cl-list1 cl-list2) nil)
848 (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
849 (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
851 (defun subsetp (cl-list1 cl-list2 &rest cl-keys)
854 \nKeywords supported: :test :test-not :key
856 (cond ((null cl-list1) t) ((null cl-list2) nil)
857 ((equal cl-list1 cl-list2) t)
858 (t (cl-parsing-keywords (:key) (:test :test-not)
859 (while (and cl-list1
860 (apply 'member* (cl-check-key (car cl-list1))
861 cl-list2 cl-keys))
862 (pop cl-list1))
863 (null cl-list1)))))
865 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
868 \nKeywords supported: :key
870 (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
872 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
875 \nKeywords supported: :key
877 (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
879 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
883 \nKeywords supported: :test :test-not :key
885 (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
887 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
890 \nKeywords supported: :key
892 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
894 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
897 \nKeywords supported: :key
899 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
901 (defun sublis (cl-alist cl-tree &rest cl-keys)
904 \nKeywords supported: :test :test-not :key
906 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
907 (cl-sublis-rec cl-tree)))
909 (defvar cl-alist)
910 (defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if*
911 (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
912 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
913 (setq cl-p (cdr cl-p)))
914 (if cl-p (cdr (car cl-p))
915 (if (consp cl-tree)
916 (let ((cl-a (cl-sublis-rec (car cl-tree)))
917 (cl-d (cl-sublis-rec (cdr cl-tree))))
918 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
919 cl-tree
920 (cons cl-a cl-d)))
921 cl-tree))))
923 (defun nsublis (cl-alist cl-tree &rest cl-keys)
926 \nKeywords supported: :test :test-not :key
928 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
929 (let ((cl-hold (list cl-tree)))
930 (cl-nsublis-rec cl-hold)
931 (car cl-hold))))
933 (defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if*
934 (while (consp cl-tree)
935 (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
936 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
937 (setq cl-p (cdr cl-p)))
938 (if cl-p (setcar cl-tree (cdr (car cl-p)))
939 (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
940 (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
941 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
942 (setq cl-p (cdr cl-p)))
943 (if cl-p
944 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
945 (setq cl-tree (cdr cl-tree))))))
947 (defun tree-equal (cl-x cl-y &rest cl-keys)
950 \nKeywords supported: :test :test-not :key
952 (cl-parsing-keywords (:test :test-not :key) ()
953 (cl-tree-equal-rec cl-x cl-y)))
955 (defun cl-tree-equal-rec (cl-x cl-y)
956 (while (and (consp cl-x) (consp cl-y)
957 (cl-tree-equal-rec (car cl-x) (car cl-y)))
958 (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
959 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
962 (run-hooks 'cl-seq-load-hook)
965 ;;; cl-seq.el ends here