Mercurial > hg > xemacs-beta

comparison lisp/cl-seq.el @ 2153:393039450288

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2004-06-26 21:25:23 by james] Synch with Emacs 21.3.
author james
date Sat, 26 Jun 2004 21:25:24 +0000
parents 023b83f4e54b
children 6772ce4d982b
comparison
equal deleted inserted replaced
2152:d93fedcbf6be 2153:393039450288
22 ;; You should have received a copy of the GNU General Public License 22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the Free 23 ;; along with XEmacs; see the file COPYING. If not, write to the Free
24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
25 ;; 02111-1307, USA. 25 ;; 02111-1307, USA.
26 26
27 ;;; Synched up with: FSF 19.34. 27 ;;; Synched up with: FSF 21.3.
28 28
29 ;;; Commentary: 29 ;;; Commentary:
30 30
31 ;; This file is dumped with XEmacs. 31 ;; This file is dumped with XEmacs.
32 32
49 49
50 ;;; Code: 50 ;;; Code:
51 51
52 (or (memq 'cl-19 features) 52 (or (memq 'cl-19 features)
53 (error "Tried to load `cl-seq' before `cl'!")) 53 (error "Tried to load `cl-seq' before `cl'!"))
54
55
56 ;;; We define these here so that this file can compile without having
57 ;;; loaded the cl.el file already.
58
59 (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
60 (defmacro cl-pop (place)
61 (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
62 54
63 55
64 ;;; Keyword parsing. This is special-cased here so that we can compile 56 ;;; Keyword parsing. This is special-cased here so that we can compile
65 ;;; this file independent from cl-macs. 57 ;;; this file independent from cl-macs.
66 58
88 (function 80 (function
89 (lambda (x) 81 (lambda (x)
90 (let* ((var (if (consp x) (car x) x)) 82 (let* ((var (if (consp x) (car x) x))
91 (mem (list 'car (list 'cdr (list 'memq (list 'quote var) 83 (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
92 'cl-keys))))) 84 'cl-keys)))))
93 (if (eq var ':test-not) 85 (if (eq var :test-not)
94 (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) 86 (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
95 (if (eq var ':if-not) 87 (if (eq var :if-not)
96 (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) 88 (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
97 (list (intern 89 (list (intern
98 (format "cl-%s" (substring (symbol-name var) 1))) 90 (format "cl-%s" (substring (symbol-name var) 1)))
99 (if (consp x) (list 'or mem (car (cdr x))) mem))))) 91 (if (consp x) (list 'or mem (car (cdr x))) mem)))))
100 kwords) 92 kwords)
159 Keywords supported: :start :end :from-end :initial-value :key" 151 Keywords supported: :start :end :from-end :initial-value :key"
160 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () 152 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
161 (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) 153 (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
162 (setq cl-seq (subseq cl-seq cl-start cl-end)) 154 (setq cl-seq (subseq cl-seq cl-start cl-end))
163 (if cl-from-end (setq cl-seq (nreverse cl-seq))) 155 (if cl-from-end (setq cl-seq (nreverse cl-seq)))
164 (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value) 156 (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value)
165 (cl-seq (cl-check-key (cl-pop cl-seq))) 157 (cl-seq (cl-check-key (pop cl-seq)))
166 (t (funcall cl-func))))) 158 (t (funcall cl-func)))))
167 (if cl-from-end 159 (if cl-from-end
168 (while cl-seq 160 (while cl-seq
169 (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq)) 161 (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq))
170 cl-accum))) 162 cl-accum)))
171 (while cl-seq 163 (while cl-seq
172 (setq cl-accum (funcall cl-func cl-accum 164 (setq cl-accum (funcall cl-func cl-accum
173 (cl-check-key (cl-pop cl-seq)))))) 165 (cl-check-key (pop cl-seq))))))
174 cl-accum))) 166 cl-accum)))
175 167
176 (defun fill (seq item &rest cl-keys) 168 (defun fill (seq item &rest cl-keys)
177 "Fill the elements of SEQ with ITEM. 169 "Fill the elements of SEQ with ITEM.
178 Keywords supported: :start :end" 170 Keywords supported: :start :end"
245 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end 237 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
246 cl-from-end))) 238 cl-from-end)))
247 (if cl-i 239 (if cl-i
248 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) 240 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
249 (append (if cl-from-end 241 (append (if cl-from-end
250 (list ':end (1+ cl-i)) 242 (list :end (1+ cl-i))
251 (list ':start cl-i)) 243 (list :start cl-i))
252 cl-keys)))) 244 cl-keys))))
253 (if (listp cl-seq) cl-res 245 (if (listp cl-seq) cl-res
254 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) 246 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))
255 cl-seq)) 247 cl-seq))
256 (setq cl-end (- (or cl-end 8000000) cl-start)) 248 (setq cl-end (- (or cl-end 8000000) cl-start))
269 (nconc (ldiff cl-seq cl-p) 261 (nconc (ldiff cl-seq cl-p)
270 (if (= cl-count 1) (cdr cl-p) 262 (if (= cl-count 1) (cdr cl-p)
271 (and (cdr cl-p) 263 (and (cdr cl-p)
272 (apply 'delete* cl-item 264 (apply 'delete* cl-item
273 (copy-sequence (cdr cl-p)) 265 (copy-sequence (cdr cl-p))
274 ':start 0 ':end (1- cl-end) 266 :start 0 :end (1- cl-end)
275 ':count (1- cl-count) cl-keys)))) 267 :count (1- cl-count) cl-keys))))
276 cl-seq)) 268 cl-seq))
277 cl-seq))))) 269 cl-seq)))))
278 270
279 (defun remove-if (cl-pred cl-list &rest cl-keys) 271 (defun remove-if (cl-pred cl-list &rest cl-keys)
280 "Remove all items satisfying PREDICATE in SEQ. 272 "Remove all items satisfying PREDICATE in SEQ.
281 This is a non-destructive function; it makes a copy of SEQ if necessary 273 This is a non-destructive function; it makes a copy of SEQ if necessary
282 to avoid corrupting the original SEQ. 274 to avoid corrupting the original SEQ.
283 Keywords supported: :key :count :start :end :from-end" 275 Keywords supported: :key :count :start :end :from-end"
284 (apply 'remove* nil cl-list ':if cl-pred cl-keys)) 276 (apply 'remove* nil cl-list :if cl-pred cl-keys))
285 277
286 (defun remove-if-not (cl-pred cl-list &rest cl-keys) 278 (defun remove-if-not (cl-pred cl-list &rest cl-keys)
287 "Remove all items not satisfying PREDICATE in SEQ. 279 "Remove all items not satisfying PREDICATE in SEQ.
288 This is a non-destructive function; it makes a copy of SEQ if necessary 280 This is a non-destructive function; it makes a copy of SEQ if necessary
289 to avoid corrupting the original SEQ. 281 to avoid corrupting the original SEQ.
290 Keywords supported: :key :count :start :end :from-end" 282 Keywords supported: :key :count :start :end :from-end"
291 (apply 'remove* nil cl-list ':if-not cl-pred cl-keys)) 283 (apply 'remove* nil cl-list :if-not cl-pred cl-keys))
292 284
293 (defun delete* (cl-item cl-seq &rest cl-keys) 285 (defun delete* (cl-item cl-seq &rest cl-keys)
294 "Remove all occurrences of ITEM in SEQ. 286 "Remove all occurrences of ITEM in SEQ.
295 This is a destructive function; it reuses the storage of SEQ whenever possible. 287 This is a destructive function; it reuses the storage of SEQ whenever possible.
296 Keywords supported: :test :test-not :key :count :start :end :from-end" 288 Keywords supported: :test :test-not :key :count :start :end :from-end"
334 326
335 (defun delete-if (cl-pred cl-list &rest cl-keys) 327 (defun delete-if (cl-pred cl-list &rest cl-keys)
336 "Remove all items satisfying PREDICATE in SEQ. 328 "Remove all items satisfying PREDICATE in SEQ.
337 This is a destructive function; it reuses the storage of SEQ whenever possible. 329 This is a destructive function; it reuses the storage of SEQ whenever possible.
338 Keywords supported: :key :count :start :end :from-end" 330 Keywords supported: :key :count :start :end :from-end"
339 (apply 'delete* nil cl-list ':if cl-pred cl-keys)) 331 (apply 'delete* nil cl-list :if cl-pred cl-keys))
340 332
341 (defun delete-if-not (cl-pred cl-list &rest cl-keys) 333 (defun delete-if-not (cl-pred cl-list &rest cl-keys)
342 "Remove all items not satisfying PREDICATE in SEQ. 334 "Remove all items not satisfying PREDICATE in SEQ.
343 This is a destructive function; it reuses the storage of SEQ whenever possible. 335 This is a destructive function; it reuses the storage of SEQ whenever possible.
344 Keywords supported: :key :count :start :end :from-end" 336 Keywords supported: :key :count :start :end :from-end"
345 (apply 'delete* nil cl-list ':if-not cl-pred cl-keys)) 337 (apply 'delete* nil cl-list :if-not cl-pred cl-keys))
346 338
347 (or (and (fboundp 'delete) (subrp (symbol-function 'delete))) 339 ;; XEmacs change: this is in subr.el in Emacs
348 (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal)))))
349
350 (defun remove (cl-item cl-seq) 340 (defun remove (cl-item cl-seq)
351 "Remove all occurrences of ITEM in SEQ, testing with `equal' 341 "Remove all occurrences of ITEM in SEQ, testing with `equal'
352 This is a non-destructive function; it makes a copy of SEQ if necessary 342 This is a non-destructive function; it makes a copy of SEQ if necessary
353 to avoid corrupting the original SEQ. 343 to avoid corrupting the original SEQ.
354 Also see: `remove*', `delete', `delete*'" 344 Also see: `remove*', `delete', `delete*'"
355 (remove* cl-item cl-seq ':test 'equal)) 345 (remove* cl-item cl-seq ':test 'equal))
356 346
347 ;; XEmacs change: this is in subr.el in Emacs
357 (defun remq (cl-elt cl-list) 348 (defun remq (cl-elt cl-list)
358 "Remove all occurrences of ELT in LIST, comparing with `eq'. 349 "Remove all occurrences of ELT in LIST, comparing with `eq'.
359 This is a non-destructive function; it makes a copy of LIST to avoid 350 This is a non-destructive function; it makes a copy of LIST to avoid
360 corrupting the original LIST. 351 corrupting the original LIST.
361 Also see: `delq', `delete', `delete*', `remove', `remove*'." 352 Also see: `delq', `delete', `delete*', `remove', `remove*'."
428 cl-seq 419 cl-seq
429 (setq cl-seq (copy-sequence cl-seq)) 420 (setq cl-seq (copy-sequence cl-seq))
430 (or cl-from-end 421 (or cl-from-end
431 (progn (cl-set-elt cl-seq cl-i cl-new) 422 (progn (cl-set-elt cl-seq cl-i cl-new)
432 (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) 423 (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
433 (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count 424 (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count
434 ':start cl-i cl-keys)))))) 425 :start cl-i cl-keys))))))
435 426
436 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) 427 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
437 "Substitute NEW for all items satisfying PREDICATE in SEQ. 428 "Substitute NEW for all items satisfying PREDICATE in SEQ.
438 This is a non-destructive function; it makes a copy of SEQ if necessary 429 This is a non-destructive function; it makes a copy of SEQ if necessary
439 to avoid corrupting the original SEQ. 430 to avoid corrupting the original SEQ.
440 Keywords supported: :key :count :start :end :from-end" 431 Keywords supported: :key :count :start :end :from-end"
441 (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys)) 432 (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys))
442 433
443 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) 434 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
444 "Substitute NEW for all items not satisfying PREDICATE in SEQ. 435 "Substitute NEW for all items not satisfying PREDICATE in SEQ.
445 This is a non-destructive function; it makes a copy of SEQ if necessary 436 This is a non-destructive function; it makes a copy of SEQ if necessary
446 to avoid corrupting the original SEQ. 437 to avoid corrupting the original SEQ.
447 Keywords supported: :key :count :start :end :from-end" 438 Keywords supported: :key :count :start :end :from-end"
448 (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys)) 439 (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys))
449 440
450 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) 441 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
451 "Substitute NEW for OLD in SEQ. 442 "Substitute NEW for OLD in SEQ.
452 This is a destructive function; it reuses the storage of SEQ whenever possible. 443 This is a destructive function; it reuses the storage of SEQ whenever possible.
453 Keywords supported: :test :test-not :key :count :start :end :from-end" 444 Keywords supported: :test :test-not :key :count :start :end :from-end"
481 472
482 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) 473 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
483 "Substitute NEW for all items satisfying PREDICATE in SEQ. 474 "Substitute NEW for all items satisfying PREDICATE in SEQ.
484 This is a destructive function; it reuses the storage of SEQ whenever possible. 475 This is a destructive function; it reuses the storage of SEQ whenever possible.
485 Keywords supported: :key :count :start :end :from-end" 476 Keywords supported: :key :count :start :end :from-end"
486 (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys)) 477 (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
487 478
488 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) 479 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
489 "Substitute NEW for all items not satisfying PREDICATE in SEQ. 480 "Substitute NEW for all items not satisfying PREDICATE in SEQ.
490 This is a destructive function; it reuses the storage of SEQ whenever possible. 481 This is a destructive function; it reuses the storage of SEQ whenever possible.
491 Keywords supported: :key :count :start :end :from-end" 482 Keywords supported: :key :count :start :end :from-end"
492 (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys)) 483 (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
493 484
494 (defun find (cl-item cl-seq &rest cl-keys) 485 (defun find (cl-item cl-seq &rest cl-keys)
495 "Find the first occurrence of ITEM in LIST. 486 "Find the first occurrence of ITEM in LIST.
496 Return the matching ITEM, or nil if not found. 487 Return the matching ITEM, or nil if not found.
497 Keywords supported: :test :test-not :key :start :end :from-end" 488 Keywords supported: :test :test-not :key :start :end :from-end"
500 491
501 (defun find-if (cl-pred cl-list &rest cl-keys) 492 (defun find-if (cl-pred cl-list &rest cl-keys)
502 "Find the first item satisfying PREDICATE in LIST. 493 "Find the first item satisfying PREDICATE in LIST.
503 Return the matching ITEM, or nil if not found. 494 Return the matching ITEM, or nil if not found.
504 Keywords supported: :key :start :end :from-end" 495 Keywords supported: :key :start :end :from-end"
505 (apply 'find nil cl-list ':if cl-pred cl-keys)) 496 (apply 'find nil cl-list :if cl-pred cl-keys))
506 497
507 (defun find-if-not (cl-pred cl-list &rest cl-keys) 498 (defun find-if-not (cl-pred cl-list &rest cl-keys)
508 "Find the first item not satisfying PREDICATE in LIST. 499 "Find the first item not satisfying PREDICATE in LIST.
509 Return the matching ITEM, or nil if not found. 500 Return the matching ITEM, or nil if not found.
510 Keywords supported: :key :start :end :from-end" 501 Keywords supported: :key :start :end :from-end"
511 (apply 'find nil cl-list ':if-not cl-pred cl-keys)) 502 (apply 'find nil cl-list :if-not cl-pred cl-keys))
512 503
513 (defun position (cl-item cl-seq &rest cl-keys) 504 (defun position (cl-item cl-seq &rest cl-keys)
514 "Find the first occurrence of ITEM in LIST. 505 "Find the first occurrence of ITEM in LIST.
515 Return the index of the matching item, or nil if not found. 506 Return the index of the matching item, or nil if not found.
516 Keywords supported: :test :test-not :key :start :end :from-end" 507 Keywords supported: :test :test-not :key :start :end :from-end"
541 532
542 (defun position-if (cl-pred cl-list &rest cl-keys) 533 (defun position-if (cl-pred cl-list &rest cl-keys)
543 "Find the first item satisfying PREDICATE in LIST. 534 "Find the first item satisfying PREDICATE in LIST.
544 Return the index of the matching item, or nil if not found. 535 Return the index of the matching item, or nil if not found.
545 Keywords supported: :key :start :end :from-end" 536 Keywords supported: :key :start :end :from-end"
546 (apply 'position nil cl-list ':if cl-pred cl-keys)) 537 (apply 'position nil cl-list :if cl-pred cl-keys))
547 538
548 (defun position-if-not (cl-pred cl-list &rest cl-keys) 539 (defun position-if-not (cl-pred cl-list &rest cl-keys)
549 "Find the first item not satisfying PREDICATE in LIST. 540 "Find the first item not satisfying PREDICATE in LIST.
550 Return the index of the matching item, or nil if not found. 541 Return the index of the matching item, or nil if not found.
551 Keywords supported: :key :start :end :from-end" 542 Keywords supported: :key :start :end :from-end"
552 (apply 'position nil cl-list ':if-not cl-pred cl-keys)) 543 (apply 'position nil cl-list :if-not cl-pred cl-keys))
553 544
554 (defun count (cl-item cl-seq &rest cl-keys) 545 (defun count (cl-item cl-seq &rest cl-keys)
555 "Count the number of occurrences of ITEM in LIST. 546 "Count the number of occurrences of ITEM in LIST.
556 Keywords supported: :test :test-not :key :start :end" 547 Keywords supported: :test :test-not :key :start :end"
557 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () 548 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
558 (let ((cl-count 0) cl-x) 549 (let ((cl-count 0) cl-x)
559 (or cl-end (setq cl-end (length cl-seq))) 550 (or cl-end (setq cl-end (length cl-seq)))
560 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) 551 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
561 (while (< cl-start cl-end) 552 (while (< cl-start cl-end)
562 (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start))) 553 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
563 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) 554 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
564 (setq cl-start (1+ cl-start))) 555 (setq cl-start (1+ cl-start)))
565 cl-count))) 556 cl-count)))
566 557
567 (defun count-if (cl-pred cl-list &rest cl-keys) 558 (defun count-if (cl-pred cl-list &rest cl-keys)
568 "Count the number of items satisfying PREDICATE in LIST. 559 "Count the number of items satisfying PREDICATE in LIST.
569 Keywords supported: :key :start :end" 560 Keywords supported: :key :start :end"
570 (apply 'count nil cl-list ':if cl-pred cl-keys)) 561 (apply 'count nil cl-list :if cl-pred cl-keys))
571 562
572 (defun count-if-not (cl-pred cl-list &rest cl-keys) 563 (defun count-if-not (cl-pred cl-list &rest cl-keys)
573 "Count the number of items not satisfying PREDICATE in LIST. 564 "Count the number of items not satisfying PREDICATE in LIST.
574 Keywords supported: :key :start :end" 565 Keywords supported: :key :start :end"
575 (apply 'count nil cl-list ':if-not cl-pred cl-keys)) 566 (apply 'count nil cl-list :if-not cl-pred cl-keys))
576 567
577 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) 568 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
578 "Compare SEQ1 with SEQ2, return index of first mismatching element. 569 "Compare SEQ1 with SEQ2, return index of first mismatching element.
579 Return nil if the sequences match. If one sequence is a prefix of the 570 Return nil if the sequences match. If one sequence is a prefix of the
580 other, the return value indicates the end of the shorted sequence. 571 other, the return value indicates the end of the shorter sequence.
581 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" 572 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
582 (cl-parsing-keywords (:test :test-not :key :from-end 573 (cl-parsing-keywords (:test :test-not :key :from-end
583 (:start1 0) :end1 (:start2 0) :end2) () 574 (:start1 0) :end1 (:start2 0) :end2) ()
584 (or cl-end1 (setq cl-end1 (length cl-seq1))) 575 (or cl-end1 (setq cl-end1 (length cl-seq1)))
585 (or cl-end2 (setq cl-end2 (length cl-seq2))) 576 (or cl-end2 (setq cl-end2 (length cl-seq2)))
620 (setq cl-end2 (- cl-end2 (1- cl-len))) 611 (setq cl-end2 (- cl-end2 (1- cl-len)))
621 (while (and (< cl-start2 cl-end2) 612 (while (and (< cl-start2 cl-end2)
622 (setq cl-pos (cl-position cl-first cl-seq2 613 (setq cl-pos (cl-position cl-first cl-seq2
623 cl-start2 cl-end2 cl-from-end)) 614 cl-start2 cl-end2 cl-from-end))
624 (apply 'mismatch cl-seq1 cl-seq2 615 (apply 'mismatch cl-seq1 cl-seq2
625 ':start1 (1+ cl-start1) ':end1 cl-end1 616 :start1 (1+ cl-start1) :end1 cl-end1
626 ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len) 617 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
627 ':from-end nil cl-keys)) 618 :from-end nil cl-keys))
628 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) 619 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
629 (and (< cl-start2 cl-end2) cl-pos))))) 620 (and (< cl-start2 cl-end2) cl-pos)))))
630 621
631 (defun sort* (cl-seq cl-pred &rest cl-keys) 622 (defun sort* (cl-seq cl-pred &rest cl-keys)
632 "Sort the argument SEQUENCE according to PREDICATE. 623 "Sort the argument SEQUENCE according to PREDICATE.
657 (cl-parsing-keywords (:key) () 648 (cl-parsing-keywords (:key) ()
658 (let ((cl-res nil)) 649 (let ((cl-res nil))
659 (while (and cl-seq1 cl-seq2) 650 (while (and cl-seq1 cl-seq2)
660 (if (funcall cl-pred (cl-check-key (car cl-seq2)) 651 (if (funcall cl-pred (cl-check-key (car cl-seq2))
661 (cl-check-key (car cl-seq1))) 652 (cl-check-key (car cl-seq1)))
662 (cl-push (cl-pop cl-seq2) cl-res) 653 (push (pop cl-seq2) cl-res)
663 (cl-push (cl-pop cl-seq1) cl-res))) 654 (push (pop cl-seq1) cl-res)))
664 (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) 655 (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
665 656
666 ;;; See compiler macro in cl-macs.el 657 ;;; See compiler macro in cl-macs.el
667 (defun member* (cl-item cl-list &rest cl-keys) 658 (defun member* (cl-item cl-list &rest cl-keys)
668 "Find the first occurrence of ITEM in LIST. 659 "Find the first occurrence of ITEM in LIST.
679 670
680 (defun member-if (cl-pred cl-list &rest cl-keys) 671 (defun member-if (cl-pred cl-list &rest cl-keys)
681 "Find the first item satisfying PREDICATE in LIST. 672 "Find the first item satisfying PREDICATE in LIST.
682 Return the sublist of LIST whose car matches. 673 Return the sublist of LIST whose car matches.
683 Keywords supported: :key" 674 Keywords supported: :key"
684 (apply 'member* nil cl-list ':if cl-pred cl-keys)) 675 (apply 'member* nil cl-list :if cl-pred cl-keys))
685 676
686 (defun member-if-not (cl-pred cl-list &rest cl-keys) 677 (defun member-if-not (cl-pred cl-list &rest cl-keys)
687 "Find the first item not satisfying PREDICATE in LIST. 678 "Find the first item not satisfying PREDICATE in LIST.
688 Return the sublist of LIST whose car matches. 679 Return the sublist of LIST whose car matches.
689 Keywords supported: :key" 680 Keywords supported: :key"
690 (apply 'member* nil cl-list ':if-not cl-pred cl-keys)) 681 (apply 'member* nil cl-list :if-not cl-pred cl-keys))
691 682
692 (defun cl-adjoin (cl-item cl-list &rest cl-keys) 683 (defun cl-adjoin (cl-item cl-list &rest cl-keys)
693 (if (cl-parsing-keywords (:key) t 684 (if (cl-parsing-keywords (:key) t
694 (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) 685 (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
695 cl-list 686 cl-list
711 (assq cl-item cl-alist)))) 702 (assq cl-item cl-alist))))
712 703
713 (defun assoc-if (cl-pred cl-list &rest cl-keys) 704 (defun assoc-if (cl-pred cl-list &rest cl-keys)
714 "Find the first item whose car satisfies PREDICATE in LIST. 705 "Find the first item whose car satisfies PREDICATE in LIST.
715 Keywords supported: :key" 706 Keywords supported: :key"
716 (apply 'assoc* nil cl-list ':if cl-pred cl-keys)) 707 (apply 'assoc* nil cl-list :if cl-pred cl-keys))
717 708
718 (defun assoc-if-not (cl-pred cl-list &rest cl-keys) 709 (defun assoc-if-not (cl-pred cl-list &rest cl-keys)
719 "Find the first item whose car does not satisfy PREDICATE in LIST. 710 "Find the first item whose car does not satisfy PREDICATE in LIST.
720 Keywords supported: :key" 711 Keywords supported: :key"
721 (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys)) 712 (apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
722 713
723 (defun rassoc* (cl-item cl-alist &rest cl-keys) 714 (defun rassoc* (cl-item cl-alist &rest cl-keys)
724 "Find the first item whose cdr matches ITEM in LIST. 715 "Find the first item whose cdr matches ITEM in LIST.
725 Keywords supported: :test :test-not :key" 716 Keywords supported: :test :test-not :key"
726 (if (or cl-keys (numberp cl-item)) 717 (if (or cl-keys (numberp cl-item))
733 (rassq cl-item cl-alist))) 724 (rassq cl-item cl-alist)))
734 725
735 (defun rassoc-if (cl-pred cl-list &rest cl-keys) 726 (defun rassoc-if (cl-pred cl-list &rest cl-keys)
736 "Find the first item whose cdr satisfies PREDICATE in LIST. 727 "Find the first item whose cdr satisfies PREDICATE in LIST.
737 Keywords supported: :key" 728 Keywords supported: :key"
738 (apply 'rassoc* nil cl-list ':if cl-pred cl-keys)) 729 (apply 'rassoc* nil cl-list :if cl-pred cl-keys))
739 730
740 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys) 731 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
741 "Find the first item whose cdr does not satisfy PREDICATE in LIST. 732 "Find the first item whose cdr does not satisfy PREDICATE in LIST.
742 Keywords supported: :key" 733 Keywords supported: :key"
743 (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys)) 734 (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
744 735
745 (defun union (cl-list1 cl-list2 &rest cl-keys) 736 (defun union (cl-list1 cl-list2 &rest cl-keys)
746 "Combine LIST1 and LIST2 using a set-union operation. 737 "Combine LIST1 and LIST2 using a set-union operation.
747 The result list contains all items that appear in either LIST1 or LIST2. 738 The result list contains all items that appear in either LIST1 or LIST2.
748 This is a non-destructive function; it makes a copy of the data if necessary 739 This is a non-destructive function; it makes a copy of the data if necessary
755 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) 746 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
756 (while cl-list2 747 (while cl-list2
757 (if (or cl-keys (numberp (car cl-list2))) 748 (if (or cl-keys (numberp (car cl-list2)))
758 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) 749 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
759 (or (memq (car cl-list2) cl-list1) 750 (or (memq (car cl-list2) cl-list1)
760 (cl-push (car cl-list2) cl-list1))) 751 (push (car cl-list2) cl-list1)))
761 (cl-pop cl-list2)) 752 (pop cl-list2))
762 cl-list1))) 753 cl-list1)))
763 754
764 (defun nunion (cl-list1 cl-list2 &rest cl-keys) 755 (defun nunion (cl-list1 cl-list2 &rest cl-keys)
765 "Combine LIST1 and LIST2 using a set-union operation. 756 "Combine LIST1 and LIST2 using a set-union operation.
766 The result list contains all items that appear in either LIST1 or LIST2. 757 The result list contains all items that appear in either LIST1 or LIST2.
785 (while cl-list2 776 (while cl-list2
786 (if (if (or cl-keys (numberp (car cl-list2))) 777 (if (if (or cl-keys (numberp (car cl-list2)))
787 (apply 'member* (cl-check-key (car cl-list2)) 778 (apply 'member* (cl-check-key (car cl-list2))
788 cl-list1 cl-keys) 779 cl-list1 cl-keys)
789 (memq (car cl-list2) cl-list1)) 780 (memq (car cl-list2) cl-list1))
790 (cl-push (car cl-list2) cl-res)) 781 (push (car cl-list2) cl-res))
791 (cl-pop cl-list2)) 782 (pop cl-list2))
792 cl-res))))) 783 cl-res)))))
793 784
794 (defun nintersection (cl-list1 cl-list2 &rest cl-keys) 785 (defun nintersection (cl-list1 cl-list2 &rest cl-keys)
795 "Combine LIST1 and LIST2 using a set-intersection operation. 786 "Combine LIST1 and LIST2 using a set-intersection operation.
796 The result list contains all items that appear in both LIST1 and LIST2. 787 The result list contains all items that appear in both LIST1 and LIST2.
811 (while cl-list1 802 (while cl-list1
812 (or (if (or cl-keys (numberp (car cl-list1))) 803 (or (if (or cl-keys (numberp (car cl-list1)))
813 (apply 'member* (cl-check-key (car cl-list1)) 804 (apply 'member* (cl-check-key (car cl-list1))
814 cl-list2 cl-keys) 805 cl-list2 cl-keys)
815 (memq (car cl-list1) cl-list2)) 806 (memq (car cl-list1) cl-list2))
816 (cl-push (car cl-list1) cl-res)) 807 (push (car cl-list1) cl-res))
817 (cl-pop cl-list1)) 808 (pop cl-list1))
818 cl-res)))) 809 cl-res))))
819 810
820 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys) 811 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
821 "Combine LIST1 and LIST2 using a set-difference operation. 812 "Combine LIST1 and LIST2 using a set-difference operation.
822 The result list contains all items that appear in LIST1 but not LIST2. 813 The result list contains all items that appear in LIST1 but not LIST2.
856 ((equal cl-list1 cl-list2) t) 847 ((equal cl-list1 cl-list2) t)
857 (t (cl-parsing-keywords (:key) (:test :test-not) 848 (t (cl-parsing-keywords (:key) (:test :test-not)
858 (while (and cl-list1 849 (while (and cl-list1
859 (apply 'member* (cl-check-key (car cl-list1)) 850 (apply 'member* (cl-check-key (car cl-list1))
860 cl-list2 cl-keys)) 851 cl-list2 cl-keys))
861 (cl-pop cl-list1)) 852 (pop cl-list1))
862 (null cl-list1))))) 853 (null cl-list1)))))
863 854
864 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) 855 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
865 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). 856 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
866 Return a copy of TREE with all matching elements replaced by NEW. 857 Return a copy of TREE with all matching elements replaced by NEW.
867 Keywords supported: :key" 858 Keywords supported: :key"
868 (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) 859 (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
869 860
870 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) 861 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
871 "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). 862 "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
872 Return a copy of TREE with all non-matching elements replaced by NEW. 863 Return a copy of TREE with all non-matching elements replaced by NEW.
873 Keywords supported: :key" 864 Keywords supported: :key"
874 (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) 865 (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
875 866
876 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys) 867 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
877 "Substitute NEW for OLD everywhere in TREE (destructively). 868 "Substitute NEW for OLD everywhere in TREE (destructively).
878 Any element of TREE which is `eql' to OLD is changed to NEW (via a call 869 Any element of TREE which is `eql' to OLD is changed to NEW (via a call
879 to `setcar'). 870 to `setcar').
882 873
883 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) 874 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
884 "Substitute NEW for elements matching PREDICATE in TREE (destructively). 875 "Substitute NEW for elements matching PREDICATE in TREE (destructively).
885 Any element of TREE which matches is changed to NEW (via a call to `setcar'). 876 Any element of TREE which matches is changed to NEW (via a call to `setcar').
886 Keywords supported: :key" 877 Keywords supported: :key"
887 (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) 878 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
888 879
889 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) 880 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
890 "Substitute NEW for elements not matching PREDICATE in TREE (destructively). 881 "Substitute NEW for elements not matching PREDICATE in TREE (destructively).
891 Any element of TREE which matches is changed to NEW (via a call to `setcar'). 882 Any element of TREE which matches is changed to NEW (via a call to `setcar').
892 Keywords supported: :key" 883 Keywords supported: :key"
893 (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) 884 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
894 885
895 (defun sublis (cl-alist cl-tree &rest cl-keys) 886 (defun sublis (cl-alist cl-tree &rest cl-keys)
896 "Perform substitutions indicated by ALIST in TREE (non-destructively). 887 "Perform substitutions indicated by ALIST in TREE (non-destructively).
897 Return a copy of TREE with all matching elements replaced. 888 Return a copy of TREE with all matching elements replaced.
898 Keywords supported: :test :test-not :key" 889 Keywords supported: :test :test-not :key"
950 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) 941 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
951 942
952 943
953 (run-hooks 'cl-seq-load-hook) 944 (run-hooks 'cl-seq-load-hook)
954 945
946 ;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c
955 ;;; cl-seq.el ends here 947 ;;; cl-seq.el ends here