Mercurial > hg > xemacs-beta
annotate lisp/cl-seq.el @ 4885:6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
lisp/ChangeLog addition:
2010-01-24 Aidan Kehoe <kehoea@parhasard.net>
Correct the semantics of #'member*, #'eql, #'assoc* in the
presence of bignums; change the integerp byte code to fixnump
semantics.
* bytecomp.el (fixnump, integerp, byte-compile-integerp):
Change the integerp byte code to fixnump; add a byte-compile
method to integerp using fixnump and numberp and avoiding a
funcall most of the time, since in the non-core contexts where
integerp is used, it's mostly distinguishing between fixnums and
things that are not numbers at all.
* byte-optimize.el (side-effect-free-fns, byte-after-unbind-ops)
(byte-compile-side-effect-and-error-free-ops):
Replace the integerp bytecode with fixnump; add fixnump to the
side-effect-free-fns. Add the other extended number type
predicates to the list in passing.
* obsolete.el (floatp-safe): Mark this as obsolete.
* cl.el (eql): Go into more detail in the docstring here. Don't
bother checking whether both arguments are numbers; one is enough,
#'equal will fail correctly if they have distinct types.
(subst): Replace a call to #'integerp (deciding whether to use
#'memq or not) with one to #'fixnump.
Delete most-positive-fixnum, most-negative-fixnum from this file;
they're now always in C, so they can't be modified from Lisp.
* cl-seq.el (member*, assoc*, rassoc*):
Correct these functions in the presence of bignums.
* cl-macs.el (cl-make-type-test): The type test for a fixnum is
now fixnump. Ditch floatp-safe, use floatp instead.
(eql): Correct this compiler macro in the presence of bignums.
(assoc*): Correct this compiler macro in the presence of bignums.
* simple.el (undo):
Change #'integerp to #'fixnump here, since we use #'delq with the
same value as ELT a few lines down.
src/ChangeLog addition:
2010-01-24 Aidan Kehoe <kehoea@parhasard.net>
Fix problems with #'eql, extended number types, and the hash table
implementation; change the Bintegerp bytecode to fixnump semantics
even on bignum builds, since #'integerp can have a fast
implementation in terms of #'fixnump for most of its extant uses,
but not vice-versa.
* lisp.h: Always #include number.h; we want the macros provided in
it, even if the various number types are not available.
* number.h (NON_FIXNUM_NUMBER_P): New macro, giving 1 when its
argument is of non-immediate number type. Equivalent to FLOATP if
WITH_NUMBER_TYPES is not defined.
* elhash.c (lisp_object_eql_equal, lisp_object_eql_hash):
Use NON_FIXNUM_NUMBER_P in these functions, instead of FLOATP,
giving more correct behaviour in the presence of the extended
number types.
* bytecode.c (Bfixnump, execute_optimized_program):
Rename Bintegerp to Bfixnump; change its semantics to reflect the
new name on builds with bignum support.
* data.c (Ffixnump, Fintegerp, syms_of_data, vars_of_data):
Always make #'fixnump available, even on non-BIGNUM builds;
always implement #'integerp in this file, even on BIGNUM builds.
Move most-positive-fixnum, most-negative-fixnum here from
number.c, so they are Lisp constants even on builds without number
types, and attempts to change or bind them error.
Use the NUMBERP and INTEGERP macros even on builds without
extended number types.
* data.c (fixnum_char_or_marker_to_int):
Rename this function from integer_char_or_marker_to_int, to better
reflect the arguments it accepts.
* number.c (Fevenp, Foddp, syms_of_number):
Never provide #'integerp in this file. Remove #'oddp,
#'evenp; their implementations are overridden by those in cl.el.
* number.c (vars_of_number):
most-positive-fixnum, most-negative-fixnum are no longer here.
man/ChangeLog addition:
2010-01-23 Aidan Kehoe <kehoea@parhasard.net>
Generally: be careful to say fixnum, not integer, when talking
about fixed-precision integral types. I'm sure I've missed
instances, both here and in the docstrings, but this is a decent
start.
* lispref/text.texi (Columns):
Document where only fixnums, not integers generally, are accepted.
(Registers):
Remove some ancient char-int confoundance here.
* lispref/strings.texi (Creating Strings, Creating Strings):
Be more exact in describing where fixnums but not integers in
general are accepted.
(Creating Strings): Use a more contemporary example to illustrate
how concat deals with lists including integers about #xFF. Delete
some obsolete documentation on same.
(Char Table Types): Document that only fixnums are accepted as
values in syntax tables.
* lispref/searching.texi (String Search, Search and Replace):
Be exact in describing where fixnums but not integers in general
are accepted.
* lispref/range-tables.texi (Range Tables): Be exact in describing
them; only fixnums are accepted to describe ranges.
* lispref/os.texi (Killing XEmacs, User Identification)
(Time of Day, Time Conversion):
Be more exact about using fixnum where only fixed-precision
integers are accepted.
* lispref/objects.texi (Integer Type): Be more exact (and
up-to-date) about the possible values for
integers. Cross-reference to documentation of the bignum extension.
(Equality Predicates):
(Range Table Type):
(Array Type): Use fixnum, not integer, to describe a
fixed-precision integer.
(Syntax Table Type): Correct some English syntax here.
* lispref/numbers.texi (Numbers): Change the phrasing here to use
fixnum to mean the fixed-precision integers normal in emacs.
Document that our terminology deviates from that of Common Lisp,
and that we're working on it.
(Compatibility Issues): Reiterate the Common Lisp versus Emacs
Lisp compatibility issues.
(Comparison of Numbers, Arithmetic Operations):
* lispref/commands.texi (Command Loop Info, Working With Events):
* lispref/buffers.texi (Modification Time):
Be more exact in describing where fixnums but not integers in
general are accepted.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 24 Jan 2010 15:21:27 +0000 |
parents | 393039450288 |
children | 545ec923b4eb |
rev | line source |
---|---|
613 | 1 ;;; cl-seq.el --- Common Lisp extensions for XEmacs Lisp (part three) |
428 | 2 |
3 ;; Copyright (C) 1993 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Dave Gillespie <daveg@synaptics.com> | |
6 ;; Maintainer: XEmacs Development Team | |
7 ;; Version: 2.02 | |
8 ;; Keywords: extensions, dumped | |
9 | |
10 ;; This file is part of XEmacs. | |
11 | |
12 ;; XEmacs is free software; you can redistribute it and/or modify it | |
13 ;; under the terms of the GNU General Public License as published by | |
14 ;; the Free Software Foundation; either version 2, or (at your option) | |
15 ;; any later version. | |
16 | |
17 ;; XEmacs is distributed in the hope that it will be useful, but | |
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
20 ;; General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
23 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
25 ;; 02111-1307, USA. | |
26 | |
2153 | 27 ;;; Synched up with: FSF 21.3. |
428 | 28 |
29 ;;; Commentary: | |
30 | |
31 ;; This file is dumped with XEmacs. | |
32 | |
33 ;; These are extensions to Emacs Lisp that provide a degree of | |
34 ;; Common Lisp compatibility, beyond what is already built-in | |
35 ;; in Emacs Lisp. | |
36 ;; | |
37 ;; This package was written by Dave Gillespie; it is a complete | |
38 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
39 ;; | |
40 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. | |
41 ;; | |
42 ;; Bug reports, comments, and suggestions are welcome! | |
43 | |
44 ;; This file contains the Common Lisp sequence and list functions | |
45 ;; which take keyword arguments. | |
46 | |
47 ;; See cl.el for Change Log. | |
48 | |
49 | |
50 ;;; Code: | |
51 | |
52 (or (memq 'cl-19 features) | |
53 (error "Tried to load `cl-seq' before `cl'!")) | |
54 | |
55 | |
56 ;;; Keyword parsing. This is special-cased here so that we can compile | |
57 ;;; this file independent from cl-macs. | |
58 | |
59 (defmacro cl-parsing-keywords (kwords other-keys &rest body) | |
442 | 60 "Helper macro for functions with keyword arguments. |
61 This is a temporary solution, until keyword arguments are natively supported. | |
62 Declare your function ending with (... &rest cl-keys), then wrap the | |
63 function body in a call to `cl-parsing-keywords'. | |
64 | |
65 KWORDS is a list of keyword definitions. Each definition should be | |
66 either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case, | |
67 the default value is nil. The keywords are available in BODY as the name | |
68 of the keyword, minus its initial colon and prepended with `cl-'. | |
69 | |
70 OTHER-KEYS specifies other keywords that are accepted but ignored. It | |
71 is either the value 't' (ignore all other keys, equivalent to the | |
72 &allow-other-keys argument declaration in Common Lisp) or a list in the | |
73 same format as KWORDS. If keywords are given that are not in KWORDS | |
74 and not allowed by OTHER-KEYS, an error will normally be signalled; but | |
75 the caller can override this by specifying a non-nil value for the | |
76 keyword :allow-other-keys (which defaults to t)." | |
428 | 77 (cons |
78 'let* | |
79 (cons (mapcar | |
80 (function | |
81 (lambda (x) | |
82 (let* ((var (if (consp x) (car x) x)) | |
83 (mem (list 'car (list 'cdr (list 'memq (list 'quote var) | |
84 'cl-keys))))) | |
2153 | 85 (if (eq var :test-not) |
428 | 86 (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) |
2153 | 87 (if (eq var :if-not) |
428 | 88 (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) |
89 (list (intern | |
90 (format "cl-%s" (substring (symbol-name var) 1))) | |
91 (if (consp x) (list 'or mem (car (cdr x))) mem))))) | |
92 kwords) | |
93 (append | |
94 (and (not (eq other-keys t)) | |
95 (list | |
96 (list 'let '((cl-keys-temp cl-keys)) | |
97 (list 'while 'cl-keys-temp | |
98 (list 'or (list 'memq '(car cl-keys-temp) | |
99 (list 'quote | |
100 (mapcar | |
101 (function | |
102 (lambda (x) | |
103 (if (consp x) | |
104 (car x) x))) | |
105 (append kwords | |
106 other-keys)))) | |
107 '(car (cdr (memq (quote :allow-other-keys) | |
108 cl-keys))) | |
109 '(error "Bad keyword argument %s" | |
110 (car cl-keys-temp))) | |
111 '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) | |
112 body)))) | |
113 (put 'cl-parsing-keywords 'lisp-indent-function 2) | |
114 (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) | |
115 | |
116 (defmacro cl-check-key (x) | |
117 (list 'if 'cl-key (list 'funcall 'cl-key x) x)) | |
118 | |
119 (defmacro cl-check-test-nokey (item x) | |
120 (list 'cond | |
121 (list 'cl-test | |
122 (list 'eq (list 'not (list 'funcall 'cl-test item x)) | |
123 'cl-test-not)) | |
124 (list 'cl-if | |
125 (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) | |
126 (list 't (list 'if (list 'numberp item) | |
127 (list 'equal item x) (list 'eq item x))))) | |
128 | |
129 (defmacro cl-check-test (item x) | |
130 (list 'cl-check-test-nokey item (list 'cl-check-key x))) | |
131 | |
132 (defmacro cl-check-match (x y) | |
133 (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) | |
134 (list 'if 'cl-test | |
135 (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) | |
136 (list 'if (list 'numberp x) | |
137 (list 'equal x y) (list 'eq x y)))) | |
138 | |
139 (put 'cl-check-key 'edebug-form-spec 'edebug-forms) | |
140 (put 'cl-check-test 'edebug-form-spec 'edebug-forms) | |
141 (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) | |
142 (put 'cl-check-match 'edebug-form-spec 'edebug-forms) | |
143 | |
144 (defvar cl-test) (defvar cl-test-not) | |
145 (defvar cl-if) (defvar cl-if-not) | |
146 (defvar cl-key) | |
147 | |
148 | |
149 (defun reduce (cl-func cl-seq &rest cl-keys) | |
150 "Reduce two-argument FUNCTION across SEQUENCE. | |
151 Keywords supported: :start :end :from-end :initial-value :key" | |
152 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () | |
153 (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) | |
154 (setq cl-seq (subseq cl-seq cl-start cl-end)) | |
155 (if cl-from-end (setq cl-seq (nreverse cl-seq))) | |
2153 | 156 (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) |
157 (cl-seq (cl-check-key (pop cl-seq))) | |
428 | 158 (t (funcall cl-func))))) |
159 (if cl-from-end | |
160 (while cl-seq | |
2153 | 161 (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq)) |
428 | 162 cl-accum))) |
163 (while cl-seq | |
164 (setq cl-accum (funcall cl-func cl-accum | |
2153 | 165 (cl-check-key (pop cl-seq)))))) |
428 | 166 cl-accum))) |
167 | |
168 (defun fill (seq item &rest cl-keys) | |
169 "Fill the elements of SEQ with ITEM. | |
170 Keywords supported: :start :end" | |
171 (cl-parsing-keywords ((:start 0) :end) () | |
172 (if (listp seq) | |
173 (let ((p (nthcdr cl-start seq)) | |
174 (n (if cl-end (- cl-end cl-start) 8000000))) | |
175 (while (and p (>= (setq n (1- n)) 0)) | |
176 (setcar p item) | |
177 (setq p (cdr p)))) | |
178 (or cl-end (setq cl-end (length seq))) | |
179 (if (and (= cl-start 0) (= cl-end (length seq))) | |
180 (fillarray seq item) | |
181 (while (< cl-start cl-end) | |
182 (aset seq cl-start item) | |
183 (setq cl-start (1+ cl-start))))) | |
184 seq)) | |
185 | |
186 (defun replace (cl-seq1 cl-seq2 &rest cl-keys) | |
187 "Replace the elements of SEQ1 with the elements of SEQ2. | |
188 SEQ1 is destructively modified, then returned. | |
189 Keywords supported: :start1 :end1 :start2 :end2" | |
190 (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () | |
191 (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) | |
192 (or (= cl-start1 cl-start2) | |
193 (let* ((cl-len (length cl-seq1)) | |
194 (cl-n (min (- (or cl-end1 cl-len) cl-start1) | |
195 (- (or cl-end2 cl-len) cl-start2)))) | |
196 (while (>= (setq cl-n (1- cl-n)) 0) | |
197 (cl-set-elt cl-seq1 (+ cl-start1 cl-n) | |
198 (elt cl-seq2 (+ cl-start2 cl-n)))))) | |
199 (if (listp cl-seq1) | |
200 (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) | |
201 (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) | |
202 (if (listp cl-seq2) | |
203 (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) | |
204 (cl-n (min cl-n1 | |
205 (if cl-end2 (- cl-end2 cl-start2) 4000000)))) | |
206 (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) | |
207 (setcar cl-p1 (car cl-p2)) | |
208 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) | |
209 (setq cl-end2 (min (or cl-end2 (length cl-seq2)) | |
210 (+ cl-start2 cl-n1))) | |
211 (while (and cl-p1 (< cl-start2 cl-end2)) | |
212 (setcar cl-p1 (aref cl-seq2 cl-start2)) | |
213 (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) | |
214 (setq cl-end1 (min (or cl-end1 (length cl-seq1)) | |
215 (+ cl-start1 (- (or cl-end2 (length cl-seq2)) | |
216 cl-start2)))) | |
217 (if (listp cl-seq2) | |
218 (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) | |
219 (while (< cl-start1 cl-end1) | |
220 (aset cl-seq1 cl-start1 (car cl-p2)) | |
221 (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) | |
222 (while (< cl-start1 cl-end1) | |
223 (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) | |
224 (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) | |
225 cl-seq1)) | |
226 | |
227 (defun remove* (cl-item cl-seq &rest cl-keys) | |
228 "Remove all occurrences of ITEM in SEQ. | |
229 This is a non-destructive function; it makes a copy of SEQ if necessary | |
230 to avoid corrupting the original SEQ. | |
231 Keywords supported: :test :test-not :key :count :start :end :from-end" | |
232 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end | |
233 (:start 0) :end) () | |
234 (if (<= (or cl-count (setq cl-count 8000000)) 0) | |
235 cl-seq | |
236 (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) | |
237 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end | |
238 cl-from-end))) | |
239 (if cl-i | |
240 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) | |
241 (append (if cl-from-end | |
2153 | 242 (list :end (1+ cl-i)) |
243 (list :start cl-i)) | |
428 | 244 cl-keys)))) |
245 (if (listp cl-seq) cl-res | |
246 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) | |
247 cl-seq)) | |
248 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
249 (if (= cl-start 0) | |
250 (while (and cl-seq (> cl-end 0) | |
251 (cl-check-test cl-item (car cl-seq)) | |
252 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) | |
253 (> (setq cl-count (1- cl-count)) 0)))) | |
254 (if (and (> cl-count 0) (> cl-end 0)) | |
255 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) | |
256 (setq cl-end (1- cl-end)) (cdr cl-seq)))) | |
257 (while (and cl-p (> cl-end 0) | |
258 (not (cl-check-test cl-item (car cl-p)))) | |
259 (setq cl-p (cdr cl-p) cl-end (1- cl-end))) | |
260 (if (and cl-p (> cl-end 0)) | |
261 (nconc (ldiff cl-seq cl-p) | |
262 (if (= cl-count 1) (cdr cl-p) | |
263 (and (cdr cl-p) | |
264 (apply 'delete* cl-item | |
265 (copy-sequence (cdr cl-p)) | |
2153 | 266 :start 0 :end (1- cl-end) |
267 :count (1- cl-count) cl-keys)))) | |
428 | 268 cl-seq)) |
269 cl-seq))))) | |
270 | |
271 (defun remove-if (cl-pred cl-list &rest cl-keys) | |
272 "Remove all items satisfying PREDICATE in SEQ. | |
273 This is a non-destructive function; it makes a copy of SEQ if necessary | |
274 to avoid corrupting the original SEQ. | |
275 Keywords supported: :key :count :start :end :from-end" | |
2153 | 276 (apply 'remove* nil cl-list :if cl-pred cl-keys)) |
428 | 277 |
278 (defun remove-if-not (cl-pred cl-list &rest cl-keys) | |
279 "Remove all items not satisfying PREDICATE in SEQ. | |
280 This is a non-destructive function; it makes a copy of SEQ if necessary | |
281 to avoid corrupting the original SEQ. | |
282 Keywords supported: :key :count :start :end :from-end" | |
2153 | 283 (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) |
428 | 284 |
285 (defun delete* (cl-item cl-seq &rest cl-keys) | |
286 "Remove all occurrences of ITEM in SEQ. | |
287 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
288 Keywords supported: :test :test-not :key :count :start :end :from-end" | |
289 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end | |
290 (:start 0) :end) () | |
291 (if (<= (or cl-count (setq cl-count 8000000)) 0) | |
292 cl-seq | |
293 (if (listp cl-seq) | |
294 (if (and cl-from-end (< cl-count 4000000)) | |
295 (let (cl-i) | |
296 (while (and (>= (setq cl-count (1- cl-count)) 0) | |
297 (setq cl-i (cl-position cl-item cl-seq cl-start | |
298 cl-end cl-from-end))) | |
299 (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) | |
300 (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) | |
301 (setcdr cl-tail (cdr (cdr cl-tail))))) | |
302 (setq cl-end cl-i)) | |
303 cl-seq) | |
304 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
305 (if (= cl-start 0) | |
306 (progn | |
307 (while (and cl-seq | |
308 (> cl-end 0) | |
309 (cl-check-test cl-item (car cl-seq)) | |
310 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) | |
311 (> (setq cl-count (1- cl-count)) 0))) | |
312 (setq cl-end (1- cl-end))) | |
313 (setq cl-start (1- cl-start))) | |
314 (if (and (> cl-count 0) (> cl-end 0)) | |
315 (let ((cl-p (nthcdr cl-start cl-seq))) | |
316 (while (and (cdr cl-p) (> cl-end 0)) | |
317 (if (cl-check-test cl-item (car (cdr cl-p))) | |
318 (progn | |
319 (setcdr cl-p (cdr (cdr cl-p))) | |
320 (if (= (setq cl-count (1- cl-count)) 0) | |
321 (setq cl-end 1))) | |
322 (setq cl-p (cdr cl-p))) | |
323 (setq cl-end (1- cl-end))))) | |
324 cl-seq) | |
325 (apply 'remove* cl-item cl-seq cl-keys))))) | |
326 | |
327 (defun delete-if (cl-pred cl-list &rest cl-keys) | |
328 "Remove all items satisfying PREDICATE in SEQ. | |
329 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
330 Keywords supported: :key :count :start :end :from-end" | |
2153 | 331 (apply 'delete* nil cl-list :if cl-pred cl-keys)) |
428 | 332 |
333 (defun delete-if-not (cl-pred cl-list &rest cl-keys) | |
334 "Remove all items not satisfying PREDICATE in SEQ. | |
335 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
336 Keywords supported: :key :count :start :end :from-end" | |
2153 | 337 (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) |
428 | 338 |
2153 | 339 ;; XEmacs change: this is in subr.el in Emacs |
428 | 340 (defun remove (cl-item cl-seq) |
341 "Remove all occurrences of ITEM in SEQ, testing with `equal' | |
342 This is a non-destructive function; it makes a copy of SEQ if necessary | |
343 to avoid corrupting the original SEQ. | |
344 Also see: `remove*', `delete', `delete*'" | |
345 (remove* cl-item cl-seq ':test 'equal)) | |
346 | |
2153 | 347 ;; XEmacs change: this is in subr.el in Emacs |
428 | 348 (defun remq (cl-elt cl-list) |
442 | 349 "Remove all occurrences of ELT in LIST, comparing with `eq'. |
428 | 350 This is a non-destructive function; it makes a copy of LIST to avoid |
351 corrupting the original LIST. | |
352 Also see: `delq', `delete', `delete*', `remove', `remove*'." | |
353 (if (memq cl-elt cl-list) | |
354 (delq cl-elt (copy-list cl-list)) | |
355 cl-list)) | |
356 | |
357 (defun remove-duplicates (cl-seq &rest cl-keys) | |
358 "Return a copy of SEQ with all duplicate elements removed. | |
359 Keywords supported: :test :test-not :key :start :end :from-end" | |
360 (cl-delete-duplicates cl-seq cl-keys t)) | |
361 | |
362 (defun delete-duplicates (cl-seq &rest cl-keys) | |
363 "Remove all duplicate elements from SEQ (destructively). | |
364 Keywords supported: :test :test-not :key :start :end :from-end" | |
365 (cl-delete-duplicates cl-seq cl-keys nil)) | |
366 | |
367 (defun cl-delete-duplicates (cl-seq cl-keys cl-copy) | |
368 (if (listp cl-seq) | |
369 (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) | |
370 () | |
371 (if cl-from-end | |
372 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) | |
373 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) | |
374 (while (> cl-end 1) | |
375 (setq cl-i 0) | |
376 (while (setq cl-i (cl-position (cl-check-key (car cl-p)) | |
377 (cdr cl-p) cl-i (1- cl-end))) | |
378 (if cl-copy (setq cl-seq (copy-sequence cl-seq) | |
379 cl-p (nthcdr cl-start cl-seq) cl-copy nil)) | |
380 (let ((cl-tail (nthcdr cl-i cl-p))) | |
381 (setcdr cl-tail (cdr (cdr cl-tail)))) | |
382 (setq cl-end (1- cl-end))) | |
383 (setq cl-p (cdr cl-p) cl-end (1- cl-end) | |
384 cl-start (1+ cl-start))) | |
385 cl-seq) | |
386 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) | |
387 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) | |
388 (cl-position (cl-check-key (car cl-seq)) | |
389 (cdr cl-seq) 0 (1- cl-end))) | |
390 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) | |
391 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) | |
392 (setq cl-end (1- cl-end) cl-start 1) cl-seq))) | |
393 (while (and (cdr (cdr cl-p)) (> cl-end 1)) | |
394 (if (cl-position (cl-check-key (car (cdr cl-p))) | |
395 (cdr (cdr cl-p)) 0 (1- cl-end)) | |
396 (progn | |
397 (if cl-copy (setq cl-seq (copy-sequence cl-seq) | |
398 cl-p (nthcdr (1- cl-start) cl-seq) | |
399 cl-copy nil)) | |
400 (setcdr cl-p (cdr (cdr cl-p)))) | |
401 (setq cl-p (cdr cl-p))) | |
402 (setq cl-end (1- cl-end) cl-start (1+ cl-start))) | |
403 cl-seq))) | |
404 (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) | |
405 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) | |
406 | |
407 (defun substitute (cl-new cl-old cl-seq &rest cl-keys) | |
408 "Substitute NEW for OLD in SEQ. | |
409 This is a non-destructive function; it makes a copy of SEQ if necessary | |
410 to avoid corrupting the original SEQ. | |
411 Keywords supported: :test :test-not :key :count :start :end :from-end" | |
412 (cl-parsing-keywords (:test :test-not :key :if :if-not :count | |
413 (:start 0) :end :from-end) () | |
414 (if (or (eq cl-old cl-new) | |
415 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) | |
416 cl-seq | |
417 (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) | |
418 (if (not cl-i) | |
419 cl-seq | |
420 (setq cl-seq (copy-sequence cl-seq)) | |
421 (or cl-from-end | |
422 (progn (cl-set-elt cl-seq cl-i cl-new) | |
423 (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) | |
2153 | 424 (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count |
425 :start cl-i cl-keys)))))) | |
428 | 426 |
427 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) | |
428 "Substitute NEW for all items satisfying PREDICATE in SEQ. | |
429 This is a non-destructive function; it makes a copy of SEQ if necessary | |
430 to avoid corrupting the original SEQ. | |
431 Keywords supported: :key :count :start :end :from-end" | |
2153 | 432 (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) |
428 | 433 |
434 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) | |
435 "Substitute NEW for all items not satisfying PREDICATE in SEQ. | |
436 This is a non-destructive function; it makes a copy of SEQ if necessary | |
437 to avoid corrupting the original SEQ. | |
438 Keywords supported: :key :count :start :end :from-end" | |
2153 | 439 (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) |
428 | 440 |
441 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) | |
442 "Substitute NEW for OLD in SEQ. | |
443 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
444 Keywords supported: :test :test-not :key :count :start :end :from-end" | |
445 (cl-parsing-keywords (:test :test-not :key :if :if-not :count | |
446 (:start 0) :end :from-end) () | |
447 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) | |
448 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) | |
449 (let ((cl-p (nthcdr cl-start cl-seq))) | |
450 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
451 (while (and cl-p (> cl-end 0) (> cl-count 0)) | |
452 (if (cl-check-test cl-old (car cl-p)) | |
453 (progn | |
454 (setcar cl-p cl-new) | |
455 (setq cl-count (1- cl-count)))) | |
456 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) | |
457 (or cl-end (setq cl-end (length cl-seq))) | |
458 (if cl-from-end | |
459 (while (and (< cl-start cl-end) (> cl-count 0)) | |
460 (setq cl-end (1- cl-end)) | |
461 (if (cl-check-test cl-old (elt cl-seq cl-end)) | |
462 (progn | |
463 (cl-set-elt cl-seq cl-end cl-new) | |
464 (setq cl-count (1- cl-count))))) | |
465 (while (and (< cl-start cl-end) (> cl-count 0)) | |
466 (if (cl-check-test cl-old (aref cl-seq cl-start)) | |
467 (progn | |
468 (aset cl-seq cl-start cl-new) | |
469 (setq cl-count (1- cl-count)))) | |
470 (setq cl-start (1+ cl-start)))))) | |
471 cl-seq)) | |
472 | |
473 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) | |
474 "Substitute NEW for all items satisfying PREDICATE in SEQ. | |
475 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
476 Keywords supported: :key :count :start :end :from-end" | |
2153 | 477 (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) |
428 | 478 |
479 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) | |
480 "Substitute NEW for all items not satisfying PREDICATE in SEQ. | |
481 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
482 Keywords supported: :key :count :start :end :from-end" | |
2153 | 483 (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) |
428 | 484 |
485 (defun find (cl-item cl-seq &rest cl-keys) | |
486 "Find the first occurrence of ITEM in LIST. | |
487 Return the matching ITEM, or nil if not found. | |
488 Keywords supported: :test :test-not :key :start :end :from-end" | |
489 (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) | |
490 (and cl-pos (elt cl-seq cl-pos)))) | |
491 | |
492 (defun find-if (cl-pred cl-list &rest cl-keys) | |
493 "Find the first item satisfying PREDICATE in LIST. | |
494 Return the matching ITEM, or nil if not found. | |
495 Keywords supported: :key :start :end :from-end" | |
2153 | 496 (apply 'find nil cl-list :if cl-pred cl-keys)) |
428 | 497 |
498 (defun find-if-not (cl-pred cl-list &rest cl-keys) | |
499 "Find the first item not satisfying PREDICATE in LIST. | |
500 Return the matching ITEM, or nil if not found. | |
501 Keywords supported: :key :start :end :from-end" | |
2153 | 502 (apply 'find nil cl-list :if-not cl-pred cl-keys)) |
428 | 503 |
504 (defun position (cl-item cl-seq &rest cl-keys) | |
505 "Find the first occurrence of ITEM in LIST. | |
506 Return the index of the matching item, or nil if not found. | |
507 Keywords supported: :test :test-not :key :start :end :from-end" | |
508 (cl-parsing-keywords (:test :test-not :key :if :if-not | |
509 (:start 0) :end :from-end) () | |
510 (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) | |
511 | |
512 (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) | |
513 (if (listp cl-seq) | |
514 (let ((cl-p (nthcdr cl-start cl-seq))) | |
515 (or cl-end (setq cl-end 8000000)) | |
516 (let ((cl-res nil)) | |
517 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) | |
518 (if (cl-check-test cl-item (car cl-p)) | |
519 (setq cl-res cl-start)) | |
520 (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) | |
521 cl-res)) | |
522 (or cl-end (setq cl-end (length cl-seq))) | |
523 (if cl-from-end | |
524 (progn | |
525 (while (and (>= (setq cl-end (1- cl-end)) cl-start) | |
526 (not (cl-check-test cl-item (aref cl-seq cl-end))))) | |
527 (and (>= cl-end cl-start) cl-end)) | |
528 (while (and (< cl-start cl-end) | |
529 (not (cl-check-test cl-item (aref cl-seq cl-start)))) | |
530 (setq cl-start (1+ cl-start))) | |
531 (and (< cl-start cl-end) cl-start)))) | |
532 | |
533 (defun position-if (cl-pred cl-list &rest cl-keys) | |
534 "Find the first item satisfying PREDICATE in LIST. | |
535 Return the index of the matching item, or nil if not found. | |
536 Keywords supported: :key :start :end :from-end" | |
2153 | 537 (apply 'position nil cl-list :if cl-pred cl-keys)) |
428 | 538 |
539 (defun position-if-not (cl-pred cl-list &rest cl-keys) | |
540 "Find the first item not satisfying PREDICATE in LIST. | |
541 Return the index of the matching item, or nil if not found. | |
542 Keywords supported: :key :start :end :from-end" | |
2153 | 543 (apply 'position nil cl-list :if-not cl-pred cl-keys)) |
428 | 544 |
545 (defun count (cl-item cl-seq &rest cl-keys) | |
546 "Count the number of occurrences of ITEM in LIST. | |
547 Keywords supported: :test :test-not :key :start :end" | |
548 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () | |
549 (let ((cl-count 0) cl-x) | |
550 (or cl-end (setq cl-end (length cl-seq))) | |
551 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) | |
552 (while (< cl-start cl-end) | |
2153 | 553 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) |
428 | 554 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) |
555 (setq cl-start (1+ cl-start))) | |
556 cl-count))) | |
557 | |
558 (defun count-if (cl-pred cl-list &rest cl-keys) | |
559 "Count the number of items satisfying PREDICATE in LIST. | |
560 Keywords supported: :key :start :end" | |
2153 | 561 (apply 'count nil cl-list :if cl-pred cl-keys)) |
428 | 562 |
563 (defun count-if-not (cl-pred cl-list &rest cl-keys) | |
564 "Count the number of items not satisfying PREDICATE in LIST. | |
565 Keywords supported: :key :start :end" | |
2153 | 566 (apply 'count nil cl-list :if-not cl-pred cl-keys)) |
428 | 567 |
568 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) | |
569 "Compare SEQ1 with SEQ2, return index of first mismatching element. | |
570 Return nil if the sequences match. If one sequence is a prefix of the | |
2153 | 571 other, the return value indicates the end of the shorter sequence. |
428 | 572 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" |
573 (cl-parsing-keywords (:test :test-not :key :from-end | |
574 (:start1 0) :end1 (:start2 0) :end2) () | |
575 (or cl-end1 (setq cl-end1 (length cl-seq1))) | |
576 (or cl-end2 (setq cl-end2 (length cl-seq2))) | |
577 (if cl-from-end | |
578 (progn | |
579 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) | |
580 (cl-check-match (elt cl-seq1 (1- cl-end1)) | |
581 (elt cl-seq2 (1- cl-end2)))) | |
582 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) | |
583 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) | |
584 (1- cl-end1))) | |
585 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) | |
586 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) | |
587 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) | |
588 (cl-check-match (if cl-p1 (car cl-p1) | |
589 (aref cl-seq1 cl-start1)) | |
590 (if cl-p2 (car cl-p2) | |
591 (aref cl-seq2 cl-start2)))) | |
592 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) | |
593 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) | |
594 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) | |
595 cl-start1))))) | |
596 | |
597 (defun search (cl-seq1 cl-seq2 &rest cl-keys) | |
598 "Search for SEQ1 as a subsequence of SEQ2. | |
599 Return the index of the leftmost element of the first match found; | |
600 return nil if there are no matches. | |
601 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" | |
602 (cl-parsing-keywords (:test :test-not :key :from-end | |
603 (:start1 0) :end1 (:start2 0) :end2) () | |
604 (or cl-end1 (setq cl-end1 (length cl-seq1))) | |
605 (or cl-end2 (setq cl-end2 (length cl-seq2))) | |
606 (if (>= cl-start1 cl-end1) | |
607 (if cl-from-end cl-end2 cl-start2) | |
608 (let* ((cl-len (- cl-end1 cl-start1)) | |
609 (cl-first (cl-check-key (elt cl-seq1 cl-start1))) | |
610 (cl-if nil) cl-pos) | |
611 (setq cl-end2 (- cl-end2 (1- cl-len))) | |
612 (while (and (< cl-start2 cl-end2) | |
613 (setq cl-pos (cl-position cl-first cl-seq2 | |
614 cl-start2 cl-end2 cl-from-end)) | |
615 (apply 'mismatch cl-seq1 cl-seq2 | |
2153 | 616 :start1 (1+ cl-start1) :end1 cl-end1 |
617 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) | |
618 :from-end nil cl-keys)) | |
428 | 619 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) |
620 (and (< cl-start2 cl-end2) cl-pos))))) | |
621 | |
622 (defun sort* (cl-seq cl-pred &rest cl-keys) | |
623 "Sort the argument SEQUENCE according to PREDICATE. | |
624 This is a destructive function; it reuses the storage of SEQUENCE if possible. | |
625 Keywords supported: :key" | |
626 (if (nlistp cl-seq) | |
627 (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) | |
628 (cl-parsing-keywords (:key) () | |
629 (if (memq cl-key '(nil identity)) | |
630 (sort cl-seq cl-pred) | |
631 (sort cl-seq (function (lambda (cl-x cl-y) | |
632 (funcall cl-pred (funcall cl-key cl-x) | |
633 (funcall cl-key cl-y))))))))) | |
634 | |
635 (defun stable-sort (cl-seq cl-pred &rest cl-keys) | |
636 "Sort the argument SEQUENCE stably according to PREDICATE. | |
637 This is a destructive function; it reuses the storage of SEQUENCE if possible. | |
638 Keywords supported: :key" | |
639 (apply 'sort* cl-seq cl-pred cl-keys)) | |
640 | |
641 (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) | |
642 "Destructively merge the two sequences to produce a new sequence. | |
643 TYPE is the sequence type to return, SEQ1 and SEQ2 are the two | |
644 argument sequences, and PRED is a `less-than' predicate on the elements. | |
645 Keywords supported: :key" | |
646 (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) | |
647 (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) | |
648 (cl-parsing-keywords (:key) () | |
649 (let ((cl-res nil)) | |
650 (while (and cl-seq1 cl-seq2) | |
651 (if (funcall cl-pred (cl-check-key (car cl-seq2)) | |
652 (cl-check-key (car cl-seq1))) | |
2153 | 653 (push (pop cl-seq2) cl-res) |
654 (push (pop cl-seq1) cl-res))) | |
428 | 655 (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) |
656 | |
657 ;;; See compiler macro in cl-macs.el | |
658 (defun member* (cl-item cl-list &rest cl-keys) | |
659 "Find the first occurrence of ITEM in LIST. | |
660 Return the sublist of LIST whose car is ITEM. | |
661 Keywords supported: :test :test-not :key" | |
662 (if cl-keys | |
663 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
664 (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) | |
665 (setq cl-list (cdr cl-list))) | |
666 cl-list) | |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
667 (if (and (numberp cl-item) (not (fixnump cl-item))) |
428 | 668 (member cl-item cl-list) |
669 (memq cl-item cl-list)))) | |
670 | |
671 (defun member-if (cl-pred cl-list &rest cl-keys) | |
672 "Find the first item satisfying PREDICATE in LIST. | |
673 Return the sublist of LIST whose car matches. | |
674 Keywords supported: :key" | |
2153 | 675 (apply 'member* nil cl-list :if cl-pred cl-keys)) |
428 | 676 |
677 (defun member-if-not (cl-pred cl-list &rest cl-keys) | |
678 "Find the first item not satisfying PREDICATE in LIST. | |
679 Return the sublist of LIST whose car matches. | |
680 Keywords supported: :key" | |
2153 | 681 (apply 'member* nil cl-list :if-not cl-pred cl-keys)) |
428 | 682 |
683 (defun cl-adjoin (cl-item cl-list &rest cl-keys) | |
684 (if (cl-parsing-keywords (:key) t | |
685 (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) | |
686 cl-list | |
687 (cons cl-item cl-list))) | |
688 | |
689 ;;; See compiler macro in cl-macs.el | |
690 (defun assoc* (cl-item cl-alist &rest cl-keys) | |
691 "Find the first item whose car matches ITEM in LIST. | |
692 Keywords supported: :test :test-not :key" | |
693 (if cl-keys | |
694 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
695 (while (and cl-alist | |
696 (or (not (consp (car cl-alist))) | |
697 (not (cl-check-test cl-item (car (car cl-alist)))))) | |
698 (setq cl-alist (cdr cl-alist))) | |
699 (and cl-alist (car cl-alist))) | |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
700 (if (and (numberp cl-item) (not (fixnump cl-item))) |
428 | 701 (assoc cl-item cl-alist) |
702 (assq cl-item cl-alist)))) | |
703 | |
704 (defun assoc-if (cl-pred cl-list &rest cl-keys) | |
705 "Find the first item whose car satisfies PREDICATE in LIST. | |
706 Keywords supported: :key" | |
2153 | 707 (apply 'assoc* nil cl-list :if cl-pred cl-keys)) |
428 | 708 |
709 (defun assoc-if-not (cl-pred cl-list &rest cl-keys) | |
710 "Find the first item whose car does not satisfy PREDICATE in LIST. | |
711 Keywords supported: :key" | |
2153 | 712 (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) |
428 | 713 |
714 (defun rassoc* (cl-item cl-alist &rest cl-keys) | |
715 "Find the first item whose cdr matches ITEM in LIST. | |
716 Keywords supported: :test :test-not :key" | |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
717 (if (or cl-keys (and (numberp cl-item) (not (fixnump cl-item)))) |
428 | 718 (cl-parsing-keywords (:test :test-not :key :if :if-not) () |
719 (while (and cl-alist | |
720 (or (not (consp (car cl-alist))) | |
721 (not (cl-check-test cl-item (cdr (car cl-alist)))))) | |
722 (setq cl-alist (cdr cl-alist))) | |
723 (and cl-alist (car cl-alist))) | |
724 (rassq cl-item cl-alist))) | |
725 | |
726 (defun rassoc-if (cl-pred cl-list &rest cl-keys) | |
727 "Find the first item whose cdr satisfies PREDICATE in LIST. | |
728 Keywords supported: :key" | |
2153 | 729 (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) |
428 | 730 |
731 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys) | |
732 "Find the first item whose cdr does not satisfy PREDICATE in LIST. | |
733 Keywords supported: :key" | |
2153 | 734 (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) |
428 | 735 |
736 (defun union (cl-list1 cl-list2 &rest cl-keys) | |
737 "Combine LIST1 and LIST2 using a set-union operation. | |
738 The result list contains all items that appear in either LIST1 or LIST2. | |
739 This is a non-destructive function; it makes a copy of the data if necessary | |
740 to avoid corrupting the original LIST1 and LIST2. | |
741 Keywords supported: :test :test-not :key" | |
742 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) | |
743 ((equal cl-list1 cl-list2) cl-list1) | |
744 (t | |
745 (or (>= (length cl-list1) (length cl-list2)) | |
746 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) | |
747 (while cl-list2 | |
748 (if (or cl-keys (numberp (car cl-list2))) | |
749 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) | |
750 (or (memq (car cl-list2) cl-list1) | |
2153 | 751 (push (car cl-list2) cl-list1))) |
752 (pop cl-list2)) | |
428 | 753 cl-list1))) |
754 | |
755 (defun nunion (cl-list1 cl-list2 &rest cl-keys) | |
756 "Combine LIST1 and LIST2 using a set-union operation. | |
757 The result list contains all items that appear in either LIST1 or LIST2. | |
758 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
759 whenever possible. | |
760 Keywords supported: :test :test-not :key" | |
761 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) | |
762 (t (apply 'union cl-list1 cl-list2 cl-keys)))) | |
763 | |
764 (defun intersection (cl-list1 cl-list2 &rest cl-keys) | |
765 "Combine LIST1 and LIST2 using a set-intersection operation. | |
766 The result list contains all items that appear in both LIST1 and LIST2. | |
767 This is a non-destructive function; it makes a copy of the data if necessary | |
768 to avoid corrupting the original LIST1 and LIST2. | |
769 Keywords supported: :test :test-not :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)) | |
2153 | 781 (push (car cl-list2) cl-res)) |
782 (pop cl-list2)) | |
428 | 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 (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) | |
792 | |
793 (defun set-difference (cl-list1 cl-list2 &rest cl-keys) | |
794 "Combine LIST1 and LIST2 using a set-difference operation. | |
795 The result list contains all items that appear in LIST1 but not LIST2. | |
796 This is a non-destructive function; it makes a copy of the data if necessary | |
797 to avoid corrupting the original LIST1 and LIST2. | |
798 Keywords supported: :test :test-not :key" | |
799 (if (or (null cl-list1) (null cl-list2)) cl-list1 | |
800 (cl-parsing-keywords (:key) (:test :test-not) | |
801 (let ((cl-res nil)) | |
802 (while cl-list1 | |
803 (or (if (or cl-keys (numberp (car cl-list1))) | |
804 (apply 'member* (cl-check-key (car cl-list1)) | |
805 cl-list2 cl-keys) | |
806 (memq (car cl-list1) cl-list2)) | |
2153 | 807 (push (car cl-list1) cl-res)) |
808 (pop cl-list1)) | |
428 | 809 cl-res)))) |
810 | |
811 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys) | |
812 "Combine LIST1 and LIST2 using a set-difference operation. | |
813 The result list contains all items that appear in LIST1 but not LIST2. | |
814 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
815 whenever possible. | |
816 Keywords supported: :test :test-not :key" | |
817 (if (or (null cl-list1) (null cl-list2)) cl-list1 | |
818 (apply 'set-difference cl-list1 cl-list2 cl-keys))) | |
819 | |
820 (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) | |
821 "Combine LIST1 and LIST2 using a set-exclusive-or operation. | |
822 The result list contains all items that appear in exactly one of LIST1, LIST2. | |
823 This is a non-destructive function; it makes a copy of the data if necessary | |
824 to avoid corrupting the original LIST1 and LIST2. | |
825 Keywords supported: :test :test-not :key" | |
826 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) | |
827 ((equal cl-list1 cl-list2) nil) | |
828 (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) | |
829 (apply 'set-difference cl-list2 cl-list1 cl-keys))))) | |
830 | |
831 (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) | |
832 "Combine LIST1 and LIST2 using a set-exclusive-or operation. | |
833 The result list contains all items that appear in exactly one of LIST1, LIST2. | |
834 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
835 whenever possible. | |
836 Keywords supported: :test :test-not :key" | |
837 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) | |
838 ((equal cl-list1 cl-list2) nil) | |
839 (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) | |
840 (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) | |
841 | |
842 (defun subsetp (cl-list1 cl-list2 &rest cl-keys) | |
843 "True if LIST1 is a subset of LIST2. | |
844 I.e., if every element of LIST1 also appears in LIST2. | |
845 Keywords supported: :test :test-not :key" | |
846 (cond ((null cl-list1) t) ((null cl-list2) nil) | |
847 ((equal cl-list1 cl-list2) t) | |
848 (t (cl-parsing-keywords (:key) (:test :test-not) | |
849 (while (and cl-list1 | |
850 (apply 'member* (cl-check-key (car cl-list1)) | |
851 cl-list2 cl-keys)) | |
2153 | 852 (pop cl-list1)) |
428 | 853 (null cl-list1))))) |
854 | |
855 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) | |
856 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). | |
857 Return a copy of TREE with all matching elements replaced by NEW. | |
858 Keywords supported: :key" | |
2153 | 859 (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) |
428 | 860 |
861 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) | |
862 "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). | |
863 Return a copy of TREE with all non-matching elements replaced by NEW. | |
864 Keywords supported: :key" | |
2153 | 865 (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) |
428 | 866 |
867 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys) | |
868 "Substitute NEW for OLD everywhere in TREE (destructively). | |
869 Any element of TREE which is `eql' to OLD is changed to NEW (via a call | |
870 to `setcar'). | |
871 Keywords supported: :test :test-not :key" | |
872 (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) | |
873 | |
874 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) | |
875 "Substitute NEW for elements matching PREDICATE in TREE (destructively). | |
876 Any element of TREE which matches is changed to NEW (via a call to `setcar'). | |
877 Keywords supported: :key" | |
2153 | 878 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) |
428 | 879 |
880 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) | |
881 "Substitute NEW for elements not matching PREDICATE in TREE (destructively). | |
882 Any element of TREE which matches is changed to NEW (via a call to `setcar'). | |
883 Keywords supported: :key" | |
2153 | 884 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) |
428 | 885 |
886 (defun sublis (cl-alist cl-tree &rest cl-keys) | |
887 "Perform substitutions indicated by ALIST in TREE (non-destructively). | |
888 Return a copy of TREE with all matching elements replaced. | |
889 Keywords supported: :test :test-not :key" | |
890 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
891 (cl-sublis-rec cl-tree))) | |
892 | |
893 (defvar cl-alist) | |
894 (defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* | |
895 (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) | |
896 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
897 (setq cl-p (cdr cl-p))) | |
898 (if cl-p (cdr (car cl-p)) | |
899 (if (consp cl-tree) | |
900 (let ((cl-a (cl-sublis-rec (car cl-tree))) | |
901 (cl-d (cl-sublis-rec (cdr cl-tree)))) | |
902 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) | |
903 cl-tree | |
904 (cons cl-a cl-d))) | |
905 cl-tree)))) | |
906 | |
907 (defun nsublis (cl-alist cl-tree &rest cl-keys) | |
908 "Perform substitutions indicated by ALIST in TREE (destructively). | |
909 Any matching element of TREE is changed via a call to `setcar'. | |
910 Keywords supported: :test :test-not :key" | |
911 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
912 (let ((cl-hold (list cl-tree))) | |
913 (cl-nsublis-rec cl-hold) | |
914 (car cl-hold)))) | |
915 | |
916 (defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* | |
917 (while (consp cl-tree) | |
918 (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) | |
919 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
920 (setq cl-p (cdr cl-p))) | |
921 (if cl-p (setcar cl-tree (cdr (car cl-p))) | |
922 (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) | |
923 (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) | |
924 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
925 (setq cl-p (cdr cl-p))) | |
926 (if cl-p | |
927 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) | |
928 (setq cl-tree (cdr cl-tree)))))) | |
929 | |
930 (defun tree-equal (cl-x cl-y &rest cl-keys) | |
931 "Return t if trees X and Y have `eql' leaves. | |
932 Atoms are compared by `eql'; cons cells are compared recursively. | |
933 Keywords supported: :test :test-not :key" | |
934 (cl-parsing-keywords (:test :test-not :key) () | |
935 (cl-tree-equal-rec cl-x cl-y))) | |
936 | |
937 (defun cl-tree-equal-rec (cl-x cl-y) | |
938 (while (and (consp cl-x) (consp cl-y) | |
939 (cl-tree-equal-rec (car cl-x) (car cl-y))) | |
940 (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) | |
941 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) | |
942 | |
943 | |
944 (run-hooks 'cl-seq-load-hook) | |
945 | |
2153 | 946 ;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c |
428 | 947 ;;; cl-seq.el ends here |