cgit.sxemacs.org Git - sxemacs/blob - lisp/cl-seq.el

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