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