lisp/emacs-lisp/cl-seq.el

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