Mercurial > hg > xemacs-beta
annotate lisp/cl-seq.el @ 5086:47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
2010-03-02 Aidan Kehoe <kehoea@parhasard.net>
* eval.c (print_multiple_value):
Say #<INTERNAL OBJECT (XEmacs bug?) ...> when printing these, for
consistency with the rest of the print code.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Tue, 02 Mar 2010 13:20:51 +0000 |
| parents | 6afe991b8135 |
| children | 2e528066e2fc |
| rev | line source |
|---|---|
| 613 | 1 ;;; cl-seq.el --- Common Lisp extensions for XEmacs Lisp (part three) |
| 428 | 2 |
| 3 ;; Copyright (C) 1993 Free Software Foundation, Inc. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
4 ;; Copyright (C) 2010 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Dave Gillespie <daveg@synaptics.com> | |
| 7 ;; Maintainer: XEmacs Development Team | |
| 8 ;; Version: 2.02 | |
| 9 ;; Keywords: extensions, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
| 13 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 14 ;; under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 21 ;; General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 26 ;; 02111-1307, USA. | |
| 27 | |
| 2153 | 28 ;;; Synched up with: FSF 21.3. |
| 428 | 29 |
| 30 ;;; Commentary: | |
| 31 | |
| 32 ;; This file is dumped with XEmacs. | |
| 33 | |
| 34 ;; These are extensions to Emacs Lisp that provide a degree of | |
| 35 ;; Common Lisp compatibility, beyond what is already built-in | |
| 36 ;; in Emacs Lisp. | |
| 37 ;; | |
| 38 ;; This package was written by Dave Gillespie; it is a complete | |
| 39 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
| 40 ;; | |
| 41 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. | |
| 42 ;; | |
| 43 ;; Bug reports, comments, and suggestions are welcome! | |
| 44 | |
| 45 ;; This file contains the Common Lisp sequence and list functions | |
| 46 ;; which take keyword arguments. | |
| 47 | |
| 48 ;; See cl.el for Change Log. | |
| 49 | |
| 50 | |
| 51 ;;; Code: | |
| 52 | |
| 53 (or (memq 'cl-19 features) | |
| 54 (error "Tried to load `cl-seq' before `cl'!")) | |
| 55 | |
| 56 | |
| 57 ;;; Keyword parsing. This is special-cased here so that we can compile | |
| 58 ;;; this file independent from cl-macs. | |
| 59 | |
| 60 (defmacro cl-parsing-keywords (kwords other-keys &rest body) | |
| 442 | 61 "Helper macro for functions with keyword arguments. |
| 62 This is a temporary solution, until keyword arguments are natively supported. | |
| 63 Declare your function ending with (... &rest cl-keys), then wrap the | |
| 64 function body in a call to `cl-parsing-keywords'. | |
| 65 | |
| 66 KWORDS is a list of keyword definitions. Each definition should be | |
| 67 either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case, | |
| 68 the default value is nil. The keywords are available in BODY as the name | |
| 69 of the keyword, minus its initial colon and prepended with `cl-'. | |
| 70 | |
| 71 OTHER-KEYS specifies other keywords that are accepted but ignored. It | |
| 72 is either the value 't' (ignore all other keys, equivalent to the | |
| 73 &allow-other-keys argument declaration in Common Lisp) or a list in the | |
| 74 same format as KWORDS. If keywords are given that are not in KWORDS | |
| 75 and not allowed by OTHER-KEYS, an error will normally be signalled; but | |
| 76 the caller can override this by specifying a non-nil value for the | |
| 77 keyword :allow-other-keys (which defaults to t)." | |
| 428 | 78 (cons |
| 79 'let* | |
| 80 (cons (mapcar | |
| 81 (function | |
| 82 (lambda (x) | |
| 83 (let* ((var (if (consp x) (car x) x)) | |
| 84 (mem (list 'car (list 'cdr (list 'memq (list 'quote var) | |
| 85 'cl-keys))))) | |
| 2153 | 86 (if (eq var :test-not) |
| 428 | 87 (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) |
| 2153 | 88 (if (eq var :if-not) |
| 428 | 89 (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) |
| 90 (list (intern | |
| 91 (format "cl-%s" (substring (symbol-name var) 1))) | |
| 92 (if (consp x) (list 'or mem (car (cdr x))) mem))))) | |
| 93 kwords) | |
| 94 (append | |
| 95 (and (not (eq other-keys t)) | |
| 96 (list | |
| 97 (list 'let '((cl-keys-temp cl-keys)) | |
| 98 (list 'while 'cl-keys-temp | |
| 99 (list 'or (list 'memq '(car cl-keys-temp) | |
| 100 (list 'quote | |
| 101 (mapcar | |
| 102 (function | |
| 103 (lambda (x) | |
| 104 (if (consp x) | |
| 105 (car x) x))) | |
| 106 (append kwords | |
| 107 other-keys)))) | |
| 108 '(car (cdr (memq (quote :allow-other-keys) | |
| 109 cl-keys))) | |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5067
diff
changeset
|
110 '(error 'invalid-keyword-argument |
| 428 | 111 (car cl-keys-temp))) |
| 112 '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) | |
| 113 body)))) | |
| 114 (put 'cl-parsing-keywords 'lisp-indent-function 2) | |
| 115 (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) | |
| 116 | |
| 117 (defmacro cl-check-key (x) | |
| 118 (list 'if 'cl-key (list 'funcall 'cl-key x) x)) | |
| 119 | |
| 120 (defmacro cl-check-test-nokey (item x) | |
| 121 (list 'cond | |
| 122 (list 'cl-test | |
| 123 (list 'eq (list 'not (list 'funcall 'cl-test item x)) | |
| 124 'cl-test-not)) | |
| 125 (list 'cl-if | |
| 126 (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) | |
| 127 (list 't (list 'if (list 'numberp item) | |
| 128 (list 'equal item x) (list 'eq item x))))) | |
| 129 | |
| 130 (defmacro cl-check-test (item x) | |
| 131 (list 'cl-check-test-nokey item (list 'cl-check-key x))) | |
| 132 | |
| 133 (defmacro cl-check-match (x y) | |
| 134 (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) | |
| 135 (list 'if 'cl-test | |
| 136 (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) | |
| 137 (list 'if (list 'numberp x) | |
| 138 (list 'equal x y) (list 'eq x y)))) | |
| 139 | |
| 140 (put 'cl-check-key 'edebug-form-spec 'edebug-forms) | |
| 141 (put 'cl-check-test 'edebug-form-spec 'edebug-forms) | |
| 142 (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) | |
| 143 (put 'cl-check-match 'edebug-form-spec 'edebug-forms) | |
| 144 | |
| 145 (defvar cl-test) (defvar cl-test-not) | |
| 146 (defvar cl-if) (defvar cl-if-not) | |
| 147 (defvar cl-key) | |
| 148 | |
| 149 | |
| 150 (defun reduce (cl-func cl-seq &rest cl-keys) | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
151 "Combine the elements of sequence using FUNCTION, a binary operation. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
152 For example, `(reduce #'+ SEQUENCE)' returns the sum of all elements in |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
153 SEQUENCE, and `(reduce #'union SEQUENCE)' returns the union of all elements |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
154 in SEQUENCE. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
155 Keywords supported: :start :end :from-end :initial-value :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
156 See `remove*' for the meaning of :start, :end, :from-end and :key. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
157 :initial-value specifies an element (typically an identity element, such as 0) |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
158 that is conceptually prepended to the sequence (or appended, when :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
159 is given). |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
160 If the sequence has one element, that element is returned directly. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
161 If the sequence has no elements, :initial-value is returned if given; |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
162 otherwise, FUNCTION is called with no arguments, and its result returned." |
| 428 | 163 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () |
| 164 (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) | |
| 165 (setq cl-seq (subseq cl-seq cl-start cl-end)) | |
| 166 (if cl-from-end (setq cl-seq (nreverse cl-seq))) | |
| 2153 | 167 (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) |
| 168 (cl-seq (cl-check-key (pop cl-seq))) | |
| 428 | 169 (t (funcall cl-func))))) |
| 170 (if cl-from-end | |
| 171 (while cl-seq | |
| 2153 | 172 (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq)) |
| 428 | 173 cl-accum))) |
| 174 (while cl-seq | |
| 175 (setq cl-accum (funcall cl-func cl-accum | |
| 2153 | 176 (cl-check-key (pop cl-seq)))))) |
| 428 | 177 cl-accum))) |
| 178 | |
| 179 (defun fill (seq item &rest cl-keys) | |
| 180 "Fill the elements of SEQ with ITEM. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
181 Keywords supported: :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
182 :start and :end specify a subsequence of SEQ; see `remove*' for more |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
183 information." |
| 428 | 184 (cl-parsing-keywords ((:start 0) :end) () |
| 185 (if (listp seq) | |
| 186 (let ((p (nthcdr cl-start seq)) | |
| 187 (n (if cl-end (- cl-end cl-start) 8000000))) | |
| 188 (while (and p (>= (setq n (1- n)) 0)) | |
| 189 (setcar p item) | |
| 190 (setq p (cdr p)))) | |
| 191 (or cl-end (setq cl-end (length seq))) | |
| 192 (if (and (= cl-start 0) (= cl-end (length seq))) | |
| 193 (fillarray seq item) | |
| 194 (while (< cl-start cl-end) | |
| 195 (aset seq cl-start item) | |
| 196 (setq cl-start (1+ cl-start))))) | |
| 197 seq)) | |
| 198 | |
| 199 (defun replace (cl-seq1 cl-seq2 &rest cl-keys) | |
| 200 "Replace the elements of SEQ1 with the elements of SEQ2. | |
| 201 SEQ1 is destructively modified, then returned. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
202 Keywords supported: :start1 :end1 :start2 :end2 |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
203 :start1 and :end1 specify a subsequence of SEQ1, and :start2 and :end2 a |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
204 subsequence of SEQ2; see `search' for more information." |
| 428 | 205 (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () |
| 206 (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) | |
| 207 (or (= cl-start1 cl-start2) | |
| 208 (let* ((cl-len (length cl-seq1)) | |
| 209 (cl-n (min (- (or cl-end1 cl-len) cl-start1) | |
| 210 (- (or cl-end2 cl-len) cl-start2)))) | |
| 211 (while (>= (setq cl-n (1- cl-n)) 0) | |
| 212 (cl-set-elt cl-seq1 (+ cl-start1 cl-n) | |
| 213 (elt cl-seq2 (+ cl-start2 cl-n)))))) | |
| 214 (if (listp cl-seq1) | |
| 215 (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) | |
| 216 (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) | |
| 217 (if (listp cl-seq2) | |
| 218 (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) | |
| 219 (cl-n (min cl-n1 | |
| 220 (if cl-end2 (- cl-end2 cl-start2) 4000000)))) | |
| 221 (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) | |
| 222 (setcar cl-p1 (car cl-p2)) | |
| 223 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) | |
| 224 (setq cl-end2 (min (or cl-end2 (length cl-seq2)) | |
| 225 (+ cl-start2 cl-n1))) | |
| 226 (while (and cl-p1 (< cl-start2 cl-end2)) | |
| 227 (setcar cl-p1 (aref cl-seq2 cl-start2)) | |
| 228 (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) | |
| 229 (setq cl-end1 (min (or cl-end1 (length cl-seq1)) | |
| 230 (+ cl-start1 (- (or cl-end2 (length cl-seq2)) | |
| 231 cl-start2)))) | |
| 232 (if (listp cl-seq2) | |
| 233 (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) | |
| 234 (while (< cl-start1 cl-end1) | |
| 235 (aset cl-seq1 cl-start1 (car cl-p2)) | |
| 236 (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) | |
| 237 (while (< cl-start1 cl-end1) | |
| 238 (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) | |
| 239 (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) | |
| 240 cl-seq1)) | |
| 241 | |
| 242 (defun remove* (cl-item cl-seq &rest cl-keys) | |
| 243 "Remove all occurrences of ITEM in SEQ. | |
| 244 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 245 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
246 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
247 The keywords :test and :test-not specify two-argument test and negated-test |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
248 predicates, respectively; :test defaults to `eql'. :key specifies a |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
249 one-argument function that transforms elements of SEQ into \"comparison keys\" |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
250 before the test predicate is applied. See `member*' for more information |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
251 on these keywords. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
252 :start and :end, if given, specify indices of a subsequence of SEQ to |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
253 be processed. Indices are 0-based and processing involves the subsequence |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
254 starting at the index given by :start and ending just before the index |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
255 given by :end. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
256 :count, if given, limits the number of items removed to the number specified. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
257 :from-end, if given, causes processing to proceed starting from the end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
258 instead of the beginning; in this case, this matters only if :count is given." |
| 428 | 259 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end |
| 260 (:start 0) :end) () | |
| 261 (if (<= (or cl-count (setq cl-count 8000000)) 0) | |
| 262 cl-seq | |
| 263 (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) | |
| 264 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end | |
| 265 cl-from-end))) | |
| 266 (if cl-i | |
| 267 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) | |
| 268 (append (if cl-from-end | |
| 2153 | 269 (list :end (1+ cl-i)) |
| 270 (list :start cl-i)) | |
| 428 | 271 cl-keys)))) |
| 272 (if (listp cl-seq) cl-res | |
| 273 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) | |
| 274 cl-seq)) | |
| 275 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
| 276 (if (= cl-start 0) | |
| 277 (while (and cl-seq (> cl-end 0) | |
| 278 (cl-check-test cl-item (car cl-seq)) | |
| 279 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) | |
| 280 (> (setq cl-count (1- cl-count)) 0)))) | |
| 281 (if (and (> cl-count 0) (> cl-end 0)) | |
| 282 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) | |
| 283 (setq cl-end (1- cl-end)) (cdr cl-seq)))) | |
| 284 (while (and cl-p (> cl-end 0) | |
| 285 (not (cl-check-test cl-item (car cl-p)))) | |
| 286 (setq cl-p (cdr cl-p) cl-end (1- cl-end))) | |
| 287 (if (and cl-p (> cl-end 0)) | |
| 288 (nconc (ldiff cl-seq cl-p) | |
| 289 (if (= cl-count 1) (cdr cl-p) | |
| 290 (and (cdr cl-p) | |
| 291 (apply 'delete* cl-item | |
| 292 (copy-sequence (cdr cl-p)) | |
| 2153 | 293 :start 0 :end (1- cl-end) |
| 294 :count (1- cl-count) cl-keys)))) | |
| 428 | 295 cl-seq)) |
| 296 cl-seq))))) | |
| 297 | |
| 298 (defun remove-if (cl-pred cl-list &rest cl-keys) | |
| 299 "Remove all items satisfying PREDICATE in SEQ. | |
| 300 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 301 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
302 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
303 See `remove*' for the meaning of the keywords." |
| 2153 | 304 (apply 'remove* nil cl-list :if cl-pred cl-keys)) |
| 428 | 305 |
| 306 (defun remove-if-not (cl-pred cl-list &rest cl-keys) | |
| 307 "Remove all items not satisfying PREDICATE in SEQ. | |
| 308 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 309 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
310 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
311 See `remove*' for the meaning of the keywords." |
| 2153 | 312 (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 313 |
| 314 (defun delete* (cl-item cl-seq &rest cl-keys) | |
| 315 "Remove all occurrences of ITEM in SEQ. | |
| 316 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
317 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
318 See `remove*' for the meaning of the keywords." |
| 428 | 319 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end |
| 320 (:start 0) :end) () | |
| 321 (if (<= (or cl-count (setq cl-count 8000000)) 0) | |
| 322 cl-seq | |
| 323 (if (listp cl-seq) | |
| 324 (if (and cl-from-end (< cl-count 4000000)) | |
| 325 (let (cl-i) | |
| 326 (while (and (>= (setq cl-count (1- cl-count)) 0) | |
| 327 (setq cl-i (cl-position cl-item cl-seq cl-start | |
| 328 cl-end cl-from-end))) | |
| 329 (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) | |
| 330 (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) | |
| 331 (setcdr cl-tail (cdr (cdr cl-tail))))) | |
| 332 (setq cl-end cl-i)) | |
| 333 cl-seq) | |
| 334 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
| 335 (if (= cl-start 0) | |
| 336 (progn | |
| 337 (while (and cl-seq | |
| 338 (> cl-end 0) | |
| 339 (cl-check-test cl-item (car cl-seq)) | |
| 340 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) | |
| 341 (> (setq cl-count (1- cl-count)) 0))) | |
| 342 (setq cl-end (1- cl-end))) | |
| 343 (setq cl-start (1- cl-start))) | |
| 344 (if (and (> cl-count 0) (> cl-end 0)) | |
| 345 (let ((cl-p (nthcdr cl-start cl-seq))) | |
| 346 (while (and (cdr cl-p) (> cl-end 0)) | |
| 347 (if (cl-check-test cl-item (car (cdr cl-p))) | |
| 348 (progn | |
| 349 (setcdr cl-p (cdr (cdr cl-p))) | |
| 350 (if (= (setq cl-count (1- cl-count)) 0) | |
| 351 (setq cl-end 1))) | |
| 352 (setq cl-p (cdr cl-p))) | |
| 353 (setq cl-end (1- cl-end))))) | |
| 354 cl-seq) | |
| 355 (apply 'remove* cl-item cl-seq cl-keys))))) | |
| 356 | |
| 357 (defun delete-if (cl-pred cl-list &rest cl-keys) | |
| 358 "Remove all items satisfying PREDICATE in SEQ. | |
| 359 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
360 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
361 See `remove*' for the meaning of the keywords." |
| 2153 | 362 (apply 'delete* nil cl-list :if cl-pred cl-keys)) |
| 428 | 363 |
| 364 (defun delete-if-not (cl-pred cl-list &rest cl-keys) | |
| 365 "Remove all items not satisfying PREDICATE in SEQ. | |
| 366 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
367 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
368 See `remove*' for the meaning of the keywords." |
| 2153 | 369 (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 370 |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
371 ;; XEmacs change: this is in subr.el in GNU Emacs |
| 428 | 372 (defun remove (cl-item cl-seq) |
| 373 "Remove all occurrences of ITEM in SEQ, testing with `equal' | |
| 374 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 375 to avoid corrupting the original SEQ. | |
| 376 Also see: `remove*', `delete', `delete*'" | |
| 377 (remove* cl-item cl-seq ':test 'equal)) | |
| 378 | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
379 ;; XEmacs change: this is in subr.el in GNU Emacs |
| 428 | 380 (defun remq (cl-elt cl-list) |
| 442 | 381 "Remove all occurrences of ELT in LIST, comparing with `eq'. |
| 428 | 382 This is a non-destructive function; it makes a copy of LIST to avoid |
| 383 corrupting the original LIST. | |
| 384 Also see: `delq', `delete', `delete*', `remove', `remove*'." | |
| 385 (if (memq cl-elt cl-list) | |
| 386 (delq cl-elt (copy-list cl-list)) | |
| 387 cl-list)) | |
| 388 | |
| 389 (defun remove-duplicates (cl-seq &rest cl-keys) | |
| 390 "Return a copy of SEQ with all duplicate elements removed. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
391 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
392 See `remove*' for the meaning of the keywords." |
| 428 | 393 (cl-delete-duplicates cl-seq cl-keys t)) |
| 394 | |
| 395 (defun delete-duplicates (cl-seq &rest cl-keys) | |
| 396 "Remove all duplicate elements from SEQ (destructively). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
397 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
398 See `remove*' for the meaning of the keywords." |
| 428 | 399 (cl-delete-duplicates cl-seq cl-keys nil)) |
| 400 | |
| 401 (defun cl-delete-duplicates (cl-seq cl-keys cl-copy) | |
| 402 (if (listp cl-seq) | |
| 403 (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) | |
| 404 () | |
| 405 (if cl-from-end | |
| 406 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) | |
| 407 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) | |
| 408 (while (> cl-end 1) | |
| 409 (setq cl-i 0) | |
| 410 (while (setq cl-i (cl-position (cl-check-key (car cl-p)) | |
| 411 (cdr cl-p) cl-i (1- cl-end))) | |
| 412 (if cl-copy (setq cl-seq (copy-sequence cl-seq) | |
| 413 cl-p (nthcdr cl-start cl-seq) cl-copy nil)) | |
| 414 (let ((cl-tail (nthcdr cl-i cl-p))) | |
| 415 (setcdr cl-tail (cdr (cdr cl-tail)))) | |
| 416 (setq cl-end (1- cl-end))) | |
| 417 (setq cl-p (cdr cl-p) cl-end (1- cl-end) | |
| 418 cl-start (1+ cl-start))) | |
| 419 cl-seq) | |
| 420 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) | |
| 421 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) | |
| 422 (cl-position (cl-check-key (car cl-seq)) | |
| 423 (cdr cl-seq) 0 (1- cl-end))) | |
| 424 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) | |
| 425 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) | |
| 426 (setq cl-end (1- cl-end) cl-start 1) cl-seq))) | |
| 427 (while (and (cdr (cdr cl-p)) (> cl-end 1)) | |
| 428 (if (cl-position (cl-check-key (car (cdr cl-p))) | |
| 429 (cdr (cdr cl-p)) 0 (1- cl-end)) | |
| 430 (progn | |
| 431 (if cl-copy (setq cl-seq (copy-sequence cl-seq) | |
| 432 cl-p (nthcdr (1- cl-start) cl-seq) | |
| 433 cl-copy nil)) | |
| 434 (setcdr cl-p (cdr (cdr cl-p)))) | |
| 435 (setq cl-p (cdr cl-p))) | |
| 436 (setq cl-end (1- cl-end) cl-start (1+ cl-start))) | |
| 437 cl-seq))) | |
| 438 (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) | |
| 439 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) | |
| 440 | |
| 441 (defun substitute (cl-new cl-old cl-seq &rest cl-keys) | |
| 442 "Substitute NEW for OLD in SEQ. | |
| 443 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 444 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
445 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
446 See `remove*' for the meaning of the keywords." |
| 428 | 447 (cl-parsing-keywords (:test :test-not :key :if :if-not :count |
| 448 (:start 0) :end :from-end) () | |
| 449 (if (or (eq cl-old cl-new) | |
| 450 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) | |
| 451 cl-seq | |
| 452 (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) | |
| 453 (if (not cl-i) | |
| 454 cl-seq | |
| 455 (setq cl-seq (copy-sequence cl-seq)) | |
| 456 (or cl-from-end | |
| 457 (progn (cl-set-elt cl-seq cl-i cl-new) | |
| 458 (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) | |
| 2153 | 459 (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count |
| 460 :start cl-i cl-keys)))))) | |
| 428 | 461 |
| 462 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) | |
| 463 "Substitute NEW for all items satisfying PREDICATE in SEQ. | |
| 464 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 465 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
466 See `remove*' for the meaning of the keywords." |
| 2153 | 467 (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) |
| 428 | 468 |
| 469 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) | |
| 470 "Substitute NEW for all items not satisfying PREDICATE in SEQ. | |
| 471 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 472 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
473 See `remove*' for the meaning of the keywords." |
| 2153 | 474 (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 475 |
| 476 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) | |
| 477 "Substitute NEW for OLD in SEQ. | |
| 478 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
479 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
480 See `remove*' for the meaning of the keywords." |
| 428 | 481 (cl-parsing-keywords (:test :test-not :key :if :if-not :count |
| 482 (:start 0) :end :from-end) () | |
| 483 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) | |
| 484 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) | |
| 485 (let ((cl-p (nthcdr cl-start cl-seq))) | |
| 486 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
| 487 (while (and cl-p (> cl-end 0) (> cl-count 0)) | |
| 488 (if (cl-check-test cl-old (car cl-p)) | |
| 489 (progn | |
| 490 (setcar cl-p cl-new) | |
| 491 (setq cl-count (1- cl-count)))) | |
| 492 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) | |
| 493 (or cl-end (setq cl-end (length cl-seq))) | |
| 494 (if cl-from-end | |
| 495 (while (and (< cl-start cl-end) (> cl-count 0)) | |
| 496 (setq cl-end (1- cl-end)) | |
| 497 (if (cl-check-test cl-old (elt cl-seq cl-end)) | |
| 498 (progn | |
| 499 (cl-set-elt cl-seq cl-end cl-new) | |
| 500 (setq cl-count (1- cl-count))))) | |
| 501 (while (and (< cl-start cl-end) (> cl-count 0)) | |
| 502 (if (cl-check-test cl-old (aref cl-seq cl-start)) | |
| 503 (progn | |
| 504 (aset cl-seq cl-start cl-new) | |
| 505 (setq cl-count (1- cl-count)))) | |
| 506 (setq cl-start (1+ cl-start)))))) | |
| 507 cl-seq)) | |
| 508 | |
| 509 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) | |
| 510 "Substitute NEW for all items satisfying PREDICATE in SEQ. | |
| 511 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
512 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
513 See `remove*' for the meaning of the keywords." |
| 2153 | 514 (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) |
| 428 | 515 |
| 516 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) | |
| 517 "Substitute NEW for all items not satisfying PREDICATE in SEQ. | |
| 518 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
519 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
520 See `remove*' for the meaning of the keywords." |
| 2153 | 521 (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 522 |
| 523 (defun find (cl-item cl-seq &rest cl-keys) | |
| 524 "Find the first occurrence of ITEM in LIST. | |
| 525 Return the matching ITEM, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
526 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
527 See `remove*' for the meaning of the keywords." |
| 428 | 528 (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) |
| 529 (and cl-pos (elt cl-seq cl-pos)))) | |
| 530 | |
| 531 (defun find-if (cl-pred cl-list &rest cl-keys) | |
| 532 "Find the first item satisfying PREDICATE in LIST. | |
| 533 Return the matching ITEM, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
534 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
535 See `remove*' for the meaning of the keywords." |
| 2153 | 536 (apply 'find nil cl-list :if cl-pred cl-keys)) |
| 428 | 537 |
| 538 (defun find-if-not (cl-pred cl-list &rest cl-keys) | |
| 539 "Find the first item not satisfying PREDICATE in LIST. | |
| 540 Return the matching ITEM, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
541 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
542 See `remove*' for the meaning of the keywords." |
| 2153 | 543 (apply 'find nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 544 |
| 545 (defun position (cl-item cl-seq &rest cl-keys) | |
| 546 "Find the first occurrence of ITEM in LIST. | |
| 547 Return the index of the matching item, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
548 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
549 See `remove*' for the meaning of the keywords." |
| 428 | 550 (cl-parsing-keywords (:test :test-not :key :if :if-not |
| 551 (:start 0) :end :from-end) () | |
| 552 (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) | |
| 553 | |
| 554 (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) | |
| 555 (if (listp cl-seq) | |
| 556 (let ((cl-p (nthcdr cl-start cl-seq))) | |
| 557 (or cl-end (setq cl-end 8000000)) | |
| 558 (let ((cl-res nil)) | |
| 559 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) | |
| 560 (if (cl-check-test cl-item (car cl-p)) | |
| 561 (setq cl-res cl-start)) | |
| 562 (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) | |
| 563 cl-res)) | |
| 564 (or cl-end (setq cl-end (length cl-seq))) | |
| 565 (if cl-from-end | |
| 566 (progn | |
| 567 (while (and (>= (setq cl-end (1- cl-end)) cl-start) | |
| 568 (not (cl-check-test cl-item (aref cl-seq cl-end))))) | |
| 569 (and (>= cl-end cl-start) cl-end)) | |
| 570 (while (and (< cl-start cl-end) | |
| 571 (not (cl-check-test cl-item (aref cl-seq cl-start)))) | |
| 572 (setq cl-start (1+ cl-start))) | |
| 573 (and (< cl-start cl-end) cl-start)))) | |
| 574 | |
| 575 (defun position-if (cl-pred cl-list &rest cl-keys) | |
| 576 "Find the first item satisfying PREDICATE in LIST. | |
| 577 Return the index of the matching item, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
578 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
579 See `remove*' for the meaning of the keywords." |
| 2153 | 580 (apply 'position nil cl-list :if cl-pred cl-keys)) |
| 428 | 581 |
| 582 (defun position-if-not (cl-pred cl-list &rest cl-keys) | |
| 583 "Find the first item not satisfying PREDICATE in LIST. | |
| 584 Return the index of the matching item, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
585 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
586 See `remove*' for the meaning of the keywords." |
| 2153 | 587 (apply 'position nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 588 |
| 589 (defun count (cl-item cl-seq &rest cl-keys) | |
| 590 "Count the number of occurrences of ITEM in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
591 Keywords supported: :test :test-not :key :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
592 See `remove*' for the meaning of the keywords." |
| 428 | 593 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () |
| 594 (let ((cl-count 0) cl-x) | |
| 595 (or cl-end (setq cl-end (length cl-seq))) | |
| 596 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) | |
| 597 (while (< cl-start cl-end) | |
| 2153 | 598 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) |
| 428 | 599 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) |
| 600 (setq cl-start (1+ cl-start))) | |
| 601 cl-count))) | |
| 602 | |
| 603 (defun count-if (cl-pred cl-list &rest cl-keys) | |
| 604 "Count the number of items satisfying PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
605 Keywords supported: :key :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
606 See `remove*' for the meaning of the keywords." |
| 2153 | 607 (apply 'count nil cl-list :if cl-pred cl-keys)) |
| 428 | 608 |
| 609 (defun count-if-not (cl-pred cl-list &rest cl-keys) | |
| 610 "Count the number of items not satisfying PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
611 Keywords supported: :key :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
612 See `remove*' for the meaning of the keywords." |
| 2153 | 613 (apply 'count nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 614 |
| 615 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) | |
| 616 "Compare SEQ1 with SEQ2, return index of first mismatching element. | |
| 617 Return nil if the sequences match. If one sequence is a prefix of the | |
| 2153 | 618 other, the return value indicates the end of the shorter sequence. |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
619 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
620 See `search' for the meaning of the keywords." |
| 428 | 621 (cl-parsing-keywords (:test :test-not :key :from-end |
| 622 (:start1 0) :end1 (:start2 0) :end2) () | |
| 623 (or cl-end1 (setq cl-end1 (length cl-seq1))) | |
| 624 (or cl-end2 (setq cl-end2 (length cl-seq2))) | |
| 625 (if cl-from-end | |
| 626 (progn | |
| 627 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) | |
| 628 (cl-check-match (elt cl-seq1 (1- cl-end1)) | |
| 629 (elt cl-seq2 (1- cl-end2)))) | |
| 630 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) | |
| 631 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) | |
| 632 (1- cl-end1))) | |
| 633 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) | |
| 634 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) | |
| 635 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) | |
| 636 (cl-check-match (if cl-p1 (car cl-p1) | |
| 637 (aref cl-seq1 cl-start1)) | |
| 638 (if cl-p2 (car cl-p2) | |
| 639 (aref cl-seq2 cl-start2)))) | |
| 640 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) | |
| 641 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) | |
| 642 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) | |
| 643 cl-start1))))) | |
| 644 | |
| 645 (defun search (cl-seq1 cl-seq2 &rest cl-keys) | |
| 646 "Search for SEQ1 as a subsequence of SEQ2. | |
| 647 Return the index of the leftmost element of the first match found; | |
| 648 return nil if there are no matches. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
649 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
650 See `remove*' for the meaning of the keywords. In this case, :start1 and :end1 |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
651 specify a subsequence of SEQ1, and :start2 and :end2 specify a subsequence |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
652 of SEQ2." |
| 428 | 653 (cl-parsing-keywords (:test :test-not :key :from-end |
| 654 (:start1 0) :end1 (:start2 0) :end2) () | |
| 655 (or cl-end1 (setq cl-end1 (length cl-seq1))) | |
| 656 (or cl-end2 (setq cl-end2 (length cl-seq2))) | |
| 657 (if (>= cl-start1 cl-end1) | |
| 658 (if cl-from-end cl-end2 cl-start2) | |
| 659 (let* ((cl-len (- cl-end1 cl-start1)) | |
| 660 (cl-first (cl-check-key (elt cl-seq1 cl-start1))) | |
| 661 (cl-if nil) cl-pos) | |
| 662 (setq cl-end2 (- cl-end2 (1- cl-len))) | |
| 663 (while (and (< cl-start2 cl-end2) | |
| 664 (setq cl-pos (cl-position cl-first cl-seq2 | |
| 665 cl-start2 cl-end2 cl-from-end)) | |
| 666 (apply 'mismatch cl-seq1 cl-seq2 | |
| 2153 | 667 :start1 (1+ cl-start1) :end1 cl-end1 |
| 668 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) | |
| 669 :from-end nil cl-keys)) | |
| 428 | 670 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) |
| 671 (and (< cl-start2 cl-end2) cl-pos))))) | |
| 672 | |
| 673 (defun sort* (cl-seq cl-pred &rest cl-keys) | |
| 674 "Sort the argument SEQUENCE according to PREDICATE. | |
| 675 This is a destructive function; it reuses the storage of SEQUENCE if possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
676 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
677 :key specifies a one-argument function that transforms elements of SEQUENCE |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
678 into \"comparison keys\" before the test predicate is applied. See |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
679 `member*' for more information." |
| 428 | 680 (if (nlistp cl-seq) |
| 681 (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) | |
| 682 (cl-parsing-keywords (:key) () | |
| 683 (if (memq cl-key '(nil identity)) | |
| 684 (sort cl-seq cl-pred) | |
| 685 (sort cl-seq (function (lambda (cl-x cl-y) | |
| 686 (funcall cl-pred (funcall cl-key cl-x) | |
| 687 (funcall cl-key cl-y))))))))) | |
| 688 | |
| 689 (defun stable-sort (cl-seq cl-pred &rest cl-keys) | |
| 690 "Sort the argument SEQUENCE stably according to PREDICATE. | |
| 691 This is a destructive function; it reuses the storage of SEQUENCE if possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
692 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
693 :key specifies a one-argument function that transforms elements of SEQUENCE |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
694 into \"comparison keys\" before the test predicate is applied. See |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
695 `member*' for more information." |
| 428 | 696 (apply 'sort* cl-seq cl-pred cl-keys)) |
| 697 | |
| 698 (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) | |
| 699 "Destructively merge the two sequences to produce a new sequence. | |
| 700 TYPE is the sequence type to return, SEQ1 and SEQ2 are the two | |
| 701 argument sequences, and PRED is a `less-than' predicate on the elements. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
702 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
703 :key specifies a one-argument function that transforms elements of SEQ1 and |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
704 SEQ2 into \"comparison keys\" before the test predicate is applied. See |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
705 `member*' for more information." |
| 428 | 706 (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) |
| 707 (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) | |
| 708 (cl-parsing-keywords (:key) () | |
| 709 (let ((cl-res nil)) | |
| 710 (while (and cl-seq1 cl-seq2) | |
| 711 (if (funcall cl-pred (cl-check-key (car cl-seq2)) | |
| 712 (cl-check-key (car cl-seq1))) | |
| 2153 | 713 (push (pop cl-seq2) cl-res) |
| 714 (push (pop cl-seq1) cl-res))) | |
| 428 | 715 (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) |
| 716 | |
| 717 ;;; See compiler macro in cl-macs.el | |
| 718 (defun member* (cl-item cl-list &rest cl-keys) | |
| 719 "Find the first occurrence of ITEM in LIST. | |
| 720 Return the sublist of LIST whose car is ITEM. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
721 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
722 The keyword :test specifies a two-argument function that is used to |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
723 compare ITEM with elements in LIST; if omitted, it defaults to `eql'. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
724 The keyword :test-not is similar, but specifies a negated predicate. That |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
725 is, ITEM is considered equal to an element in LIST if the given predicate |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
726 returns nil. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
727 :key specifies a one-argument function that transforms elements of LIST into |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
728 \"comparison keys\" before the test predicate is applied. For example, |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
729 if :key is #'car, then ITEM is compared with the car of elements from LIST1. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
730 The :key function, however, is not applied to ITEM, and does not affect the |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
731 elements in the returned list, which are taken directly from the elements in |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
732 LIST." |
| 428 | 733 (if cl-keys |
| 734 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
| 735 (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) | |
| 736 (setq cl-list (cdr cl-list))) | |
| 737 cl-list) | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
738 (if (and (numberp cl-item) (not (fixnump cl-item))) |
| 428 | 739 (member cl-item cl-list) |
| 740 (memq cl-item cl-list)))) | |
| 741 | |
| 742 (defun member-if (cl-pred cl-list &rest cl-keys) | |
| 743 "Find the first item satisfying PREDICATE in LIST. | |
| 744 Return the sublist of LIST whose car matches. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
745 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
746 See `member*' for the meaning of :key." |
| 2153 | 747 (apply 'member* nil cl-list :if cl-pred cl-keys)) |
| 428 | 748 |
| 749 (defun member-if-not (cl-pred cl-list &rest cl-keys) | |
| 750 "Find the first item not satisfying PREDICATE in LIST. | |
| 751 Return the sublist of LIST whose car matches. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
752 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
753 See `member*' for the meaning of :key." |
| 2153 | 754 (apply 'member* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 755 |
| 756 (defun cl-adjoin (cl-item cl-list &rest cl-keys) | |
| 757 (if (cl-parsing-keywords (:key) t | |
| 758 (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) | |
| 759 cl-list | |
| 760 (cons cl-item cl-list))) | |
| 761 | |
| 762 ;;; See compiler macro in cl-macs.el | |
| 763 (defun assoc* (cl-item cl-alist &rest cl-keys) | |
| 764 "Find the first item whose car matches ITEM in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
765 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
766 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 767 (if cl-keys |
| 768 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
| 769 (while (and cl-alist | |
| 770 (or (not (consp (car cl-alist))) | |
| 771 (not (cl-check-test cl-item (car (car cl-alist)))))) | |
| 772 (setq cl-alist (cdr cl-alist))) | |
| 773 (and cl-alist (car cl-alist))) | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
774 (if (and (numberp cl-item) (not (fixnump cl-item))) |
| 428 | 775 (assoc cl-item cl-alist) |
| 776 (assq cl-item cl-alist)))) | |
| 777 | |
| 778 (defun assoc-if (cl-pred cl-list &rest cl-keys) | |
| 779 "Find the first item whose car satisfies PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
780 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
781 See `member*' for the meaning of :key." |
| 2153 | 782 (apply 'assoc* nil cl-list :if cl-pred cl-keys)) |
| 428 | 783 |
| 784 (defun assoc-if-not (cl-pred cl-list &rest cl-keys) | |
| 785 "Find the first item whose car does not satisfy PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
786 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
787 See `member*' for the meaning of :key." |
| 2153 | 788 (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 789 |
| 790 (defun rassoc* (cl-item cl-alist &rest cl-keys) | |
| 791 "Find the first item whose cdr matches ITEM in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
792 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
793 See `member*' for the meaning of :test, :test-not and :key." |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
794 (if (or cl-keys (and (numberp cl-item) (not (fixnump cl-item)))) |
| 428 | 795 (cl-parsing-keywords (:test :test-not :key :if :if-not) () |
| 796 (while (and cl-alist | |
| 797 (or (not (consp (car cl-alist))) | |
| 798 (not (cl-check-test cl-item (cdr (car cl-alist)))))) | |
| 799 (setq cl-alist (cdr cl-alist))) | |
| 800 (and cl-alist (car cl-alist))) | |
| 801 (rassq cl-item cl-alist))) | |
| 802 | |
| 803 (defun rassoc-if (cl-pred cl-list &rest cl-keys) | |
| 804 "Find the first item whose cdr satisfies PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
805 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
806 See `member*' for the meaning of :key." |
| 2153 | 807 (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) |
| 428 | 808 |
| 809 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys) | |
| 810 "Find the first item whose cdr does not satisfy PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
811 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
812 See `member*' for the meaning of :key." |
| 2153 | 813 (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 814 |
| 815 (defun union (cl-list1 cl-list2 &rest cl-keys) | |
| 816 "Combine LIST1 and LIST2 using a set-union operation. | |
| 817 The result list contains all items that appear in either LIST1 or LIST2. | |
| 818 This is a non-destructive function; it makes a copy of the data if necessary | |
| 819 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
820 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
821 The keywords :test and :test-not specify two-argument test and negated-test |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
822 predicates, respectively; :test defaults to `eql'. see `member*' for more |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
823 information. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
824 :key specifies a one-argument function that transforms elements of LIST1 |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
825 and LIST2 into \"comparison keys\" before the test predicate is applied. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
826 For example, if :key is #'car, then the car of elements from LIST1 is |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
827 compared with the car of elements from LIST2. The :key function, however, |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
828 does not affect the elements in the returned list, which are taken directly |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
829 from the elements in LIST1 and LIST2." |
| 428 | 830 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 831 ((equal cl-list1 cl-list2) cl-list1) | |
| 832 (t | |
| 833 (or (>= (length cl-list1) (length cl-list2)) | |
| 834 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) | |
| 835 (while cl-list2 | |
| 836 (if (or cl-keys (numberp (car cl-list2))) | |
| 837 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) | |
| 838 (or (memq (car cl-list2) cl-list1) | |
| 2153 | 839 (push (car cl-list2) cl-list1))) |
| 840 (pop cl-list2)) | |
| 428 | 841 cl-list1))) |
| 842 | |
| 843 (defun nunion (cl-list1 cl-list2 &rest cl-keys) | |
| 844 "Combine LIST1 and LIST2 using a set-union operation. | |
| 845 The result list contains all items that appear in either LIST1 or LIST2. | |
| 846 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 847 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
848 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
849 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 850 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 851 (t (apply 'union cl-list1 cl-list2 cl-keys)))) | |
| 852 | |
|
5067
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
853 ;; XEmacs addition: NOT IN COMMON LISP. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
854 (defun stable-union (cl-list1 cl-list2 &rest cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
855 "Stably combine LIST1 and LIST2 using a set-union operation. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
856 The result list contains all items that appear in either LIST1 or LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
857 The result is \"stable\" in that it preserves the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
858 LIST1 and LIST2. The result specifically consists of the elements in LIST1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
859 in order, followed by any elements in LIST2 that are not also in LIST1, in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
860 the order given in LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
861 This is a non-destructive function; it makes a copy of the data if necessary |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
862 to avoid corrupting the original LIST1 and LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
863 Keywords supported: :test :test-not :key |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
864 See `union' for the meaning of :test, :test-not and :key. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
865 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
866 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
867 extension." |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
868 ;; The standard `union' doesn't produce a "stable" union -- |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
869 ;; it iterates over the second list instead of the first one, and returns |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
870 ;; the values in backwards order. According to the CLTL2 documentation, |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
871 ;; `union' is not required to preserve the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
872 ;; any fashion, so we add a new function rather than changing the |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
873 ;; semantics of `union'. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
874 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
875 ((equal cl-list1 cl-list2) cl-list1) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
876 (t |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
877 (append |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
878 cl-list1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
879 (cl-parsing-keywords (:key) (:test :test-not) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
880 (loop for cl-l in cl-list2 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
881 if (not (if (or cl-keys (numberp cl-l)) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
882 (apply 'member* (cl-check-key cl-l) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
883 cl-list1 cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
884 (memq cl-l cl-list1))) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
885 collect cl-l)))))) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
886 |
| 428 | 887 (defun intersection (cl-list1 cl-list2 &rest cl-keys) |
| 888 "Combine LIST1 and LIST2 using a set-intersection operation. | |
| 889 The result list contains all items that appear in both LIST1 and LIST2. | |
| 890 This is a non-destructive function; it makes a copy of the data if necessary | |
| 891 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
892 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
893 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 894 (and cl-list1 cl-list2 |
| 895 (if (equal cl-list1 cl-list2) cl-list1 | |
| 896 (cl-parsing-keywords (:key) (:test :test-not) | |
| 897 (let ((cl-res nil)) | |
| 898 (or (>= (length cl-list1) (length cl-list2)) | |
| 899 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) | |
| 900 (while cl-list2 | |
| 901 (if (if (or cl-keys (numberp (car cl-list2))) | |
| 902 (apply 'member* (cl-check-key (car cl-list2)) | |
| 903 cl-list1 cl-keys) | |
| 904 (memq (car cl-list2) cl-list1)) | |
| 2153 | 905 (push (car cl-list2) cl-res)) |
| 906 (pop cl-list2)) | |
| 428 | 907 cl-res))))) |
| 908 | |
| 909 (defun nintersection (cl-list1 cl-list2 &rest cl-keys) | |
| 910 "Combine LIST1 and LIST2 using a set-intersection operation. | |
| 911 The result list contains all items that appear in both LIST1 and LIST2. | |
| 912 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 913 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
914 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
915 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 916 (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) |
| 917 | |
|
5067
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
918 ;; XEmacs addition: NOT IN COMMON LISP. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
919 (defun stable-intersection (cl-list1 cl-list2 &rest cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
920 "Stably combine LIST1 and LIST2 using a set-intersection operation. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
921 The result list contains all items that appear in both LIST1 and LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
922 The result is \"stable\" in that it preserves the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
923 LIST1 that are also in LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
924 This is a non-destructive function; it makes a copy of the data if necessary |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
925 to avoid corrupting the original LIST1 and LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
926 Keywords supported: :test :test-not :key |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
927 See `union' for the meaning of :test, :test-not and :key. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
928 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
929 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
930 extension." |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
931 ;; The standard `intersection' doesn't produce a "stable" intersection -- |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
932 ;; it iterates over the second list instead of the first one, and returns |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
933 ;; the values in backwards order. According to the CLTL2 documentation, |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
934 ;; `intersection' is not required to preserve the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
935 ;; any fashion, so we add a new function rather than changing the |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
936 ;; semantics of `intersection'. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
937 (and cl-list1 cl-list2 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
938 (if (equal cl-list1 cl-list2) cl-list1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
939 (cl-parsing-keywords (:key) (:test :test-not) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
940 (loop for cl-l in cl-list1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
941 if (if (or cl-keys (numberp cl-l)) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
942 (apply 'member* (cl-check-key cl-l) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
943 cl-list2 cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
944 (memq cl-l cl-list2)) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
945 collect cl-l))))) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
946 |
| 428 | 947 (defun set-difference (cl-list1 cl-list2 &rest cl-keys) |
| 948 "Combine LIST1 and LIST2 using a set-difference operation. | |
| 949 The result list contains all items that appear in LIST1 but not LIST2. | |
| 950 This is a non-destructive function; it makes a copy of the data if necessary | |
| 951 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
952 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
953 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 954 (if (or (null cl-list1) (null cl-list2)) cl-list1 |
| 955 (cl-parsing-keywords (:key) (:test :test-not) | |
| 956 (let ((cl-res nil)) | |
| 957 (while cl-list1 | |
| 958 (or (if (or cl-keys (numberp (car cl-list1))) | |
| 959 (apply 'member* (cl-check-key (car cl-list1)) | |
| 960 cl-list2 cl-keys) | |
| 961 (memq (car cl-list1) cl-list2)) | |
| 2153 | 962 (push (car cl-list1) cl-res)) |
| 963 (pop cl-list1)) | |
| 428 | 964 cl-res)))) |
| 965 | |
| 966 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys) | |
| 967 "Combine LIST1 and LIST2 using a set-difference operation. | |
| 968 The result list contains all items that appear in LIST1 but not LIST2. | |
| 969 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 970 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
971 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
972 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 973 (if (or (null cl-list1) (null cl-list2)) cl-list1 |
| 974 (apply 'set-difference cl-list1 cl-list2 cl-keys))) | |
| 975 | |
| 976 (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) | |
| 977 "Combine LIST1 and LIST2 using a set-exclusive-or operation. | |
| 978 The result list contains all items that appear in exactly one of LIST1, LIST2. | |
| 979 This is a non-destructive function; it makes a copy of the data if necessary | |
| 980 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
981 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
982 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 983 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 984 ((equal cl-list1 cl-list2) nil) | |
| 985 (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) | |
| 986 (apply 'set-difference cl-list2 cl-list1 cl-keys))))) | |
| 987 | |
| 988 (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) | |
| 989 "Combine LIST1 and LIST2 using a set-exclusive-or operation. | |
| 990 The result list contains all items that appear in exactly one of LIST1, LIST2. | |
| 991 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 992 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
993 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
994 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 995 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 996 ((equal cl-list1 cl-list2) nil) | |
| 997 (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) | |
| 998 (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) | |
| 999 | |
| 1000 (defun subsetp (cl-list1 cl-list2 &rest cl-keys) | |
| 1001 "True if LIST1 is a subset of LIST2. | |
| 1002 I.e., if every element of LIST1 also appears in LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1003 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1004 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 1005 (cond ((null cl-list1) t) ((null cl-list2) nil) |
| 1006 ((equal cl-list1 cl-list2) t) | |
| 1007 (t (cl-parsing-keywords (:key) (:test :test-not) | |
| 1008 (while (and cl-list1 | |
| 1009 (apply 'member* (cl-check-key (car cl-list1)) | |
| 1010 cl-list2 cl-keys)) | |
| 2153 | 1011 (pop cl-list1)) |
| 428 | 1012 (null cl-list1))))) |
| 1013 | |
| 1014 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1015 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). | |
| 1016 Return a copy of TREE with all matching elements replaced by NEW. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1017 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1018 See `member*' for the meaning of :key." |
| 2153 | 1019 (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) |
| 428 | 1020 |
| 1021 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1022 "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). | |
| 1023 Return a copy of TREE with all non-matching elements replaced by NEW. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1024 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1025 See `member*' for the meaning of :key." |
| 2153 | 1026 (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) |
| 428 | 1027 |
| 1028 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys) | |
| 1029 "Substitute NEW for OLD everywhere in TREE (destructively). | |
| 1030 Any element of TREE which is `eql' to OLD is changed to NEW (via a call | |
| 1031 to `setcar'). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1032 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1033 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 1034 (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) |
| 1035 | |
| 1036 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1037 "Substitute NEW for elements matching PREDICATE in TREE (destructively). | |
| 1038 Any element of TREE which matches is changed to NEW (via a call to `setcar'). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1039 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1040 See `member*' for the meaning of :key." |
| 2153 | 1041 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) |
| 428 | 1042 |
| 1043 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1044 "Substitute NEW for elements not matching PREDICATE in TREE (destructively). | |
| 1045 Any element of TREE which matches is changed to NEW (via a call to `setcar'). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1046 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1047 See `member*' for the meaning of :key." |
| 2153 | 1048 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) |
| 428 | 1049 |
| 1050 (defun sublis (cl-alist cl-tree &rest cl-keys) | |
| 1051 "Perform substitutions indicated by ALIST in TREE (non-destructively). | |
| 1052 Return a copy of TREE with all matching elements replaced. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1053 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1054 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 1055 (cl-parsing-keywords (:test :test-not :key :if :if-not) () |
| 1056 (cl-sublis-rec cl-tree))) | |
| 1057 | |
| 1058 (defvar cl-alist) | |
| 1059 (defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* | |
| 1060 (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) | |
| 1061 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
| 1062 (setq cl-p (cdr cl-p))) | |
| 1063 (if cl-p (cdr (car cl-p)) | |
| 1064 (if (consp cl-tree) | |
| 1065 (let ((cl-a (cl-sublis-rec (car cl-tree))) | |
| 1066 (cl-d (cl-sublis-rec (cdr cl-tree)))) | |
| 1067 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) | |
| 1068 cl-tree | |
| 1069 (cons cl-a cl-d))) | |
| 1070 cl-tree)))) | |
| 1071 | |
| 1072 (defun nsublis (cl-alist cl-tree &rest cl-keys) | |
| 1073 "Perform substitutions indicated by ALIST in TREE (destructively). | |
| 1074 Any matching element of TREE is changed via a call to `setcar'. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1075 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1076 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 1077 (cl-parsing-keywords (:test :test-not :key :if :if-not) () |
| 1078 (let ((cl-hold (list cl-tree))) | |
| 1079 (cl-nsublis-rec cl-hold) | |
| 1080 (car cl-hold)))) | |
| 1081 | |
| 1082 (defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* | |
| 1083 (while (consp cl-tree) | |
| 1084 (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) | |
| 1085 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
| 1086 (setq cl-p (cdr cl-p))) | |
| 1087 (if cl-p (setcar cl-tree (cdr (car cl-p))) | |
| 1088 (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) | |
| 1089 (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) | |
| 1090 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
| 1091 (setq cl-p (cdr cl-p))) | |
| 1092 (if cl-p | |
| 1093 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) | |
| 1094 (setq cl-tree (cdr cl-tree)))))) | |
| 1095 | |
| 1096 (defun tree-equal (cl-x cl-y &rest cl-keys) | |
| 1097 "Return t if trees X and Y have `eql' leaves. | |
| 1098 Atoms are compared by `eql'; cons cells are compared recursively. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1099 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1100 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 1101 (cl-parsing-keywords (:test :test-not :key) () |
| 1102 (cl-tree-equal-rec cl-x cl-y))) | |
| 1103 | |
| 1104 (defun cl-tree-equal-rec (cl-x cl-y) | |
| 1105 (while (and (consp cl-x) (consp cl-y) | |
| 1106 (cl-tree-equal-rec (car cl-x) (car cl-y))) | |
| 1107 (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) | |
| 1108 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) | |
| 1109 | |
| 1110 | |
| 1111 (run-hooks 'cl-seq-load-hook) | |
| 1112 | |
| 2153 | 1113 ;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c |
| 428 | 1114 ;;; cl-seq.el ends here |