Mercurial > hg > xemacs-beta

comparison lisp/cl-seq.el @ 5448:89331fa1c819

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merged with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 06 Jan 2011 00:35:22 +0100
parents 308d34e9f07d d1b17a33450b
children 0af042a0c116
comparison
equal deleted inserted replaced
5447:4b08f375e2fb 5448:89331fa1c819
43 ;; This file contains the Common Lisp sequence and list functions 43 ;; This file contains the Common Lisp sequence and list functions
44 ;; which take keyword arguments. 44 ;; which take keyword arguments.
45 45
46 ;; See cl.el for Change Log. 46 ;; See cl.el for Change Log.
47 47
48
49 ;;; Code: 48 ;;; Code:
50 49
51 ;;; Keyword parsing. This is special-cased here so that we can compile 50 ;; XEmacs; all the heavy lifting of this file is now in C. There's no need
52 ;;; this file independent from cl-macs. 51 ;; for the cl-parsing-keywords macro. We could use defun* for the
53 52 ;; keyword-parsing code, which would avoid the necessity of the arguments:
54 (defmacro cl-parsing-keywords (kwords other-keys &rest body) 53 ;; () lists in the docstrings, but that often breaks because of dynamic
55 "Helper macro for functions with keyword arguments. 54 ;; scope (e.g. a variable called start bound in this file and one in a
56 This is a temporary solution, until keyword arguments are natively supported. 55 ;; user-supplied test predicate may well interfere with each other).
57 Declare your function ending with (... &rest cl-keys), then wrap the 56
58 function body in a call to `cl-parsing-keywords'. 57 ;; XEmacs change: these two are in subr.el in GNU Emacs.
59
60 KWORDS is a list of keyword definitions. Each definition should be
61 either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case,
62 the default value is nil. The keywords are available in BODY as the name
63 of the keyword, minus its initial colon and prepended with `cl-'.
64
65 OTHER-KEYS specifies other keywords that are accepted but ignored. It
66 is either the value 't' (ignore all other keys, equivalent to the
67 &allow-other-keys argument declaration in Common Lisp) or a list in the
68 same format as KWORDS. If keywords are given that are not in KWORDS
69 and not allowed by OTHER-KEYS, an error will normally be signalled; but
70 the caller can override this by specifying a non-nil value for the
71 keyword :allow-other-keys (which defaults to t)."
72 (cons
73 'let*
74 (cons (mapcar
75 (function
76 (lambda (x)
77 (let* ((var (if (consp x) (car x) x))
78 (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
79 'cl-keys)))))
80 (if (eq var :test-not)
81 (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
82 (if (eq var :if-not)
83 (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
84 (list (intern
85 (format "cl-%s" (substring (symbol-name var) 1)))
86 (if (consp x) (list 'or mem (car (cdr x))) mem)))))
87 kwords)
88 (append
89 (and (not (eq other-keys t))
90 (list
91 (list 'let '((cl-keys-temp cl-keys))
92 (list 'while 'cl-keys-temp
93 (list 'or (list 'memq '(car cl-keys-temp)
94 (list 'quote
95 (mapcar
96 (function
97 (lambda (x)
98 (if (consp x)
99 (car x) x)))
100 (append kwords
101 other-keys))))
102 '(car (cdr (memq (quote :allow-other-keys)
103 cl-keys)))
104 '(error 'invalid-keyword-argument
105 (car cl-keys-temp)))
106 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
107 body))))
108 (put 'cl-parsing-keywords 'lisp-indent-function 2)
109 (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
110
111 (defmacro cl-check-key (x)
112 (list 'if 'cl-key (list 'funcall 'cl-key x) x))
113
114 (defmacro cl-check-test-nokey (item x)
115 (list 'cond
116 (list 'cl-test
117 (list 'eq (list 'not (list 'funcall 'cl-test item x))
118 'cl-test-not))
119 (list 'cl-if
120 (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
121 (list 't (list 'if (list 'numberp item)
122 (list 'equal item x) (list 'eq item x)))))
123
124 (defmacro cl-check-test (item x)
125 (list 'cl-check-test-nokey item (list 'cl-check-key x)))
126
127 (defmacro cl-check-match (x y)
128 (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
129 (list 'if 'cl-test
130 (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
131 (list 'if (list 'numberp x)
132 (list 'equal x y) (list 'eq x y))))
133
134 (put 'cl-check-key 'edebug-form-spec 'edebug-forms)
135 (put 'cl-check-test 'edebug-form-spec 'edebug-forms)
136 (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
137 (put 'cl-check-match 'edebug-form-spec 'edebug-forms)
138
139 (defvar cl-test) (defvar cl-test-not)
140 (defvar cl-if) (defvar cl-if-not)
141 (defvar cl-key)
142
143 ;; XEmacs; #'replace is in fns.c.
144
145 (defun remove* (cl-item cl-seq &rest cl-keys)
146 "Remove all occurrences of ITEM in SEQ.
147 This is a non-destructive function; it makes a copy of SEQ if necessary
148 to avoid corrupting the original SEQ.
149 Keywords supported: :test :test-not :key :count :start :end :from-end
150 The keywords :test and :test-not specify two-argument test and negated-test
151 predicates, respectively; :test defaults to `eql'. :key specifies a
152 one-argument function that transforms elements of SEQ into \"comparison keys\"
153 before the test predicate is applied. See `member*' for more information
154 on these keywords.
155 :start and :end, if given, specify indices of a subsequence of SEQ to
156 be processed. Indices are 0-based and processing involves the subsequence
157 starting at the index given by :start and ending just before the index
158 given by :end.
159 :count, if given, limits the number of items removed to the number specified.
160 :from-end, if given, causes processing to proceed starting from the end
161 instead of the beginning; in this case, this matters only if :count is given."
162 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
163 (:start 0) :end) ()
164 (if (<= (or cl-count (setq cl-count 8000000)) 0)
165 cl-seq
166 (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
167 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
168 cl-from-end)))
169 (if cl-i
170 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
171 (append (if cl-from-end
172 (list :end (1+ cl-i))
173 (list :start cl-i))
174 cl-keys))))
175 (typecase cl-seq
176 (list cl-res)
177 (string (concat cl-res))
178 (vector (vconcat cl-res))
179 (bit-vector (bvconcat cl-res))))
180 cl-seq))
181 (setq cl-end (- (or cl-end 8000000) cl-start))
182 (if (= cl-start 0)
183 (while (and cl-seq (> cl-end 0)
184 (cl-check-test cl-item (car cl-seq))
185 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
186 (> (setq cl-count (1- cl-count)) 0))))
187 (if (and (> cl-count 0) (> cl-end 0))
188 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
189 (setq cl-end (1- cl-end)) (cdr cl-seq))))
190 (while (and cl-p (> cl-end 0)
191 (not (cl-check-test cl-item (car cl-p))))
192 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
193 (if (and cl-p (> cl-end 0))
194 (nconc (ldiff cl-seq cl-p)
195 (if (= cl-count 1) (cdr cl-p)
196 (and (cdr cl-p)
197 (apply 'delete* cl-item
198 (copy-sequence (cdr cl-p))
199 :start 0 :end (1- cl-end)
200 :count (1- cl-count) cl-keys))))
201 cl-seq))
202 cl-seq)))))
203
204 (defun remove-if (cl-pred cl-list &rest cl-keys)
205 "Remove all items satisfying PREDICATE in SEQ.
206 This is a non-destructive function; it makes a copy of SEQ if necessary
207 to avoid corrupting the original SEQ.
208 Keywords supported: :key :count :start :end :from-end
209 See `remove*' for the meaning of the keywords."
210 (apply 'remove* nil cl-list :if cl-pred cl-keys))
211
212 (defun remove-if-not (cl-pred cl-list &rest cl-keys)
213 "Remove all items not satisfying PREDICATE in SEQ.
214 This is a non-destructive function; it makes a copy of SEQ if necessary
215 to avoid corrupting the original SEQ.
216 Keywords supported: :key :count :start :end :from-end
217 See `remove*' for the meaning of the keywords."
218 (apply 'remove* nil cl-list :if-not cl-pred cl-keys))
219
220 (defun delete* (cl-item cl-seq &rest cl-keys)
221 "Remove all occurrences of ITEM in SEQ.
222 This is a destructive function; it reuses the storage of SEQ whenever possible.
223 Keywords supported: :test :test-not :key :count :start :end :from-end
224 See `remove*' for the meaning of the keywords."
225 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
226 (:start 0) :end) ()
227 (if (<= (or cl-count (setq cl-count 8000000)) 0)
228 cl-seq
229 (if (listp cl-seq)
230 (if (and cl-from-end (< cl-count 4000000))
231 (let (cl-i)
232 (while (and (>= (setq cl-count (1- cl-count)) 0)
233 (setq cl-i (cl-position cl-item cl-seq cl-start
234 cl-end cl-from-end)))
235 (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
236 (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
237 (setcdr cl-tail (cdr (cdr cl-tail)))))
238 (setq cl-end cl-i))
239 cl-seq)
240 (setq cl-end (- (or cl-end 8000000) cl-start))
241 (if (= cl-start 0)
242 (progn
243 (while (and cl-seq
244 (> cl-end 0)
245 (cl-check-test cl-item (car cl-seq))
246 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
247 (> (setq cl-count (1- cl-count)) 0)))
248 (setq cl-end (1- cl-end)))
249 (setq cl-start (1- cl-start)))
250 (if (and (> cl-count 0) (> cl-end 0))
251 (let ((cl-p (nthcdr cl-start cl-seq)))
252 (while (and (cdr cl-p) (> cl-end 0))
253 (if (cl-check-test cl-item (car (cdr cl-p)))
254 (progn
255 (setcdr cl-p (cdr (cdr cl-p)))
256 (if (= (setq cl-count (1- cl-count)) 0)
257 (setq cl-end 1)))
258 (setq cl-p (cdr cl-p)))
259 (setq cl-end (1- cl-end)))))
260 cl-seq)
261 (apply 'remove* cl-item cl-seq cl-keys)))))
262
263 (defun delete-if (cl-pred cl-list &rest cl-keys)
264 "Remove all items satisfying PREDICATE in SEQ.
265 This is a destructive function; it reuses the storage of SEQ whenever possible.
266 Keywords supported: :key :count :start :end :from-end
267 See `remove*' for the meaning of the keywords."
268 (apply 'delete* nil cl-list :if cl-pred cl-keys))
269
270 (defun delete-if-not (cl-pred cl-list &rest cl-keys)
271 "Remove all items not satisfying PREDICATE in SEQ.
272 This is a destructive function; it reuses the storage of SEQ whenever possible.
273 Keywords supported: :key :count :start :end :from-end
274 See `remove*' for the meaning of the keywords."
275 (apply 'delete* nil cl-list :if-not cl-pred cl-keys))
276
277 ;; XEmacs change: this is in subr.el in GNU Emacs
278 (defun remove (cl-item cl-seq) 58 (defun remove (cl-item cl-seq)
279 "Remove all occurrences of ITEM in SEQ, testing with `equal' 59 "Remove all occurrences of ITEM in SEQUENCE, testing with `equal'.
280 This is a non-destructive function; it makes a copy of SEQ if necessary 60
281 to avoid corrupting the original SEQ. 61 This is a non-destructive function; it makes a copy of SEQUENCE if necessary
282 Also see: `remove*', `delete', `delete*'" 62 to avoid corrupting the original SEQUENCE.
283 (remove* cl-item cl-seq ':test 'equal)) 63 Also see: `remove*', `delete', `delete*'
284 64
285 ;; XEmacs change: this is in subr.el in GNU Emacs 65 arguments: (ITEM SEQUENCE)"
286 (defun remq (cl-elt cl-list) 66 (remove* cl-item cl-seq :test #'equal))
287 "Remove all occurrences of ELT in LIST, comparing with `eq'. 67
288 This is a non-destructive function; it makes a copy of LIST to avoid 68 (defun remq (cl-item cl-seq)
289 corrupting the original LIST. 69 "Remove all occurrences of ITEM in SEQUENCE, comparing with `eq'.
290 Also see: `delq', `delete', `delete*', `remove', `remove*'." 70
291 (if (memq cl-elt cl-list) 71 This is a non-destructive function; it makes a copy of SEQUENCE to avoid
292 (delq cl-elt (copy-list cl-list)) 72 corrupting the original LIST. See also the more general `remove*'.
293 cl-list)) 73
294 74 arguments: (ITEM SEQUENCE)"
295 (defun remove-duplicates (cl-seq &rest cl-keys) 75 (remove* cl-item cl-seq :test #'eq))
296 "Return a copy of SEQ with all duplicate elements removed. 76
297 Keywords supported: :test :test-not :key :start :end :from-end 77 (defun remove-if (cl-predicate cl-seq &rest cl-keys)
298 See `remove*' for the meaning of the keywords." 78 "Remove all items satisfying PREDICATE in SEQUENCE.
299 (cl-delete-duplicates cl-seq cl-keys t)) 79
300 80 This is a non-destructive function; it makes a copy of SEQUENCE if necessary
301 (defun delete-duplicates (cl-seq &rest cl-keys) 81 to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy
302 "Remove all duplicate elements from SEQ (destructively). 82 may share list structure with SEQUENCE. If no item satisfies PREDICATE,
303 Keywords supported: :test :test-not :key :start :end :from-end 83 SEQUENCE itself is returned, unmodified.
304 See `remove*' for the meaning of the keywords." 84
305 (cl-delete-duplicates cl-seq cl-keys nil)) 85 See `remove*' for the meaning of the keywords.
306 86
307 (defun cl-delete-duplicates (cl-seq cl-keys cl-copy) 87 arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
308 (if (listp cl-seq) 88 (apply 'remove* 'remove* cl-seq :if cl-predicate cl-keys))
309 (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) 89
310 () 90 (defun remove-if-not (cl-predicate cl-seq &rest cl-keys)
311 (if cl-from-end 91 "Remove all items not satisfying PREDICATE in SEQUENCE.
312 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) 92
313 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) 93 This is a non-destructive function; it makes a copy of SEQUENCE if necessary
314 (while (> cl-end 1) 94 to avoid corrupting the original SEQUENCE. If SEQUENCE is a list, the copy
315 (setq cl-i 0) 95 may share list structure with SEQUENCE.
316 (while (setq cl-i (cl-position (cl-check-key (car cl-p)) 96
317 (cdr cl-p) cl-i (1- cl-end))) 97 See `remove*' for the meaning of the keywords.
318 (if cl-copy (setq cl-seq (copy-sequence cl-seq) 98
319 cl-p (nthcdr cl-start cl-seq) cl-copy nil)) 99 arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
320 (let ((cl-tail (nthcdr cl-i cl-p))) 100 (apply 'remove* 'remove* cl-seq :if-not cl-predicate cl-keys))
321 (setcdr cl-tail (cdr (cdr cl-tail)))) 101
322 (setq cl-end (1- cl-end))) 102 (defun delete-if (cl-predicate cl-seq &rest cl-keys)
323 (setq cl-p (cdr cl-p) cl-end (1- cl-end) 103 "Remove all items satisfying PREDICATE in SEQUENCE.
324 cl-start (1+ cl-start))) 104
325 cl-seq) 105 This is a destructive function; if SEQUENCE is a list, it reuses its
326 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) 106 storage. If SEQUENCE is an array and some element satisfies SEQUENCE, a
327 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) 107 copy is always returned.
328 (cl-position (cl-check-key (car cl-seq)) 108
329 (cdr cl-seq) 0 (1- cl-end))) 109 See `remove*' for the meaning of the keywords.
330 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) 110
331 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) 111 arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
332 (setq cl-end (1- cl-end) cl-start 1) cl-seq))) 112 (apply 'delete* 'delete* cl-seq :if cl-predicate cl-keys))
333 (while (and (cdr (cdr cl-p)) (> cl-end 1)) 113
334 (if (cl-position (cl-check-key (car (cdr cl-p))) 114 (defun delete-if-not (cl-predicate cl-seq &rest cl-keys)
335 (cdr (cdr cl-p)) 0 (1- cl-end)) 115 "Remove all items not satisfying PREDICATE in SEQUENCE.
336 (progn 116
337 (if cl-copy (setq cl-seq (copy-sequence cl-seq) 117 This is a destructive function; it reuses the storage of SEQUENCE whenever
338 cl-p (nthcdr (1- cl-start) cl-seq) 118 possible.
339 cl-copy nil)) 119
340 (setcdr cl-p (cdr (cdr cl-p)))) 120 See `remove*' for the meaning of the keywords.
341 (setq cl-p (cdr cl-p))) 121
342 (setq cl-end (1- cl-end) cl-start (1+ cl-start))) 122 arguments: (PREDICATE SEQUENCE &key (KEY #'IDENTITY) (START 0) END FROM-END COUNT)"
343 cl-seq))) 123 (apply 'delete* 'delete* cl-seq :if-not cl-predicate cl-keys))
344 (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) 124
345 (typecase cl-seq 125 (defun substitute-if (cl-new cl-predicate cl-seq &rest cl-keys)
346 (string (concat cl-res)) 126 "Substitute NEW for all items satisfying PREDICATE in SEQUENCE.
347 (vector (vconcat cl-res)) 127
348 (bit-vector (bvconcat cl-res)))))) 128 This is a non-destructive function; it makes a copy of SEQUENCE if necessary
349 129 to avoid corrupting the original SEQUENCE.
350 (defun substitute (cl-new cl-old cl-seq &rest cl-keys) 130
351 "Substitute NEW for OLD in SEQ. 131 See `remove*' for the meaning of the keywords.
352 This is a non-destructive function; it makes a copy of SEQ if necessary 132
353 to avoid corrupting the original SEQ. 133 arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
354 Keywords supported: :test :test-not :key :count :start :end :from-end 134 (apply 'substitute cl-new 'substitute cl-seq :if cl-predicate cl-keys))
355 See `remove*' for the meaning of the keywords." 135
356 (cl-parsing-keywords (:test :test-not :key :if :if-not :count 136 (defun substitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys)
357 (:start 0) :end :from-end) () 137 "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE.
358 (if (or (eq cl-old cl-new) 138
359 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) 139 This is a non-destructive function; it makes a copy of SEQUENCE if necessary
360 cl-seq 140 to avoid corrupting the original SEQUENCE.
361 (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) 141
362 (if (not cl-i) 142 See `remove*' for the meaning of the keywords.
363 cl-seq 143
364 (setq cl-seq (copy-sequence cl-seq)) 144 arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
365 (or cl-from-end 145 (apply 'substitute cl-new 'substitute cl-seq :if-not cl-predicate
366 (progn (cl-set-elt cl-seq cl-i cl-new) 146 cl-keys))
367 (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) 147
368 (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count 148 (defun nsubstitute-if (cl-new cl-predicate cl-seq &rest cl-keys)
369 :start cl-i cl-keys)))))) 149 "Substitute NEW for all items satisfying PREDICATE in SEQUENCE.
370 150
371 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) 151 This is destructive function; it modifies SEQUENCE directly, never returning
372 "Substitute NEW for all items satisfying PREDICATE in SEQ. 152 a copy. See `substitute-if' for a non-destructive version.
373 This is a non-destructive function; it makes a copy of SEQ if necessary 153
374 to avoid corrupting the original SEQ. 154 See `remove*' for the meaning of the keywords.
375 See `remove*' for the meaning of the keywords." 155
376 (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) 156 arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
377 157 (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if cl-predicate
378 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) 158 cl-keys))
379 "Substitute NEW for all items not satisfying PREDICATE in SEQ. 159
380 This is a non-destructive function; it makes a copy of SEQ if necessary 160 (defun nsubstitute-if-not (cl-new cl-predicate cl-seq &rest cl-keys)
381 to avoid corrupting the original SEQ. 161 "Substitute NEW for all items not satisfying PREDICATE in SEQUENCE.
382 See `remove*' for the meaning of the keywords." 162
383 (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) 163 This is destructive function; it modifies SEQUENCE directly, never returning
384 164 a copy. See `substitute-if-not' for a non-destructive version.
385 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) 165
386 "Substitute NEW for OLD in SEQ. 166 See `remove*' for the meaning of the keywords.
387 This is a destructive function; it reuses the storage of SEQ whenever possible. 167
388 Keywords supported: :test :test-not :key :count :start :end :from-end 168 arguments: (NEW PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END COUNT FROM-END)"
389 See `remove*' for the meaning of the keywords." 169 (apply 'nsubstitute cl-new 'nsubstitute cl-seq :if-not cl-predicate
390 (cl-parsing-keywords (:test :test-not :key :if :if-not :count 170 cl-keys))
391 (:start 0) :end :from-end) () 171
392 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) 172 (defun find-if (cl-predicate cl-seq &rest cl-keys)
393 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) 173 "Find the first item satisfying PREDICATE in SEQUENCE.
394 (let ((cl-p (nthcdr cl-start cl-seq))) 174
395 (setq cl-end (- (or cl-end 8000000) cl-start)) 175 Return the matching item, or DEFAULT (not a keyword specified for this
396 (while (and cl-p (> cl-end 0) (> cl-count 0)) 176 function by Common Lisp) if not found.
397 (if (cl-check-test cl-old (car cl-p)) 177
398 (progn 178 See `remove*' for the meaning of the other keywords.
399 (setcar cl-p cl-new) 179
400 (setq cl-count (1- cl-count)))) 180 arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)"
401 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) 181 (apply 'find 'find cl-seq :if cl-predicate cl-keys))
402 (or cl-end (setq cl-end (length cl-seq))) 182
403 (if cl-from-end 183 (defun find-if-not (cl-predicate cl-seq &rest cl-keys)
404 (while (and (< cl-start cl-end) (> cl-count 0)) 184 "Find the first item not satisfying PREDICATE in SEQUENCE.
405 (setq cl-end (1- cl-end)) 185
406 (if (cl-check-test cl-old (elt cl-seq cl-end)) 186 Return the matching ITEM, or DEFAULT (not a keyword specified for this
407 (progn 187 function by Common Lisp) if not found.
408 (cl-set-elt cl-seq cl-end cl-new) 188
409 (setq cl-count (1- cl-count))))) 189 See `remove*' for the meaning of the keywords.
410 (while (and (< cl-start cl-end) (> cl-count 0)) 190
411 (if (cl-check-test cl-old (aref cl-seq cl-start)) 191 arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END DEFAULT)"
412 (progn 192 (apply 'find 'find cl-seq :if-not cl-predicate cl-keys))
413 (aset cl-seq cl-start cl-new) 193
414 (setq cl-count (1- cl-count)))) 194 (defun position-if (cl-predicate cl-seq &rest cl-keys)
415 (setq cl-start (1+ cl-start)))))) 195 "Find the first item satisfying PREDICATE in SEQUENCE.
416 cl-seq)) 196
417
418 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
419 "Substitute NEW for all items satisfying PREDICATE in SEQ.
420 This is a destructive function; it reuses the storage of SEQ whenever possible.
421 Keywords supported: :key :count :start :end :from-end
422 See `remove*' for the meaning of the keywords."
423 (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
424
425 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
426 "Substitute NEW for all items not satisfying PREDICATE in SEQ.
427 This is a destructive function; it reuses the storage of SEQ whenever possible.
428 Keywords supported: :key :count :start :end :from-end
429 See `remove*' for the meaning of the keywords."
430 (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
431
432 (defun find (cl-item cl-seq &rest cl-keys)
433 "Find the first occurrence of ITEM in LIST.
434 Return the matching ITEM, or nil if not found.
435 Keywords supported: :test :test-not :key :start :end :from-end
436 See `remove*' for the meaning of the keywords."
437 (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
438 (and cl-pos (elt cl-seq cl-pos))))
439
440 (defun find-if (cl-pred cl-list &rest cl-keys)
441 "Find the first item satisfying PREDICATE in LIST.
442 Return the matching ITEM, or nil if not found.
443 Keywords supported: :key :start :end :from-end
444 See `remove*' for the meaning of the keywords."
445 (apply 'find nil cl-list :if cl-pred cl-keys))
446
447 (defun find-if-not (cl-pred cl-list &rest cl-keys)
448 "Find the first item not satisfying PREDICATE in LIST.
449 Return the matching ITEM, or nil if not found.
450 Keywords supported: :key :start :end :from-end
451 See `remove*' for the meaning of the keywords."
452 (apply 'find nil cl-list :if-not cl-pred cl-keys))
453
454 (defun position (cl-item cl-seq &rest cl-keys)
455 "Find the first occurrence of ITEM in LIST.
456 Return the index of the matching item, or nil if not found. 197 Return the index of the matching item, or nil if not found.
457 Keywords supported: :test :test-not :key :start :end :from-end 198
458 See `remove*' for the meaning of the keywords." 199 See `remove*' for the meaning of the keywords.
459 (cl-parsing-keywords (:test :test-not :key :if :if-not 200
460 (:start 0) :end :from-end) () 201 arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
461 (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) 202 (apply 'position 'position cl-seq :if cl-predicate cl-keys))
462 203
463 (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) 204 (defun position-if-not (cl-predicate cl-seq &rest cl-keys)
464 (if (listp cl-seq) 205 "Find the first item not satisfying PREDICATE in SEQUENCE.
465 (let ((cl-p (nthcdr cl-start cl-seq))) 206
466 (or cl-end (setq cl-end 8000000))
467 (let ((cl-res nil))
468 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
469 (if (cl-check-test cl-item (car cl-p))
470 (setq cl-res cl-start))
471 (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
472 cl-res))
473 (or cl-end (setq cl-end (length cl-seq)))
474 (if cl-from-end
475 (progn
476 (while (and (>= (setq cl-end (1- cl-end)) cl-start)
477 (not (cl-check-test cl-item (aref cl-seq cl-end)))))
478 (and (>= cl-end cl-start) cl-end))
479 (while (and (< cl-start cl-end)
480 (not (cl-check-test cl-item (aref cl-seq cl-start))))
481 (setq cl-start (1+ cl-start)))
482 (and (< cl-start cl-end) cl-start))))
483
484 (defun position-if (cl-pred cl-list &rest cl-keys)
485 "Find the first item satisfying PREDICATE in LIST.
486 Return the index of the matching item, or nil if not found. 207 Return the index of the matching item, or nil if not found.
487 Keywords supported: :key :start :end :from-end 208
488 See `remove*' for the meaning of the keywords." 209 See `remove*' for the meaning of the keywords.
489 (apply 'position nil cl-list :if cl-pred cl-keys)) 210
490 211 arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
491 (defun position-if-not (cl-pred cl-list &rest cl-keys) 212 (apply 'position 'position cl-seq :if-not cl-predicate cl-keys))
492 "Find the first item not satisfying PREDICATE in LIST. 213
493 Return the index of the matching item, or nil if not found. 214 (defun count-if (cl-predicate cl-seq &rest cl-keys)
494 Keywords supported: :key :start :end :from-end 215 "Count the number of items satisfying PREDICATE in SEQUENCE.
495 See `remove*' for the meaning of the keywords." 216
496 (apply 'position nil cl-list :if-not cl-pred cl-keys)) 217 See `remove*' for the meaning of the keywords.
497 218
498 (defun count (cl-item cl-seq &rest cl-keys) 219 arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
499 "Count the number of occurrences of ITEM in LIST. 220 (apply 'count 'count cl-seq :if cl-predicate cl-keys))
500 Keywords supported: :test :test-not :key :start :end 221
501 See `remove*' for the meaning of the keywords." 222 (defun count-if-not (cl-predicate cl-seq &rest cl-keys)
502 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () 223 "Count the number of items not satisfying PREDICATE in SEQUENCE.
503 (let ((cl-count 0) cl-x) 224
504 (or cl-end (setq cl-end (length cl-seq))) 225 See `remove*' for the meaning of the keywords.
505 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) 226
506 (while (< cl-start cl-end) 227 arguments: (PREDICATE SEQUENCE &key (KEY #'identity) (START 0) END FROM-END)"
507 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) 228 (apply 'count 'count cl-seq :if-not cl-predicate cl-keys))
508 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) 229
509 (setq cl-start (1+ cl-start))) 230 (defun stable-sort (cl-seq cl-predicate &rest cl-keys)
510 cl-count)))
511
512 (defun count-if (cl-pred cl-list &rest cl-keys)
513 "Count the number of items satisfying PREDICATE in LIST.
514 Keywords supported: :key :start :end
515 See `remove*' for the meaning of the keywords."
516 (apply 'count nil cl-list :if cl-pred cl-keys))
517
518 (defun count-if-not (cl-pred cl-list &rest cl-keys)
519 "Count the number of items not satisfying PREDICATE in LIST.
520 Keywords supported: :key :start :end
521 See `remove*' for the meaning of the keywords."
522 (apply 'count nil cl-list :if-not cl-pred cl-keys))
523
524 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
525 "Compare SEQ1 with SEQ2, return index of first mismatching element.
526 Return nil if the sequences match. If one sequence is a prefix of the
527 other, the return value indicates the end of the shorter sequence.
528 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
529 See `search' for the meaning of the keywords."
530 (cl-parsing-keywords (:test :test-not :key :from-end
531 (:start1 0) :end1 (:start2 0) :end2) ()
532 (or cl-end1 (setq cl-end1 (length cl-seq1)))
533 (or cl-end2 (setq cl-end2 (length cl-seq2)))
534 (if cl-from-end
535 (progn
536 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
537 (cl-check-match (elt cl-seq1 (1- cl-end1))
538 (elt cl-seq2 (1- cl-end2))))
539 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
540 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
541 (1- cl-end1)))
542 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
543 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
544 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
545 (cl-check-match (if cl-p1 (car cl-p1)
546 (aref cl-seq1 cl-start1))
547 (if cl-p2 (car cl-p2)
548 (aref cl-seq2 cl-start2))))
549 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
550 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
551 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
552 cl-start1)))))
553
554 (defun search (cl-seq1 cl-seq2 &rest cl-keys)
555 "Search for SEQ1 as a subsequence of SEQ2.
556 Return the index of the leftmost element of the first match found;
557 return nil if there are no matches.
558 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
559 See `remove*' for the meaning of the keywords. In this case, :start1 and :end1
560 specify a subsequence of SEQ1, and :start2 and :end2 specify a subsequence
561 of SEQ2."
562 (cl-parsing-keywords (:test :test-not :key :from-end
563 (:start1 0) :end1 (:start2 0) :end2) ()
564 (or cl-end1 (setq cl-end1 (length cl-seq1)))
565 (or cl-end2 (setq cl-end2 (length cl-seq2)))
566 (if (>= cl-start1 cl-end1)
567 (if cl-from-end cl-end2 cl-start2)
568 (let* ((cl-len (- cl-end1 cl-start1))
569 (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
570 (cl-if nil) cl-pos)
571 (setq cl-end2 (- cl-end2 (1- cl-len)))
572 (while (and (< cl-start2 cl-end2)
573 (setq cl-pos (cl-position cl-first cl-seq2
574 cl-start2 cl-end2 cl-from-end))
575 (apply 'mismatch cl-seq1 cl-seq2
576 :start1 (1+ cl-start1) :end1 cl-end1
577 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
578 :from-end nil cl-keys))
579 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
580 (and (< cl-start2 cl-end2) cl-pos)))))
581
582 (defun stable-sort (cl-seq cl-pred &rest cl-keys)
583 "Sort the argument SEQUENCE stably according to PREDICATE. 231 "Sort the argument SEQUENCE stably according to PREDICATE.
584 This is a destructive function; it reuses the storage of SEQUENCE if possible. 232 This is a destructive function; it reuses the storage of SEQUENCE if possible.
585 Keywords supported: :key 233 Keywords supported: :key
586 :key specifies a one-argument function that transforms elements of SEQUENCE 234 :key specifies a one-argument function that transforms elements of SEQUENCE
587 into \"comparison keys\" before the test predicate is applied. See 235 into \"comparison keys\" before the test predicate is applied. See
588 `member*' for more information. 236 `member*' for more information.
589 237
590 arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))" 238 arguments: (SEQUENCE PREDICATE &key (KEY #'identity))"
591 (apply 'sort* cl-seq cl-pred cl-keys)) 239 (apply 'sort* cl-seq cl-predicate cl-keys))
592 240
593 ;;; See compiler macro in cl-macs.el 241 (defun member-if (cl-predicate cl-list &rest cl-keys)
594 (defun member* (cl-item cl-list &rest cl-keys)
595 "Find the first occurrence of ITEM in LIST.
596 Return the sublist of LIST whose car is ITEM.
597 Keywords supported: :test :test-not :key
598 The keyword :test specifies a two-argument function that is used to
599 compare ITEM with elements in LIST; if omitted, it defaults to `eql'.
600 The keyword :test-not is similar, but specifies a negated predicate. That
601 is, ITEM is considered equal to an element in LIST if the given predicate
602 returns nil.
603 :key specifies a one-argument function that transforms elements of LIST into
604 \"comparison keys\" before the test predicate is applied. For example,
605 if :key is #'car, then ITEM is compared with the car of elements from LIST1.
606 The :key function, however, is not applied to ITEM, and does not affect the
607 elements in the returned list, which are taken directly from the elements in
608 LIST."
609 (if cl-keys
610 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
611 (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
612 (setq cl-list (cdr cl-list)))
613 cl-list)
614 (if (and (numberp cl-item) (not (fixnump cl-item)))
615 (member cl-item cl-list)
616 (memq cl-item cl-list))))
617
618 (defun member-if (cl-pred cl-list &rest cl-keys)
619 "Find the first item satisfying PREDICATE in LIST. 242 "Find the first item satisfying PREDICATE in LIST.
620 Return the sublist of LIST whose car matches. 243 Return the sublist of LIST whose car matches.
621 Keywords supported: :key 244 See `member*' for the meaning of :key.
622 See `member*' for the meaning of :key." 245
623 (apply 'member* nil cl-list :if cl-pred cl-keys)) 246 arguments: (PREDICATE LIST &key (KEY #'identity))"
624 247 (apply 'member* 'member* cl-list :if cl-predicate cl-keys))
625 (defun member-if-not (cl-pred cl-list &rest cl-keys) 248
249 (defun member-if-not (cl-predicate cl-list &rest cl-keys)
626 "Find the first item not satisfying PREDICATE in LIST. 250 "Find the first item not satisfying PREDICATE in LIST.
627 Return the sublist of LIST whose car matches. 251 Return the sublist of LIST whose car matches.
628 Keywords supported: :key 252 See `member*' for the meaning of :key.
629 See `member*' for the meaning of :key." 253
630 (apply 'member* nil cl-list :if-not cl-pred cl-keys)) 254 arguments: (PREDICATE LIST &key (KEY #'identity))"
631 255 (apply 'member* 'member* cl-list :if-not cl-predicate cl-keys))
632 (defun cl-adjoin (cl-item cl-list &rest cl-keys) 256
633 (if (cl-parsing-keywords (:key) t 257 (defun assoc-if (cl-predicate cl-alist &rest cl-keys)
634 (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) 258 "Return the first item whose car satisfies PREDICATE in ALIST.
635 cl-list 259 See `member*' for the meaning of :key.
636 (cons cl-item cl-list))) 260
637 261 arguments: (PREDICATE ALIST &key (KEY #'identity))"
638 ;;; See compiler macro in cl-macs.el 262 (apply 'assoc* 'assoc* cl-alist :if cl-predicate cl-keys))
639 (defun assoc* (cl-item cl-alist &rest cl-keys) 263
640 "Find the first item whose car matches ITEM in LIST. 264 (defun assoc-if-not (cl-predicate cl-alist &rest cl-keys)
641 Keywords supported: :test :test-not :key 265 "Return the first item whose car does not satisfy PREDICATE in ALIST.
642 See `member*' for the meaning of :test, :test-not and :key." 266 See `member*' for the meaning of :key.
643 (if cl-keys 267
644 (cl-parsing-keywords (:test :test-not :key :if :if-not) () 268 arguments: (PREDICATE ALIST &key (KEY #'identity))"
645 (while (and cl-alist 269 (apply 'assoc* 'assoc* cl-alist :if-not cl-predicate cl-keys))
646 (or (not (consp (car cl-alist))) 270
647 (not (cl-check-test cl-item (car (car cl-alist)))))) 271 (defun rassoc-if (cl-predicate cl-alist &rest cl-keys)
648 (setq cl-alist (cdr cl-alist))) 272 "Return the first item whose cdr satisfies PREDICATE in ALIST.
649 (and cl-alist (car cl-alist))) 273 See `member*' for the meaning of :key.
650 (if (and (numberp cl-item) (not (fixnump cl-item))) 274
651 (assoc cl-item cl-alist) 275 arguments: (PREDICATE ALIST &key (KEY #'identity))"
652 (assq cl-item cl-alist)))) 276 (apply 'rassoc* 'rassoc* cl-alist :if cl-predicate cl-keys))
653 277
654 (defun assoc-if (cl-pred cl-list &rest cl-keys) 278 (defun rassoc-if-not (cl-predicate cl-alist &rest cl-keys)
655 "Find the first item whose car satisfies PREDICATE in LIST. 279 "Return the first item whose cdr does not satisfy PREDICATE in ALIST.
656 Keywords supported: :key 280 See `member*' for the meaning of :key.
657 See `member*' for the meaning of :key." 281
658 (apply 'assoc* nil cl-list :if cl-pred cl-keys)) 282 arguments: (PREDICATE ALIST &key (KEY #'identity))"
659 283 (apply 'rassoc* 'rassoc* cl-alist :if-not cl-predicate cl-keys))
660 (defun assoc-if-not (cl-pred cl-list &rest cl-keys)
661 "Find the first item whose car does not satisfy PREDICATE in LIST.
662 Keywords supported: :key
663 See `member*' for the meaning of :key."
664 (apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
665
666 (defun rassoc* (cl-item cl-alist &rest cl-keys)
667 "Find the first item whose cdr matches ITEM in LIST.
668 Keywords supported: :test :test-not :key
669 See `member*' for the meaning of :test, :test-not and :key."
670 (if (or cl-keys (and (numberp cl-item) (not (fixnump cl-item))))
671 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
672 (while (and cl-alist
673 (or (not (consp (car cl-alist)))
674 (not (cl-check-test cl-item (cdr (car cl-alist))))))
675 (setq cl-alist (cdr cl-alist)))
676 (and cl-alist (car cl-alist)))
677 (rassq cl-item cl-alist)))
678
679 (defun rassoc-if (cl-pred cl-list &rest cl-keys)
680 "Find the first item whose cdr satisfies PREDICATE in LIST.
681 Keywords supported: :key
682 See `member*' for the meaning of :key."
683 (apply 'rassoc* nil cl-list :if cl-pred cl-keys))
684
685 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
686 "Find the first item whose cdr does not satisfy PREDICATE in LIST.
687 Keywords supported: :key
688 See `member*' for the meaning of :key."
689 (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
690
691 (defun union (cl-list1 cl-list2 &rest cl-keys)
692 "Combine LIST1 and LIST2 using a set-union operation.
693 The result list contains all items that appear in either LIST1 or LIST2.
694 This is a non-destructive function; it makes a copy of the data if necessary
695 to avoid corrupting the original LIST1 and LIST2.
696 Keywords supported: :test :test-not :key
697 The keywords :test and :test-not specify two-argument test and negated-test
698 predicates, respectively; :test defaults to `eql'. see `member*' for more
699 information.
700 :key specifies a one-argument function that transforms elements of LIST1
701 and LIST2 into \"comparison keys\" before the test predicate is applied.
702 For example, if :key is #'car, then the car of elements from LIST1 is
703 compared with the car of elements from LIST2. The :key function, however,
704 does not affect the elements in the returned list, which are taken directly
705 from the elements in LIST1 and LIST2."
706 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
707 ((equal cl-list1 cl-list2) cl-list1)
708 (t
709 (or (>= (length cl-list1) (length cl-list2))
710 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
711 (while cl-list2
712 (if (or cl-keys (numberp (car cl-list2)))
713 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
714 (or (memq (car cl-list2) cl-list1)
715 (push (car cl-list2) cl-list1)))
716 (pop cl-list2))
717 cl-list1)))
718
719 (defun nunion (cl-list1 cl-list2 &rest cl-keys)
720 "Combine LIST1 and LIST2 using a set-union operation.
721 The result list contains all items that appear in either LIST1 or LIST2.
722 This is a destructive function; it reuses the storage of LIST1 and LIST2
723 whenever possible.
724 Keywords supported: :test :test-not :key
725 See `union' for the meaning of :test, :test-not and :key."
726 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
727 (t (apply 'union cl-list1 cl-list2 cl-keys))))
728 284
729 ;; XEmacs addition: NOT IN COMMON LISP. 285 ;; XEmacs addition: NOT IN COMMON LISP.
730 (defun stable-union (cl-list1 cl-list2 &rest cl-keys) 286 (defun stable-union (cl-list1 cl-list2 &rest cl-keys)
731 "Stably combine LIST1 and LIST2 using a set-union operation. 287 "Stably combine LIST1 and LIST2 using a set-union operation.
732 The result list contains all items that appear in either LIST1 or LIST2. 288 The result list contains all items that appear in either LIST1 or LIST2.
733 The result is \"stable\" in that it preserves the ordering of elements in 289 The result is \"stable\" in that it preserves the ordering of elements in
734 LIST1 and LIST2. The result specifically consists of the elements in LIST1 290 LIST1 and LIST2. The result specifically consists of the elements in LIST1
735 in order, followed by any elements in LIST2 that are not also in LIST1, in 291 in order, followed by any elements in LIST2 that are not also in LIST1, in
736 the order given in LIST2. 292 the order given in LIST2.
293
737 This is a non-destructive function; it makes a copy of the data if necessary 294 This is a non-destructive function; it makes a copy of the data if necessary
738 to avoid corrupting the original LIST1 and LIST2. 295 to avoid corrupting the original LIST1 and LIST2.
739 Keywords supported: :test :test-not :key 296
740 See `union' for the meaning of :test, :test-not and :key. 297 See `union' for the meaning of :test, :test-not and :key.
741 298
742 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs 299 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs
743 extension." 300 extension.
301
302 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)"
744 ;; The standard `union' doesn't produce a "stable" union -- 303 ;; The standard `union' doesn't produce a "stable" union --
745 ;; it iterates over the second list instead of the first one, and returns 304 ;; it iterates over the second list instead of the first one, and returns
746 ;; the values in backwards order. According to the CLTL2 documentation, 305 ;; the values in backwards order. According to the CLTL2 documentation,
747 ;; `union' is not required to preserve the ordering of elements in 306 ;; `union' is not required to preserve the ordering of elements in
748 ;; any fashion, so we add a new function rather than changing the 307 ;; any fashion, so we add a new function rather than changing the
749 ;; semantics of `union'. 308 ;; semantics of `union'.
750 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) 309 (apply 'union cl-list1 cl-list2 :stable t cl-keys))
751 ((equal cl-list1 cl-list2) cl-list1)
752 (t
753 (append
754 cl-list1
755 (cl-parsing-keywords (:key) (:test :test-not)
756 (loop for cl-l in cl-list2
757 if (not (if (or cl-keys (numberp cl-l))
758 (apply 'member* (cl-check-key cl-l)
759 cl-list1 cl-keys)
760 (memq cl-l cl-list1)))
761 collect cl-l))))))
762
763 (defun intersection (cl-list1 cl-list2 &rest cl-keys)
764 "Combine LIST1 and LIST2 using a set-intersection operation.
765 The result list contains all items that appear in both LIST1 and LIST2.
766 This is a non-destructive function; it makes a copy of the data if necessary
767 to avoid corrupting the original LIST1 and LIST2.
768 Keywords supported: :test :test-not :key
769 See `union' for the meaning of :test, :test-not and :key."
770 (and cl-list1 cl-list2
771 (if (equal cl-list1 cl-list2) cl-list1
772 (cl-parsing-keywords (:key) (:test :test-not)
773 (let ((cl-res nil))
774 (or (>= (length cl-list1) (length cl-list2))
775 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
776 (while cl-list2
777 (if (if (or cl-keys (numberp (car cl-list2)))
778 (apply 'member* (cl-check-key (car cl-list2))
779 cl-list1 cl-keys)
780 (memq (car cl-list2) cl-list1))
781 (push (car cl-list2) cl-res))
782 (pop cl-list2))
783 cl-res)))))
784
785 (defun nintersection (cl-list1 cl-list2 &rest cl-keys)
786 "Combine LIST1 and LIST2 using a set-intersection operation.
787 The result list contains all items that appear in both LIST1 and LIST2.
788 This is a destructive function; it reuses the storage of LIST1 and LIST2
789 whenever possible.
790 Keywords supported: :test :test-not :key
791 See `union' for the meaning of :test, :test-not and :key."
792 (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
793 310
794 ;; XEmacs addition: NOT IN COMMON LISP. 311 ;; XEmacs addition: NOT IN COMMON LISP.
795 (defun stable-intersection (cl-list1 cl-list2 &rest cl-keys) 312 (defun stable-intersection (cl-list1 cl-list2 &rest cl-keys)
796 "Stably combine LIST1 and LIST2 using a set-intersection operation. 313 "Stably combine LIST1 and LIST2 using a set-intersection operation.
314
797 The result list contains all items that appear in both LIST1 and LIST2. 315 The result list contains all items that appear in both LIST1 and LIST2.
798 The result is \"stable\" in that it preserves the ordering of elements in 316 The result is \"stable\" in that it preserves the ordering of elements in
799 LIST1 that are also in LIST2. 317 LIST1 that are also in LIST2.
318
800 This is a non-destructive function; it makes a copy of the data if necessary 319 This is a non-destructive function; it makes a copy of the data if necessary
801 to avoid corrupting the original LIST1 and LIST2. 320 to avoid corrupting the original LIST1 and LIST2.
802 Keywords supported: :test :test-not :key 321
803 See `union' for the meaning of :test, :test-not and :key. 322 See `union' for the meaning of :test, :test-not and :key.
804 323
805 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs 324 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs
806 extension." 325 extension.
326
327 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)"
807 ;; The standard `intersection' doesn't produce a "stable" intersection -- 328 ;; The standard `intersection' doesn't produce a "stable" intersection --
808 ;; it iterates over the second list instead of the first one, and returns 329 ;; it iterates over the second list instead of the first one, and returns
809 ;; the values in backwards order. According to the CLTL2 documentation, 330 ;; the values in backwards order. According to the CLTL2 documentation,
810 ;; `intersection' is not required to preserve the ordering of elements in 331 ;; `intersection' is not required to preserve the ordering of elements in
811 ;; any fashion, so we add a new function rather than changing the 332 ;; any fashion, but it's trivial to implement a stable ordering in C,
812 ;; semantics of `intersection'. 333 ;; given that the order of arguments to the test function is specified.
813 (and cl-list1 cl-list2 334 (apply 'intersection cl-list1 cl-list2 :stable t cl-keys))
814 (if (equal cl-list1 cl-list2) cl-list1 335
815 (cl-parsing-keywords (:key) (:test :test-not) 336 (defun subst-if (cl-new cl-predicate cl-tree &rest cl-keys)
816 (loop for cl-l in cl-list1
817 if (if (or cl-keys (numberp cl-l))
818 (apply 'member* (cl-check-key cl-l)
819 cl-list2 cl-keys)
820 (memq cl-l cl-list2))
821 collect cl-l)))))
822
823 (defun set-difference (cl-list1 cl-list2 &rest cl-keys)
824 "Combine LIST1 and LIST2 using a set-difference operation.
825 The result list contains all items that appear in LIST1 but not LIST2.
826 This is a non-destructive function; it makes a copy of the data if necessary
827 to avoid corrupting the original LIST1 and LIST2.
828 Keywords supported: :test :test-not :key
829 See `union' for the meaning of :test, :test-not and :key."
830 (if (or (null cl-list1) (null cl-list2)) cl-list1
831 (cl-parsing-keywords (:key) (:test :test-not)
832 (let ((cl-res nil))
833 (while cl-list1
834 (or (if (or cl-keys (numberp (car cl-list1)))
835 (apply 'member* (cl-check-key (car cl-list1))
836 cl-list2 cl-keys)
837 (memq (car cl-list1) cl-list2))
838 (push (car cl-list1) cl-res))
839 (pop cl-list1))
840 cl-res))))
841
842 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
843 "Combine LIST1 and LIST2 using a set-difference operation.
844 The result list contains all items that appear in LIST1 but not LIST2.
845 This is a destructive function; it reuses the storage of LIST1 and LIST2
846 whenever possible.
847 Keywords supported: :test :test-not :key
848 See `union' for the meaning of :test, :test-not and :key."
849 (if (or (null cl-list1) (null cl-list2)) cl-list1
850 (apply 'set-difference cl-list1 cl-list2 cl-keys)))
851
852 (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
853 "Combine LIST1 and LIST2 using a set-exclusive-or operation.
854 The result list contains all items that appear in exactly one of LIST1, LIST2.
855 This is a non-destructive function; it makes a copy of the data if necessary
856 to avoid corrupting the original LIST1 and LIST2.
857 Keywords supported: :test :test-not :key
858 See `union' for the meaning of :test, :test-not and :key."
859 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
860 ((equal cl-list1 cl-list2) nil)
861 (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
862 (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
863
864 (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
865 "Combine LIST1 and LIST2 using a set-exclusive-or operation.
866 The result list contains all items that appear in exactly one of LIST1, LIST2.
867 This is a destructive function; it reuses the storage of LIST1 and LIST2
868 whenever possible.
869 Keywords supported: :test :test-not :key
870 See `union' for the meaning of :test, :test-not and :key."
871 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
872 ((equal cl-list1 cl-list2) nil)
873 (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
874 (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
875
876 (defun subsetp (cl-list1 cl-list2 &rest cl-keys)
877 "True if LIST1 is a subset of LIST2.
878 I.e., if every element of LIST1 also appears in LIST2.
879 Keywords supported: :test :test-not :key
880 See `union' for the meaning of :test, :test-not and :key."
881 (cond ((null cl-list1) t) ((null cl-list2) nil)
882 ((equal cl-list1 cl-list2) t)
883 (t (cl-parsing-keywords (:key) (:test :test-not)
884 (while (and cl-list1
885 (apply 'member* (cl-check-key (car cl-list1))
886 cl-list2 cl-keys))
887 (pop cl-list1))
888 (null cl-list1)))))
889
890 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
891 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). 337 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
892 Return a copy of TREE with all matching elements replaced by NEW. 338
893 Keywords supported: :key 339 Return a copy of TREE with all matching elements replaced by NEW. If no
894 See `member*' for the meaning of :key." 340 element matches PREDICATE, return tree.
895 (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) 341
896 342 See `member*' for the meaning of :key.
897 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) 343
898 "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). 344 arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
899 Return a copy of TREE with all non-matching elements replaced by NEW. 345 (apply 'subst cl-new 'subst cl-tree :if cl-predicate cl-keys))
900 Keywords supported: :key 346
901 See `member*' for the meaning of :key." 347 (defun subst-if-not (cl-new cl-predicate cl-tree &rest cl-keys)
902 (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) 348 "Substitute NEW for elements not matching PREDICATE in TREE.
903 349
904 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys) 350 Return a copy of TREE with all matching elements replaced by NEW. If every
905 "Substitute NEW for OLD everywhere in TREE (destructively). 351 element matches PREDICATE, return tree.
906 Any element of TREE which is `eql' to OLD is changed to NEW (via a call 352
907 to `setcar'). 353 See `member*' for the meaning of :key.
908 Keywords supported: :test :test-not :key 354
909 See `member*' for the meaning of :test, :test-not and :key." 355 arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
910 (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) 356 (apply 'subst cl-new 'subst cl-tree :if-not cl-predicate cl-keys))
911 357
912 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) 358 (defun nsubst-if (cl-new cl-predicate cl-tree &rest cl-keys)
913 "Substitute NEW for elements matching PREDICATE in TREE (destructively). 359 "Substitute NEW for elements matching PREDICATE in TREE (destructively).
360
914 Any element of TREE which matches is changed to NEW (via a call to `setcar'). 361 Any element of TREE which matches is changed to NEW (via a call to `setcar').
915 Keywords supported: :key 362
916 See `member*' for the meaning of :key." 363 See `member*' for the meaning of :key.
917 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) 364
918 365 arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
919 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) 366 (apply 'nsubst cl-new 'nsubst cl-tree :if cl-predicate cl-keys))
367
368 (defun nsubst-if-not (cl-new cl-predicate cl-tree &rest cl-keys)
920 "Substitute NEW for elements not matching PREDICATE in TREE (destructively). 369 "Substitute NEW for elements not matching PREDICATE in TREE (destructively).
370
921 Any element of TREE which matches is changed to NEW (via a call to `setcar'). 371 Any element of TREE which matches is changed to NEW (via a call to `setcar').
922 Keywords supported: :key 372
923 See `member*' for the meaning of :key." 373 See `member*' for the meaning of :key.
924 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) 374
925 375 arguments: (NEW PREDICATE TREE &key (KEY #'identity))"
926 (defun sublis (cl-alist cl-tree &rest cl-keys) 376 (apply 'nsubst cl-new 'nsubst cl-tree :if-not cl-predicate cl-keys))
927 "Perform substitutions indicated by ALIST in TREE (non-destructively).
928 Return a copy of TREE with all matching elements replaced.
929 Keywords supported: :test :test-not :key
930 See `member*' for the meaning of :test, :test-not and :key."
931 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
932 (cl-sublis-rec cl-tree)))
933
934 (defvar cl-alist)
935 (defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if*
936 (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
937 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
938 (setq cl-p (cdr cl-p)))
939 (if cl-p (cdr (car cl-p))
940 (if (consp cl-tree)
941 (let ((cl-a (cl-sublis-rec (car cl-tree)))
942 (cl-d (cl-sublis-rec (cdr cl-tree))))
943 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
944 cl-tree
945 (cons cl-a cl-d)))
946 cl-tree))))
947
948 (defun nsublis (cl-alist cl-tree &rest cl-keys)
949 "Perform substitutions indicated by ALIST in TREE (destructively).
950 Any matching element of TREE is changed via a call to `setcar'.
951 Keywords supported: :test :test-not :key
952 See `member*' for the meaning of :test, :test-not and :key."
953 (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
954 (let ((cl-hold (list cl-tree)))
955 (cl-nsublis-rec cl-hold)
956 (car cl-hold))))
957
958 (defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if*
959 (while (consp cl-tree)
960 (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
961 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
962 (setq cl-p (cdr cl-p)))
963 (if cl-p (setcar cl-tree (cdr (car cl-p)))
964 (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
965 (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
966 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
967 (setq cl-p (cdr cl-p)))
968 (if cl-p
969 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
970 (setq cl-tree (cdr cl-tree))))))
971
972 (defun tree-equal (cl-x cl-y &rest cl-keys)
973 "Return t if trees X and Y have `eql' leaves.
974 Atoms are compared by `eql'; cons cells are compared recursively.
975 Keywords supported: :test :test-not :key
976 See `union' for the meaning of :test, :test-not and :key."
977 (cl-parsing-keywords (:test :test-not :key) ()
978 (cl-tree-equal-rec cl-x cl-y)))
979
980 (defun cl-tree-equal-rec (cl-x cl-y)
981 (while (and (consp cl-x) (consp cl-y)
982 (cl-tree-equal-rec (car cl-x) (car cl-y)))
983 (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
984 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
985
986
987 (run-hooks 'cl-seq-load-hook)
988 377
989 ;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c 378 ;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c
990 ;;; cl-seq.el ends here 379 ;;; cl-seq.el ends here