home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / browser2.zip / cl-seq.el < prev    next >
Lisp/Scheme  |  1995-02-10  |  39KB  |  921 lines
  1. ;; cl-seq.el --- Common Lisp extensions for GNU Emacs Lisp (part three)
  2.  
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Dave Gillespie <daveg@synaptics.com>
  6. ;; Version: 2.02
  7. ;; Keywords: extensions
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 1, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;; Commentary:
  26.  
  27. ;; These are extensions to Emacs Lisp that provide a degree of
  28. ;; Common Lisp compatibility, beyond what is already built-in
  29. ;; in Emacs Lisp.
  30. ;;
  31. ;; This package was written by Dave Gillespie; it is a complete
  32. ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
  33. ;;
  34. ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
  35. ;;
  36. ;; Bug reports, comments, and suggestions are welcome!
  37.  
  38. ;; This file contains the Common Lisp sequence and list functions
  39. ;; which take keyword arguments.
  40.  
  41. ;; See cl.el for Change Log.
  42.  
  43.  
  44. ;; Code:
  45.  
  46. (or (memq 'cl-19 features)
  47.     (error "Tried to load `cl-seq' before `cl'!"))
  48.  
  49.  
  50. ;;; We define these here so that this file can compile without having
  51. ;;; loaded the cl.el file already.
  52.  
  53. (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
  54. (defmacro cl-pop (place)
  55.   (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
  56.  
  57.  
  58. ;;; Keyword parsing.  This is special-cased here so that we can compile
  59. ;;; this file independent from cl-macs.
  60.  
  61. (defmacro cl-parsing-keywords (kwords other-keys &rest body)
  62.   (cons
  63.    'let*
  64.    (cons (mapcar
  65.       (function
  66.        (lambda (x)
  67.          (let* ((var (if (consp x) (car x) x))
  68.             (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
  69.                              'cl-keys)))))
  70.            (if (eq var ':test-not)
  71.            (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
  72.            (if (eq var ':if-not)
  73.            (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
  74.            (list (intern
  75.               (format "cl-%s" (substring (symbol-name var) 1)))
  76.              (if (consp x) (list 'or mem (car (cdr x))) mem)))))
  77.       kwords)
  78.      (append
  79.       (and (not (eq other-keys t))
  80.            (list
  81.         (list 'let '((cl-keys-temp cl-keys))
  82.               (list 'while 'cl-keys-temp
  83.                 (list 'or (list 'memq '(car cl-keys-temp)
  84.                         (list 'quote
  85.                           (mapcar
  86.                            (function
  87.                             (lambda (x)
  88.                               (if (consp x)
  89.                               (car x) x)))
  90.                            (append kwords
  91.                                other-keys))))
  92.                   '(car (cdr (memq (quote :allow-other-keys)
  93.                            cl-keys)))
  94.                   '(error "Bad keyword argument %s"
  95.                       (car cl-keys-temp)))
  96.                 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
  97.       body))))
  98. (put 'cl-parsing-keywords 'lisp-indent-function 2)
  99. (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
  100.  
  101. (defmacro cl-check-key (x)
  102.   (list 'if 'cl-key (list 'funcall 'cl-key x) x))
  103.  
  104. (defmacro cl-check-test-nokey (item x)
  105.   (list 'cond
  106.     (list 'cl-test
  107.           (list 'eq (list 'not (list 'funcall 'cl-test item x))
  108.             'cl-test-not))
  109.     (list 'cl-if
  110.           (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
  111.     (list 't (list 'if (list 'numberp item)
  112.                (list 'equal item x) (list 'eq item x)))))
  113.  
  114. (defmacro cl-check-test (item x)
  115.   (list 'cl-check-test-nokey item (list 'cl-check-key x)))
  116.  
  117. (defmacro cl-check-match (x y)
  118.   (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
  119.   (list 'if 'cl-test
  120.     (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
  121.     (list 'if (list 'numberp x)
  122.           (list 'equal x y) (list 'eq x y))))
  123.  
  124. (put 'cl-check-key 'edebug-form-spec 'edebug-forms)
  125. (put 'cl-check-test 'edebug-form-spec 'edebug-forms)
  126. (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
  127. (put 'cl-check-match 'edebug-form-spec 'edebug-forms)
  128.  
  129. (defvar cl-test) (defvar cl-test-not)
  130. (defvar cl-if) (defvar cl-if-not)
  131. (defvar cl-key)
  132.  
  133.  
  134. (defun reduce (cl-func cl-seq &rest cl-keys)
  135.   "Reduce two-argument FUNCTION across SEQUENCE.
  136. Keywords supported:  :start :end :from-end :initial-value :key"
  137.   (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
  138.     (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
  139.     (setq cl-seq (subseq cl-seq cl-start cl-end))
  140.     (if cl-from-end (setq cl-seq (nreverse cl-seq)))
  141.     (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value)
  142.               (cl-seq (cl-check-key (cl-pop cl-seq)))
  143.               (t (funcall cl-func)))))
  144.       (if cl-from-end
  145.       (while cl-seq
  146.         (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq))
  147.                     cl-accum)))
  148.     (while cl-seq
  149.       (setq cl-accum (funcall cl-func cl-accum
  150.                   (cl-check-key (cl-pop cl-seq))))))
  151.       cl-accum)))
  152.  
  153. (defun fill (seq item &rest cl-keys)
  154.   "Fill the elements of SEQ with ITEM.
  155. Keywords supported:  :start :end"
  156.   (cl-parsing-keywords ((:start 0) :end) ()
  157.     (if (listp seq)
  158.     (let ((p (nthcdr cl-start seq))
  159.           (n (if cl-end (- cl-end cl-start) 8000000)))
  160.       (while (and p (>= (setq n (1- n)) 0))
  161.         (setcar p item)
  162.         (setq p (cdr p))))
  163.       (or cl-end (setq cl-end (length seq)))
  164.       (if (and (= cl-start 0) (= cl-end (length seq)))
  165.       (fillarray seq item)
  166.     (while (< cl-start cl-end)
  167.       (aset seq cl-start item)
  168.       (setq cl-start (1+ cl-start)))))
  169.     seq))
  170.  
  171. (defun replace (cl-seq1 cl-seq2 &rest cl-keys)
  172.   "Replace the elements of SEQ1 with the elements of SEQ2.
  173. SEQ1 is destructively modified, then returned.
  174. Keywords supported:  :start1 :end1 :start2 :end2"
  175.   (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
  176.     (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
  177.     (or (= cl-start1 cl-start2)
  178.         (let* ((cl-len (length cl-seq1))
  179.            (cl-n (min (- (or cl-end1 cl-len) cl-start1)
  180.                   (- (or cl-end2 cl-len) cl-start2))))
  181.           (while (>= (setq cl-n (1- cl-n)) 0)
  182.         (cl-set-elt cl-seq1 (+ cl-start1 cl-n)
  183.                 (elt cl-seq2 (+ cl-start2 cl-n))))))
  184.       (if (listp cl-seq1)
  185.       (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
  186.         (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000)))
  187.         (if (listp cl-seq2)
  188.         (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
  189.               (cl-n (min cl-n1
  190.                  (if cl-end2 (- cl-end2 cl-start2) 4000000))))
  191.           (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0))
  192.             (setcar cl-p1 (car cl-p2))
  193.             (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
  194.           (setq cl-end2 (min (or cl-end2 (length cl-seq2))
  195.                  (+ cl-start2 cl-n1)))
  196.           (while (and cl-p1 (< cl-start2 cl-end2))
  197.         (setcar cl-p1 (aref cl-seq2 cl-start2))
  198.         (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
  199.     (setq cl-end1 (min (or cl-end1 (length cl-seq1))
  200.                (+ cl-start1 (- (or cl-end2 (length cl-seq2))
  201.                        cl-start2))))
  202.     (if (listp cl-seq2)
  203.         (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
  204.           (while (< cl-start1 cl-end1)
  205.         (aset cl-seq1 cl-start1 (car cl-p2))
  206.         (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
  207.       (while (< cl-start1 cl-end1)
  208.         (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
  209.         (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
  210.     cl-seq1))
  211.  
  212. (defun remove* (cl-item cl-seq &rest cl-keys)
  213.   "Remove all occurrences of ITEM in SEQ.
  214. This is a non-destructive function; it makes a copy of SEQ if necessary
  215. to avoid corrupting the original SEQ.
  216. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  217.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
  218.             (:start 0) :end) ()
  219.     (if (<= (or cl-count (setq cl-count 8000000)) 0)
  220.     cl-seq
  221.       (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
  222.       (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
  223.                    cl-from-end)))
  224.         (if cl-i
  225.         (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
  226.                      (append (if cl-from-end
  227.                          (list ':end (1+ cl-i))
  228.                            (list ':start cl-i))
  229.                          cl-keys))))
  230.           (if (listp cl-seq) cl-res
  231.             (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))
  232.           cl-seq))
  233.     (setq cl-end (- (or cl-end 8000000) cl-start))
  234.     (if (= cl-start 0)
  235.         (while (and cl-seq (> cl-end 0)
  236.             (cl-check-test cl-item (car cl-seq))
  237.             (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
  238.             (> (setq cl-count (1- cl-count)) 0))))
  239.     (if (and (> cl-count 0) (> cl-end 0))
  240.         (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
  241.               (setq cl-end (1- cl-end)) (cdr cl-seq))))
  242.           (while (and cl-p (> cl-end 0)
  243.               (not (cl-check-test cl-item (car cl-p))))
  244.         (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
  245.           (if (and cl-p (> cl-end 0))
  246.           (nconc (ldiff cl-seq cl-p)
  247.              (if (= cl-count 1) (cdr cl-p)
  248.                (and (cdr cl-p)
  249.                 (apply 'delete* cl-item
  250.                        (copy-sequence (cdr cl-p))
  251.                        ':start 0 ':end (1- cl-end)
  252.                        ':count (1- cl-count) cl-keys))))
  253.         cl-seq))
  254.       cl-seq)))))
  255.  
  256. (defun remove-if (cl-pred cl-list &rest cl-keys)
  257.   "Remove all items satisfying PREDICATE in SEQ.
  258. This is a non-destructive function; it makes a copy of SEQ if necessary
  259. to avoid corrupting the original SEQ.
  260. Keywords supported:  :key :count :start :end :from-end"
  261.   (apply 'remove* nil cl-list ':if cl-pred cl-keys))
  262.  
  263. (defun remove-if-not (cl-pred cl-list &rest cl-keys)
  264.   "Remove all items not satisfying PREDICATE in SEQ.
  265. This is a non-destructive function; it makes a copy of SEQ if necessary
  266. to avoid corrupting the original SEQ.
  267. Keywords supported:  :key :count :start :end :from-end"
  268.   (apply 'remove* nil cl-list ':if-not cl-pred cl-keys))
  269.  
  270. (defun delete* (cl-item cl-seq &rest cl-keys)
  271.   "Remove all occurrences of ITEM in SEQ.
  272. This is a destructive function; it reuses the storage of SEQ whenever possible.
  273. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  274.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
  275.             (:start 0) :end) ()
  276.     (if (<= (or cl-count (setq cl-count 8000000)) 0)
  277.     cl-seq
  278.       (if (listp cl-seq)
  279.       (if (and cl-from-end (< cl-count 4000000))
  280.           (let (cl-i)
  281.         (while (and (>= (setq cl-count (1- cl-count)) 0)
  282.                 (setq cl-i (cl-position cl-item cl-seq cl-start
  283.                             cl-end cl-from-end)))
  284.           (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
  285.             (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
  286.               (setcdr cl-tail (cdr (cdr cl-tail)))))
  287.           (setq cl-end cl-i))
  288.         cl-seq)
  289.         (setq cl-end (- (or cl-end 8000000) cl-start))
  290.         (if (= cl-start 0)
  291.         (progn
  292.           (while (and cl-seq
  293.                   (> cl-end 0)
  294.                   (cl-check-test cl-item (car cl-seq))
  295.                   (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
  296.                   (> (setq cl-count (1- cl-count)) 0)))
  297.           (setq cl-end (1- cl-end)))
  298.           (setq cl-start (1- cl-start)))
  299.         (if (and (> cl-count 0) (> cl-end 0))
  300.         (let ((cl-p (nthcdr cl-start cl-seq)))
  301.           (while (and (cdr cl-p) (> cl-end 0))
  302.             (if (cl-check-test cl-item (car (cdr cl-p)))
  303.             (progn
  304.               (setcdr cl-p (cdr (cdr cl-p)))
  305.               (if (= (setq cl-count (1- cl-count)) 0)
  306.                   (setq cl-end 1)))
  307.               (setq cl-p (cdr cl-p)))
  308.             (setq cl-end (1- cl-end)))))
  309.         cl-seq)
  310.     (apply 'remove* cl-item cl-seq cl-keys)))))
  311.  
  312. (defun delete-if (cl-pred cl-list &rest cl-keys)
  313.   "Remove all items satisfying PREDICATE in SEQ.
  314. This is a destructive function; it reuses the storage of SEQ whenever possible.
  315. Keywords supported:  :key :count :start :end :from-end"
  316.   (apply 'delete* nil cl-list ':if cl-pred cl-keys))
  317.  
  318. (defun delete-if-not (cl-pred cl-list &rest cl-keys)
  319.   "Remove all items not satisfying PREDICATE in SEQ.
  320. This is a destructive function; it reuses the storage of SEQ whenever possible.
  321. Keywords supported:  :key :count :start :end :from-end"
  322.   (apply 'delete* nil cl-list ':if-not cl-pred cl-keys))
  323.  
  324. (or (and (fboundp 'delete) (subrp (symbol-function 'delete)))
  325.     (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal)))))
  326. (defun remove (x y) (remove* x y ':test 'equal))
  327. (defun remq (x y) (if (memq x y) (delq x (copy-list y)) y))
  328.  
  329. (defun remove-duplicates (cl-seq &rest cl-keys)
  330.   "Return a copy of SEQ with all duplicate elements removed.
  331. Keywords supported:  :test :test-not :key :start :end :from-end"
  332.   (cl-delete-duplicates cl-seq cl-keys t))
  333.  
  334. (defun delete-duplicates (cl-seq &rest cl-keys)
  335.   "Remove all duplicate elements from SEQ (destructively).
  336. Keywords supported:  :test :test-not :key :start :end :from-end"
  337.   (cl-delete-duplicates cl-seq cl-keys nil))
  338.  
  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)
  342.       ()
  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))
  368.           (progn
  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)))))
  378.  
  379. (defun substitute (cl-new cl-old cl-seq &rest cl-keys)
  380.   "Substitute NEW for OLD in SEQ.
  381. This is a non-destructive function; it makes a copy of SEQ if necessary
  382. to avoid corrupting the original SEQ.
  383. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  384.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count
  385.             (:start 0) :end :from-end) ()
  386.     (if (or (eq cl-old cl-new)
  387.         (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
  388.     cl-seq
  389.       (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end)))
  390.     (if (not cl-i)
  391.         cl-seq
  392.       (setq cl-seq (copy-sequence cl-seq))
  393.       (or cl-from-end
  394.           (progn (cl-set-elt cl-seq cl-i cl-new)
  395.              (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
  396.       (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count
  397.          ':start cl-i cl-keys))))))
  398.  
  399. (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
  400.   "Substitute NEW for all items satisfying PREDICATE in SEQ.
  401. This is a non-destructive function; it makes a copy of SEQ if necessary
  402. to avoid corrupting the original SEQ.
  403. Keywords supported:  :key :count :start :end :from-end"
  404.   (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys))
  405.  
  406. (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
  407.   "Substitute NEW for all items not satisfying PREDICATE in SEQ.
  408. This is a non-destructive function; it makes a copy of SEQ if necessary
  409. to avoid corrupting the original SEQ.
  410. Keywords supported:  :key :count :start :end :from-end"
  411.   (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys))
  412.  
  413. (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
  414.   "Substitute NEW for OLD in SEQ.
  415. This is a destructive function; it reuses the storage of SEQ whenever possible.
  416. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  417.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count
  418.             (:start 0) :end :from-end) ()
  419.     (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
  420.     (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
  421.         (let ((cl-p (nthcdr cl-start cl-seq)))
  422.           (setq cl-end (- (or cl-end 8000000) cl-start))
  423.           (while (and cl-p (> cl-end 0) (> cl-count 0))
  424.         (if (cl-check-test cl-old (car cl-p))
  425.             (progn
  426.               (setcar cl-p cl-new)
  427.               (setq cl-count (1- cl-count))))
  428.         (setq cl-p (cdr cl-p) cl-end (1- cl-end))))
  429.       (or cl-end (setq cl-end (length cl-seq)))
  430.       (if cl-from-end
  431.           (while (and (< cl-start cl-end) (> cl-count 0))
  432.         (setq cl-end (1- cl-end))
  433.         (if (cl-check-test cl-old (elt cl-seq cl-end))
  434.             (progn
  435.               (cl-set-elt cl-seq cl-end cl-new)
  436.               (setq cl-count (1- cl-count)))))
  437.         (while (and (< cl-start cl-end) (> cl-count 0))
  438.           (if (cl-check-test cl-old (aref cl-seq cl-start))
  439.           (progn
  440.             (aset cl-seq cl-start cl-new)
  441.             (setq cl-count (1- cl-count))))
  442.           (setq cl-start (1+ cl-start))))))
  443.     cl-seq))
  444.  
  445. (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
  446.   "Substitute NEW for all items satisfying PREDICATE in SEQ.
  447. This is a destructive function; it reuses the storage of SEQ whenever possible.
  448. Keywords supported:  :key :count :start :end :from-end"
  449.   (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys))
  450.  
  451. (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
  452.   "Substitute NEW for all items not satisfying PREDICATE in SEQ.
  453. This is a destructive function; it reuses the storage of SEQ whenever possible.
  454. Keywords supported:  :key :count :start :end :from-end"
  455.   (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys))
  456.  
  457. (defun find (cl-item cl-seq &rest cl-keys)
  458.   "Find the first occurrence of ITEM in LIST.
  459. Return the matching ITEM, or nil if not found.
  460. Keywords supported:  :test :test-not :key :start :end :from-end"
  461.   (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
  462.     (and cl-pos (elt cl-seq cl-pos))))
  463.  
  464. (defun find-if (cl-pred cl-list &rest cl-keys)
  465.   "Find the first item satisfying PREDICATE in LIST.
  466. Return the matching ITEM, or nil if not found.
  467. Keywords supported:  :key :start :end :from-end"
  468.   (apply 'find nil cl-list ':if cl-pred cl-keys))
  469.  
  470. (defun find-if-not (cl-pred cl-list &rest cl-keys)
  471.   "Find the first item not satisfying PREDICATE in LIST.
  472. Return the matching ITEM, or nil if not found.
  473. Keywords supported:  :key :start :end :from-end"
  474.   (apply 'find nil cl-list ':if-not cl-pred cl-keys))
  475.  
  476. (defun position (cl-item cl-seq &rest cl-keys)
  477.   "Find the first occurrence of ITEM in LIST.
  478. Return the index of the matching item, or nil if not found.
  479. Keywords supported:  :test :test-not :key :start :end :from-end"
  480.   (cl-parsing-keywords (:test :test-not :key :if :if-not
  481.             (:start 0) :end :from-end) ()
  482.     (cl-position cl-item cl-seq cl-start cl-end cl-from-end)))
  483.  
  484. (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
  485.   (if (listp cl-seq)
  486.       (let ((cl-p (nthcdr cl-start cl-seq)))
  487.     (or cl-end (setq cl-end 8000000))
  488.     (let ((cl-res nil))
  489.       (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
  490.         (if (cl-check-test cl-item (car cl-p))
  491.         (setq cl-res cl-start))
  492.         (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
  493.       cl-res))
  494.     (or cl-end (setq cl-end (length cl-seq)))
  495.     (if cl-from-end
  496.     (progn
  497.       (while (and (>= (setq cl-end (1- cl-end)) cl-start)
  498.               (not (cl-check-test cl-item (aref cl-seq cl-end)))))
  499.       (and (>= cl-end cl-start) cl-end))
  500.       (while (and (< cl-start cl-end)
  501.           (not (cl-check-test cl-item (aref cl-seq cl-start))))
  502.     (setq cl-start (1+ cl-start)))
  503.       (and (< cl-start cl-end) cl-start))))
  504.  
  505. (defun position-if (cl-pred cl-list &rest cl-keys)
  506.   "Find the first item satisfying PREDICATE in LIST.
  507. Return the index of the matching item, or nil if not found.
  508. Keywords supported:  :key :start :end :from-end"
  509.   (apply 'position nil cl-list ':if cl-pred cl-keys))
  510.  
  511. (defun position-if-not (cl-pred cl-list &rest cl-keys)
  512.   "Find the first item not satisfying PREDICATE in LIST.
  513. Return the index of the matching item, or nil if not found.
  514. Keywords supported:  :key :start :end :from-end"
  515.   (apply 'position nil cl-list ':if-not cl-pred cl-keys))
  516.  
  517. (defun count (cl-item cl-seq &rest cl-keys)
  518.   "Count the number of occurrences of ITEM in LIST.
  519. Keywords supported:  :test :test-not :key :start :end"
  520.   (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
  521.     (let ((cl-count 0) cl-x)
  522.       (or cl-end (setq cl-end (length cl-seq)))
  523.       (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
  524.       (while (< cl-start cl-end)
  525.     (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start)))
  526.     (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
  527.     (setq cl-start (1+ cl-start)))
  528.       cl-count)))
  529.  
  530. (defun count-if (cl-pred cl-list &rest cl-keys)
  531.   "Count the number of items satisfying PREDICATE in LIST.
  532. Keywords supported:  :key :start :end"
  533.   (apply 'count nil cl-list ':if cl-pred cl-keys))
  534.  
  535. (defun count-if-not (cl-pred cl-list &rest cl-keys)
  536.   "Count the number of items not satisfying PREDICATE in LIST.
  537. Keywords supported:  :key :start :end"
  538.   (apply 'count nil cl-list ':if-not cl-pred cl-keys))
  539.  
  540. (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
  541.   "Compare SEQ1 with SEQ2, return index of first mismatching element.
  542. Return nil if the sequences match.  If one sequence is a prefix of the
  543. other, the return value indicates the end of the shorted sequence.
  544. Keywords supported:  :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
  545.   (cl-parsing-keywords (:test :test-not :key :from-end
  546.             (:start1 0) :end1 (:start2 0) :end2) ()
  547.     (or cl-end1 (setq cl-end1 (length cl-seq1)))
  548.     (or cl-end2 (setq cl-end2 (length cl-seq2)))
  549.     (if cl-from-end
  550.     (progn
  551.       (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
  552.               (cl-check-match (elt cl-seq1 (1- cl-end1))
  553.                       (elt cl-seq2 (1- cl-end2))))
  554.         (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
  555.       (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
  556.            (1- cl-end1)))
  557.       (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
  558.         (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
  559.     (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
  560.             (cl-check-match (if cl-p1 (car cl-p1)
  561.                       (aref cl-seq1 cl-start1))
  562.                     (if cl-p2 (car cl-p2)
  563.                       (aref cl-seq2 cl-start2))))
  564.       (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
  565.         cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
  566.     (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
  567.          cl-start1)))))
  568.  
  569. (defun search (cl-seq1 cl-seq2 &rest cl-keys)
  570.   "Search for SEQ1 as a subsequence of SEQ2.
  571. Return the index of the leftmost element of the first match found;
  572. return nil if there are no matches.
  573. Keywords supported:  :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
  574.   (cl-parsing-keywords (:test :test-not :key :from-end
  575.             (:start1 0) :end1 (:start2 0) :end2) ()
  576.     (or cl-end1 (setq cl-end1 (length cl-seq1)))
  577.     (or cl-end2 (setq cl-end2 (length cl-seq2)))
  578.     (if (>= cl-start1 cl-end1)
  579.     (if cl-from-end cl-end2 cl-start2)
  580.       (let* ((cl-len (- cl-end1 cl-start1))
  581.          (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
  582.          (cl-if nil) cl-pos)
  583.     (setq cl-end2 (- cl-end2 (1- cl-len)))
  584.     (while (and (< cl-start2 cl-end2)
  585.             (setq cl-pos (cl-position cl-first cl-seq2
  586.                           cl-start2 cl-end2 cl-from-end))
  587.             (apply 'mismatch cl-seq1 cl-seq2
  588.                ':start1 (1+ cl-start1) ':end1 cl-end1
  589.                ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len)
  590.                ':from-end nil cl-keys))
  591.       (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
  592.     (and (< cl-start2 cl-end2) cl-pos)))))
  593.  
  594. (defun sort* (cl-seq cl-pred &rest cl-keys)
  595.   "Sort the argument SEQUENCE according to PREDICATE.
  596. This is a destructive function; it reuses the storage of SEQUENCE if possible.
  597. Keywords supported:  :key"
  598.   (if (nlistp cl-seq)
  599.       (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
  600.     (cl-parsing-keywords (:key) ()
  601.       (if (memq cl-key '(nil identity))
  602.       (sort cl-seq cl-pred)
  603.     (sort cl-seq (function (lambda (cl-x cl-y)
  604.                  (funcall cl-pred (funcall cl-key cl-x)
  605.                       (funcall cl-key cl-y)))))))))
  606.  
  607. (defun stable-sort (cl-seq cl-pred &rest cl-keys)
  608.   "Sort the argument SEQUENCE stably according to PREDICATE.
  609. This is a destructive function; it reuses the storage of SEQUENCE if possible.
  610. Keywords supported:  :key"
  611.   (apply 'sort* cl-seq cl-pred cl-keys))
  612.  
  613. (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
  614.   "Destructively merge the two sequences to produce a new sequence.
  615. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two
  616. argument sequences, and PRED is a `less-than' predicate on the elements.
  617. Keywords supported:  :key"
  618.   (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil)))
  619.   (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil)))
  620.   (cl-parsing-keywords (:key) ()
  621.     (let ((cl-res nil))
  622.       (while (and cl-seq1 cl-seq2)
  623.     (if (funcall cl-pred (cl-check-key (car cl-seq2))
  624.              (cl-check-key (car cl-seq1)))
  625.         (cl-push (cl-pop cl-seq2) cl-res)
  626.       (cl-push (cl-pop cl-seq1) cl-res)))
  627.       (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
  628.  
  629. ;;; See compiler macro in cl-macs.el
  630. (defun member* (cl-item cl-list &rest cl-keys)
  631.   "Find the first occurrence of ITEM in LIST.
  632. Return the sublist of LIST whose car is ITEM.
  633. Keywords supported:  :test :test-not :key"
  634.   (if cl-keys
  635.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  636.     (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
  637.       (setq cl-list (cdr cl-list)))
  638.     cl-list)
  639.     (if (and (numberp cl-item) (not (integerp cl-item)))
  640.     (member cl-item cl-list)
  641.       (memq cl-item cl-list))))
  642.  
  643. (defun member-if (cl-pred cl-list &rest cl-keys)
  644.   "Find the first item satisfying PREDICATE in LIST.
  645. Return the sublist of LIST whose car matches.
  646. Keywords supported:  :key"
  647.   (apply 'member* nil cl-list ':if cl-pred cl-keys))
  648.  
  649. (defun member-if-not (cl-pred cl-list &rest cl-keys)
  650.   "Find the first item not satisfying PREDICATE in LIST.
  651. Return the sublist of LIST whose car matches.
  652. Keywords supported:  :key"
  653.   (apply 'member* nil cl-list ':if-not cl-pred cl-keys))
  654.  
  655. (defun cl-adjoin (cl-item cl-list &rest cl-keys)
  656.   (if (cl-parsing-keywords (:key) t
  657.     (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
  658.       cl-list
  659.     (cons cl-item cl-list)))
  660.  
  661. ;;; See compiler macro in cl-macs.el
  662. (defun assoc* (cl-item cl-alist &rest cl-keys)
  663.   "Find the first item whose car matches ITEM in LIST.
  664. Keywords supported:  :test :test-not :key"
  665.   (if cl-keys
  666.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  667.     (while (and cl-alist
  668.             (or (not (consp (car cl-alist)))
  669.             (not (cl-check-test cl-item (car (car cl-alist))))))
  670.       (setq cl-alist (cdr cl-alist)))
  671.     (and cl-alist (car cl-alist)))
  672.     (if (and (numberp cl-item) (not (integerp cl-item)))
  673.     (assoc cl-item cl-alist)
  674.       (assq cl-item cl-alist))))
  675.  
  676. (defun assoc-if (cl-pred cl-list &rest cl-keys)
  677.   "Find the first item whose car satisfies PREDICATE in LIST.
  678. Keywords supported:  :key"
  679.   (apply 'assoc* nil cl-list ':if cl-pred cl-keys))
  680.  
  681. (defun assoc-if-not (cl-pred cl-list &rest cl-keys)
  682.   "Find the first item whose car does not satisfy PREDICATE in LIST.
  683. Keywords supported:  :key"
  684.   (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys))
  685.  
  686. (defun rassoc* (cl-item cl-alist &rest cl-keys)
  687.   "Find the first item whose cdr matches ITEM in LIST.
  688. Keywords supported:  :test :test-not :key"
  689.   (if (or cl-keys (numberp cl-item))
  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 (cdr (car cl-alist))))))
  694.       (setq cl-alist (cdr cl-alist)))
  695.     (and cl-alist (car cl-alist)))
  696.     (rassq cl-item cl-alist)))
  697.  
  698. (defun rassoc (item alist) (rassoc* item alist ':test 'equal))
  699.  
  700. (defun rassoc-if (cl-pred cl-list &rest cl-keys)
  701.   "Find the first item whose cdr satisfies PREDICATE in LIST.
  702. Keywords supported:  :key"
  703.   (apply 'rassoc* nil cl-list ':if cl-pred cl-keys))
  704.  
  705. (defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
  706.   "Find the first item whose cdr does not satisfy PREDICATE in LIST.
  707. Keywords supported:  :key"
  708.   (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys))
  709.  
  710. (defun union (cl-list1 cl-list2 &rest cl-keys)
  711.   "Combine LIST1 and LIST2 using a set-union operation.
  712. The result list contains all items that appear in either LIST1 or LIST2.
  713. This is a non-destructive function; it makes a copy of the data if necessary
  714. to avoid corrupting the original LIST1 and LIST2.
  715. Keywords supported:  :test :test-not :key"
  716.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  717.     ((equal cl-list1 cl-list2) cl-list1)
  718.     (t
  719.      (or (>= (length cl-list1) (length cl-list2))
  720.          (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
  721.      (while cl-list2
  722.        (if (or cl-keys (numberp (car cl-list2)))
  723.            (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
  724.          (or (memq (car cl-list2) cl-list1)
  725.          (cl-push (car cl-list2) cl-list1)))
  726.        (cl-pop cl-list2))
  727.      cl-list1)))
  728.  
  729. (defun nunion (cl-list1 cl-list2 &rest cl-keys)
  730.   "Combine LIST1 and LIST2 using a set-union operation.
  731. The result list contains all items that appear in either LIST1 or LIST2.
  732. This is a destructive function; it reuses the storage of LIST1 and LIST2
  733. whenever possible.
  734. Keywords supported:  :test :test-not :key"
  735.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  736.     (t (apply 'union cl-list1 cl-list2 cl-keys))))
  737.  
  738. (defun intersection (cl-list1 cl-list2 &rest cl-keys)
  739.   "Combine LIST1 and LIST2 using a set-intersection operation.
  740. The result list contains all items that appear in both LIST1 and LIST2.
  741. This is a non-destructive function; it makes a copy of the data if necessary
  742. to avoid corrupting the original LIST1 and LIST2.
  743. Keywords supported:  :test :test-not :key"
  744.   (and cl-list1 cl-list2
  745.        (if (equal cl-list1 cl-list2) cl-list1
  746.      (cl-parsing-keywords (:key) (:test :test-not)
  747.        (let ((cl-res nil))
  748.          (or (>= (length cl-list1) (length cl-list2))
  749.          (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
  750.          (while cl-list2
  751.            (if (if (or cl-keys (numberp (car cl-list2)))
  752.                (apply 'member* (cl-check-key (car cl-list2))
  753.                   cl-list1 cl-keys)
  754.              (memq (car cl-list2) cl-list1))
  755.            (cl-push (car cl-list2) cl-res))
  756.            (cl-pop cl-list2))
  757.          cl-res)))))
  758.  
  759. (defun nintersection (cl-list1 cl-list2 &rest cl-keys)
  760.   "Combine LIST1 and LIST2 using a set-intersection operation.
  761. The result list contains all items that appear in both LIST1 and LIST2.
  762. This is a destructive function; it reuses the storage of LIST1 and LIST2
  763. whenever possible.
  764. Keywords supported:  :test :test-not :key"
  765.   (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
  766.  
  767. (defun set-difference (cl-list1 cl-list2 &rest cl-keys)
  768.   "Combine LIST1 and LIST2 using a set-difference operation.
  769. The result list contains all items that appear in LIST1 but not LIST2.
  770. This is a non-destructive function; it makes a copy of the data if necessary
  771. to avoid corrupting the original LIST1 and LIST2.
  772. Keywords supported:  :test :test-not :key"
  773.   (if (or (null cl-list1) (null cl-list2)) cl-list1
  774.     (cl-parsing-keywords (:key) (:test :test-not)
  775.       (let ((cl-res nil))
  776.     (while cl-list1
  777.       (or (if (or cl-keys (numberp (car cl-list1)))
  778.           (apply 'member* (cl-check-key (car cl-list1))
  779.              cl-list2 cl-keys)
  780.         (memq (car cl-list1) cl-list2))
  781.           (cl-push (car cl-list1) cl-res))
  782.       (cl-pop cl-list1))
  783.     cl-res))))
  784.  
  785. (defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
  786.   "Combine LIST1 and LIST2 using a set-difference operation.
  787. The result list contains all items that appear in LIST1 but not LIST2.
  788. This is a destructive function; it reuses the storage of LIST1 and LIST2
  789. whenever possible.
  790. Keywords supported:  :test :test-not :key"
  791.   (if (or (null cl-list1) (null cl-list2)) cl-list1
  792.     (apply 'set-difference cl-list1 cl-list2 cl-keys)))
  793.  
  794. (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
  795.   "Combine LIST1 and LIST2 using a set-exclusive-or operation.
  796. The result list contains all items that appear in exactly one of LIST1, LIST2.
  797. This is a non-destructive function; it makes a copy of the data if necessary
  798. to avoid corrupting the original LIST1 and LIST2.
  799. Keywords supported:  :test :test-not :key"
  800.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  801.     ((equal cl-list1 cl-list2) nil)
  802.     (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
  803.            (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
  804.  
  805. (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
  806.   "Combine LIST1 and LIST2 using a set-exclusive-or operation.
  807. The result list contains all items that appear in exactly one of LIST1, LIST2.
  808. This is a destructive function; it reuses the storage of LIST1 and LIST2
  809. whenever possible.
  810. Keywords supported:  :test :test-not :key"
  811.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  812.     ((equal cl-list1 cl-list2) nil)
  813.     (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
  814.           (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
  815.  
  816. (defun subsetp (cl-list1 cl-list2 &rest cl-keys)
  817.   "True if LIST1 is a subset of LIST2.
  818. I.e., if every element of LIST1 also appears in LIST2.
  819. Keywords supported:  :test :test-not :key"
  820.   (cond ((null cl-list1) t) ((null cl-list2) nil)
  821.     ((equal cl-list1 cl-list2) t)
  822.     (t (cl-parsing-keywords (:key) (:test :test-not)
  823.          (while (and cl-list1
  824.              (apply 'member* (cl-check-key (car cl-list1))
  825.                 cl-list2 cl-keys))
  826.            (cl-pop cl-list1))
  827.          (null cl-list1)))))
  828.  
  829. (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
  830.   "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
  831. Return a copy of TREE with all matching elements replaced by NEW.
  832. Keywords supported:  :key"
  833.   (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
  834.  
  835. (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
  836.   "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
  837. Return a copy of TREE with all non-matching elements replaced by NEW.
  838. Keywords supported:  :key"
  839.   (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
  840.  
  841. (defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
  842.   "Substitute NEW for OLD everywhere in TREE (destructively).
  843. Any element of TREE which is `eql' to OLD is changed to NEW (via a call
  844. to `setcar').
  845. Keywords supported:  :test :test-not :key"
  846.   (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
  847.  
  848. (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
  849.   "Substitute NEW for elements matching PREDICATE in TREE (destructively).
  850. Any element of TREE which matches is changed to NEW (via a call to `setcar').
  851. Keywords supported:  :key"
  852.   (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
  853.  
  854. (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
  855.   "Substitute NEW for elements not matching PREDICATE in TREE (destructively).
  856. Any element of TREE which matches is changed to NEW (via a call to `setcar').
  857. Keywords supported:  :key"
  858.   (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
  859.  
  860. (defun sublis (cl-alist cl-tree &rest cl-keys)
  861.   "Perform substitutions indicated by ALIST in TREE (non-destructively).
  862. Return a copy of TREE with all matching elements replaced.
  863. Keywords supported:  :test :test-not :key"
  864.   (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  865.     (cl-sublis-rec cl-tree)))
  866.  
  867. (defvar cl-alist)
  868. (defun cl-sublis-rec (cl-tree)   ; uses cl-alist/key/test*/if*
  869.   (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
  870.     (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  871.       (setq cl-p (cdr cl-p)))
  872.     (if cl-p (cdr (car cl-p))
  873.       (if (consp cl-tree)
  874.       (let ((cl-a (cl-sublis-rec (car cl-tree)))
  875.         (cl-d (cl-sublis-rec (cdr cl-tree))))
  876.         (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
  877.         cl-tree
  878.           (cons cl-a cl-d)))
  879.     cl-tree))))
  880.  
  881. (defun nsublis (cl-alist cl-tree &rest cl-keys)
  882.   "Perform substitutions indicated by ALIST in TREE (destructively).
  883. Any matching element of TREE is changed via a call to `setcar'.
  884. Keywords supported:  :test :test-not :key"
  885.   (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  886.     (let ((cl-hold (list cl-tree)))
  887.       (cl-nsublis-rec cl-hold)
  888.       (car cl-hold))))
  889.  
  890. (defun cl-nsublis-rec (cl-tree)   ; uses cl-alist/temp/p/key/test*/if*
  891.   (while (consp cl-tree)
  892.     (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
  893.       (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  894.     (setq cl-p (cdr cl-p)))
  895.       (if cl-p (setcar cl-tree (cdr (car cl-p)))
  896.     (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
  897.       (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
  898.       (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  899.     (setq cl-p (cdr cl-p)))
  900.       (if cl-p
  901.       (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
  902.     (setq cl-tree (cdr cl-tree))))))
  903.  
  904. (defun tree-equal (cl-x cl-y &rest cl-keys)
  905.   "T if trees X and Y have `eql' leaves.
  906. Atoms are compared by `eql'; cons cells are compared recursively.
  907. Keywords supported:  :test :test-not :key"
  908.   (cl-parsing-keywords (:test :test-not :key) ()
  909.     (cl-tree-equal-rec cl-x cl-y)))
  910.  
  911. (defun cl-tree-equal-rec (cl-x cl-y)
  912.   (while (and (consp cl-x) (consp cl-y)
  913.           (cl-tree-equal-rec (car cl-x) (car cl-y)))
  914.     (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
  915.   (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
  916.  
  917.  
  918. (run-hooks 'cl-seq-load-hook)
  919.  
  920. ;;; cl-seq.el ends here
  921.