Mercurial > hg > xemacs-beta

comparison lisp/cl-seq.el @ 5327:d1b17a33450b

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