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