Mercurial > hg > xemacs-beta

comparison src/sequence.c @ 5607:1a507c4c6c42

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Refactor out sequence-oriented builtins from fns.c to the new sequence.c. src/ChangeLog addition: 2011-12-04 Aidan Kehoe <kehoea@parhasard.net> * Makefile.in.in (objs): * depend: Add sequence.o to the list of objects and dependencies. * alloc.c: * alloc.c (mark_bit_vector): * alloc.c (print_bit_vector): * alloc.c (bit_vector_equal): * alloc.c (internal_bit_vector_equalp_hash): * alloc.c (bit_vector_hash): * alloc.c (init_alloc_once_early): Move the implementation of the bit vector type here from fns.c. * emacs.c (main_1): Call syms_of_sequence() here, now sequence.c is included. * fns.c (Fold_rassq): Move this together with the rest of the Fold_* functions. * fns.c: * fns.c (syms_of_fns): Move most functions dealing with sequences generally, and especially those taking key arguments, to a separate file, sequence.c. * general-slots.h: Qyes_or_no_p belong here, not fns.c. * lisp.h: Make Flist_length available here, it's used by sequence.c * sequence.c: * sequence.c (check_sequence_range): * sequence.c (Flength): * sequence.c (check_other_nokey): * sequence.c (check_other_key): * sequence.c (check_if_key): * sequence.c (check_match_eq_key): * sequence.c (check_match_eql_key): * sequence.c (check_match_equal_key): * sequence.c (check_match_equalp_key): * sequence.c (check_match_other_key): * sequence.c (check_lss_key): * sequence.c (check_lss_key_car): * sequence.c (check_string_lessp_key): * sequence.c (check_string_lessp_key_car): * sequence.c (get_check_match_function_1): * sequence.c (get_merge_predicate): * sequence.c (count_with_tail): * sequence.c (list_count_from_end): * sequence.c (string_count_from_end): * sequence.c (Fcount): * sequence.c (Fsubseq): * sequence.c (list_position_cons_before): * sequence.c (FmemberX): * sequence.c (Fadjoin): * sequence.c (FassocX): * sequence.c (FrassocX): * sequence.c (position): * sequence.c (Fposition): * sequence.c (Ffind): * sequence.c (delq_no_quit_and_free_cons): * sequence.c (FdeleteX): * sequence.c (FremoveX): * sequence.c (list_delete_duplicates_from_end): * sequence.c (Fdelete_duplicates): * sequence.c (Fremove_duplicates): * sequence.c (Fnreverse): * sequence.c (Freverse): * sequence.c (list_merge): * sequence.c (array_merge): * sequence.c (list_array_merge_into_list): * sequence.c (list_list_merge_into_array): * sequence.c (list_array_merge_into_array): * sequence.c (Fmerge): * sequence.c (list_sort): * sequence.c (array_sort): * sequence.c (FsortX): * sequence.c (Ffill): * sequence.c (mapcarX): * sequence.c (shortest_length_among_sequences): * sequence.c (Fmapconcat): * sequence.c (FmapcarX): * sequence.c (Fmapvector): * sequence.c (Fmapcan): * sequence.c (Fmap): * sequence.c (Fmap_into): * sequence.c (Fsome): * sequence.c (Fevery): * sequence.c (Freduce): * sequence.c (replace_string_range_1): * sequence.c (Freplace): * sequence.c (Fnsubstitute): * sequence.c (Fsubstitute): * sequence.c (subst): * sequence.c (sublis): * sequence.c (Fsublis): * sequence.c (nsublis): * sequence.c (Fnsublis): * sequence.c (Fsubst): * sequence.c (Fnsubst): * sequence.c (tree_equal): * sequence.c (Ftree_equal): * sequence.c (mismatch_from_end): * sequence.c (mismatch_list_list): * sequence.c (mismatch_list_string): * sequence.c (mismatch_list_array): * sequence.c (mismatch_string_array): * sequence.c (mismatch_string_string): * sequence.c (mismatch_array_array): * sequence.c (get_mismatch_func): * sequence.c (Fmismatch): * sequence.c (Fsearch): * sequence.c (venn): * sequence.c (nvenn): * sequence.c (Funion): * sequence.c (Fset_exclusive_or): * sequence.c (Fnset_exclusive_or): * sequence.c (syms_of_sequence): Add this file, containing those general functions that dealt with sequences that were in fns.c. * symsinit.h: Make syms_of_sequence() available here. man/ChangeLog addition: 2011-12-04 Aidan Kehoe <kehoea@parhasard.net> * internals/internals.texi (Basic Lisp Modules): Document sequence.c here too.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 04 Dec 2011 18:42:50 +0000
parents
children 37479d841681
comparison
equal deleted inserted replaced
5606:7c383c5784ed 5607:1a507c4c6c42
1 /* Various functions that operate on sequences, split out from fns.c
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software: you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation, either version 3 of the License, or (at your
10 option) any later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */
19
20 #include <config.h>
21 #include "lisp.h"
22 #include "extents.h"
23
24 Lisp_Object Qadjoin, Qarray, QassocX, Qbit_vector, Qcar_less_than_car;
25 Lisp_Object QdeleteX, Qdelete_duplicates, Qevery, Qfill, Qfind, Qidentity;
26 Lisp_Object Qintersection, Qmap, Qmap_into, Qmapc, Qmapcan, QmapcarX;
27 Lisp_Object Qmapconcat, Qmapvector, Qmerge, Qmismatch, Qnintersection;
28 Lisp_Object Qnset_difference, Qnsubstitute, Qnunion, Qposition, QrassocX;
29 Lisp_Object Qreduce, QremoveX, Qreplace, Qset_difference, Qsome, QsortX;
30 Lisp_Object Qstring_lessp, Qsubsetp, Qsubstitute, Qvector;
31
32 Lisp_Object Q_count, Q_descend_structures, Q_end1, Q_end2, Q_from_end;
33 Lisp_Object Q_if_, Q_if_not, Q_initial_value, Q_stable, Q_start1, Q_start2;
34 Lisp_Object Q_test_not;
35
36 extern Fixnum max_lisp_eval_depth;
37 extern int lisp_eval_depth;
38
39 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
40
41 static DOESNT_RETURN
42 mapping_interaction_error (Lisp_Object func, Lisp_Object object)
43 {
44 invalid_state_2 ("object modified while traversing it", func, object);
45 }
46
47 static void
48 check_sequence_range (Lisp_Object sequence, Lisp_Object start,
49 Lisp_Object end, Lisp_Object length)
50 {
51 Lisp_Object args[] = { Qzero, start, NILP (end) ? length : end, length };
52
53 if (NILP (Fleq (countof (args), args)))
54 {
55 args_out_of_range_3 (sequence, start, end);
56 }
57 }
58
59 DEFUN ("length", Flength, 1, 1, 0, /*
60 Return the length of vector, bit vector, list or string SEQUENCE.
61 */
62 (sequence))
63 {
64 retry:
65 if (STRINGP (sequence))
66 return make_fixnum (string_char_length (sequence));
67 else if (CONSP (sequence))
68 {
69 Elemcount len;
70 GET_EXTERNAL_LIST_LENGTH (sequence, len);
71 return make_fixnum (len);
72 }
73 else if (VECTORP (sequence))
74 return make_fixnum (XVECTOR_LENGTH (sequence));
75 else if (NILP (sequence))
76 return Qzero;
77 else if (BIT_VECTORP (sequence))
78 return make_fixnum (bit_vector_length (XBIT_VECTOR (sequence)));
79 else
80 {
81 check_losing_bytecode ("length", sequence);
82 sequence = wrong_type_argument (Qsequencep, sequence);
83 goto retry;
84 }
85 }
86
87 /* Various test functions for #'member*, #'assoc* and the other functions
88 that take both TEST and KEY arguments. */
89
90 Boolint
91 check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
92 Lisp_Object item, Lisp_Object elt)
93 {
94 return EQ (item, elt);
95 }
96
97 static Boolint
98 check_eq_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
99 Lisp_Object elt)
100 {
101 elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
102 return EQ (item, elt);
103 }
104
105 /* The next two are not used by #'member* and #'assoc*, since we can decide
106 on #'eq vs. #'equal when we have the type of ITEM. */
107 static Boolint
108 check_eql_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
109 Lisp_Object elt1, Lisp_Object elt2)
110 {
111 return EQ (elt1, elt2)
112 || (NON_FIXNUM_NUMBER_P (elt1) && internal_equal (elt1, elt2, 0));
113 }
114
115 static Boolint
116 check_eql_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
117 Lisp_Object elt)
118 {
119 elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
120 return EQ (item, elt)
121 || (NON_FIXNUM_NUMBER_P (item) && internal_equal (item, elt, 0));
122 }
123
124 static Boolint
125 check_equal_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
126 Lisp_Object item, Lisp_Object elt)
127 {
128 return internal_equal (item, elt, 0);
129 }
130
131 static Boolint
132 check_equal_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item,
133 Lisp_Object elt)
134 {
135 elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
136 return internal_equal (item, elt, 0);
137 }
138
139 static Boolint
140 check_equalp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
141 Lisp_Object item, Lisp_Object elt)
142 {
143 return internal_equalp (item, elt, 0);
144 }
145
146 static Boolint
147 check_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key,
148 Lisp_Object item, Lisp_Object elt)
149 {
150 elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
151 return internal_equalp (item, elt, 0);
152 }
153
154 static Boolint
155 check_string_match_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
156 Lisp_Object item, Lisp_Object elt)
157 {
158 return !NILP (Fstring_match (item, elt, Qnil, Qnil));
159 }
160
161 static Boolint
162 check_string_match_key (Lisp_Object UNUSED (test), Lisp_Object key,
163 Lisp_Object item, Lisp_Object elt)
164 {
165 elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt));
166 return !NILP (Fstring_match (item, elt, Qnil, Qnil));
167 }
168
169 static Boolint
170 check_other_nokey (Lisp_Object test, Lisp_Object UNUSED (key),
171 Lisp_Object item, Lisp_Object elt)
172 {
173 Lisp_Object args[] = { test, item, elt };
174 struct gcpro gcpro1;
175
176 GCPRO1 (args[0]);
177 gcpro1.nvars = countof (args);
178 item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
179 UNGCPRO;
180
181 return !NILP (item);
182 }
183
184 static Boolint
185 check_other_key (Lisp_Object test, Lisp_Object key,
186 Lisp_Object item, Lisp_Object elt)
187 {
188 Lisp_Object args[] = { item, key, elt };
189 struct gcpro gcpro1;
190
191 GCPRO1 (args[0]);
192 gcpro1.nvars = countof (args);
193 args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args) - 1, args + 1));
194 args[1] = item;
195 args[0] = test;
196 item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
197 UNGCPRO;
198
199 return !NILP (item);
200 }
201
202 static Boolint
203 check_if_nokey (Lisp_Object test, Lisp_Object UNUSED (key),
204 Lisp_Object UNUSED (item), Lisp_Object elt)
205 {
206 elt = IGNORE_MULTIPLE_VALUES (call1 (test, elt));
207 return !NILP (elt);
208 }
209
210 static Boolint
211 check_if_key (Lisp_Object test, Lisp_Object key,
212 Lisp_Object UNUSED (item), Lisp_Object elt)
213 {
214 Lisp_Object args[] = { key, elt };
215 struct gcpro gcpro1;
216
217 GCPRO1 (args[0]);
218 gcpro1.nvars = countof (args);
219 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
220 args[0] = test;
221 elt = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
222 UNGCPRO;
223
224 return !NILP (elt);
225 }
226
227 static Boolint
228 check_match_eq_key (Lisp_Object UNUSED (test), Lisp_Object key,
229 Lisp_Object elt1, Lisp_Object elt2)
230 {
231 Lisp_Object args[] = { key, elt1, elt2 };
232 struct gcpro gcpro1;
233
234 GCPRO1 (args[0]);
235 gcpro1.nvars = countof (args);
236 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
237 args[1] = key;
238 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
239 UNGCPRO;
240
241 return EQ (args[0], args[1]);
242 }
243
244 static Boolint
245 check_match_eql_key (Lisp_Object UNUSED (test), Lisp_Object key,
246 Lisp_Object elt1, Lisp_Object elt2)
247 {
248 Lisp_Object args[] = { key, elt1, elt2 };
249 struct gcpro gcpro1;
250
251 GCPRO1 (args[0]);
252 gcpro1.nvars = countof (args);
253 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
254 args[1] = key;
255 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
256 UNGCPRO;
257
258 return EQ (args[0], args[1]) ||
259 (NON_FIXNUM_NUMBER_P (args[0]) && internal_equal (args[0], args[1], 0));
260 }
261
262 static Boolint
263 check_match_equal_key (Lisp_Object UNUSED (test), Lisp_Object key,
264 Lisp_Object elt1, Lisp_Object elt2)
265 {
266 Lisp_Object args[] = { key, elt1, elt2 };
267 struct gcpro gcpro1;
268
269 GCPRO1 (args[0]);
270 gcpro1.nvars = countof (args);
271 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
272 args[1] = key;
273 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
274 UNGCPRO;
275
276 return internal_equal (args[0], args[1], 0);
277 }
278
279 static Boolint
280 check_match_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key,
281 Lisp_Object elt1, Lisp_Object elt2)
282 {
283 Lisp_Object args[] = { key, elt1, elt2 };
284 struct gcpro gcpro1;
285
286 GCPRO1 (args[0]);
287 gcpro1.nvars = countof (args);
288 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
289 args[1] = key;
290 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
291 UNGCPRO;
292
293 return internal_equalp (args[0], args[1], 0);
294 }
295
296 static Boolint
297 check_match_other_key (Lisp_Object test, Lisp_Object key,
298 Lisp_Object elt1, Lisp_Object elt2)
299 {
300 Lisp_Object args[] = { key, elt1, elt2 };
301 struct gcpro gcpro1;
302
303 GCPRO1 (args[0]);
304 gcpro1.nvars = countof (args);
305 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
306 args[1] = key;
307 args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
308 args[1] = args[0];
309 args[0] = test;
310
311 elt1 = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
312 UNGCPRO;
313
314 return !NILP (elt1);
315 }
316
317 static Boolint
318 check_lss_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
319 Lisp_Object elt1, Lisp_Object elt2)
320 {
321 return bytecode_arithcompare (elt1, elt2) < 0;
322 }
323
324 static Boolint
325 check_lss_key (Lisp_Object UNUSED (test), Lisp_Object key,
326 Lisp_Object elt1, Lisp_Object elt2)
327 {
328 Lisp_Object args[] = { key, elt1, elt2 };
329 struct gcpro gcpro1;
330
331 GCPRO1 (args[0]);
332 gcpro1.nvars = countof (args);
333 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
334 args[1] = key;
335 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
336 UNGCPRO;
337
338 return bytecode_arithcompare (args[0], args[1]) < 0;
339 }
340
341 Boolint
342 check_lss_key_car (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
343 Lisp_Object elt1, Lisp_Object elt2)
344 {
345 struct gcpro gcpro1, gcpro2;
346
347 GCPRO2 (elt1, elt2);
348 elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
349 elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
350 UNGCPRO;
351
352 return bytecode_arithcompare (elt1, elt2) < 0;
353 }
354
355 Boolint
356 check_string_lessp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
357 Lisp_Object elt1, Lisp_Object elt2)
358 {
359 return !NILP (Fstring_lessp (elt1, elt2));
360 }
361
362 static Boolint
363 check_string_lessp_key (Lisp_Object UNUSED (test), Lisp_Object key,
364 Lisp_Object elt1, Lisp_Object elt2)
365 {
366 Lisp_Object args[] = { key, elt1, elt2 };
367 struct gcpro gcpro1;
368
369 GCPRO1 (args[0]);
370 gcpro1.nvars = countof (args);
371 args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
372 args[1] = key;
373 args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1));
374 UNGCPRO;
375
376 return !NILP (Fstring_lessp (args[0], args[1]));
377 }
378
379 static Boolint
380 check_string_lessp_key_car (Lisp_Object UNUSED (test),
381 Lisp_Object UNUSED (key),
382 Lisp_Object elt1, Lisp_Object elt2)
383 {
384 struct gcpro gcpro1, gcpro2;
385
386 GCPRO2 (elt1, elt2);
387 elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1);
388 elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2);
389 UNGCPRO;
390
391 return !NILP (Fstring_lessp (elt1, elt2));
392 }
393
394 static check_test_func_t
395 get_check_match_function_1 (Lisp_Object item,
396 Lisp_Object *test_inout, Lisp_Object test_not,
397 Lisp_Object if_, Lisp_Object if_not,
398 Lisp_Object key, Boolint *test_not_unboundp_out,
399 check_test_func_t *test_func_out)
400 {
401 Lisp_Object test = *test_inout;
402 check_test_func_t result = NULL, test_func = NULL;
403 Boolint force_if = 0;
404
405 if (!NILP (if_))
406 {
407 if (!(NILP (test) && NILP (test_not) && NILP (if_not)))
408 {
409 invalid_argument ("only one keyword among :test :test-not "
410 ":if :if-not allowed", if_);
411 }
412
413 test = *test_inout = if_;
414 force_if = 1;
415 }
416 else if (!NILP (if_not))
417 {
418 if (!(NILP (test) && NILP (test_not)))
419 {
420 invalid_argument ("only one keyword among :test :test-not "
421 ":if :if-not allowed", if_not);
422 }
423
424 test_not = if_not;
425 force_if = 1;
426 }
427
428 if (NILP (test))
429 {
430 if (!NILP (test_not))
431 {
432 test = *test_inout = test_not;
433 if (NULL != test_not_unboundp_out)
434 {
435 *test_not_unboundp_out = 0;
436 }
437 }
438 else
439 {
440 test = Qeql;
441 if (NULL != test_not_unboundp_out)
442 {
443 *test_not_unboundp_out = 1;
444 }
445 }
446 }
447 else if (!NILP (test_not))
448 {
449 invalid_argument_2 ("conflicting :test and :test-not keyword arguments",
450 test, test_not);
451 }
452
453 test = indirect_function (test, 1);
454
455 if (NILP (key) ||
456 EQ (indirect_function (key, 1), XSYMBOL_FUNCTION (Qidentity)))
457 {
458 key = Qidentity;
459 }
460
461 if (force_if)
462 {
463 result = EQ (key, Qidentity) ? check_if_nokey : check_if_key;
464
465 if (NULL != test_func_out)
466 {
467 *test_func_out = result;
468 }
469
470 return result;
471 }
472
473 if (!UNBOUNDP (item) && EQ (test, XSYMBOL_FUNCTION (Qeql)))
474 {
475 test = XSYMBOL_FUNCTION (NON_FIXNUM_NUMBER_P (item) ? Qequal : Qeq);
476 }
477
478 #define FROB(known_test, eq_condition) \
479 if (EQ (test, XSYMBOL_FUNCTION (Q##known_test))) do \
480 { \
481 if (eq_condition) \
482 { \
483 test = XSYMBOL_FUNCTION (Qeq); \
484 goto force_eq_check; \
485 } \
486 \
487 if (!EQ (Qidentity, key)) \
488 { \
489 test_func = check_##known_test##_key; \
490 result = check_match_##known_test##_key; \
491 } \
492 else \
493 { \
494 result = test_func = check_##known_test##_nokey; \
495 } \
496 } while (0)
497
498 FROB (eql, 0);
499 else if (SUBRP (test))
500 {
501 force_eq_check:
502 FROB (eq, 0);
503 else FROB (equal, (SYMBOLP (item) || FIXNUMP (item) || CHARP (item)));
504 else FROB (equalp, (SYMBOLP (item)));
505 else if (EQ (test, XSYMBOL_FUNCTION (Qstring_match)))
506 {
507 if (EQ (Qidentity, key))
508 {
509 test_func = result = check_string_match_nokey;
510 }
511 else
512 {
513 test_func = check_string_match_key;
514 result = check_other_key;
515 }
516 }
517 }
518
519 if (NULL == result)
520 {
521 if (EQ (Qidentity, key))
522 {
523 test_func = result = check_other_nokey;
524 }
525 else
526 {
527 test_func = check_other_key;
528 result = check_match_other_key;
529 }
530 }
531
532 if (NULL != test_func_out)
533 {
534 *test_func_out = test_func;
535 }
536
537 return result;
538 }
539 #undef FROB
540
541 /* Given TEST, TEST_NOT, IF, IF_NOT, KEY, and ITEM, return a C function
542 pointer appropriate for use in deciding whether a given element of a
543 sequence satisfies TEST.
544
545 Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero
546 if it was bound, and set *test_inout to the value it was bound to. If
547 TEST was not bound, leave *test_inout alone; the value is not used by
548 check_eq_*key() or check_equal_*key(), which are the defaults, depending
549 on the type of ITEM.
550
551 The returned function takes arguments (TEST, KEY, ITEM, ELT), where ITEM
552 is the item being searched for and ELT is the element of the sequence
553 being examined.
554
555 Error if both TEST and TEST_NOT were specified, which Common Lisp says is
556 undefined behaviour. */
557
558 static check_test_func_t
559 get_check_test_function (Lisp_Object item,
560 Lisp_Object *test_inout, Lisp_Object test_not,
561 Lisp_Object if_, Lisp_Object if_not,
562 Lisp_Object key, Boolint *test_not_unboundp_out)
563 {
564 check_test_func_t result = NULL;
565 get_check_match_function_1 (item, test_inout, test_not, if_, if_not,
566 key, test_not_unboundp_out, &result);
567 return result;
568 }
569
570 /* Given TEST, TEST_NOT, IF, IF_NOT and KEY, return a C function pointer
571 appropriate for use in deciding whether two given elements of a sequence
572 satisfy TEST.
573
574 Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero
575 if it was bound, and set *test_inout to the value it was bound to. If
576 TEST was not bound, leave *test_inout alone; the value is not used by
577 check_eql_*key().
578
579 The returned function takes arguments (TEST, KEY, ELT1, ELT2), where ELT1
580 and ELT2 are elements of the sequence being examined.
581
582 The value that would be given by get_check_test_function() is returned in
583 *TEST_FUNC_OUT, which allows calling functions to do their own key checks
584 if they're processing one element at a time.
585
586 Error if both TEST and TEST_NOT were specified, which Common Lisp says is
587 undefined behaviour. */
588
589 static check_test_func_t
590 get_check_match_function (Lisp_Object *test_inout, Lisp_Object test_not,
591 Lisp_Object if_, Lisp_Object if_not,
592 Lisp_Object key, Boolint *test_not_unboundp_out,
593 check_test_func_t *test_func_out)
594 {
595 return get_check_match_function_1 (Qunbound, test_inout, test_not,
596 if_, if_not, key,
597 test_not_unboundp_out, test_func_out);
598 }
599
600 /* Given PREDICATE and KEY, return a C function pointer appropriate for use
601 in deciding whether one given element of a sequence is less than
602 another. */
603
604 static check_test_func_t
605 get_merge_predicate (Lisp_Object predicate, Lisp_Object key)
606 {
607 predicate = indirect_function (predicate, 1);
608
609 if (NILP (key))
610 {
611 key = Qidentity;
612 }
613 else
614 {
615 key = indirect_function (key, 1);
616 if (EQ (key, XSYMBOL_FUNCTION (Qidentity)))
617 {
618 key = Qidentity;
619 }
620 }
621
622 if (EQ (key, Qidentity) && EQ (predicate,
623 XSYMBOL_FUNCTION (Qcar_less_than_car)))
624 {
625 key = XSYMBOL_FUNCTION (Qcar);
626 predicate = XSYMBOL_FUNCTION (Qlss);
627 }
628
629 if (EQ (predicate, XSYMBOL_FUNCTION (Qlss)))
630 {
631 if (EQ (key, Qidentity))
632 {
633 return check_lss_nokey;
634 }
635
636 if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
637 {
638 return check_lss_key_car;
639 }
640
641 return check_lss_key;
642 }
643
644 if (EQ (predicate, XSYMBOL_FUNCTION (Qstring_lessp)))
645 {
646 if (EQ (key, Qidentity))
647 {
648 return check_string_lessp_nokey;
649 }
650
651 if (EQ (key, XSYMBOL_FUNCTION (Qcar)))
652 {
653 return check_string_lessp_key_car;
654 }
655
656 return check_string_lessp_key;
657 }
658
659 if (EQ (key, Qidentity))
660 {
661 return check_other_nokey;
662 }
663
664 return check_match_other_key;
665 }
666
667
668 static Lisp_Object string_count_from_end (Lisp_Object, Lisp_Object ,
669 check_test_func_t, Boolint,
670 Lisp_Object, Lisp_Object,
671 Lisp_Object, Lisp_Object);
672
673 static Lisp_Object list_count_from_end (Lisp_Object, Lisp_Object,
674 check_test_func_t, Boolint,
675 Lisp_Object, Lisp_Object,
676 Lisp_Object, Lisp_Object);
677
678 /* Count the number of occurrences of ITEM in SEQUENCE; if SEQUENCE is a
679 list, store the cons cell of which the car is the last ITEM in SEQUENCE,
680 at the address given by tail_out. */
681
682 static Lisp_Object
683 count_with_tail (Lisp_Object *tail_out, int nargs, Lisp_Object *args,
684 Lisp_Object caller)
685 {
686 Lisp_Object item = args[0], sequence = args[1];
687 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0;
688 Elemcount len, ii = 0, counting = MOST_POSITIVE_FIXNUM;
689 Boolint test_not_unboundp = 1;
690 check_test_func_t check_test = NULL;
691
692 PARSE_KEYWORDS_8 (caller, nargs, args, 9,
693 (test, key, start, end, from_end, test_not, count,
694 if_, if_not), (start = Qzero), 2, 0);
695
696 CHECK_SEQUENCE (sequence);
697 CHECK_NATNUM (start);
698 starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
699
700 if (!NILP (end))
701 {
702 CHECK_NATNUM (end);
703 ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
704 }
705
706 if (!NILP (count))
707 {
708 CHECK_INTEGER (count);
709 counting = BIGNUMP (count) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (count);
710
711 /* Our callers should have filtered out non-positive COUNT. */
712 assert (counting >= 0);
713 /* And we're not prepared to handle COUNT from any other caller at the
714 moment. */
715 assert (EQ (caller, QremoveX)|| EQ (caller, QdeleteX));
716 }
717
718 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
719 key, &test_not_unboundp);
720
721 *tail_out = Qnil;
722
723 if (CONSP (sequence))
724 {
725 if (EQ (caller, Qcount) && !NILP (from_end)
726 && (!EQ (key, Qnil) ||
727 check_test == check_other_nokey || check_test == check_if_nokey))
728 {
729 /* #'count, #'count-if, and #'count-if-not are documented to have
730 a given traversal order if :from-end t is passed in, even
731 though forward traversal of the sequence has the same result
732 and is algorithmically less expensive for lists and strings.
733 This order isn't necessary for other callers, though. */
734 return list_count_from_end (item, sequence, check_test,
735 test_not_unboundp, test, key,
736 start, end);
737 }
738
739 /* If COUNT is non-nil and FROM-END is t, we can give the tail
740 containing the last match, since that's what #'remove* is
741 interested in (a zero or negative COUNT won't ever reach
742 count_with_tail(), our callers will return immediately on seeing
743 it). */
744 if (!NILP (count) && !NILP (from_end))
745 {
746 counting = MOST_POSITIVE_FIXNUM;
747 }
748
749 {
750 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
751 {
752 if (!(ii < ending))
753 {
754 break;
755 }
756
757 if (starting <= ii &&
758 check_test (test, key, item, elt) == test_not_unboundp)
759 {
760 encountered++;
761 *tail_out = tail;
762
763 if (encountered == counting)
764 {
765 break;
766 }
767 }
768
769 ii++;
770 }
771 END_GC_EXTERNAL_LIST_LOOP (elt);
772 }
773
774 if ((ii < starting || (ii < ending && !NILP (end))) &&
775 encountered != counting)
776 {
777 check_sequence_range (args[1], start, end, Flength (args[1]));
778 }
779 }
780 else if (STRINGP (sequence))
781 {
782 Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
783 Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
784 Lisp_Object character = Qnil;
785
786 if (EQ (caller, Qcount) && !NILP (from_end)
787 && (!EQ (key, Qnil) ||
788 check_test == check_other_nokey || check_test == check_if_nokey))
789 {
790 /* See comment above in the list code. */
791 return string_count_from_end (item, sequence,
792 check_test, test_not_unboundp,
793 test, key, start, end);
794 }
795
796 while (cursor_offset < byte_len && ii < ending && encountered < counting)
797 {
798 if (ii >= starting)
799 {
800 character = make_char (itext_ichar (cursor));
801
802 if (check_test (test, key, item, character)
803 == test_not_unboundp)
804 {
805 encountered++;
806 }
807
808 startp = XSTRING_DATA (sequence);
809 cursor = startp + cursor_offset;
810 if (byte_len != XSTRING_LENGTH (sequence)
811 || !valid_ibyteptr_p (cursor))
812 {
813 mapping_interaction_error (caller, sequence);
814 }
815 }
816
817 INC_IBYTEPTR (cursor);
818 cursor_offset = cursor - startp;
819 ii++;
820 }
821
822 if (ii < starting || (ii < ending && !NILP (end)))
823 {
824 check_sequence_range (sequence, start, end, Flength (sequence));
825 }
826 }
827 else
828 {
829 Lisp_Object object = Qnil;
830
831 len = XFIXNUM (Flength (sequence));
832 check_sequence_range (sequence, start, end, make_fixnum (len));
833
834 ending = min (ending, len);
835 if (0 == len)
836 {
837 /* Catches the case where we have nil. */
838 return make_integer (encountered);
839 }
840
841 if (NILP (from_end))
842 {
843 for (ii = starting; ii < ending && encountered < counting; ii++)
844 {
845 object = Faref (sequence, make_fixnum (ii));
846 if (check_test (test, key, item, object) == test_not_unboundp)
847 {
848 encountered++;
849 }
850 }
851 }
852 else
853 {
854 for (ii = ending - 1; ii >= starting && encountered < counting; ii--)
855 {
856 object = Faref (sequence, make_fixnum (ii));
857 if (check_test (test, key, item, object) == test_not_unboundp)
858 {
859 encountered++;
860 }
861 }
862 }
863 }
864
865 return make_integer (encountered);
866 }
867
868 static Lisp_Object
869 list_count_from_end (Lisp_Object item, Lisp_Object sequence,
870 check_test_func_t check_test, Boolint test_not_unboundp,
871 Lisp_Object test, Lisp_Object key,
872 Lisp_Object start, Lisp_Object end)
873 {
874 Elemcount length = XFIXNUM (Flength (sequence)), ii = 0, starting = XFIXNUM (start);
875 Elemcount ending = NILP (end) ? length : XFIXNUM (end), encountered = 0;
876 Lisp_Object *storage;
877 struct gcpro gcpro1;
878
879 check_sequence_range (sequence, start, end, make_integer (length));
880
881 storage = alloca_array (Lisp_Object, ending - starting);
882
883 {
884 EXTERNAL_LIST_LOOP_2 (elt, sequence)
885 {
886 if (starting <= ii && ii < ending)
887 {
888 storage[ii - starting] = elt;
889 }
890 ii++;
891 }
892 }
893
894 GCPRO1 (storage[0]);
895 gcpro1.nvars = ending - starting;
896
897 for (ii = ending - 1; ii >= starting; ii--)
898 {
899 if (check_test (test, key, item, storage[ii - starting])
900 == test_not_unboundp)
901 {
902 encountered++;
903 }
904 }
905
906 UNGCPRO;
907
908 return make_integer (encountered);
909 }
910
911 static Lisp_Object
912 string_count_from_end (Lisp_Object item, Lisp_Object sequence,
913 check_test_func_t check_test, Boolint test_not_unboundp,
914 Lisp_Object test, Lisp_Object key,
915 Lisp_Object start, Lisp_Object end)
916 {
917 Elemcount length = string_char_length (sequence), ii = 0;
918 Elemcount starting = XFIXNUM (start), ending = NILP (end) ? length : XFIXNUM (end);
919 Elemcount encountered = 0;
920 Ibyte *cursor = XSTRING_DATA (sequence);
921 Ibyte *endp = cursor + XSTRING_LENGTH (sequence);
922 Ichar *storage;
923
924 check_sequence_range (sequence, start, end, make_integer (length));
925
926 storage = alloca_array (Ichar, ending - starting);
927
928 while (cursor < endp && ii < ending)
929 {
930 if (starting <= ii && ii < ending)
931 {
932 storage [ii - starting] = itext_ichar (cursor);
933 }
934
935 ii++;
936 INC_IBYTEPTR (cursor);
937 }
938
939 for (ii = ending - 1; ii >= starting; ii--)
940 {
941 if (check_test (test, key, item, make_char (storage [ii - starting]))
942 == test_not_unboundp)
943 {
944 encountered++;
945 }
946 }
947
948 return make_integer (encountered);
949 }
950
951 DEFUN ("count", Fcount, 2, MANY, 0, /*
952 Count the number of occurrences of ITEM in SEQUENCE.
953
954 See `remove*' for the meaning of the keywords.
955
956 arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
957 */
958 (int nargs, Lisp_Object *args))
959 {
960 Lisp_Object tail = Qnil;
961
962 /* count_with_tail() accepts more keywords than we do, check those we've
963 been given. */
964 PARSE_KEYWORDS (Fcount, nargs, args, 8,
965 (test, test_not, if_, if_not, key, start, end, from_end),
966 NULL);
967
968 return count_with_tail (&tail, nargs, args, Qcount);
969 }
970
971 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
972 Return the subsequence of SEQUENCE starting at START and ending before END.
973 END may be omitted; then the subsequence runs to the end of SEQUENCE.
974
975 If START or END is negative, it counts from the end, in contravention of
976 Common Lisp.
977 The returned subsequence is always of the same type as SEQUENCE.
978 If SEQUENCE is a string, relevant parts of the string-extent-data
979 are copied to the new string.
980
981 See also `substring-no-properties', which only operates on strings, and does
982 not copy extent data.
983 */
984 (sequence, start, end))
985 {
986 Elemcount len, ss, ee = MOST_POSITIVE_FIXNUM, ii;
987 Lisp_Object result = Qnil;
988
989 CHECK_SEQUENCE (sequence);
990 CHECK_FIXNUM (start);
991 ss = XFIXNUM (start);
992
993 if (!NILP (end))
994 {
995 CHECK_FIXNUM (end);
996 ee = XFIXNUM (end);
997 }
998
999 if (STRINGP (sequence))
1000 {
1001 Bytecount bstart, blen;
1002
1003 get_string_range_char (sequence, start, end, &ss, &ee,
1004 GB_HISTORICAL_STRING_BEHAVIOR);
1005 bstart = string_index_char_to_byte (sequence, ss);
1006 blen = string_offset_char_to_byte_len (sequence, bstart, ee - ss);
1007
1008 result = make_string (XSTRING_DATA (sequence) + bstart, blen);
1009 /* Copy any applicable extent information into the new string. */
1010 copy_string_extents (result, sequence, 0, bstart, blen);
1011 }
1012 else if (CONSP (sequence))
1013 {
1014 Lisp_Object result_tail, saved = sequence;
1015
1016 if (ss < 0 || ee < 0)
1017 {
1018 len = XFIXNUM (Flength (sequence));
1019 if (ss < 0)
1020 {
1021 ss = len + ss;
1022 start = make_integer (ss);
1023 }
1024
1025 if (ee < 0)
1026 {
1027 ee = len + ee;
1028 end = make_integer (ee);
1029 }
1030 else
1031 {
1032 ee = min (ee, len);
1033 }
1034 }
1035
1036 if (0 != ss)
1037 {
1038 sequence = Fnthcdr (make_fixnum (ss), sequence);
1039 }
1040
1041 ii = ss + 1;
1042
1043 if (ss < ee && !NILP (sequence))
1044 {
1045 result = result_tail = Fcons (Fcar (sequence), Qnil);
1046 sequence = Fcdr (sequence);
1047
1048 {
1049 EXTERNAL_LIST_LOOP_2 (elt, sequence)
1050 {
1051 if (!(ii < ee))
1052 {
1053 break;
1054 }
1055
1056 XSETCDR (result_tail, Fcons (elt, Qnil));
1057 result_tail = XCDR (result_tail);
1058 ii++;
1059 }
1060 }
1061 }
1062
1063 if (NILP (result) || (ii < ee && !NILP (end)))
1064 {
1065 /* We were handed a cons, which definitely has elements. nil
1066 result means either ss >= ee or SEQUENCE was nil after the
1067 nthcdr; in both cases that means START and END were incorrectly
1068 specified for this sequence. ii < ee with a non-nil end means
1069 the user handed us a bogus end value. */
1070 check_sequence_range (saved, start, end, Flength (saved));
1071 }
1072 }
1073 else
1074 {
1075 len = XFIXNUM (Flength (sequence));
1076 if (ss < 0)
1077 {
1078 ss = len + ss;
1079 start = make_integer (ss);
1080 }
1081
1082 if (ee < 0)
1083 {
1084 ee = len + ee;
1085 end = make_integer (ee);
1086 }
1087 else
1088 {
1089 ee = min (len, ee);
1090 }
1091
1092 check_sequence_range (sequence, start, end, make_fixnum (len));
1093
1094 if (VECTORP (sequence))
1095 {
1096 result = Fvector (ee - ss, XVECTOR_DATA (sequence) + ss);
1097 }
1098 else if (BIT_VECTORP (sequence))
1099 {
1100 result = make_bit_vector (ee - ss, Qzero);
1101
1102 for (ii = ss; ii < ee; ii++)
1103 {
1104 set_bit_vector_bit (XBIT_VECTOR (result), ii - ss,
1105 bit_vector_bit (XBIT_VECTOR (sequence), ii));
1106 }
1107 }
1108 else if (NILP (sequence))
1109 {
1110 DO_NOTHING;
1111 }
1112 else
1113 {
1114 /* Won't happen, since CHECK_SEQUENCE didn't error. */
1115 ABORT ();
1116 }
1117 }
1118
1119 return result;
1120 }
1121
1122 DEFUN ("elt", Felt, 2, 2, 0, /*
1123 Return element of SEQUENCE at index N.
1124 */
1125 (sequence, n))
1126 {
1127 /* This function can GC */
1128 retry:
1129 CHECK_FIXNUM_COERCE_CHAR (n); /* yuck! */
1130 if (LISTP (sequence))
1131 {
1132 Lisp_Object tem = Fnthcdr (n, sequence);
1133 /* #### Utterly, completely, fucking disgusting.
1134 * #### The whole point of "elt" is that it operates on
1135 * #### sequences, and does error- (bounds-) checking.
1136 */
1137 if (CONSP (tem))
1138 return XCAR (tem);
1139 else
1140 #if 1
1141 /* This is The Way It Has Always Been. */
1142 return Qnil;
1143 #else
1144 /* This is The Way Mly and Cltl2 say It Should Be. */
1145 args_out_of_range (sequence, n);
1146 #endif
1147 }
1148 else if (STRINGP (sequence) ||
1149 VECTORP (sequence) ||
1150 BIT_VECTORP (sequence))
1151 return Faref (sequence, n);
1152 else
1153 {
1154 check_losing_bytecode ("elt", sequence);
1155 sequence = wrong_type_argument (Qsequencep, sequence);
1156 goto retry;
1157 }
1158 }
1159
1160 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
1161 Return a copy of a list and substructures.
1162 The argument is copied, and any lists contained within it are copied
1163 recursively. Circularities and shared substructures are not preserved.
1164 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
1165 are not copied.
1166 */
1167 (arg, vecp))
1168 {
1169 return safe_copy_tree (arg, vecp, 0);
1170 }
1171
1172 Lisp_Object
1173 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
1174 {
1175 if (depth + lisp_eval_depth > max_lisp_eval_depth)
1176 stack_overflow ("Stack overflow in copy-tree", arg);
1177
1178 if (CONSP (arg))
1179 {
1180 Lisp_Object rest;
1181 rest = arg = Fcopy_sequence (arg);
1182 while (CONSP (rest))
1183 {
1184 Lisp_Object elt = XCAR (rest);
1185 QUIT;
1186 if (CONSP (elt) || VECTORP (elt))
1187 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1);
1188 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
1189 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1);
1190 rest = XCDR (rest);
1191 }
1192 }
1193 else if (VECTORP (arg) && ! NILP (vecp))
1194 {
1195 int i = XVECTOR_LENGTH (arg);
1196 int j;
1197 arg = Fcopy_sequence (arg);
1198 for (j = 0; j < i; j++)
1199 {
1200 Lisp_Object elt = XVECTOR_DATA (arg) [j];
1201 QUIT;
1202 if (CONSP (elt) || VECTORP (elt))
1203 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1);
1204 }
1205 }
1206 return arg;
1207 }
1208
1209 DEFUN ("member", Fmember, 2, 2, 0, /*
1210 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1211 The value is actually the tail of LIST whose car is ELT.
1212 */
1213 (elt, list))
1214 {
1215 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1216 {
1217 if (internal_equal (elt, list_elt, 0))
1218 return tail;
1219 }
1220 return Qnil;
1221 }
1222
1223 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1224 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1225 The value is actually the tail of LIST whose car is ELT.
1226 */
1227 (elt, list))
1228 {
1229 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1230 {
1231 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1232 return tail;
1233 }
1234 return Qnil;
1235 }
1236
1237 Lisp_Object
1238 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1239 {
1240 LIST_LOOP_3 (list_elt, list, tail)
1241 {
1242 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1243 return tail;
1244 }
1245 return Qnil;
1246 }
1247
1248 /* Return the first index of ITEM in LIST. In CONS_OUT, return the cons cell
1249 before that containing the element. If the element is in the first cons
1250 cell, return Qnil in CONS_OUT. TEST, KEY, START, END are as in
1251 #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should have been initialized
1252 with get_check_match_function() or get_check_test_function(). A non-zero
1253 REVERSE_TEST_ORDER means call TEST with the element from LIST as its
1254 first argument and ITEM as its second. Error if LIST is ill-formed, or
1255 circular. */
1256 static Lisp_Object
1257 list_position_cons_before (Lisp_Object *cons_out,
1258 Lisp_Object item, Lisp_Object list,
1259 check_test_func_t check_test,
1260 Boolint test_not_unboundp,
1261 Lisp_Object test, Lisp_Object key,
1262 Boolint reverse_test_order,
1263 Lisp_Object start, Lisp_Object end)
1264 {
1265 struct gcpro gcpro1;
1266 Lisp_Object tail_before = Qnil;
1267 Elemcount ii = 0, starting = XFIXNUM (start);
1268 Elemcount ending = NILP (end) ? MOST_POSITIVE_FIXNUM : XFIXNUM (end);
1269
1270 GCPRO1 (tail_before);
1271
1272 if (check_test == check_eq_nokey)
1273 {
1274 /* TEST is #'eq, no need to call any C functions, and the test order
1275 won't be visible. */
1276 EXTERNAL_LIST_LOOP_3 (elt, list, tail)
1277 {
1278 if (starting <= ii && ii < ending &&
1279 EQ (item, elt) == test_not_unboundp)
1280 {
1281 *cons_out = tail_before;
1282 RETURN_UNGCPRO (make_integer (ii));
1283 }
1284 else
1285 {
1286 if (ii >= ending)
1287 {
1288 break;
1289 }
1290 }
1291 ii++;
1292 tail_before = tail;
1293 }
1294 }
1295 else
1296 {
1297 GC_EXTERNAL_LIST_LOOP_3 (elt, list, tail)
1298 {
1299 if (starting <= ii && ii < ending &&
1300 (reverse_test_order ?
1301 check_test (test, key, elt, item) :
1302 check_test (test, key, item, elt)) == test_not_unboundp)
1303 {
1304 *cons_out = tail_before;
1305 XUNGCPRO (elt);
1306 UNGCPRO;
1307 return make_integer (ii);
1308 }
1309 else
1310 {
1311 if (ii >= ending)
1312 {
1313 break;
1314 }
1315 }
1316 ii++;
1317 tail_before = tail;
1318 }
1319 END_GC_EXTERNAL_LIST_LOOP (elt);
1320 }
1321
1322 RETURN_UNGCPRO (Qnil);
1323 }
1324
1325 DEFUN ("member*", FmemberX, 2, MANY, 0, /*
1326 Return the first sublist of LIST with car ITEM, or nil if no such sublist.
1327
1328 The keyword :test specifies a two-argument function that is used to compare
1329 ITEM with elements in LIST; if omitted, it defaults to `eql'.
1330
1331 The keyword :test-not is similar, but specifies a negated function. That
1332 is, ITEM is considered equal to an element in LIST if the given function
1333 returns nil. Common Lisp deprecates :test-not, and if both are specified,
1334 XEmacs signals an error.
1335
1336 :key specifies a one-argument function that transforms elements of LIST into
1337 \"comparison keys\" before the test predicate is applied. For example,
1338 if :key is #'car, then ITEM is compared with the car of elements from LIST.
1339 The :key function, however, is not applied to ITEM, and does not affect the
1340 elements in the returned list, which are taken directly from the elements in
1341 LIST.
1342
1343 arguments: (ITEM LIST &key (TEST #'eql) TEST-NOT (KEY #'identity))
1344 */
1345 (int nargs, Lisp_Object *args))
1346 {
1347 Lisp_Object item = args[0], list = args[1], result = Qnil, position0;
1348 Boolint test_not_unboundp = 1;
1349 check_test_func_t check_test = NULL;
1350
1351 PARSE_KEYWORDS (FmemberX, nargs, args, 5, (test, if_not, if_, test_not, key),
1352 NULL);
1353 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
1354 key, &test_not_unboundp);
1355 position0
1356 = list_position_cons_before (&result, item, list, check_test,
1357 test_not_unboundp, test, key, 0, Qzero, Qnil);
1358
1359 return CONSP (result) ? XCDR (result) : ZEROP (position0) ? list : Qnil;
1360 }
1361
1362 /* This macro might eventually find a better home than here. */
1363
1364 #define CHECK_KEY_ARGUMENT(key) \
1365 do { \
1366 if (NILP (key)) \
1367 { \
1368 key = Qidentity; \
1369 } \
1370 \
1371 if (!EQ (key, Qidentity)) \
1372 { \
1373 key = indirect_function (key, 1); \
1374 if (EQ (key, XSYMBOL_FUNCTION (Qidentity))) \
1375 { \
1376 key = Qidentity; \
1377 } \
1378 } \
1379 } while (0)
1380
1381 #define KEY(key, item) (EQ (Qidentity, key) ? item : \
1382 IGNORE_MULTIPLE_VALUES (call1 (key, item)))
1383
1384 DEFUN ("adjoin", Fadjoin, 2, MANY, 0, /*
1385 Return ITEM consed onto the front of LIST, if not already in LIST.
1386
1387 Otherwise, return LIST unmodified.
1388
1389 See `member*' for the meaning of the keywords.
1390
1391 arguments: (ITEM LIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
1392 */
1393 (int nargs, Lisp_Object *args))
1394 {
1395 Lisp_Object item = args[0], list = args[1], keyed = Qnil, ignore = Qnil;
1396 struct gcpro gcpro1;
1397 Boolint test_not_unboundp = 1;
1398 check_test_func_t check_test = NULL;
1399
1400 PARSE_KEYWORDS (Fadjoin, nargs, args, 3, (test, key, test_not),
1401 NULL);
1402
1403 CHECK_KEY_ARGUMENT (key);
1404
1405 keyed = KEY (key, item);
1406
1407 GCPRO1 (keyed);
1408 check_test = get_check_test_function (keyed, &test, test_not, Qnil, Qnil,
1409 key, &test_not_unboundp);
1410 if (NILP (list_position_cons_before (&ignore, keyed, list, check_test,
1411 test_not_unboundp, test, key, 0, Qzero,
1412 Qnil)))
1413 {
1414 RETURN_UNGCPRO (Fcons (item, list));
1415 }
1416
1417 RETURN_UNGCPRO (list);
1418 }
1419
1420 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1421 Return non-nil if KEY is `equal' to the car of an element of ALIST.
1422 The value is actually the element of ALIST whose car equals KEY.
1423 */
1424 (key, alist))
1425 {
1426 /* This function can GC. */
1427 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1428 {
1429 if (internal_equal (key, elt_car, 0))
1430 return elt;
1431 }
1432 return Qnil;
1433 }
1434
1435 Lisp_Object
1436 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
1437 {
1438 int speccount = specpdl_depth ();
1439 specbind (Qinhibit_quit, Qt);
1440 return unbind_to_1 (speccount, Fassoc (key, alist));
1441 }
1442
1443 DEFUN ("assq", Fassq, 2, 2, 0, /*
1444 Return non-nil if KEY is `eq' to the car of an element of ALIST.
1445 The value is actually the element of ALIST whose car is KEY.
1446 Elements of ALIST that are not conses are ignored.
1447 */
1448 (key, alist))
1449 {
1450 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1451 {
1452 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1453 return elt;
1454 }
1455 return Qnil;
1456 }
1457
1458 /* Like Fassq but never report an error and do not allow quits.
1459 Use only on lists known never to be circular. */
1460
1461 Lisp_Object
1462 assq_no_quit (Lisp_Object key, Lisp_Object alist)
1463 {
1464 /* This cannot GC. */
1465 LIST_LOOP_2 (elt, alist)
1466 {
1467 Lisp_Object elt_car = XCAR (elt);
1468 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1469 return elt;
1470 }
1471 return Qnil;
1472 }
1473
1474 DEFUN ("assoc*", FassocX, 2, MANY, 0, /*
1475 Find the first item whose car matches ITEM in ALIST.
1476
1477 See `member*' for the meaning of :test, :test-not and :key.
1478
1479 arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
1480 */
1481 (int nargs, Lisp_Object *args))
1482 {
1483 Lisp_Object item = args[0], alist = args[1];
1484 Boolint test_not_unboundp = 1;
1485 check_test_func_t check_test = NULL;
1486
1487 PARSE_KEYWORDS (FassocX, nargs, args, 5, (test, if_, if_not, test_not, key),
1488 NULL);
1489
1490 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
1491 key, &test_not_unboundp);
1492
1493 if (check_test == check_eq_nokey)
1494 {
1495 /* TEST is #'eq, no need to call any C functions. */
1496 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1497 {
1498 if (EQ (item, elt_car) == test_not_unboundp)
1499 {
1500 return elt;
1501 }
1502 }
1503 }
1504 else
1505 {
1506 GC_EXTERNAL_LIST_LOOP_2 (elt, alist)
1507 {
1508 if (CONSP (elt) &&
1509 check_test (test, key, item, XCAR (elt)) == test_not_unboundp)
1510 {
1511 XUNGCPRO (elt);
1512 return elt;
1513 }
1514 }
1515 END_GC_EXTERNAL_LIST_LOOP (elt);
1516 }
1517
1518 return Qnil;
1519 }
1520
1521 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1522 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
1523 The value is actually the element of ALIST whose cdr equals VALUE.
1524 */
1525 (value, alist))
1526 {
1527 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1528 {
1529 if (internal_equal (value, elt_cdr, 0))
1530 return elt;
1531 }
1532 return Qnil;
1533 }
1534
1535 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1536 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
1537 The value is actually the element of ALIST whose cdr is VALUE.
1538 */
1539 (value, alist))
1540 {
1541 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1542 {
1543 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1544 return elt;
1545 }
1546 return Qnil;
1547 }
1548
1549 /* Like Frassq, but caller must ensure that ALIST is properly
1550 nil-terminated and ebola-free. */
1551 Lisp_Object
1552 rassq_no_quit (Lisp_Object value, Lisp_Object alist)
1553 {
1554 LIST_LOOP_2 (elt, alist)
1555 {
1556 Lisp_Object elt_cdr = XCDR (elt);
1557 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
1558 return elt;
1559 }
1560 return Qnil;
1561 }
1562
1563 DEFUN ("rassoc*", FrassocX, 2, MANY, 0, /*
1564 Find the first item whose cdr matches ITEM in ALIST.
1565
1566 See `member*' for the meaning of :test, :test-not and :key.
1567
1568 arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT)
1569 */
1570 (int nargs, Lisp_Object *args))
1571 {
1572 Lisp_Object item = args[0], alist = args[1];
1573 Boolint test_not_unboundp = 1;
1574 check_test_func_t check_test = NULL;
1575
1576 PARSE_KEYWORDS (FrassocX, nargs, args, 5, (test, if_, if_not, test_not, key),
1577 NULL);
1578
1579 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
1580 key, &test_not_unboundp);
1581
1582 if (check_test == check_eq_nokey)
1583 {
1584 /* TEST is #'eq, no need to call any C functions. */
1585 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
1586 {
1587 if (EQ (item, elt_cdr) == test_not_unboundp)
1588 {
1589 return elt;
1590 }
1591 }
1592 }
1593 else
1594 {
1595 GC_EXTERNAL_LIST_LOOP_2 (elt, alist)
1596 {
1597 if (CONSP (elt) &&
1598 check_test (test, key, item, XCDR (elt)) == test_not_unboundp)
1599 {
1600 XUNGCPRO (elt);
1601 return elt;
1602 }
1603 }
1604 END_GC_EXTERNAL_LIST_LOOP (elt);
1605 }
1606
1607 return Qnil;
1608 }
1609
1610 /* This is the implementation of both #'find and #'position. */
1611 static Lisp_Object
1612 position (Lisp_Object *object_out, Lisp_Object item, Lisp_Object sequence,
1613 check_test_func_t check_test, Boolint test_not_unboundp,
1614 Lisp_Object test, Lisp_Object key, Lisp_Object start, Lisp_Object end,
1615 Lisp_Object from_end, Lisp_Object default_, Lisp_Object caller)
1616 {
1617 Lisp_Object result = Qnil;
1618 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, len, ii = 0;
1619
1620 CHECK_SEQUENCE (sequence);
1621 CHECK_NATNUM (start);
1622 starting = FIXNUMP (start) ? XFIXNUM (start) : 1 + MOST_POSITIVE_FIXNUM;
1623
1624 if (!NILP (end))
1625 {
1626 CHECK_NATNUM (end);
1627 ending = FIXNUMP (end) ? XFIXNUM (end) : 1 + MOST_POSITIVE_FIXNUM;
1628 }
1629
1630 *object_out = default_;
1631
1632 if (CONSP (sequence))
1633 {
1634 if (!(starting < ending))
1635 {
1636 check_sequence_range (sequence, start, end, Flength (sequence));
1637 /* starting could be equal to ending, in which case nil is what
1638 we want to return. */
1639 return Qnil;
1640 }
1641
1642 {
1643 GC_EXTERNAL_LIST_LOOP_2 (elt, sequence)
1644 {
1645 if (starting <= ii && ii < ending
1646 && check_test (test, key, item, elt) == test_not_unboundp)
1647 {
1648 result = make_integer (ii);
1649 *object_out = elt;
1650
1651 if (NILP (from_end))
1652 {
1653 XUNGCPRO (elt);
1654 return result;
1655 }
1656 }
1657 else if (ii == ending)
1658 {
1659 break;
1660 }
1661
1662 ii++;
1663 }
1664 END_GC_EXTERNAL_LIST_LOOP (elt);
1665 }
1666
1667 if (ii < starting || (ii < ending && !NILP (end)))
1668 {
1669 check_sequence_range (sequence, start, end, Flength (sequence));
1670 }
1671 }
1672 else if (STRINGP (sequence))
1673 {
1674 Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
1675 Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
1676 Lisp_Object character = Qnil;
1677
1678 while (cursor_offset < byte_len && ii < ending)
1679 {
1680 if (ii >= starting)
1681 {
1682 character = make_char (itext_ichar (cursor));
1683
1684 if (check_test (test, key, item, character) == test_not_unboundp)
1685 {
1686 result = make_integer (ii);
1687 *object_out = character;
1688
1689 if (NILP (from_end))
1690 {
1691 return result;
1692 }
1693 }
1694
1695 startp = XSTRING_DATA (sequence);
1696 cursor = startp + cursor_offset;
1697 if (byte_len != XSTRING_LENGTH (sequence)
1698 || !valid_ibyteptr_p (cursor))
1699 {
1700 mapping_interaction_error (caller, sequence);
1701 }
1702 }
1703
1704 INC_IBYTEPTR (cursor);
1705 cursor_offset = cursor - startp;
1706 ii++;
1707 }
1708
1709 if (ii < starting || (ii < ending && !NILP (end)))
1710 {
1711 check_sequence_range (sequence, start, end, Flength (sequence));
1712 }
1713 }
1714 else
1715 {
1716 Lisp_Object object = Qnil;
1717 len = XFIXNUM (Flength (sequence));
1718 check_sequence_range (sequence, start, end, make_fixnum (len));
1719
1720 ending = min (ending, len);
1721 if (0 == len)
1722 {
1723 /* Catches the case where we have nil. */
1724 return result;
1725 }
1726
1727 if (NILP (from_end))
1728 {
1729 for (ii = starting; ii < ending; ii++)
1730 {
1731 object = Faref (sequence, make_fixnum (ii));
1732 if (check_test (test, key, item, object) == test_not_unboundp)
1733 {
1734 result = make_integer (ii);
1735 *object_out = object;
1736 return result;
1737 }
1738 }
1739 }
1740 else
1741 {
1742 for (ii = ending - 1; ii >= starting; ii--)
1743 {
1744 object = Faref (sequence, make_fixnum (ii));
1745 if (check_test (test, key, item, object) == test_not_unboundp)
1746 {
1747 result = make_integer (ii);
1748 *object_out = object;
1749 return result;
1750 }
1751 }
1752 }
1753 }
1754
1755 return result;
1756 }
1757
1758 DEFUN ("position", Fposition, 2, MANY, 0, /*
1759 Return the index of the first occurrence of ITEM in SEQUENCE.
1760
1761 Return nil if not found. See `remove*' for the meaning of the keywords.
1762
1763 arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END TEST-NOT)
1764 */
1765 (int nargs, Lisp_Object *args))
1766 {
1767 Lisp_Object object = Qnil, item = args[0], sequence = args[1];
1768 Boolint test_not_unboundp = 1;
1769 check_test_func_t check_test = NULL;
1770
1771 PARSE_KEYWORDS (Fposition, nargs, args, 8,
1772 (test, if_, test_not, if_not, key, start, end, from_end),
1773 (start = Qzero));
1774
1775 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
1776 key, &test_not_unboundp);
1777
1778 return position (&object, item, sequence, check_test, test_not_unboundp,
1779 test, key, start, end, from_end, Qnil, Qposition);
1780 }
1781
1782 DEFUN ("find", Ffind, 2, MANY, 0, /*
1783 Find the first occurrence of ITEM in SEQUENCE.
1784
1785 Return the matching ITEM, or nil if not found. See `remove*' for the
1786 meaning of the keywords.
1787
1788 The keyword :default, not specified by Common Lisp, designates an object to
1789 return instead of nil if ITEM is not found.
1790
1791 arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) DEFAULT FROM-END TEST-NOT)
1792 */
1793 (int nargs, Lisp_Object *args))
1794 {
1795 Lisp_Object object = Qnil, item = args[0], sequence = args[1];
1796 Boolint test_not_unboundp = 1;
1797 check_test_func_t check_test = NULL;
1798
1799 PARSE_KEYWORDS (Ffind, nargs, args, 9,
1800 (test, if_, test_not, if_not, key, start, end, from_end,
1801 default_),
1802 (start = Qzero));
1803
1804 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
1805 key, &test_not_unboundp);
1806
1807 position (&object, item, sequence, check_test, test_not_unboundp,
1808 test, key, start, end, from_end, default_, Qposition);
1809
1810 return object;
1811 }
1812
1813 /* Like #'delq, but caller must ensure that LIST is properly
1814 nil-terminated and ebola-free. */
1815
1816 Lisp_Object
1817 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1818 {
1819 LIST_LOOP_DELETE_IF (list_elt, list,
1820 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1821 return list;
1822 }
1823
1824 /* Be VERY careful with this. This is like delq_no_quit() but
1825 also calls free_cons() on the removed conses. You must be SURE
1826 that no pointers to the freed conses remain around (e.g.
1827 someone else is pointing to part of the list). This function
1828 is useful on internal lists that are used frequently and where
1829 the actual list doesn't escape beyond known code bounds. */
1830
1831 Lisp_Object
1832 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1833 {
1834 REGISTER Lisp_Object tail = list;
1835 REGISTER Lisp_Object prev = Qnil;
1836
1837 while (!NILP (tail))
1838 {
1839 REGISTER Lisp_Object tem = XCAR (tail);
1840 if (EQ (elt, tem))
1841 {
1842 Lisp_Object cons_to_free = tail;
1843 if (NILP (prev))
1844 list = XCDR (tail);
1845 else
1846 XCDR (prev) = XCDR (tail);
1847 tail = XCDR (tail);
1848 free_cons (cons_to_free);
1849 }
1850 else
1851 {
1852 prev = tail;
1853 tail = XCDR (tail);
1854 }
1855 }
1856 return list;
1857 }
1858
1859 DEFUN ("delete*", FdeleteX, 2, MANY, 0, /*
1860 Remove all occurrences of ITEM in SEQUENCE, destructively.
1861
1862 If SEQUENCE is a non-nil list, this modifies the list directly. A non-list
1863 SEQUENCE will not be destructively modified, rather, if ITEM occurs in it, a
1864 new SEQUENCE of the same type without ITEM will be returned.
1865
1866 See `remove*' for a non-destructive alternative, and for explanation of the
1867 keyword arguments.
1868
1869 arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT)
1870 */
1871 (int nargs, Lisp_Object *args))
1872 {
1873 Lisp_Object item = args[0], sequence = args[1];
1874 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, counting = MOST_POSITIVE_FIXNUM;
1875 Elemcount len, ii = 0, encountered = 0, presenting = 0;
1876 Boolint test_not_unboundp = 1;
1877 check_test_func_t check_test = NULL;
1878
1879 PARSE_KEYWORDS (FdeleteX, nargs, args, 9,
1880 (test, if_not, if_, test_not, key, start, end, from_end,
1881 count), (start = Qzero, count = Qunbound));
1882
1883 CHECK_SEQUENCE (sequence);
1884 CHECK_NATNUM (start);
1885 starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
1886
1887 if (!NILP (end))
1888 {
1889 CHECK_NATNUM (end);
1890 ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
1891 }
1892
1893 if (!UNBOUNDP (count))
1894 {
1895 if (!NILP (count))
1896 {
1897 CHECK_INTEGER (count);
1898 if (FIXNUMP (count))
1899 {
1900 counting = XFIXNUM (count);
1901 }
1902 #ifdef HAVE_BIGNUM
1903 else
1904 {
1905 counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
1906 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1;
1907 }
1908 #endif
1909
1910 if (counting < 1)
1911 {
1912 return sequence;
1913 }
1914
1915 if (!NILP (from_end))
1916 {
1917 /* Sigh, this is inelegant. Force count_with_tail () to ignore
1918 the count keyword, so we get the actual number of matching
1919 elements, and can start removing from the beginning for the
1920 from-end case. */
1921 for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args;
1922 ii < nargs; ii += 2)
1923 {
1924 if (EQ (args[ii], Q_count))
1925 {
1926 args[ii + 1] = Qnil;
1927 break;
1928 }
1929 }
1930 ii = 0;
1931 }
1932 }
1933 }
1934
1935 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
1936 key, &test_not_unboundp);
1937
1938 if (CONSP (sequence))
1939 {
1940 Lisp_Object prev_tail_list_elt = Qnil, ignore = Qnil;
1941 Elemcount list_len = 0, deleted = 0;
1942 struct gcpro gcpro1;
1943
1944 if (!NILP (count) && !NILP (from_end))
1945 {
1946 /* Both COUNT and FROM-END were specified; we need to traverse the
1947 list twice. */
1948 Lisp_Object present = count_with_tail (&ignore, nargs, args,
1949 QdeleteX);
1950
1951 if (ZEROP (present))
1952 {
1953 return sequence;
1954 }
1955
1956 presenting = XFIXNUM (present);
1957
1958 /* If there are fewer items in the list than we have permission to
1959 delete, we don't need to differentiate between the :from-end
1960 nil and :from-end t cases. Otherwise, presenting is the number
1961 of matching items we need to ignore before we start to
1962 delete. */
1963 presenting = presenting <= counting ? 0 : presenting - counting;
1964 }
1965
1966 GCPRO1 (prev_tail_list_elt);
1967 ii = -1;
1968
1969 {
1970 GC_EXTERNAL_LIST_LOOP_4 (list_elt, sequence, tail, list_len)
1971 {
1972 ii++;
1973
1974 if (starting <= ii && ii < ending &&
1975 (check_test (test, key, item, list_elt) == test_not_unboundp)
1976 && (presenting ? encountered++ >= presenting
1977 : encountered++ < counting))
1978 {
1979 if (NILP (prev_tail_list_elt))
1980 {
1981 sequence = XCDR (tail);
1982 }
1983 else
1984 {
1985 XSETCDR (prev_tail_list_elt, XCDR (tail));
1986 }
1987
1988 /* Keep tortoise from ever passing hare. */
1989 list_len = 0;
1990 deleted++;
1991 }
1992 else
1993 {
1994 prev_tail_list_elt = tail;
1995 if (ii >= ending || (!presenting && encountered > counting))
1996 {
1997 break;
1998 }
1999 }
2000 }
2001 END_GC_EXTERNAL_LIST_LOOP (list_elt);
2002 }
2003
2004 UNGCPRO;
2005
2006 if ((ii < starting || (ii < ending && !NILP (end))) &&
2007 !(presenting ? encountered == presenting : encountered == counting))
2008 {
2009 check_sequence_range (args[1], start, end,
2010 make_fixnum (deleted + XFIXNUM (Flength (args[1]))));
2011 }
2012
2013 return sequence;
2014 }
2015 else if (STRINGP (sequence))
2016 {
2017 Ibyte *staging = alloca_ibytes (XSTRING_LENGTH (sequence));
2018 Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence);
2019 Ibyte *cursor = startp;
2020 Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence);
2021 Lisp_Object character, result = sequence;
2022
2023 if (!NILP (count) && !NILP (from_end))
2024 {
2025 Lisp_Object present = count_with_tail (&character, nargs, args,
2026 QdeleteX);
2027
2028 if (ZEROP (present))
2029 {
2030 return sequence;
2031 }
2032
2033 presenting = XFIXNUM (present);
2034
2035 /* If there are fewer items in the list than we have permission to
2036 delete, we don't need to differentiate between the :from-end
2037 nil and :from-end t cases. Otherwise, presenting is the number
2038 of matching items we need to ignore before we start to
2039 delete. */
2040 presenting = presenting <= counting ? 0 : presenting - counting;
2041 }
2042
2043 ii = 0;
2044 while (cursor_offset < byte_len)
2045 {
2046 if (ii >= starting && ii < ending)
2047 {
2048 character = make_char (itext_ichar (cursor));
2049
2050 if ((check_test (test, key, item, character)
2051 == test_not_unboundp)
2052 && (presenting ? encountered++ >= presenting :
2053 encountered++ < counting))
2054 {
2055 DO_NOTHING;
2056 }
2057 else
2058 {
2059 staging_cursor
2060 += set_itext_ichar (staging_cursor, XCHAR (character));
2061 }
2062
2063 startp = XSTRING_DATA (sequence);
2064 cursor = startp + cursor_offset;
2065 if (byte_len != XSTRING_LENGTH (sequence)
2066 || !valid_ibyteptr_p (cursor))
2067 {
2068 mapping_interaction_error (QdeleteX, sequence);
2069 }
2070 }
2071 else
2072 {
2073 staging_cursor += itext_copy_ichar (cursor, staging_cursor);
2074 }
2075
2076 INC_IBYTEPTR (cursor);
2077 cursor_offset = cursor - startp;
2078 ii++;
2079 }
2080
2081 if (ii < starting || (ii < ending && !NILP (end)))
2082 {
2083 check_sequence_range (sequence, start, end, Flength (sequence));
2084 }
2085
2086 if (0 != encountered)
2087 {
2088 result = make_string (staging, staging_cursor - staging);
2089 copy_string_extents (result, sequence, 0, 0,
2090 staging_cursor - staging);
2091 sequence = result;
2092 }
2093
2094 return sequence;
2095 }
2096 else
2097 {
2098 Lisp_Object position0 = Qnil, object = Qnil;
2099 Lisp_Object *staging = NULL, *staging_cursor, *staging_limit;
2100 Elemcount positioning;
2101
2102 len = XFIXNUM (Flength (sequence));
2103
2104 check_sequence_range (sequence, start, end, make_fixnum (len));
2105
2106 position0 = position (&object, item, sequence, check_test,
2107 test_not_unboundp, test, key, start, end,
2108 from_end, Qnil, QdeleteX);
2109 if (NILP (position0))
2110 {
2111 return sequence;
2112 }
2113
2114 ending = min (ending, len);
2115 positioning = XFIXNUM (position0);
2116 encountered = 1;
2117
2118 if (NILP (from_end))
2119 {
2120 staging = alloca_array (Lisp_Object, len - 1);
2121 staging_cursor = staging;
2122
2123 ii = 0;
2124 while (ii < positioning)
2125 {
2126 *staging_cursor++ = Faref (sequence, make_fixnum (ii));
2127 ii++;
2128 }
2129
2130 ii = positioning + 1;
2131 while (ii < ending)
2132 {
2133 object = Faref (sequence, make_fixnum (ii));
2134 if (encountered < counting
2135 && (check_test (test, key, item, object)
2136 == test_not_unboundp))
2137 {
2138 encountered++;
2139 }
2140 else
2141 {
2142 *staging_cursor++ = object;
2143 }
2144 ii++;
2145 }
2146
2147 while (ii < len)
2148 {
2149 *staging_cursor++ = Faref (sequence, make_fixnum (ii));
2150 ii++;
2151 }
2152 }
2153 else
2154 {
2155 staging = alloca_array (Lisp_Object, len - 1);
2156 staging_cursor = staging_limit = staging + len - 1;
2157
2158 ii = len - 1;
2159 while (ii > positioning)
2160 {
2161 *--staging_cursor = Faref (sequence, make_fixnum (ii));
2162 ii--;
2163 }
2164
2165 ii = positioning - 1;
2166 while (ii >= starting)
2167 {
2168 object = Faref (sequence, make_fixnum (ii));
2169 if (encountered < counting
2170 && (check_test (test, key, item, object) ==
2171 test_not_unboundp))
2172 {
2173 encountered++;
2174 }
2175 else
2176 {
2177 *--staging_cursor = object;
2178 }
2179
2180 ii--;
2181 }
2182
2183 while (ii >= 0)
2184 {
2185 *--staging_cursor = Faref (sequence, make_fixnum (ii));
2186 ii--;
2187 }
2188
2189 staging = staging_cursor;
2190 staging_cursor = staging_limit;
2191 }
2192
2193 if (VECTORP (sequence))
2194 {
2195 return Fvector (staging_cursor - staging, staging);
2196 }
2197 else if (BIT_VECTORP (sequence))
2198 {
2199 return Fbit_vector (staging_cursor - staging, staging);
2200 }
2201
2202 /* A nil sequence will have given us a nil #'position,
2203 above. */
2204 ABORT ();
2205
2206 return Qnil;
2207 }
2208 }
2209
2210 DEFUN ("remove*", FremoveX, 2, MANY, 0, /*
2211 Remove all occurrences of ITEM in SEQUENCE, non-destructively.
2212
2213 If SEQUENCE is a list, `remove*' makes a copy if that is necessary to avoid
2214 corrupting the original SEQUENCE.
2215
2216 The keywords :test and :test-not specify two-argument test and negated-test
2217 predicates, respectively; :test defaults to `eql'. :key specifies a
2218 one-argument function that transforms elements of SEQUENCE into \"comparison
2219 keys\" before the test predicate is applied. See `member*' for more
2220 information on these keywords.
2221
2222 :start and :end, if given, specify indices of a subsequence of SEQUENCE to
2223 be processed. Indices are 0-based and processing involves the subsequence
2224 starting at the index given by :start and ending just before the index given
2225 by :end.
2226
2227 :count, if given, limits the number of items removed to the number
2228 specified. :from-end, if given, causes processing to proceed starting from
2229 the end instead of the beginning; in this case, this matters only if :count
2230 is given.
2231
2232 arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT)
2233 */
2234 (int nargs, Lisp_Object *args))
2235 {
2236 Lisp_Object item = args[0], sequence = args[1], matched_count = Qnil,
2237 tail = Qnil;
2238 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, counting = MOST_POSITIVE_FIXNUM;
2239 Elemcount ii = 0, encountered = 0, presenting = 0;
2240 Boolint test_not_unboundp = 1;
2241 check_test_func_t check_test = NULL;
2242
2243 PARSE_KEYWORDS (FremoveX, nargs, args, 9,
2244 (test, if_not, if_, test_not, key, start, end, from_end,
2245 count), (start = Qzero));
2246
2247 if (!CONSP (sequence))
2248 {
2249 return FdeleteX (nargs, args);
2250 }
2251
2252 CHECK_NATNUM (start);
2253 starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
2254
2255 if (!NILP (end))
2256 {
2257 CHECK_NATNUM (end);
2258 ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
2259 }
2260
2261 if (!NILP (count))
2262 {
2263 CHECK_INTEGER (count);
2264 if (FIXNUMP (count))
2265 {
2266 counting = XFIXNUM (count);
2267 }
2268 #ifdef HAVE_BIGNUM
2269 else
2270 {
2271 counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
2272 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM;
2273 }
2274 #endif
2275
2276 if (counting <= 0)
2277 {
2278 return sequence;
2279 }
2280
2281 if (!NILP (from_end))
2282 {
2283 /* Sigh, this is inelegant. Force count_with_tail () to ignore the
2284 count keyword, so we get the actual number of matching
2285 elements, and can start removing from the beginning for the
2286 from-end case. */
2287 for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FremoveX))->min_args;
2288 ii < nargs; ii += 2)
2289 {
2290 if (EQ (args[ii], Q_count))
2291 {
2292 args[ii + 1] = Qnil;
2293 break;
2294 }
2295 }
2296 ii = 0;
2297 }
2298 }
2299
2300 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
2301 key, &test_not_unboundp);
2302
2303 matched_count = count_with_tail (&tail, nargs, args, QremoveX);
2304
2305 if (!ZEROP (matched_count))
2306 {
2307 Lisp_Object result = Qnil, result_tail = Qnil;
2308 struct gcpro gcpro1, gcpro2;
2309
2310 if (!NILP (count) && !NILP (from_end))
2311 {
2312 presenting = XFIXNUM (matched_count);
2313
2314 /* If there are fewer matching elements in the list than we have
2315 permission to delete, we don't need to differentiate between
2316 the :from-end nil and :from-end t cases. Otherwise, presenting
2317 is the number of matching items we need to ignore before we
2318 start to delete. */
2319 presenting = presenting <= counting ? 0 : presenting - counting;
2320 }
2321
2322 GCPRO2 (result, tail);
2323 {
2324 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tailing)
2325 {
2326 if (EQ (tail, tailing))
2327 {
2328 XUNGCPRO (elt);
2329 UNGCPRO;
2330
2331 if (NILP (result))
2332 {
2333 return XCDR (tail);
2334 }
2335
2336 XSETCDR (result_tail, XCDR (tail));
2337 return result;
2338 }
2339 else if (starting <= ii && ii < ending &&
2340 (check_test (test, key, item, elt) == test_not_unboundp)
2341 && (presenting ? encountered++ >= presenting
2342 : encountered++ < counting))
2343 {
2344 DO_NOTHING;
2345 }
2346 else if (NILP (result))
2347 {
2348 result = result_tail = Fcons (elt, Qnil);
2349 }
2350 else
2351 {
2352 XSETCDR (result_tail, Fcons (elt, Qnil));
2353 result_tail = XCDR (result_tail);
2354 }
2355
2356 if (ii == ending)
2357 {
2358 break;
2359 }
2360
2361 ii++;
2362 }
2363 END_GC_EXTERNAL_LIST_LOOP (elt);
2364 }
2365 UNGCPRO;
2366
2367 if (ii < starting || (ii < ending && !NILP (end)))
2368 {
2369 check_sequence_range (args[0], start, end, Flength (args[0]));
2370 }
2371
2372 return result;
2373 }
2374
2375 return sequence;
2376 }
2377
2378 Lisp_Object
2379 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
2380 {
2381 LIST_LOOP_DELETE_IF (elt, alist,
2382 (CONSP (elt) &&
2383 internal_equal (key, XCAR (elt), 0)));
2384 return alist;
2385 }
2386
2387 /* no quit, no errors; be careful */
2388
2389 Lisp_Object
2390 remassq_no_quit (Lisp_Object key, Lisp_Object alist)
2391 {
2392 LIST_LOOP_DELETE_IF (elt, alist,
2393 (CONSP (elt) &&
2394 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
2395 return alist;
2396 }
2397
2398 /* Like Fremrassq, fast and unsafe; be careful */
2399 Lisp_Object
2400 remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
2401 {
2402 LIST_LOOP_DELETE_IF (elt, alist,
2403 (CONSP (elt) &&
2404 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
2405 return alist;
2406 }
2407
2408 /* Remove duplicate elements between START and END from LIST, a non-nil
2409 list; if COPY is zero, do so destructively. Items to delete are selected
2410 according to the algorithm used when :from-end t is passed to
2411 #'delete-duplicates. Error if LIST is ill-formed or circular.
2412
2413 TEST and KEY are as in #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should
2414 reflect them, having been initialised with get_check_match_function() or
2415 get_check_test_function(). */
2416 static Lisp_Object
2417 list_delete_duplicates_from_end (Lisp_Object list,
2418 check_test_func_t check_test,
2419 Boolint test_not_unboundp,
2420 Lisp_Object test, Lisp_Object key,
2421 Lisp_Object start,
2422 Lisp_Object end, Boolint copy)
2423 {
2424 Lisp_Object checking = Qnil, result = list;
2425 Lisp_Object keyed, positioned, position_cons = Qnil, result_tail;
2426 Elemcount len = XFIXNUM (Flength (list)), pos, starting = XFIXNUM (start);
2427 Elemcount ending = (NILP (end) ? len : XFIXNUM (end)), greatest_pos_seen = -1;
2428 Elemcount ii = 0;
2429 struct gcpro gcpro1;
2430
2431 /* We can't delete (or remove) as we go, because that breaks START and
2432 END. We could if END were nil, and that would change an ON(N + 2)
2433 algorithm to an ON^2 algorithm. Here and now it doesn't matter, though,
2434 #'delete-duplicates is relatively expensive no matter what. */
2435 struct Lisp_Bit_Vector *deleting
2436 = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
2437 + (sizeof (long)
2438 * (BIT_VECTOR_LONG_STORAGE (len)
2439 - 1)));
2440
2441 check_sequence_range (list, start, end, make_integer (len));
2442
2443 deleting->size = len;
2444 memset (&(deleting->bits), 0,
2445 sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
2446
2447 GCPRO1 (keyed);
2448
2449 {
2450 GC_EXTERNAL_LIST_LOOP_3 (elt, list, tail)
2451 {
2452 if (!(starting <= ii && ii <= ending) || bit_vector_bit (deleting, ii))
2453 {
2454 ii++;
2455 continue;
2456 }
2457
2458 keyed = KEY (key, elt);
2459 checking = XCDR (tail);
2460 pos = ii + 1;
2461
2462 while (!NILP ((positioned = list_position_cons_before
2463 (&position_cons, keyed, checking, check_test,
2464 test_not_unboundp, test, key, 0,
2465 make_fixnum (max (starting - pos, 0)),
2466 make_fixnum (ending - pos)))))
2467 {
2468 pos = XFIXNUM (positioned) + pos;
2469 set_bit_vector_bit (deleting, pos, 1);
2470 greatest_pos_seen = max (greatest_pos_seen, pos);
2471 checking = NILP (position_cons) ?
2472 XCDR (checking) : XCDR (XCDR (position_cons));
2473 pos += 1;
2474 }
2475 ii++;
2476 }
2477 END_GC_EXTERNAL_LIST_LOOP (elt);
2478 }
2479
2480 UNGCPRO;
2481
2482 ii = 0;
2483
2484 if (greatest_pos_seen > -1)
2485 {
2486 if (copy)
2487 {
2488 result = result_tail = Fcons (XCAR (list), Qnil);
2489 list = XCDR (list);
2490 ii = 1;
2491
2492 {
2493 EXTERNAL_LIST_LOOP_3 (elt, list, tail)
2494 {
2495 if (ii == greatest_pos_seen)
2496 {
2497 XSETCDR (result_tail, XCDR (tail));
2498 break;
2499 }
2500 else if (!bit_vector_bit (deleting, ii))
2501 {
2502 XSETCDR (result_tail, Fcons (elt, Qnil));
2503 result_tail = XCDR (result_tail);
2504 }
2505 ii++;
2506 }
2507 }
2508 }
2509 else
2510 {
2511 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
2512 bit_vector_bit (deleting, ii++));
2513 }
2514 }
2515
2516 return result;
2517 }
2518
2519 DEFUN ("delete-duplicates", Fdelete_duplicates, 1, MANY, 0, /*
2520 Remove all duplicate elements from SEQUENCE, destructively.
2521
2522 If SEQUENCE is a list and has duplicates, modify and return it. Note that
2523 SEQUENCE may start with an element to be deleted; because of this, if
2524 modifying a variable, be sure to write `(setq VARIABLE (delete-duplicates
2525 VARIABLE))' to be certain to have a list without duplicate elements.
2526
2527 If SEQUENCE is an array and has duplicates, return a newly-allocated array
2528 of the same type comprising all unique elements of SEQUENCE.
2529
2530 If there are no duplicate elements in SEQUENCE, return it unmodified.
2531
2532 See `remove*' for the meaning of the keywords. See `remove-duplicates' for
2533 a non-destructive version of this function.
2534
2535 arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
2536 */
2537 (int nargs, Lisp_Object *args))
2538 {
2539 Lisp_Object sequence = args[0], keyed = Qnil;
2540 Lisp_Object positioned = Qnil, ignore = Qnil;
2541 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, len, ii = 0, jj = 0;
2542 Boolint test_not_unboundp = 1;
2543 check_test_func_t check_test = NULL;
2544 struct gcpro gcpro1, gcpro2;
2545
2546 PARSE_KEYWORDS (Fdelete_duplicates, nargs, args, 6,
2547 (test, key, test_not, start, end, from_end),
2548 (start = Qzero));
2549
2550 CHECK_SEQUENCE (sequence);
2551 CHECK_NATNUM (start);
2552 starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
2553
2554 if (!NILP (end))
2555 {
2556 CHECK_NATNUM (end);
2557 ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
2558 }
2559
2560 CHECK_KEY_ARGUMENT (key);
2561
2562 get_check_match_function (&test, test_not, Qnil, Qnil, key,
2563 &test_not_unboundp, &check_test);
2564
2565 if (CONSP (sequence))
2566 {
2567 if (NILP (from_end))
2568 {
2569 Lisp_Object prev_tail = Qnil;
2570 Elemcount deleted = 0;
2571
2572 GCPRO2 (keyed, prev_tail);
2573
2574 {
2575 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
2576 {
2577 if (starting <= ii && ii < ending)
2578 {
2579 keyed = KEY (key, elt);
2580 positioned
2581 = list_position_cons_before (&ignore, keyed,
2582 XCDR (tail), check_test,
2583 test_not_unboundp, test, key,
2584 0, make_fixnum (max (starting
2585 - (ii + 1),
2586 0)),
2587 make_fixnum (ending
2588 - (ii + 1)));
2589 if (!NILP (positioned))
2590 {
2591 sequence = XCDR (tail);
2592 deleted++;
2593 }
2594 else
2595 {
2596 break;
2597 }
2598 }
2599 else
2600 {
2601 break;
2602 }
2603
2604 ii++;
2605 }
2606 END_GC_EXTERNAL_LIST_LOOP (elt);
2607 }
2608 {
2609 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
2610 {
2611 if (!(starting <= ii && ii <= ending))
2612 {
2613 prev_tail = tail;
2614 ii++;
2615 continue;
2616 }
2617
2618 keyed = KEY (key, elt);
2619 positioned
2620 = list_position_cons_before (&ignore, keyed, XCDR (tail),
2621 check_test, test_not_unboundp,
2622 test, key, 0,
2623 make_fixnum (max (starting
2624 - (ii + 1), 0)),
2625 make_fixnum (ending - (ii + 1)));
2626 if (!NILP (positioned))
2627 {
2628 /* We know this isn't the first iteration of the loop,
2629 because we advanced above to the point where we have at
2630 least one non-duplicate entry at the head of the
2631 list. */
2632 XSETCDR (prev_tail, XCDR (tail));
2633 len = 0;
2634 deleted++;
2635 }
2636 else
2637 {
2638 prev_tail = tail;
2639 if (ii >= ending)
2640 {
2641 break;
2642 }
2643 }
2644
2645 ii++;
2646 }
2647 END_GC_EXTERNAL_LIST_LOOP (elt);
2648 }
2649
2650 UNGCPRO;
2651
2652 if ((ii < starting || (ii < ending && !NILP (end))))
2653 {
2654 check_sequence_range (args[0], start, end,
2655 make_fixnum (deleted
2656 + XFIXNUM (Flength (args[0]))));
2657 }
2658 }
2659 else
2660 {
2661 sequence = list_delete_duplicates_from_end (sequence, check_test,
2662 test_not_unboundp,
2663 test, key, start, end,
2664 0);
2665 }
2666 }
2667 else if (STRINGP (sequence))
2668 {
2669 Lisp_Object elt = Qnil;
2670
2671 if (EQ (Qidentity, key))
2672 {
2673 /* We know all the elements will be characters; set check_test to
2674 reflect that. This isn't useful if KEY is not #'identity, since
2675 it may return non-characters for the elements. */
2676 check_test = get_check_test_function (make_char ('a'),
2677 &test, test_not,
2678 Qnil, Qnil, key,
2679 &test_not_unboundp);
2680 }
2681
2682 if (NILP (from_end))
2683 {
2684 Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0;
2685 Ibyte *staging = alloca_ibytes (byte_len), *staging_cursor = staging;
2686 Ibyte *cursor = XSTRING_DATA (sequence), *startp = cursor;
2687 Elemcount deleted = 0;
2688
2689 GCPRO1 (elt);
2690
2691 while (cursor_offset < byte_len)
2692 {
2693 if (starting <= ii && ii < ending)
2694 {
2695 Ibyte *cursor0 = cursor;
2696 Bytecount cursor0_offset;
2697 Boolint delete_this = 0;
2698
2699 elt = KEY (key, make_char (itext_ichar (cursor)));
2700 INC_IBYTEPTR (cursor0);
2701 cursor0_offset = cursor0 - startp;
2702
2703 for (jj = ii + 1; jj < ending && cursor0_offset < byte_len;
2704 jj++)
2705 {
2706 if (check_test (test, key, elt,
2707 make_char (itext_ichar (cursor0)))
2708 == test_not_unboundp)
2709 {
2710 delete_this = 1;
2711 deleted++;
2712 break;
2713 }
2714
2715 startp = XSTRING_DATA (sequence);
2716 cursor0 = startp + cursor0_offset;
2717 if (byte_len != XSTRING_LENGTH (sequence)
2718 || !valid_ibyteptr_p (cursor0))
2719 {
2720 mapping_interaction_error (Qdelete_duplicates,
2721 sequence);
2722 }
2723
2724 INC_IBYTEPTR (cursor0);
2725 cursor0_offset = cursor0 - startp;
2726 }
2727
2728 startp = XSTRING_DATA (sequence);
2729 cursor = startp + cursor_offset;
2730
2731 if (byte_len != XSTRING_LENGTH (sequence)
2732 || !valid_ibyteptr_p (cursor))
2733 {
2734 mapping_interaction_error (Qdelete_duplicates, sequence);
2735 }
2736
2737 if (!delete_this)
2738 {
2739 staging_cursor
2740 += itext_copy_ichar (cursor, staging_cursor);
2741
2742 }
2743 }
2744 else
2745 {
2746 staging_cursor += itext_copy_ichar (cursor, staging_cursor);
2747 }
2748
2749 INC_IBYTEPTR (cursor);
2750 cursor_offset = cursor - startp;
2751 ii++;
2752 }
2753
2754 UNGCPRO;
2755
2756 if (ii < starting || (ii < ending && !NILP (end)))
2757 {
2758 check_sequence_range (sequence, start, end, Flength (sequence));
2759 }
2760
2761 if (0 != deleted)
2762 {
2763 sequence = make_string (staging, staging_cursor - staging);
2764 }
2765 }
2766 else
2767 {
2768 Elemcount deleted = 0;
2769 Ibyte *staging = alloca_ibytes ((len = string_char_length (sequence))
2770 * MAX_ICHAR_LEN);
2771 Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence);
2772 Ibyte *endp = startp + XSTRING_LENGTH (sequence);
2773 struct Lisp_Bit_Vector *deleting
2774 = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
2775 + (sizeof (long)
2776 * (BIT_VECTOR_LONG_STORAGE (len)
2777 - 1)));
2778
2779 check_sequence_range (sequence, start, end, make_integer (len));
2780
2781 /* For the from_end t case; transform contents to an array with
2782 elements addressable in constant time, use the same algorithm
2783 as for vectors. */
2784 deleting->size = len;
2785 memset (&(deleting->bits), 0,
2786 sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
2787
2788 while (startp < endp)
2789 {
2790 itext_copy_ichar (startp, staging + (ii * MAX_ICHAR_LEN));
2791 INC_IBYTEPTR (startp);
2792 ii++;
2793 }
2794
2795 GCPRO1 (elt);
2796
2797 ending = min (ending, len);
2798
2799 for (ii = ending - 1; ii >= starting; ii--)
2800 {
2801 elt = KEY (key, make_char (itext_ichar (staging +
2802 (ii * MAX_ICHAR_LEN))));
2803 for (jj = ii - 1; jj >= starting; jj--)
2804 {
2805 if (check_test (test, key, elt,
2806 make_char (itext_ichar
2807 (staging + (jj * MAX_ICHAR_LEN))))
2808 == test_not_unboundp)
2809 {
2810 set_bit_vector_bit (deleting, ii, 1);
2811 deleted++;
2812 break;
2813 }
2814 }
2815 }
2816
2817 UNGCPRO;
2818
2819 if (0 != deleted)
2820 {
2821 startp = XSTRING_DATA (sequence);
2822
2823 for (ii = 0; ii < len; ii++)
2824 {
2825 if (!bit_vector_bit (deleting, ii))
2826 {
2827 staging_cursor
2828 += itext_copy_ichar (startp, staging_cursor);
2829 }
2830
2831 INC_IBYTEPTR (startp);
2832 }
2833
2834 sequence = make_string (staging, staging_cursor - staging);
2835 }
2836 }
2837 }
2838 else if (VECTORP (sequence))
2839 {
2840 Elemcount deleted = 0;
2841 Lisp_Object *content = XVECTOR_DATA (sequence);
2842 struct Lisp_Bit_Vector *deleting;
2843 Lisp_Object elt = Qnil;
2844
2845 len = XVECTOR_LENGTH (sequence);
2846 check_sequence_range (sequence, start, end, make_integer (len));
2847
2848 deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
2849 + (sizeof (long)
2850 * (BIT_VECTOR_LONG_STORAGE (len)
2851 - 1)));
2852 deleting->size = len;
2853 memset (&(deleting->bits), 0,
2854 sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
2855
2856 GCPRO1 (elt);
2857
2858 ending = min (ending, len);
2859
2860 if (NILP (from_end))
2861 {
2862 for (ii = starting; ii < ending; ii++)
2863 {
2864 elt = KEY (key, content[ii]);
2865
2866 for (jj = ii + 1; jj < ending; jj++)
2867 {
2868 if (check_test (test, key, elt, content[jj])
2869 == test_not_unboundp)
2870 {
2871 set_bit_vector_bit (deleting, ii, 1);
2872 deleted++;
2873 break;
2874 }
2875 }
2876 }
2877 }
2878 else
2879 {
2880 for (ii = ending - 1; ii >= starting; ii--)
2881 {
2882 elt = KEY (key, content[ii]);
2883
2884 for (jj = ii - 1; jj >= starting; jj--)
2885 {
2886 if (check_test (test, key, elt, content[jj])
2887 == test_not_unboundp)
2888 {
2889 set_bit_vector_bit (deleting, ii, 1);
2890 deleted++;
2891 break;
2892 }
2893 }
2894 }
2895 }
2896
2897 UNGCPRO;
2898
2899 if (deleted)
2900 {
2901 Lisp_Object res = make_vector (len - deleted, Qnil),
2902 *res_content = XVECTOR_DATA (res);
2903
2904 for (ii = jj = 0; ii < len; ii++)
2905 {
2906 if (!bit_vector_bit (deleting, ii))
2907 {
2908 res_content[jj++] = content[ii];
2909 }
2910 }
2911
2912 sequence = res;
2913 }
2914 }
2915 else if (BIT_VECTORP (sequence))
2916 {
2917 Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
2918 Elemcount deleted = 0;
2919 /* I'm a little irritated at this. Basically, the only reasonable
2920 thing delete-duplicates should do if handed a bit vector is return
2921 something of maximum length two and minimum length 0 (because
2922 that's the possible number of distinct elements if EQ is regarded
2923 as identity, which it should be). But to support arbitrary TEST
2924 and KEY arguments, which may be non-deterministic from our
2925 perspective, we need the same algorithm as for vectors. */
2926 struct Lisp_Bit_Vector *deleting;
2927 Lisp_Object elt = Qnil;
2928
2929 len = bit_vector_length (bv);
2930
2931 if (EQ (Qidentity, key))
2932 {
2933 /* We know all the elements will be bits; set check_test to
2934 reflect that. This isn't useful if KEY is not #'identity, since
2935 it may return non-bits for the elements. */
2936 check_test = get_check_test_function (Qzero, &test, test_not,
2937 Qnil, Qnil, key,
2938 &test_not_unboundp);
2939 }
2940
2941 check_sequence_range (sequence, start, end, make_integer (len));
2942
2943 deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector)
2944 + (sizeof (long)
2945 * (BIT_VECTOR_LONG_STORAGE (len)
2946 - 1)));
2947 deleting->size = len;
2948 memset (&(deleting->bits), 0,
2949 sizeof (long) * BIT_VECTOR_LONG_STORAGE (len));
2950
2951 ending = min (ending, len);
2952
2953 GCPRO1 (elt);
2954
2955 if (NILP (from_end))
2956 {
2957 for (ii = starting; ii < ending; ii++)
2958 {
2959 elt = KEY (key, make_fixnum (bit_vector_bit (bv, ii)));
2960
2961 for (jj = ii + 1; jj < ending; jj++)
2962 {
2963 if (check_test (test, key, elt,
2964 make_fixnum (bit_vector_bit (bv, jj)))
2965 == test_not_unboundp)
2966 {
2967 set_bit_vector_bit (deleting, ii, 1);
2968 deleted++;
2969 break;
2970 }
2971 }
2972 }
2973 }
2974 else
2975 {
2976 for (ii = ending - 1; ii >= starting; ii--)
2977 {
2978 elt = KEY (key, make_fixnum (bit_vector_bit (bv, ii)));
2979
2980 for (jj = ii - 1; jj >= starting; jj--)
2981 {
2982 if (check_test (test, key, elt,
2983 make_fixnum (bit_vector_bit (bv, jj)))
2984 == test_not_unboundp)
2985 {
2986 set_bit_vector_bit (deleting, ii, 1);
2987 deleted++;
2988 break;
2989 }
2990 }
2991 }
2992 }
2993
2994 UNGCPRO;
2995
2996 if (deleted)
2997 {
2998 Lisp_Object res = make_bit_vector (len - deleted, Qzero);
2999 Lisp_Bit_Vector *resbv = XBIT_VECTOR (res);
3000
3001 for (ii = jj = 0; ii < len; ii++)
3002 {
3003 if (!bit_vector_bit (deleting, ii))
3004 {
3005 set_bit_vector_bit (resbv, jj++, bit_vector_bit (bv, ii));
3006 }
3007 }
3008
3009 sequence = res;
3010 }
3011 }
3012
3013 return sequence;
3014 }
3015
3016 DEFUN ("remove-duplicates", Fremove_duplicates, 1, MANY, 0, /*
3017 Remove duplicate elements from SEQUENCE, non-destructively.
3018
3019 If there are no duplicate elements in SEQUENCE, return it unmodified;
3020 otherwise, return a new object. If SEQUENCE is a list, the new object may
3021 share list structure with SEQUENCE.
3022
3023 See `remove*' for the meaning of the keywords.
3024
3025 arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT)
3026 */
3027 (int nargs, Lisp_Object *args))
3028 {
3029 Lisp_Object sequence = args[0], keyed, positioned = Qnil;
3030 Lisp_Object result = sequence, result_tail = result, cursor = Qnil;
3031 Lisp_Object cons_with_shared_tail = Qnil;
3032 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, ii = 0;
3033 Boolint test_not_unboundp = 1;
3034 check_test_func_t check_test = NULL;
3035 struct gcpro gcpro1, gcpro2;
3036
3037 PARSE_KEYWORDS (Fremove_duplicates, nargs, args, 6,
3038 (test, key, test_not, start, end, from_end),
3039 (start = Qzero));
3040
3041 CHECK_SEQUENCE (sequence);
3042
3043 if (!CONSP (sequence))
3044 {
3045 return Fdelete_duplicates (nargs, args);
3046 }
3047
3048 CHECK_NATNUM (start);
3049 starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
3050
3051 if (!NILP (end))
3052 {
3053 CHECK_NATNUM (end);
3054 ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
3055 }
3056
3057 if (NILP (key))
3058 {
3059 key = Qidentity;
3060 }
3061
3062 get_check_match_function (&test, test_not, Qnil, Qnil, key,
3063 &test_not_unboundp, &check_test);
3064
3065 if (NILP (from_end))
3066 {
3067 Lisp_Object ignore = Qnil;
3068
3069 GCPRO2 (keyed, result);
3070
3071 {
3072 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
3073 {
3074 if (starting <= ii && ii <= ending)
3075 {
3076 keyed = KEY (key, elt);
3077 positioned
3078 = list_position_cons_before (&ignore, keyed, XCDR (tail),
3079 check_test, test_not_unboundp,
3080 test, key, 0,
3081 make_fixnum (max (starting
3082 - (ii + 1), 0)),
3083 make_fixnum (ending - (ii + 1)));
3084 if (!NILP (positioned))
3085 {
3086 sequence = result = result_tail = XCDR (tail);
3087 }
3088 else
3089 {
3090 break;
3091 }
3092 }
3093 else
3094 {
3095 break;
3096 }
3097
3098 ii++;
3099 }
3100 END_GC_EXTERNAL_LIST_LOOP (elt);
3101 }
3102
3103 {
3104 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
3105 {
3106 if (!(starting <= ii && ii <= ending))
3107 {
3108 ii++;
3109 continue;
3110 }
3111
3112 /* For this algorithm, each time we encounter an object to be
3113 removed, copy the output list from the tail beyond the last
3114 removed cons to this one. Otherwise, the tail of the output list
3115 is shared with the input list, which is OK. */
3116
3117 keyed = KEY (key, elt);
3118 positioned
3119 = list_position_cons_before (&ignore, keyed, XCDR (tail),
3120 check_test, test_not_unboundp,
3121 test, key, 0,
3122 make_fixnum (max (starting - (ii + 1),
3123 0)),
3124 make_fixnum (ending - (ii + 1)));
3125 if (!NILP (positioned))
3126 {
3127 if (EQ (result, sequence))
3128 {
3129 result = cons_with_shared_tail
3130 = Fcons (XCAR (sequence), XCDR (sequence));
3131 }
3132
3133 result_tail = cons_with_shared_tail;
3134 cursor = XCDR (cons_with_shared_tail);
3135
3136 while (!EQ (cursor, tail) && !NILP (cursor))
3137 {
3138 XSETCDR (result_tail, Fcons (XCAR (cursor), Qnil));
3139 result_tail = XCDR (result_tail);
3140 cursor = XCDR (cursor);
3141 }
3142
3143 XSETCDR (result_tail, XCDR (tail));
3144 cons_with_shared_tail = result_tail;
3145 }
3146
3147 ii++;
3148 }
3149 END_GC_EXTERNAL_LIST_LOOP (elt);
3150 }
3151
3152 UNGCPRO;
3153
3154 if ((ii < starting || (ii < ending && !NILP (end))))
3155 {
3156 check_sequence_range (args[0], start, end, Flength (args[0]));
3157 }
3158 }
3159 else
3160 {
3161 result = list_delete_duplicates_from_end (sequence, check_test,
3162 test_not_unboundp, test, key,
3163 start, end, 1);
3164 }
3165
3166 return result;
3167 }
3168 #undef KEY
3169
3170 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
3171 Reverse SEQUENCE, destructively.
3172
3173 Return the beginning of the reversed sequence, which will be a distinct Lisp
3174 object if SEQUENCE is a list with length greater than one. See also
3175 `reverse', the non-destructive version of this function.
3176 */
3177 (sequence))
3178 {
3179 CHECK_SEQUENCE (sequence);
3180
3181 if (CONSP (sequence))
3182 {
3183 struct gcpro gcpro1, gcpro2;
3184 Lisp_Object prev = Qnil;
3185 Lisp_Object tail = sequence;
3186
3187 /* We gcpro our args; see `nconc' */
3188 GCPRO2 (prev, tail);
3189 while (!NILP (tail))
3190 {
3191 REGISTER Lisp_Object next;
3192 CONCHECK_CONS (tail);
3193 next = XCDR (tail);
3194 XCDR (tail) = prev;
3195 prev = tail;
3196 tail = next;
3197 }
3198 UNGCPRO;
3199 return prev;
3200 }
3201 else if (VECTORP (sequence))
3202 {
3203 Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
3204 Elemcount half = length / 2;
3205 Lisp_Object swap = Qnil;
3206 CHECK_LISP_WRITEABLE (sequence);
3207
3208 while (ii > half)
3209 {
3210 swap = XVECTOR_DATA (sequence) [length - ii];
3211 XVECTOR_DATA (sequence) [length - ii]
3212 = XVECTOR_DATA (sequence) [ii - 1];
3213 XVECTOR_DATA (sequence) [ii - 1] = swap;
3214 --ii;
3215 }
3216 }
3217 else if (STRINGP (sequence))
3218 {
3219 Elemcount length = XSTRING_LENGTH (sequence);
3220 Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
3221 Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
3222
3223 CHECK_LISP_WRITEABLE (sequence);
3224 while (cursor < endp)
3225 {
3226 staging_end -= itext_ichar_len (cursor);
3227 itext_copy_ichar (cursor, staging_end);
3228 INC_IBYTEPTR (cursor);
3229 }
3230
3231 assert (staging == staging_end);
3232
3233 memcpy (XSTRING_DATA (sequence), staging, length);
3234 init_string_ascii_begin (sequence);
3235 bump_string_modiff (sequence);
3236 sledgehammer_check_ascii_begin (sequence);
3237 }
3238 else if (BIT_VECTORP (sequence))
3239 {
3240 Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
3241 Elemcount length = bit_vector_length (bv), ii = length;
3242 Elemcount half = length / 2;
3243 int swap = 0;
3244
3245 CHECK_LISP_WRITEABLE (sequence);
3246 while (ii > half)
3247 {
3248 swap = bit_vector_bit (bv, length - ii);
3249 set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1));
3250 set_bit_vector_bit (bv, ii - 1, swap);
3251 --ii;
3252 }
3253 }
3254 else
3255 {
3256 assert (NILP (sequence));
3257 }
3258
3259 return sequence;
3260 }
3261
3262 DEFUN ("reverse", Freverse, 1, 1, 0, /*
3263 Reverse SEQUENCE, copying. Return the reversed sequence.
3264 See also the function `nreverse', which is used more often.
3265 */
3266 (sequence))
3267 {
3268 Lisp_Object result = Qnil;
3269
3270 CHECK_SEQUENCE (sequence);
3271
3272 if (CONSP (sequence))
3273 {
3274 EXTERNAL_LIST_LOOP_2 (elt, sequence)
3275 {
3276 result = Fcons (elt, result);
3277 }
3278 }
3279 else if (VECTORP (sequence))
3280 {
3281 Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
3282 Lisp_Object *staging = alloca_array (Lisp_Object, length);
3283
3284 while (ii > 0)
3285 {
3286 staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1];
3287 --ii;
3288 }
3289
3290 result = Fvector (length, staging);
3291 }
3292 else if (STRINGP (sequence))
3293 {
3294 Elemcount length = XSTRING_LENGTH (sequence);
3295 Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
3296 Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
3297
3298 while (cursor < endp)
3299 {
3300 staging_end -= itext_ichar_len (cursor);
3301 itext_copy_ichar (cursor, staging_end);
3302 INC_IBYTEPTR (cursor);
3303 }
3304
3305 assert (staging == staging_end);
3306
3307 result = make_string (staging, length);
3308 }
3309 else if (BIT_VECTORP (sequence))
3310 {
3311 Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res;
3312 Elemcount length = bit_vector_length (bv), ii = length;
3313
3314 result = make_bit_vector (length, Qzero);
3315 res = XBIT_VECTOR (result);
3316
3317 while (ii > 0)
3318 {
3319 set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1));
3320 --ii;
3321 }
3322 }
3323 else
3324 {
3325 assert (NILP (sequence));
3326 }
3327
3328 return result;
3329 }
3330
3331 Lisp_Object
3332 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
3333 check_test_func_t check_merge,
3334 Lisp_Object predicate, Lisp_Object key)
3335 {
3336 Lisp_Object value;
3337 Lisp_Object tail;
3338 Lisp_Object tem;
3339 Lisp_Object l1, l2;
3340 Lisp_Object tortoises[2];
3341 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
3342 int l1_count = 0, l2_count = 0;
3343
3344 l1 = org_l1;
3345 l2 = org_l2;
3346 tail = Qnil;
3347 value = Qnil;
3348 tortoises[0] = org_l1;
3349 tortoises[1] = org_l2;
3350
3351 /* It is sufficient to protect org_l1 and org_l2. When l1 and l2 are
3352 updated, we copy the new values back into the org_ vars. */
3353
3354 GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
3355 gcpro5.nvars = 2;
3356
3357 while (1)
3358 {
3359 if (NILP (l1))
3360 {
3361 UNGCPRO;
3362 if (NILP (tail))
3363 return l2;
3364 Fsetcdr (tail, l2);
3365 return value;
3366 }
3367 if (NILP (l2))
3368 {
3369 UNGCPRO;
3370 if (NILP (tail))
3371 return l1;
3372 Fsetcdr (tail, l1);
3373 return value;
3374 }
3375
3376 if (check_merge (predicate, key, Fcar (l2), Fcar (l1)) == 0)
3377 {
3378 tem = l1;
3379 l1 = Fcdr (l1);
3380 org_l1 = l1;
3381
3382 if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
3383 {
3384 if (l1_count & 1)
3385 {
3386 if (!CONSP (tortoises[0]))
3387 {
3388 mapping_interaction_error (Qmerge, tortoises[0]);
3389 }
3390
3391 tortoises[0] = XCDR (tortoises[0]);
3392 }
3393
3394 if (EQ (org_l1, tortoises[0]))
3395 {
3396 signal_circular_list_error (org_l1);
3397 }
3398 }
3399 }
3400 else
3401 {
3402 tem = l2;
3403 l2 = Fcdr (l2);
3404 org_l2 = l2;
3405
3406 if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
3407 {
3408 if (l2_count & 1)
3409 {
3410 if (!CONSP (tortoises[1]))
3411 {
3412 mapping_interaction_error (Qmerge, tortoises[1]);
3413 }
3414
3415 tortoises[1] = XCDR (tortoises[1]);
3416 }
3417
3418 if (EQ (org_l2, tortoises[1]))
3419 {
3420 signal_circular_list_error (org_l2);
3421 }
3422 }
3423 }
3424
3425 if (NILP (tail))
3426 value = tem;
3427 else
3428 Fsetcdr (tail, tem);
3429
3430 tail = tem;
3431 }
3432 }
3433
3434 static void
3435 array_merge (Lisp_Object *dest, Elemcount dest_len,
3436 Lisp_Object *front, Elemcount front_len,
3437 Lisp_Object *back, Elemcount back_len,
3438 check_test_func_t check_merge,
3439 Lisp_Object predicate, Lisp_Object key)
3440 {
3441 Elemcount ii, fronting, backing;
3442 Lisp_Object *front_staging = front;
3443 Lisp_Object *back_staging = back;
3444 struct gcpro gcpro1, gcpro2;
3445
3446 assert (dest_len == (back_len + front_len));
3447
3448 if (0 == dest_len)
3449 {
3450 return;
3451 }
3452
3453 if (front >= dest && front < (dest + dest_len))
3454 {
3455 front_staging = alloca_array (Lisp_Object, front_len);
3456
3457 for (ii = 0; ii < front_len; ++ii)
3458 {
3459 front_staging[ii] = front[ii];
3460 }
3461 }
3462
3463 if (back >= dest && back < (dest + dest_len))
3464 {
3465 back_staging = alloca_array (Lisp_Object, back_len);
3466
3467 for (ii = 0; ii < back_len; ++ii)
3468 {
3469 back_staging[ii] = back[ii];
3470 }
3471 }
3472
3473 GCPRO2 (front_staging[0], back_staging[0]);
3474 gcpro1.nvars = front_len;
3475 gcpro2.nvars = back_len;
3476
3477 for (ii = fronting = backing = 0; ii < dest_len; ++ii)
3478 {
3479 if (fronting >= front_len)
3480 {
3481 while (ii < dest_len)
3482 {
3483 dest[ii] = back_staging[backing];
3484 ++ii, ++backing;
3485 }
3486 UNGCPRO;
3487 return;
3488 }
3489
3490 if (backing >= back_len)
3491 {
3492 while (ii < dest_len)
3493 {
3494 dest[ii] = front_staging[fronting];
3495 ++ii, ++fronting;
3496 }
3497 UNGCPRO;
3498 return;
3499 }
3500
3501 if (check_merge (predicate, key, back_staging[backing],
3502 front_staging[fronting]) == 0)
3503 {
3504 dest[ii] = front_staging[fronting];
3505 ++fronting;
3506 }
3507 else
3508 {
3509 dest[ii] = back_staging[backing];
3510 ++backing;
3511 }
3512 }
3513
3514 UNGCPRO;
3515 }
3516
3517 static Lisp_Object
3518 list_array_merge_into_list (Lisp_Object list,
3519 Lisp_Object *array, Elemcount array_len,
3520 check_test_func_t check_merge,
3521 Lisp_Object predicate, Lisp_Object key,
3522 Boolint reverse_order)
3523 {
3524 Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
3525 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3526 Elemcount array_index = 0;
3527 int looped = 0;
3528
3529 GCPRO4 (list, tail, value, tortoise);
3530
3531 while (1)
3532 {
3533 if (NILP (list))
3534 {
3535 UNGCPRO;
3536
3537 if (NILP (tail))
3538 {
3539 return Flist (array_len, array);
3540 }
3541
3542 Fsetcdr (tail, Flist (array_len - array_index, array + array_index));
3543 return value;
3544 }
3545
3546 if (array_index >= array_len)
3547 {
3548 UNGCPRO;
3549 if (NILP (tail))
3550 {
3551 return list;
3552 }
3553
3554 Fsetcdr (tail, list);
3555 return value;
3556 }
3557
3558
3559 if (reverse_order ?
3560 check_merge (predicate, key, Fcar (list), array [array_index])
3561 : !check_merge (predicate, key, array [array_index], Fcar (list)))
3562 {
3563 if (NILP (tail))
3564 {
3565 value = tail = list;
3566 }
3567 else
3568 {
3569 Fsetcdr (tail, list);
3570 tail = XCDR (tail);
3571 }
3572
3573 list = Fcdr (list);
3574 }
3575 else
3576 {
3577 if (NILP (tail))
3578 {
3579 value = tail = Fcons (array [array_index], Qnil);
3580 }
3581 else
3582 {
3583 Fsetcdr (tail, Fcons (array [array_index], tail));
3584 tail = XCDR (tail);
3585 }
3586 ++array_index;
3587 }
3588
3589 if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
3590 {
3591 if (looped & 1)
3592 {
3593 tortoise = XCDR (tortoise);
3594 }
3595
3596 if (EQ (list, tortoise))
3597 {
3598 signal_circular_list_error (list);
3599 }
3600 }
3601 }
3602 }
3603
3604 static void
3605 list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
3606 Lisp_Object list_one, Lisp_Object list_two,
3607 check_test_func_t check_merge,
3608 Lisp_Object predicate, Lisp_Object key)
3609 {
3610 Elemcount output_index = 0;
3611
3612 while (output_index < output_len)
3613 {
3614 if (NILP (list_one))
3615 {
3616 while (output_index < output_len)
3617 {
3618 output [output_index] = Fcar (list_two);
3619 list_two = Fcdr (list_two), ++output_index;
3620 }
3621 return;
3622 }
3623
3624 if (NILP (list_two))
3625 {
3626 while (output_index < output_len)
3627 {
3628 output [output_index] = Fcar (list_one);
3629 list_one = Fcdr (list_one), ++output_index;
3630 }
3631 return;
3632 }
3633
3634 if (check_merge (predicate, key, Fcar (list_two), Fcar (list_one))
3635 == 0)
3636 {
3637 output [output_index] = XCAR (list_one);
3638 list_one = XCDR (list_one);
3639 }
3640 else
3641 {
3642 output [output_index] = XCAR (list_two);
3643 list_two = XCDR (list_two);
3644 }
3645
3646 ++output_index;
3647
3648 /* No need to check for circularity. */
3649 }
3650 }
3651
3652 static void
3653 list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
3654 Lisp_Object list,
3655 Lisp_Object *array, Elemcount array_len,
3656 check_test_func_t check_merge,
3657 Lisp_Object predicate, Lisp_Object key,
3658 Boolint reverse_order)
3659 {
3660 Elemcount output_index = 0, array_index = 0;
3661
3662 while (output_index < output_len)
3663 {
3664 if (NILP (list))
3665 {
3666 if (array_len - array_index != output_len - output_index)
3667 {
3668 mapping_interaction_error (Qmerge, list);
3669 }
3670
3671 while (array_index < array_len)
3672 {
3673 output [output_index++] = array [array_index++];
3674 }
3675
3676 return;
3677 }
3678
3679 if (array_index >= array_len)
3680 {
3681 while (output_index < output_len)
3682 {
3683 output [output_index++] = Fcar (list);
3684 list = Fcdr (list);
3685 }
3686
3687 return;
3688 }
3689
3690 if (reverse_order ?
3691 check_merge (predicate, key, Fcar (list), array [array_index]) :
3692 !check_merge (predicate, key, array [array_index], Fcar (list)))
3693 {
3694 output [output_index] = XCAR (list);
3695 list = XCDR (list);
3696 }
3697 else
3698 {
3699 output [output_index] = array [array_index];
3700 ++array_index;
3701 }
3702
3703 ++output_index;
3704 }
3705 }
3706
3707 #define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \
3708 do { \
3709 c_array = alloca_array (Lisp_Object, len); \
3710 for (counter = 0; counter < len; ++counter) \
3711 { \
3712 c_array[counter] = make_char (itext_ichar (strdata)); \
3713 INC_IBYTEPTR (strdata); \
3714 } \
3715 } while (0)
3716
3717 #define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \
3718 c_array = alloca_array (Lisp_Object, len); \
3719 for (counter = 0; counter < len; ++counter) \
3720 { \
3721 c_array[counter] = make_fixnum (bit_vector_bit (v, counter)); \
3722 } \
3723 } while (0)
3724
3725 DEFUN ("merge", Fmerge, 4, MANY, 0, /*
3726 Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence.
3727
3728 TYPE is the type of sequence to return. PREDICATE is a `less-than'
3729 predicate on the elements.
3730
3731 Optional keyword argument KEY is a function used to extract an object to be
3732 used for comparison from each element of SEQUENCE-ONE and SEQUENCE-TWO.
3733
3734 arguments: (TYPE SEQUENCE-ONE SEQUENCE-TWO PREDICATE &key (KEY #'IDENTITY))
3735 */
3736 (int nargs, Lisp_Object *args))
3737 {
3738 Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2],
3739 predicate = args[3], result = Qnil;
3740 check_test_func_t check_merge = NULL;
3741
3742 PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL);
3743
3744 CHECK_SEQUENCE (sequence_one);
3745 CHECK_SEQUENCE (sequence_two);
3746
3747 CHECK_KEY_ARGUMENT (key);
3748
3749 check_merge = get_merge_predicate (predicate, key);
3750
3751 if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two)))
3752 {
3753 if (NILP (sequence_two))
3754 {
3755 result = Fappend (2, args + 1);
3756 }
3757 else if (NILP (sequence_one))
3758 {
3759 args[3] = Qnil; /* Overwriting PREDICATE, and losing its GC
3760 protection, but that doesn't matter. */
3761 result = Fappend (2, args + 2);
3762 }
3763 else if (CONSP (sequence_one) && CONSP (sequence_two))
3764 {
3765 result = list_merge (sequence_one, sequence_two, check_merge,
3766 predicate, key);
3767 }
3768 else
3769 {
3770 Lisp_Object *array_storage, swap;
3771 Elemcount array_length, i;
3772 Boolint reverse_order = 0;
3773
3774 if (!CONSP (sequence_one))
3775 {
3776 /* Make sequence_one the cons, sequence_two the array: */
3777 swap = sequence_one;
3778 sequence_one = sequence_two;
3779 sequence_two = swap;
3780 reverse_order = 1;
3781 }
3782
3783 if (VECTORP (sequence_two))
3784 {
3785 array_storage = XVECTOR_DATA (sequence_two);
3786 array_length = XVECTOR_LENGTH (sequence_two);
3787 }
3788 else if (STRINGP (sequence_two))
3789 {
3790 Ibyte *strdata = XSTRING_DATA (sequence_two);
3791 array_length = string_char_length (sequence_two);
3792 /* No need to GCPRO, characters are immediate. */
3793 STRING_DATA_TO_OBJECT_ARRAY (strdata, array_storage, i,
3794 array_length);
3795
3796 }
3797 else
3798 {
3799 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence_two);
3800 array_length = bit_vector_length (v);
3801 /* No need to GCPRO, fixnums are immediate. */
3802 BIT_VECTOR_TO_OBJECT_ARRAY (v, array_storage, i, array_length);
3803 }
3804
3805 result = list_array_merge_into_list (sequence_one,
3806 array_storage, array_length,
3807 check_merge, predicate, key,
3808 reverse_order);
3809 }
3810 }
3811 else
3812 {
3813 Elemcount sequence_one_len = XFIXNUM (Flength (sequence_one)),
3814 sequence_two_len = XFIXNUM (Flength (sequence_two)), i;
3815 Elemcount output_len = 1 + sequence_one_len + sequence_two_len;
3816 Lisp_Object *output = alloca_array (Lisp_Object, output_len),
3817 *sequence_one_storage = NULL, *sequence_two_storage = NULL;
3818 Boolint do_coerce = !(EQ (type, Qvector) || EQ (type, Qstring)
3819 || EQ (type, Qbit_vector) || EQ (type, Qlist));
3820 Ibyte *strdata = NULL;
3821 Lisp_Bit_Vector *v = NULL;
3822 struct gcpro gcpro1;
3823
3824 output[0] = do_coerce ? Qlist : type;
3825 for (i = 1; i < output_len; ++i)
3826 {
3827 output[i] = Qnil;
3828 }
3829
3830 GCPRO1 (output[0]);
3831 gcpro1.nvars = output_len;
3832
3833 if (VECTORP (sequence_one))
3834 {
3835 sequence_one_storage = XVECTOR_DATA (sequence_one);
3836 }
3837 else if (STRINGP (sequence_one))
3838 {
3839 strdata = XSTRING_DATA (sequence_one);
3840 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_one_storage,
3841 i, sequence_one_len);
3842 }
3843 else if (BIT_VECTORP (sequence_one))
3844 {
3845 v = XBIT_VECTOR (sequence_one);
3846 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_one_storage,
3847 i, sequence_one_len);
3848 }
3849
3850 if (VECTORP (sequence_two))
3851 {
3852 sequence_two_storage = XVECTOR_DATA (sequence_two);
3853 }
3854 else if (STRINGP (sequence_two))
3855 {
3856 strdata = XSTRING_DATA (sequence_two);
3857 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_two_storage,
3858 i, sequence_two_len);
3859 }
3860 else if (BIT_VECTORP (sequence_two))
3861 {
3862 v = XBIT_VECTOR (sequence_two);
3863 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_two_storage,
3864 i, sequence_two_len);
3865 }
3866
3867 if (LISTP (sequence_one) && LISTP (sequence_two))
3868 {
3869 list_list_merge_into_array (output + 1, output_len - 1,
3870 sequence_one, sequence_two,
3871 check_merge, predicate, key);
3872 }
3873 else if (LISTP (sequence_one))
3874 {
3875 list_array_merge_into_array (output + 1, output_len - 1,
3876 sequence_one,
3877 sequence_two_storage,
3878 sequence_two_len,
3879 check_merge, predicate, key, 0);
3880 }
3881 else if (LISTP (sequence_two))
3882 {
3883 list_array_merge_into_array (output + 1, output_len - 1,
3884 sequence_two,
3885 sequence_one_storage,
3886 sequence_one_len,
3887 check_merge, predicate, key, 1);
3888 }
3889 else
3890 {
3891 array_merge (output + 1, output_len - 1,
3892 sequence_one_storage, sequence_one_len,
3893 sequence_two_storage, sequence_two_len,
3894 check_merge, predicate,
3895 key);
3896 }
3897
3898 result = Ffuncall (output_len, output);
3899
3900 if (do_coerce)
3901 {
3902 result = call2 (Qcoerce, result, type);
3903 }
3904
3905 UNGCPRO;
3906 }
3907
3908 return result;
3909 }
3910
3911 Lisp_Object
3912 list_sort (Lisp_Object list, check_test_func_t check_merge,
3913 Lisp_Object predicate, Lisp_Object key)
3914 {
3915 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3916 Lisp_Object back, tem;
3917 Lisp_Object front = list;
3918 Lisp_Object len = Flength (list);
3919
3920 if (XFIXNUM (len) < 2)
3921 return list;
3922
3923 len = make_fixnum (XFIXNUM (len) / 2 - 1);
3924 tem = Fnthcdr (len, list);
3925 back = Fcdr (tem);
3926 Fsetcdr (tem, Qnil);
3927
3928 GCPRO4 (front, back, predicate, key);
3929 front = list_sort (front, check_merge, predicate, key);
3930 back = list_sort (back, check_merge, predicate, key);
3931
3932 RETURN_UNGCPRO (list_merge (front, back, check_merge, predicate, key));
3933 }
3934
3935 static void
3936 array_sort (Lisp_Object *array, Elemcount array_len,
3937 check_test_func_t check_merge,
3938 Lisp_Object predicate, Lisp_Object key)
3939 {
3940 Elemcount split;
3941
3942 if (array_len < 2)
3943 return;
3944
3945 split = array_len / 2;
3946
3947 array_sort (array, split, check_merge, predicate, key);
3948 array_sort (array + split, array_len - split, check_merge, predicate,
3949 key);
3950 array_merge (array, array_len, array, split, array + split,
3951 array_len - split, check_merge, predicate, key);
3952 }
3953
3954 DEFUN ("sort*", FsortX, 2, MANY, 0, /*
3955 Sort SEQUENCE, comparing elements using PREDICATE.
3956 Returns the sorted sequence. SEQUENCE is modified by side effect.
3957
3958 PREDICATE is called with two elements of SEQUENCE, and should return t if
3959 the first element is `less' than the second.
3960
3961 Optional keyword argument KEY is a function used to extract an object to be
3962 used for comparison from each element of SEQUENCE.
3963
3964 In this implementation, sorting is always stable; but call `stable-sort' if
3965 this stability is important to you, other implementations may not make the
3966 same guarantees.
3967
3968 arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))
3969 */
3970 (int nargs, Lisp_Object *args))
3971 {
3972 Lisp_Object sequence = args[0], predicate = args[1];
3973 Lisp_Object *sequence_carray;
3974 check_test_func_t check_merge = NULL;
3975 Elemcount sequence_len, i;
3976
3977 PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL);
3978
3979 CHECK_SEQUENCE (sequence);
3980
3981 CHECK_KEY_ARGUMENT (key);
3982
3983 check_merge = get_merge_predicate (predicate, key);
3984
3985 if (LISTP (sequence))
3986 {
3987 sequence = list_sort (sequence, check_merge, predicate, key);
3988 }
3989 else if (VECTORP (sequence))
3990 {
3991 array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence),
3992 check_merge, predicate, key);
3993 }
3994 else if (STRINGP (sequence))
3995 {
3996 Ibyte *strdata = XSTRING_DATA (sequence);
3997
3998 sequence_len = string_char_length (sequence);
3999
4000 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len);
4001
4002 /* No GCPRO necessary, characters are immediate. */
4003 array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
4004
4005 strdata = XSTRING_DATA (sequence);
4006
4007 CHECK_LISP_WRITEABLE (sequence);
4008 for (i = 0; i < sequence_len; ++i)
4009 {
4010 strdata += set_itext_ichar (strdata, XCHAR (sequence_carray[i]));
4011 }
4012
4013 init_string_ascii_begin (sequence);
4014 bump_string_modiff (sequence);
4015 sledgehammer_check_ascii_begin (sequence);
4016 }
4017 else if (BIT_VECTORP (sequence))
4018 {
4019 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
4020 sequence_len = bit_vector_length (v);
4021
4022 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len);
4023
4024 /* No GCPRO necessary, bits are immediate. */
4025 array_sort (sequence_carray, sequence_len, check_merge, predicate, key);
4026
4027 for (i = 0; i < sequence_len; ++i)
4028 {
4029 set_bit_vector_bit (v, i, XFIXNUM (sequence_carray [i]));
4030 }
4031 }
4032
4033 return sequence;
4034 }
4035
4036
4037 static Lisp_Object replace_string_range_1 (Lisp_Object dest,
4038 Lisp_Object start,
4039 Lisp_Object end,
4040 const Ibyte *source,
4041 const Ibyte *source_limit,
4042 Lisp_Object item);
4043
4044 /* Fill the substring of DEST beginning at START and ending before END with
4045 the character ITEM. If DEST does not have sufficient space for END -
4046 START characters at START, write as many as is possible without changing
4047 the character length of DEST. Update the string modification flag and do
4048 any sledgehammer checks we have turned on.
4049
4050 START must be a Lisp integer. END can be nil, indicating the length of the
4051 string, or a Lisp integer. The condition (<= 0 START END (length DEST))
4052 must hold, or fill_string_range() will signal an error. */
4053 static Lisp_Object
4054 fill_string_range (Lisp_Object dest, Lisp_Object item, Lisp_Object start,
4055 Lisp_Object end)
4056 {
4057 return replace_string_range_1 (dest, start, end, NULL, NULL, item);
4058 }
4059
4060 DEFUN ("fill", Ffill, 2, MANY, 0, /*
4061 Destructively modify SEQUENCE by replacing each element with ITEM.
4062 SEQUENCE is a list, vector, bit vector, or string.
4063
4064 Optional keyword START is the index of the first element of SEQUENCE
4065 to be modified, and defaults to zero. Optional keyword END is the
4066 exclusive upper bound on the elements of SEQUENCE to be modified, and
4067 defaults to the length of SEQUENCE.
4068
4069 arguments: (SEQUENCE ITEM &key (START 0) (END (length SEQUENCE)))
4070 */
4071 (int nargs, Lisp_Object *args))
4072 {
4073 Lisp_Object sequence = args[0];
4074 Lisp_Object item = args[1];
4075 Elemcount starting, ending = MOST_POSITIVE_FIXNUM + 1, ii, len;
4076
4077 PARSE_KEYWORDS (Ffill, nargs, args, 2, (start, end), (start = Qzero));
4078
4079 CHECK_NATNUM (start);
4080 starting = BIGNUMP (start) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start);
4081
4082 if (!NILP (end))
4083 {
4084 CHECK_NATNUM (end);
4085 ending = BIGNUMP (end) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end);
4086 }
4087
4088 retry:
4089 if (STRINGP (sequence))
4090 {
4091 CHECK_CHAR_COERCE_INT (item);
4092 CHECK_LISP_WRITEABLE (sequence);
4093
4094 fill_string_range (sequence, item, start, end);
4095 }
4096 else if (VECTORP (sequence))
4097 {
4098 Lisp_Object *p = XVECTOR_DATA (sequence);
4099
4100 CHECK_LISP_WRITEABLE (sequence);
4101 len = XVECTOR_LENGTH (sequence);
4102
4103 check_sequence_range (sequence, start, end, make_fixnum (len));
4104 ending = min (ending, len);
4105
4106 for (ii = starting; ii < ending; ++ii)
4107 {
4108 p[ii] = item;
4109 }
4110 }
4111 else if (BIT_VECTORP (sequence))
4112 {
4113 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
4114 int bit;
4115
4116 CHECK_BIT (item);
4117 bit = XFIXNUM (item);
4118 CHECK_LISP_WRITEABLE (sequence);
4119 len = bit_vector_length (v);
4120
4121 check_sequence_range (sequence, start, end, make_fixnum (len));
4122 ending = min (ending, len);
4123
4124 for (ii = starting; ii < ending; ++ii)
4125 {
4126 set_bit_vector_bit (v, ii, bit);
4127 }
4128 }
4129 else if (LISTP (sequence))
4130 {
4131 Elemcount counting = 0;
4132
4133 {
4134 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
4135 {
4136 if (counting >= starting)
4137 {
4138 if (counting < ending)
4139 {
4140 XSETCAR (tail, item);
4141 }
4142 else if (counting == ending)
4143 {
4144 break;
4145 }
4146 }
4147 ++counting;
4148 }
4149 }
4150
4151 if (counting < starting || (counting != ending && !NILP (end)))
4152 {
4153 check_sequence_range (args[0], start, end, Flength (args[0]));
4154 }
4155 }
4156 else
4157 {
4158 sequence = wrong_type_argument (Qsequencep, sequence);
4159 goto retry;
4160 }
4161 return sequence;
4162 }
4163
4164
4165 /* Replace the substring of DEST beginning at START and ending before END
4166 with the text at SOURCE, which is END - START characters long and
4167 SOURCE_LIMIT - SOURCE octets long. If DEST does not have sufficient
4168 space for END - START characters at START, write as many as is possible
4169 without changing the length of DEST. Update the string modification flag
4170 and do any sledgehammer checks we have turned on in this build.
4171
4172 START must be a Lisp integer. END can be nil, indicating the length of the
4173 string, or a Lisp integer. The condition (<= 0 START END (length DEST))
4174 must hold, or replace_string_range() will signal an error. */
4175 static Lisp_Object
4176 replace_string_range (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
4177 const Ibyte *source, const Ibyte *source_limit)
4178 {
4179 return replace_string_range_1 (dest, start, end, source, source_limit,
4180 Qnil);
4181 }
4182
4183 /* This is the guts of several mapping functions.
4184
4185 Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time,
4186 taking the elements from SEQUENCES. If VALS is non-NULL, store the
4187 results into VALS, a C array of Lisp_Objects; else, if LISP_VALS is
4188 non-nil, store the results into LISP_VALS, a sequence with sufficient
4189 room for CALL_COUNT results (but see the documentation of SOME_OR_EVERY.)
4190 Else, do not accumulate any result.
4191
4192 If VALS is non-NULL, NSEQUENCES is one, and SEQUENCES[0] is a cons,
4193 mapcarX will store the elements of SEQUENCES[0] in stack and GCPRO them,
4194 so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off
4195 mapcarX.
4196
4197 Otherwise, mapcarX signals an invalid state error (see
4198 mapping_interaction_error(), above) if it encounters a non-cons,
4199 non-array when traversing SEQUENCES. Common Lisp specifies in
4200 MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION
4201 destructively modifies SEQUENCES in a way that might affect the ongoing
4202 traversal operation.
4203
4204 CALLER is a symbol describing the Lisp-visible function that was called,
4205 and any errors thrown because SEQUENCES was modified will reflect it.
4206
4207 If CALLER is Qsome, return the (possibly multiple) values given by
4208 FUNCTION the first time it is non-nil, and abandon the iterations.
4209 LISP_VALS must be the result of calling STORE_VOID_IN_LISP on the address
4210 of a Lisp object, and the return value will be stored at that address.
4211 If CALLER is Qevery, LISP_VALS must also reflect a pointer to a Lisp
4212 object, and Qnil will be stored at that address if FUNCTION gives nil;
4213 otherwise it will be left alone. */
4214
4215 static void
4216 mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals,
4217 Lisp_Object function, int nsequences, Lisp_Object *sequences,
4218 Lisp_Object caller)
4219 {
4220 Lisp_Object called, *args;
4221 struct gcpro gcpro1, gcpro2;
4222 Ibyte *lisp_vals_staging = NULL, *cursor = NULL;
4223 int i, j;
4224
4225 assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1);
4226
4227 args = alloca_array (Lisp_Object, nsequences + 1);
4228 args[0] = function;
4229 for (i = 1; i <= nsequences; ++i)
4230 {
4231 args[i] = Qnil;
4232 }
4233
4234 if (vals != NULL)
4235 {
4236 GCPRO2 (args[0], vals[0]);
4237 gcpro1.nvars = nsequences + 1;
4238 gcpro2.nvars = 0;
4239 }
4240 else
4241 {
4242 GCPRO1 (args[0]);
4243 gcpro1.nvars = nsequences + 1;
4244 }
4245
4246 /* Be extra nice in the event that we've been handed one list and one
4247 only; make it possible for FUNCTION to set cdrs not yet processed to
4248 non-cons, non-nil objects without ill-effect, if we have been handed
4249 the stack space to do that. */
4250 if (vals != NULL && 1 == nsequences && CONSP (sequences[0]))
4251 {
4252 Lisp_Object lst = sequences[0];
4253 Lisp_Object *val = vals;
4254 for (i = 0; i < call_count; ++i)
4255 {
4256 *val++ = XCAR (lst);
4257 lst = XCDR (lst);
4258 }
4259 gcpro2.nvars = call_count;
4260
4261 for (i = 0; i < call_count; ++i)
4262 {
4263 args[1] = vals[i];
4264 vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args));
4265 }
4266 }
4267 else
4268 {
4269 enum lrecord_type lisp_vals_type = lrecord_type_symbol;
4270 Binbyte *sequence_types = alloca_array (Binbyte, nsequences);
4271 for (j = 0; j < nsequences; ++j)
4272 {
4273 sequence_types[j] = XRECORD_LHEADER (sequences[j])->type;
4274 }
4275
4276 if (!EQ (caller, Qsome) && !EQ (caller, Qevery))
4277 {
4278 assert (LRECORDP (lisp_vals));
4279
4280 lisp_vals_type
4281 = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
4282
4283 if (lrecord_type_string == lisp_vals_type)
4284 {
4285 lisp_vals_staging = cursor
4286 = alloca_ibytes (call_count * MAX_ICHAR_LEN);
4287 }
4288 else if (ARRAYP (lisp_vals))
4289 {
4290 CHECK_LISP_WRITEABLE (lisp_vals);
4291 }
4292 }
4293
4294 for (i = 0; i < call_count; ++i)
4295 {
4296 for (j = 0; j < nsequences; ++j)
4297 {
4298 switch (sequence_types[j])
4299 {
4300 case lrecord_type_cons:
4301 {
4302 if (!CONSP (sequences[j]))
4303 {
4304 /* This means FUNCTION has messed around with a cons
4305 in one of the sequences, since we checked the
4306 type (CHECK_SEQUENCE()) and the length and
4307 structure (with Flength()) correctly in our
4308 callers. */
4309 mapping_interaction_error (caller, sequences[j]);
4310 }
4311 args[j + 1] = XCAR (sequences[j]);
4312 sequences[j] = XCDR (sequences[j]);
4313 break;
4314 }
4315 case lrecord_type_vector:
4316 {
4317 args[j + 1] = XVECTOR_DATA (sequences[j])[i];
4318 break;
4319 }
4320 case lrecord_type_string:
4321 {
4322 args[j + 1] = make_char (string_ichar (sequences[j], i));
4323 break;
4324 }
4325 case lrecord_type_bit_vector:
4326 {
4327 args[j + 1]
4328 = make_fixnum (bit_vector_bit (XBIT_VECTOR (sequences[j]),
4329 i));
4330 break;
4331 }
4332 default:
4333 ABORT();
4334 }
4335 }
4336 called = Ffuncall (nsequences + 1, args);
4337 if (vals != NULL)
4338 {
4339 vals[i] = IGNORE_MULTIPLE_VALUES (called);
4340 gcpro2.nvars += 1;
4341 }
4342 else if (EQ (Qsome, caller))
4343 {
4344 if (!NILP (IGNORE_MULTIPLE_VALUES (called)))
4345 {
4346 Lisp_Object *result
4347 = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals);
4348 *result = called;
4349 UNGCPRO;
4350 return;
4351 }
4352 }
4353 else if (EQ (Qevery, caller))
4354 {
4355 if (NILP (IGNORE_MULTIPLE_VALUES (called)))
4356 {
4357 Lisp_Object *result
4358 = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals);
4359 *result = Qnil;
4360 UNGCPRO;
4361 return;
4362 }
4363 }
4364 else
4365 {
4366 called = IGNORE_MULTIPLE_VALUES (called);
4367 switch (lisp_vals_type)
4368 {
4369 case lrecord_type_symbol:
4370 /* Discard the result of funcall. */
4371 break;
4372 case lrecord_type_cons:
4373 {
4374 if (!CONSP (lisp_vals))
4375 {
4376 /* If FUNCTION has inserted a non-cons non-nil
4377 cdr into the list before we've processed the
4378 relevant part, error. */
4379 mapping_interaction_error (caller, lisp_vals);
4380 }
4381 XSETCAR (lisp_vals, called);
4382 lisp_vals = XCDR (lisp_vals);
4383 break;
4384 }
4385 case lrecord_type_vector:
4386 {
4387 i < XVECTOR_LENGTH (lisp_vals) ?
4388 (XVECTOR_DATA (lisp_vals)[i] = called) :
4389 /* Let #'aset error. */
4390 Faset (lisp_vals, make_fixnum (i), called);
4391 break;
4392 }
4393 case lrecord_type_string:
4394 {
4395 CHECK_CHAR_COERCE_INT (called);
4396 cursor += set_itext_ichar (cursor, XCHAR (called));
4397 break;
4398 }
4399 case lrecord_type_bit_vector:
4400 {
4401 (BITP (called) &&
4402 i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ?
4403 set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i,
4404 XFIXNUM (called)) :
4405 (void) Faset (lisp_vals, make_fixnum (i), called);
4406 break;
4407 }
4408 default:
4409 {
4410 ABORT();
4411 break;
4412 }
4413 }
4414 }
4415 }
4416
4417 if (lisp_vals_staging != NULL)
4418 {
4419 CHECK_LISP_WRITEABLE (lisp_vals);
4420 replace_string_range (lisp_vals, Qzero, make_fixnum (call_count),
4421 lisp_vals_staging, cursor);
4422 }
4423 }
4424
4425 UNGCPRO;
4426 }
4427
4428 /* Given NSEQUENCES objects at the address pointed to by SEQUENCES, return
4429 the length of the shortest sequence. Error if all are circular, or if any
4430 one of them is not a sequence. */
4431 static Elemcount
4432 shortest_length_among_sequences (int nsequences, Lisp_Object *sequences)
4433 {
4434 Elemcount len = 1 + MOST_POSITIVE_FIXNUM;
4435 Lisp_Object length = Qnil;
4436 int i;
4437
4438 for (i = 0; i < nsequences; ++i)
4439 {
4440 if (CONSP (sequences[i]))
4441 {
4442 length = Flist_length (sequences[i]);
4443 if (!NILP (length))
4444 {
4445 len = min (len, XFIXNUM (length));
4446 }
4447 }
4448 else
4449 {
4450 CHECK_SEQUENCE (sequences[i]);
4451 length = Flength (sequences[i]);
4452 len = min (len, XFIXNUM (length));
4453 }
4454 }
4455
4456 if (len == 1 + MOST_POSITIVE_FIXNUM)
4457 {
4458 signal_circular_list_error (sequences[0]);
4459 }
4460
4461 return len;
4462 }
4463
4464 DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /*
4465 Call FUNCTION on each element of SEQUENCE, and concat results to a string.
4466 Between each pair of results, insert SEPARATOR.
4467
4468 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
4469 results in spaces between the values returned by FUNCTION. SEQUENCE itself
4470 may be a list, a vector, a bit vector, or a string.
4471
4472 With optional SEQUENCES, call FUNCTION each time with as many arguments as
4473 there are SEQUENCES, plus one for the element from SEQUENCE. One element
4474 from each sequence will be used each time FUNCTION is called, and
4475 `mapconcat' will give up once the shortest sequence is exhausted.
4476
4477 arguments: (FUNCTION SEQUENCE SEPARATOR &rest SEQUENCES)
4478 */
4479 (int nargs, Lisp_Object *args))
4480 {
4481 Lisp_Object function = args[0];
4482 Lisp_Object sequence = args[1];
4483 Lisp_Object separator = args[2];
4484 Elemcount len = MOST_POSITIVE_FIXNUM;
4485 Lisp_Object *args0;
4486 EMACS_INT i, nargs0;
4487
4488 args[2] = sequence;
4489 args[1] = separator;
4490
4491 len = shortest_length_among_sequences (nargs - 2, args + 2);
4492
4493 if (len == 0) return build_ascstring ("");
4494
4495 nargs0 = len + len - 1;
4496 args0 = alloca_array (Lisp_Object, nargs0);
4497
4498 /* Special-case this, it's very common and doesn't require any
4499 funcalls. Upside of doing it here, instead of cl-macs.el: no consing,
4500 apart from the final string, we allocate everything on the stack. */
4501 if (EQ (function, Qidentity) && 3 == nargs && CONSP (sequence))
4502 {
4503 for (i = 0; i < len; ++i)
4504 {
4505 args0[i] = XCAR (sequence);
4506 sequence = XCDR (sequence);
4507 }
4508 }
4509 else
4510 {
4511 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmapconcat);
4512 }
4513
4514 for (i = len - 1; i >= 0; i--)
4515 args0[i + i] = args0[i];
4516
4517 for (i = 1; i < nargs0; i += 2)
4518 args0[i] = separator;
4519
4520 return Fconcat (nargs0, args0);
4521 }
4522
4523 DEFUN ("mapcar*", FmapcarX, 2, MANY, 0, /*
4524 Call FUNCTION on each element of SEQUENCE; return a list of the results.
4525 The result is a list of the same length as SEQUENCE.
4526 SEQUENCE may be a list, a vector, a bit vector, or a string.
4527
4528 With optional SEQUENCES, call FUNCTION each time with as many arguments as
4529 there are SEQUENCES, plus one for the element from SEQUENCE. One element
4530 from each sequence will be used each time FUNCTION is called, and `mapcar'
4531 stops calling FUNCTION once the shortest sequence is exhausted.
4532
4533 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4534 */
4535 (int nargs, Lisp_Object *args))
4536 {
4537 Lisp_Object function = args[0];
4538 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4539 Lisp_Object *args0;
4540
4541 args0 = alloca_array (Lisp_Object, len);
4542 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX);
4543
4544 return Flist ((int) len, args0);
4545 }
4546
4547 DEFUN ("mapvector", Fmapvector, 2, MANY, 0, /*
4548 Call FUNCTION on each element of SEQUENCE; return a vector of the results.
4549 The result is a vector of the same length as SEQUENCE.
4550 SEQUENCE may be a list, a vector, a bit vector, or a string.
4551
4552 With optional SEQUENCES, call FUNCTION each time with as many arguments as
4553 there are SEQUENCES, plus one for the element from SEQUENCE. One element
4554 from each sequence will be used each time FUNCTION is called, and
4555 `mapvector' stops calling FUNCTION once the shortest sequence is exhausted.
4556
4557 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4558 */
4559 (int nargs, Lisp_Object *args))
4560 {
4561 Lisp_Object function = args[0];
4562 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4563 Lisp_Object result = make_vector (len, Qnil);
4564
4565 struct gcpro gcpro1;
4566 GCPRO1 (result);
4567 /* Don't pass result as the lisp_object argument, we want mapcarX to protect
4568 a single list argument's elements from being garbage-collected. */
4569 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1,
4570 Qmapvector);
4571 RETURN_UNGCPRO (result);
4572 }
4573
4574 DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /*
4575 Call FUNCTION on each element of SEQUENCE; chain the results together.
4576
4577 FUNCTION must normally return a list; the results will be concatenated
4578 together using `nconc'.
4579
4580 With optional SEQUENCES, call FUNCTION each time with as many arguments as
4581 there are SEQUENCES, plus one for the element from SEQUENCE. One element
4582 from each sequence will be used each time FUNCTION is called, and
4583 `mapcan' stops calling FUNCTION once the shortest sequence is exhausted.
4584
4585 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4586 */
4587 (int nargs, Lisp_Object *args))
4588 {
4589 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4590 Lisp_Object function = args[0], *result = alloca_array (Lisp_Object, len);
4591
4592 mapcarX (len, result, Qnil, function, nargs - 1, args + 1, Qmapcan);
4593
4594 /* #'nconc GCPROs its args in case of signals and error. */
4595 return Fnconc (len, result);
4596 }
4597
4598 DEFUN ("mapc", Fmapc, 2, MANY, 0, /*
4599 Call FUNCTION on each element of SEQUENCE.
4600
4601 SEQUENCE may be a list, a vector, a bit vector, or a string.
4602 This function is like `mapcar' but does not accumulate the results,
4603 which is more efficient if you do not use the results.
4604
4605 With optional SEQUENCES, call FUNCTION each time with as many arguments as
4606 there are SEQUENCES, plus one for the elements from SEQUENCE. One element
4607 from each sequence will be used each time FUNCTION is called, and
4608 `mapc' stops calling FUNCTION once the shortest sequence is exhausted.
4609
4610 Return SEQUENCE.
4611
4612 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4613 */
4614 (int nargs, Lisp_Object *args))
4615 {
4616 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4617 Lisp_Object sequence = args[1];
4618 struct gcpro gcpro1;
4619 /* We need to GCPRO sequence, because mapcarX will modify the
4620 elements of the args array handed to it, and this may involve
4621 elements of sequence getting garbage collected. */
4622 GCPRO1 (sequence);
4623 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc);
4624 RETURN_UNGCPRO (sequence);
4625 }
4626
4627 DEFUN ("map", Fmap, 3, MANY, 0, /*
4628 Map FUNCTION across one or more sequences, returning a sequence.
4629
4630 TYPE is the sequence type to return, FUNCTION is the function, SEQUENCE is
4631 the first argument sequence, SEQUENCES are the other argument sequences.
4632
4633 FUNCTION will be called with (1+ (length SEQUENCES)) arguments, and must be
4634 capable of accepting this number of arguments.
4635
4636 Certain TYPEs are recognised internally by `map', but others are not, and
4637 `coerce' may throw an error on an attempt to convert to a TYPE it does not
4638 understand. A null TYPE means do not accumulate any values.
4639
4640 arguments: (TYPE FUNCTION SEQUENCE &rest SEQUENCES)
4641 */
4642 (int nargs, Lisp_Object *args))
4643 {
4644 Lisp_Object type = args[0];
4645 Lisp_Object function = args[1];
4646 Lisp_Object result = Qnil;
4647 Lisp_Object *args0 = NULL;
4648 Elemcount len = shortest_length_among_sequences (nargs - 2, args + 2);
4649 struct gcpro gcpro1;
4650
4651 if (!NILP (type))
4652 {
4653 args0 = alloca_array (Lisp_Object, len);
4654 }
4655
4656 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmap);
4657
4658 if (EQ (type, Qnil))
4659 {
4660 return result;
4661 }
4662
4663 if (EQ (type, Qvector) || EQ (type, Qarray))
4664 {
4665 result = Fvector (len, args0);
4666 }
4667 else if (EQ (type, Qstring))
4668 {
4669 result = Fstring (len, args0);
4670 }
4671 else if (EQ (type, Qlist))
4672 {
4673 result = Flist (len, args0);
4674 }
4675 else if (EQ (type, Qbit_vector))
4676 {
4677 result = Fbit_vector (len, args0);
4678 }
4679 else
4680 {
4681 result = Flist (len, args0);
4682 GCPRO1 (result);
4683 result = call2 (Qcoerce, result, type);
4684 UNGCPRO;
4685 }
4686
4687 return result;
4688 }
4689
4690 DEFUN ("map-into", Fmap_into, 2, MANY, 0, /*
4691 Modify RESULT-SEQUENCE using the return values of FUNCTION on SEQUENCES.
4692
4693 RESULT-SEQUENCE and SEQUENCES can be lists or arrays.
4694
4695 FUNCTION must accept at least as many arguments as there are SEQUENCES
4696 \(possibly zero). If RESULT-SEQUENCE and the elements of SEQUENCES are not
4697 the same length, stop when the shortest is exhausted; any elements of
4698 RESULT-SEQUENCE beyond that are unmodified.
4699
4700 Return RESULT-SEQUENCE.
4701
4702 arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES)
4703 */
4704 (int nargs, Lisp_Object *args))
4705 {
4706 Elemcount len;
4707 Lisp_Object result_sequence = args[0];
4708 Lisp_Object function = args[1];
4709
4710 args[0] = function;
4711 args[1] = result_sequence;
4712
4713 len = shortest_length_among_sequences (nargs - 1, args + 1);
4714
4715 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
4716 Qmap_into);
4717
4718 return result_sequence;
4719 }
4720
4721 DEFUN ("some", Fsome, 2, MANY, 0, /*
4722 Return true if PREDICATE gives non-nil for an element of SEQUENCE.
4723
4724 If so, return the value (possibly multiple) given by PREDICATE.
4725
4726 With optional SEQUENCES, call PREDICATE each time with as many arguments as
4727 there are SEQUENCES (plus one for the element from SEQUENCE).
4728
4729 See also `find-if', which returns the corresponding element of SEQUENCE,
4730 rather than the value given by PREDICATE, and accepts bounding index
4731 keywords.
4732
4733 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
4734 */
4735 (int nargs, Lisp_Object *args))
4736 {
4737 Lisp_Object result = Qnil,
4738 result_ptr = STORE_VOID_IN_LISP ((void *) &result);
4739 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4740
4741 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome);
4742
4743 return result;
4744 }
4745
4746 DEFUN ("every", Fevery, 2, MANY, 0, /*
4747 Return true if PREDICATE is true of every element of SEQUENCE.
4748
4749 With optional SEQUENCES, call PREDICATE each time with as many arguments as
4750 there are SEQUENCES (plus one for the element from SEQUENCE).
4751
4752 In contrast to `some', `every' never returns multiple values.
4753
4754 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
4755 */
4756 (int nargs, Lisp_Object *args))
4757 {
4758 Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result);
4759 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4760
4761 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery);
4762
4763 return result;
4764 }
4765
4766
4767 DEFUN ("reduce", Freduce, 2, MANY, 0, /*
4768 Combine the elements of SEQUENCE using FUNCTION, a binary operation.
4769
4770 For example, `(reduce #'+ SEQUENCE)' returns the sum of all elements in
4771 SEQUENCE, and `(reduce #'union SEQUENCE)' returns the union of all elements
4772 in SEQUENCE.
4773
4774 Keywords supported: :start :end :from-end :initial-value :key
4775 See `remove*' for the meaning of :start, :end, :from-end and :key.
4776
4777 :initial-value specifies an element (typically an identity element, such as
4778 0) that is conceptually prepended to the sequence (or appended, when
4779 :from-end is given).
4780
4781 If the sequence has one element, that element is returned directly.
4782 If the sequence has no elements, :initial-value is returned if given;
4783 otherwise, FUNCTION is called with no arguments, and its result returned.
4784
4785 arguments: (FUNCTION SEQUENCE &key (START 0) (END (length SEQUENCE)) FROM-END INITIAL-VALUE (KEY #'identity))
4786 */
4787 (int nargs, Lisp_Object *args))
4788 {
4789 Lisp_Object function = args[0], sequence = args[1], accum = Qunbound;
4790 Elemcount starting, ending = MOST_POSITIVE_FIXNUM + 1, ii = 0;
4791
4792 PARSE_KEYWORDS (Freduce, nargs, args, 5,
4793 (start, end, from_end, initial_value, key),
4794 (start = Qzero, initial_value = Qunbound));
4795
4796 CHECK_SEQUENCE (sequence);
4797 CHECK_NATNUM (start);
4798 starting = BIGNUMP (start) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start);
4799 CHECK_KEY_ARGUMENT (key);
4800
4801 #define KEY(key, item) (EQ (Qidentity, key) ? item : \
4802 IGNORE_MULTIPLE_VALUES (call1 (key, item)))
4803 #define CALL2(function, accum, item) \
4804 IGNORE_MULTIPLE_VALUES (call2 (function, accum, item))
4805
4806 if (!NILP (end))
4807 {
4808 CHECK_NATNUM (end);
4809 ending = BIGNUMP (end) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end);
4810 }
4811
4812 if (VECTORP (sequence))
4813 {
4814 Lisp_Vector *vv = XVECTOR (sequence);
4815 struct gcpro gcpro1;
4816
4817 check_sequence_range (sequence, start, end, make_fixnum (vv->size));
4818
4819 ending = min (ending, vv->size);
4820
4821 GCPRO1 (accum);
4822
4823 if (!UNBOUNDP (initial_value))
4824 {
4825 accum = initial_value;
4826 }
4827 else if (ending - starting)
4828 {
4829 if (NILP (from_end))
4830 {
4831 accum = KEY (key, vv->contents[starting]);
4832 starting++;
4833 }
4834 else
4835 {
4836 accum = KEY (key, vv->contents[ending - 1]);
4837 ending--;
4838 }
4839 }
4840
4841 if (NILP (from_end))
4842 {
4843 for (ii = starting; ii < ending; ++ii)
4844 {
4845 accum = CALL2 (function, accum, KEY (key, vv->contents[ii]));
4846 }
4847 }
4848 else
4849 {
4850 for (ii = ending - 1; ii >= starting; --ii)
4851 {
4852 accum = CALL2 (function, KEY (key, vv->contents[ii]), accum);
4853 }
4854 }
4855
4856 UNGCPRO;
4857 }
4858 else if (BIT_VECTORP (sequence))
4859 {
4860 Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
4861 struct gcpro gcpro1;
4862
4863 check_sequence_range (sequence, start, end, make_fixnum (bv->size));
4864 ending = min (ending, bv->size);
4865
4866 GCPRO1 (accum);
4867
4868 if (!UNBOUNDP (initial_value))
4869 {
4870 accum = initial_value;
4871 }
4872 else if (ending - starting)
4873 {
4874 if (NILP (from_end))
4875 {
4876 accum = KEY (key, make_fixnum (bit_vector_bit (bv, starting)));
4877 starting++;
4878 }
4879 else
4880 {
4881 accum = KEY (key, make_fixnum (bit_vector_bit (bv, ending - 1)));
4882 ending--;
4883 }
4884 }
4885
4886 if (NILP (from_end))
4887 {
4888 for (ii = starting; ii < ending; ++ii)
4889 {
4890 accum = CALL2 (function, accum,
4891 KEY (key, make_fixnum (bit_vector_bit (bv, ii))));
4892 }
4893 }
4894 else
4895 {
4896 for (ii = ending - 1; ii >= starting; --ii)
4897 {
4898 accum = CALL2 (function, KEY (key,
4899 make_fixnum (bit_vector_bit (bv,
4900 ii))),
4901 accum);
4902 }
4903 }
4904
4905 UNGCPRO;
4906
4907 }
4908 else if (STRINGP (sequence))
4909 {
4910 struct gcpro gcpro1;
4911
4912 GCPRO1 (accum);
4913
4914 if (NILP (from_end))
4915 {
4916 Bytecount byte_len = XSTRING_LENGTH (sequence);
4917 Bytecount cursor_offset = 0;
4918 const Ibyte *startp = XSTRING_DATA (sequence);
4919 const Ibyte *cursor = startp;
4920
4921 for (ii = 0; ii != starting && cursor_offset < byte_len; ++ii)
4922 {
4923 INC_IBYTEPTR (cursor);
4924 cursor_offset = cursor - startp;
4925 }
4926
4927 if (!UNBOUNDP (initial_value))
4928 {
4929 accum = initial_value;
4930 }
4931 else if (ending - starting && cursor_offset < byte_len)
4932 {
4933 accum = KEY (key, make_char (itext_ichar (cursor)));
4934 starting++;
4935 startp = XSTRING_DATA (sequence);
4936 cursor = startp + cursor_offset;
4937
4938 if (byte_len != XSTRING_LENGTH (sequence)
4939 || !valid_ibyteptr_p (cursor))
4940 {
4941 mapping_interaction_error (Qreduce, sequence);
4942 }
4943
4944 INC_IBYTEPTR (cursor);
4945 cursor_offset = cursor - startp;
4946 ii++;
4947 }
4948
4949 while (cursor_offset < byte_len && ii < ending)
4950 {
4951 accum = CALL2 (function, accum,
4952 KEY (key, make_char (itext_ichar (cursor))));
4953
4954 startp = XSTRING_DATA (sequence);
4955 cursor = startp + cursor_offset;
4956
4957 if (byte_len != XSTRING_LENGTH (sequence)
4958 || !valid_ibyteptr_p (cursor))
4959 {
4960 mapping_interaction_error (Qreduce, sequence);
4961 }
4962
4963 INC_IBYTEPTR (cursor);
4964 cursor_offset = cursor - startp;
4965 ++ii;
4966 }
4967
4968 if (ii < starting || (ii < ending && !NILP (end)))
4969 {
4970 check_sequence_range (sequence, start, end, Flength (sequence));
4971 }
4972 }
4973 else
4974 {
4975 Elemcount len = string_char_length (sequence);
4976 Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence);
4977 const Ibyte *cursor;
4978
4979 check_sequence_range (sequence, start, end, make_fixnum (len));
4980 ending = min (ending, len);
4981 starting = XFIXNUM (start);
4982
4983 cursor = string_char_addr (sequence, ending - 1);
4984 cursor_offset = cursor - XSTRING_DATA (sequence);
4985
4986 if (!UNBOUNDP (initial_value))
4987 {
4988 accum = initial_value;
4989 }
4990 else if (ending - starting)
4991 {
4992 accum = KEY (key, make_char (itext_ichar (cursor)));
4993 ending--;
4994 if (ending > 0)
4995 {
4996 cursor = XSTRING_DATA (sequence) + cursor_offset;
4997
4998 if (!valid_ibyteptr_p (cursor))
4999 {
5000 mapping_interaction_error (Qreduce, sequence);
5001 }
5002
5003 DEC_IBYTEPTR (cursor);
5004 cursor_offset = cursor - XSTRING_DATA (sequence);
5005 }
5006 }
5007
5008 for (ii = ending - 1; ii >= starting; --ii)
5009 {
5010 accum = CALL2 (function, KEY (key,
5011 make_char (itext_ichar (cursor))),
5012 accum);
5013 if (ii > 0)
5014 {
5015 cursor = XSTRING_DATA (sequence) + cursor_offset;
5016
5017 if (byte_len != XSTRING_LENGTH (sequence)
5018 || !valid_ibyteptr_p (cursor))
5019 {
5020 mapping_interaction_error (Qreduce, sequence);
5021 }
5022
5023 DEC_IBYTEPTR (cursor);
5024 cursor_offset = cursor - XSTRING_DATA (sequence);
5025 }
5026 }
5027 }
5028
5029 UNGCPRO;
5030 }
5031 else if (LISTP (sequence))
5032 {
5033 if (NILP (from_end))
5034 {
5035 struct gcpro gcpro1;
5036
5037 GCPRO1 (accum);
5038
5039 if (!UNBOUNDP (initial_value))
5040 {
5041 accum = initial_value;
5042 }
5043 else if (ending - starting)
5044 {
5045 GC_EXTERNAL_LIST_LOOP_2 (elt, sequence)
5046 {
5047 if (ii == starting)
5048 {
5049 accum = KEY (key, elt);
5050 starting++;
5051 break;
5052 }
5053 ++ii;
5054 }
5055 END_GC_EXTERNAL_LIST_LOOP (elt);
5056 }
5057
5058 ii = 0;
5059
5060 if (ending - starting)
5061 {
5062 GC_EXTERNAL_LIST_LOOP_2 (elt, sequence)
5063 {
5064 if (ii >= starting)
5065 {
5066 if (ii < ending)
5067 {
5068 accum = CALL2 (function, accum, KEY (key, elt));
5069 }
5070 else if (ii == ending)
5071 {
5072 break;
5073 }
5074 }
5075 ++ii;
5076 }
5077 END_GC_EXTERNAL_LIST_LOOP (elt);
5078 }
5079
5080 UNGCPRO;
5081
5082 if (ii < starting || (ii < ending && !NILP (end)))
5083 {
5084 check_sequence_range (sequence, start, end, Flength (sequence));
5085 }
5086 }
5087 else
5088 {
5089 Boolint need_accum = 0;
5090 Lisp_Object *subsequence = NULL;
5091 Elemcount counting = 0, len = 0;
5092 struct gcpro gcpro1;
5093
5094 len = XFIXNUM (Flength (sequence));
5095 check_sequence_range (sequence, start, end, make_fixnum (len));
5096 ending = min (ending, len);
5097
5098 /* :from-end with a list; make an alloca copy of the relevant list
5099 data, attempting to go backwards isn't worth the trouble. */
5100 if (!UNBOUNDP (initial_value))
5101 {
5102 accum = initial_value;
5103 if (ending - starting && starting < ending)
5104 {
5105 subsequence = alloca_array (Lisp_Object, ending - starting);
5106 }
5107 }
5108 else if (ending - starting && starting < ending)
5109 {
5110 subsequence = alloca_array (Lisp_Object, ending - starting);
5111 need_accum = 1;
5112 }
5113
5114 if (ending - starting && starting < ending)
5115 {
5116 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
5117 {
5118 if (counting >= starting)
5119 {
5120 if (counting < ending)
5121 {
5122 subsequence[ii++] = elt;
5123 }
5124 else if (counting == ending)
5125 {
5126 break;
5127 }
5128 }
5129 ++counting;
5130 }
5131 }
5132
5133 if (subsequence != NULL)
5134 {
5135 len = ending - starting;
5136 /* If we could be sure that neither FUNCTION nor KEY modify
5137 SEQUENCE, this wouldn't be necessary, since all the
5138 elements of SUBSEQUENCE would definitely always be
5139 reachable via SEQUENCE. */
5140 GCPRO1 (subsequence[0]);
5141 gcpro1.nvars = len;
5142 }
5143
5144 if (need_accum)
5145 {
5146 accum = KEY (key, subsequence[len - 1]);
5147 --len;
5148 }
5149
5150 for (ii = len; ii != 0;)
5151 {
5152 --ii;
5153 accum = CALL2 (function, KEY (key, subsequence[ii]), accum);
5154 }
5155
5156 if (subsequence != NULL)
5157 {
5158 UNGCPRO;
5159 }
5160 }
5161 }
5162
5163 /* At this point, if ACCUM is unbound, SEQUENCE has no elements; we
5164 need to return the result of calling FUNCTION with zero
5165 arguments. */
5166 if (UNBOUNDP (accum))
5167 {
5168 accum = IGNORE_MULTIPLE_VALUES (call0 (function));
5169 }
5170
5171 return accum;
5172 }
5173
5174 /* This function is the implementation of fill_string_range() and
5175 replace_string_range(); see the comments for those functions. */
5176 static Lisp_Object
5177 replace_string_range_1 (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
5178 const Ibyte *source, const Ibyte *source_limit,
5179 Lisp_Object item)
5180 {
5181 Ibyte *destp = XSTRING_DATA (dest), *p = destp,
5182 *pend = p + XSTRING_LENGTH (dest), *pcursor, item_buf[MAX_ICHAR_LEN];
5183 Bytecount prefix_bytecount, source_len = source_limit - source;
5184 Charcount ii = 0, ending, len;
5185 Charcount starting = BIGNUMP (start) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start);
5186 Elemcount delta;
5187
5188 while (ii < starting && p < pend)
5189 {
5190 INC_IBYTEPTR (p);
5191 ii++;
5192 }
5193
5194 pcursor = p;
5195
5196 if (NILP (end))
5197 {
5198 while (pcursor < pend)
5199 {
5200 INC_IBYTEPTR (pcursor);
5201 ii++;
5202 }
5203
5204 ending = len = ii;
5205 }
5206 else
5207 {
5208 ending = BIGNUMP (end) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end);
5209 while (ii < ending && pcursor < pend)
5210 {
5211 INC_IBYTEPTR (pcursor);
5212 ii++;
5213 }
5214 }
5215
5216 if (pcursor == pend)
5217 {
5218 /* We have the length, check it for our callers. */
5219 check_sequence_range (dest, start, end, make_fixnum (ii));
5220 }
5221
5222 if (!(p == pend || p == pcursor))
5223 {
5224 prefix_bytecount = p - destp;
5225
5226 if (!NILP (item))
5227 {
5228 assert (source == NULL && source_limit == NULL);
5229 source_len = set_itext_ichar (item_buf, XCHAR (item));
5230 delta = (source_len * (ending - starting)) - (pcursor - p);
5231 }
5232 else
5233 {
5234 assert (source != NULL && source_limit != NULL);
5235 delta = source_len - (pcursor - p);
5236 }
5237
5238 if (delta)
5239 {
5240 resize_string (dest, prefix_bytecount, delta);
5241 destp = XSTRING_DATA (dest);
5242 pcursor = destp + prefix_bytecount + (pcursor - p);
5243 p = destp + prefix_bytecount;
5244 }
5245
5246 if (CHARP (item))
5247 {
5248 while (starting < ending)
5249 {
5250 memcpy (p, item_buf, source_len);
5251 p += source_len;
5252 starting++;
5253 }
5254 }
5255 else
5256 {
5257 while (starting < ending && source < source_limit)
5258 {
5259 source_len = itext_copy_ichar (source, p);
5260 p += source_len, source += source_len;
5261 }
5262 }
5263
5264 init_string_ascii_begin (dest);
5265 bump_string_modiff (dest);
5266 sledgehammer_check_ascii_begin (dest);
5267 }
5268
5269 return dest;
5270 }
5271
5272 DEFUN ("replace", Freplace, 2, MANY, 0, /*
5273 Replace the elements of SEQUENCE-ONE with the elements of SEQUENCE-TWO.
5274
5275 SEQUENCE-ONE is destructively modified, and returned. Its length is not
5276 changed.
5277
5278 Keywords :start1 and :end1 specify a subsequence of SEQUENCE-ONE, and
5279 :start2 and :end2 a subsequence of SEQUENCE-TWO. See `search' for more
5280 information.
5281
5282 arguments: (SEQUENCE-ONE SEQUENCE-TWO &key (START1 0) (END1 (length SEQUENCE-ONE)) (START2 0) (END2 (length SEQUENCE-TWO)))
5283 */
5284 (int nargs, Lisp_Object *args))
5285 {
5286 Lisp_Object sequence1 = args[0], sequence2 = args[1],
5287 result = sequence1;
5288 Elemcount starting1, ending1 = MOST_POSITIVE_FIXNUM + 1, starting2;
5289 Elemcount ending2 = MOST_POSITIVE_FIXNUM + 1, counting = 0, startcounting;
5290 Boolint sequence1_listp, sequence2_listp,
5291 overwriting = EQ (sequence1, sequence2);
5292
5293 PARSE_KEYWORDS (Freplace, nargs, args, 4, (start1, end1, start2, end2),
5294 (start1 = start2 = Qzero));
5295
5296 CHECK_SEQUENCE (sequence1);
5297 CHECK_LISP_WRITEABLE (sequence1);
5298
5299 CHECK_SEQUENCE (sequence2);
5300
5301 CHECK_NATNUM (start1);
5302 starting1 = BIGNUMP (start1) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start1);
5303 CHECK_NATNUM (start2);
5304 starting2 = BIGNUMP (start2) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start2);
5305
5306 if (!NILP (end1))
5307 {
5308 CHECK_NATNUM (end1);
5309 ending1 = BIGNUMP (end1) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end1);
5310 }
5311
5312 if (!NILP (end2))
5313 {
5314 CHECK_NATNUM (end2);
5315 ending2 = BIGNUMP (end2) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end2);
5316 }
5317
5318 sequence1_listp = LISTP (sequence1);
5319 sequence2_listp = LISTP (sequence2);
5320
5321 overwriting = overwriting && starting2 <= starting1;
5322
5323 if (sequence1_listp && !ZEROP (start1))
5324 {
5325 sequence1 = Fnthcdr (start1, sequence1);
5326
5327 if (NILP (sequence1))
5328 {
5329 check_sequence_range (args[0], start1, end1, Flength (args[0]));
5330 /* Give up early here. */
5331 return result;
5332 }
5333
5334 ending1 -= starting1;
5335 starting1 = 0;
5336 }
5337
5338 if (sequence2_listp && !ZEROP (start2))
5339 {
5340 sequence2 = Fnthcdr (start2, sequence2);
5341
5342 if (NILP (sequence2))
5343 {
5344 check_sequence_range (args[1], start1, end1, Flength (args[1]));
5345 /* Nothing available to replace sequence1's contents. */
5346 return result;
5347 }
5348
5349 ending2 -= starting2;
5350 starting2 = 0;
5351 }
5352
5353 if (overwriting)
5354 {
5355 if (EQ (start1, start2))
5356 {
5357 return result;
5358 }
5359
5360 /* Our ranges may overlap. Save the data that might be overwritten. */
5361
5362 if (CONSP (sequence2))
5363 {
5364 Elemcount len = XFIXNUM (Flength (sequence2));
5365 Lisp_Object *subsequence
5366 = alloca_array (Lisp_Object, min (ending2, len));
5367 Elemcount ii = 0;
5368
5369 LIST_LOOP_2 (elt, sequence2)
5370 {
5371 if (counting == ending2)
5372 {
5373 break;
5374 }
5375
5376 subsequence[ii++] = elt;
5377 counting++;
5378 }
5379
5380 check_sequence_range (sequence1, start1, end1,
5381 /* The XFIXNUM (start2) is intentional here; we
5382 called #'length after doing (nthcdr
5383 start2 sequence2). */
5384 make_fixnum (XFIXNUM (start2) + len));
5385 check_sequence_range (sequence2, start2, end2,
5386 make_fixnum (XFIXNUM (start2) + len));
5387
5388 while (starting1 < ending1
5389 && starting2 < ending2 && !NILP (sequence1))
5390 {
5391 XSETCAR (sequence1, subsequence[starting2]);
5392 sequence1 = XCDR (sequence1);
5393 starting1++;
5394 starting2++;
5395 }
5396 }
5397 else if (STRINGP (sequence2))
5398 {
5399 Ibyte *p = XSTRING_DATA (sequence2),
5400 *pend = p + XSTRING_LENGTH (sequence2), *pcursor,
5401 *staging;
5402 Bytecount ii = 0;
5403
5404 while (ii < starting2 && p < pend)
5405 {
5406 INC_IBYTEPTR (p);
5407 ii++;
5408 }
5409
5410 pcursor = p;
5411
5412 while (ii < ending2 && starting1 < ending1 && pcursor < pend)
5413 {
5414 INC_IBYTEPTR (pcursor);
5415 starting1++;
5416 ii++;
5417 }
5418
5419 if (pcursor == pend)
5420 {
5421 check_sequence_range (sequence1, start1, end1, make_fixnum (ii));
5422 check_sequence_range (sequence2, start2, end2, make_fixnum (ii));
5423 }
5424 else
5425 {
5426 assert ((pcursor - p) > 0);
5427 staging = alloca_ibytes (pcursor - p);
5428 memcpy (staging, p, pcursor - p);
5429 replace_string_range (result, start1,
5430 make_fixnum (starting1),
5431 staging, staging + (pcursor - p));
5432 }
5433 }
5434 else
5435 {
5436 Elemcount seq_len = XFIXNUM (Flength (sequence2)), ii = 0,
5437 subseq_len = min (min (ending1 - starting1, seq_len - starting1),
5438 min (ending2 - starting2, seq_len - starting2));
5439 Lisp_Object *subsequence = alloca_array (Lisp_Object, subseq_len);
5440
5441 check_sequence_range (sequence1, start1, end1, make_fixnum (seq_len));
5442 check_sequence_range (sequence2, start2, end2, make_fixnum (seq_len));
5443
5444 while (starting2 < ending2 && ii < seq_len)
5445 {
5446 subsequence[ii] = Faref (sequence2, make_fixnum (starting2));
5447 ii++, starting2++;
5448 }
5449
5450 ii = 0;
5451
5452 while (starting1 < ending1 && ii < seq_len)
5453 {
5454 Faset (sequence1, make_fixnum (starting1), subsequence[ii]);
5455 ii++, starting1++;
5456 }
5457 }
5458 }
5459 else if (sequence1_listp && sequence2_listp)
5460 {
5461 Lisp_Object sequence1_tortoise = sequence1,
5462 sequence2_tortoise = sequence2;
5463 Elemcount shortest_len = 0;
5464
5465 counting = startcounting = min (ending1, ending2);
5466
5467 while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2))
5468 {
5469 XSETCAR (sequence1,
5470 CONSP (sequence2) ? XCAR (sequence2)
5471 : Fcar (sequence2));
5472 sequence1 = CONSP (sequence1) ? XCDR (sequence1)
5473 : Fcdr (sequence1);
5474 sequence2 = CONSP (sequence2) ? XCDR (sequence2)
5475 : Fcdr (sequence2);
5476
5477 shortest_len++;
5478
5479 if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH)
5480 {
5481 if (counting & 1)
5482 {
5483 sequence1_tortoise = XCDR (sequence1_tortoise);
5484 sequence2_tortoise = XCDR (sequence2_tortoise);
5485 }
5486
5487 if (EQ (sequence1, sequence1_tortoise))
5488 {
5489 signal_circular_list_error (sequence1);
5490 }
5491
5492 if (EQ (sequence2, sequence2_tortoise))
5493 {
5494 signal_circular_list_error (sequence2);
5495 }
5496 }
5497 }
5498
5499 if (NILP (sequence1))
5500 {
5501 check_sequence_range (args[0], start1, end1,
5502 make_fixnum (XFIXNUM (start1) + shortest_len));
5503 }
5504 else if (NILP (sequence2))
5505 {
5506 check_sequence_range (args[1], start2, end2,
5507 make_fixnum (XFIXNUM (start2) + shortest_len));
5508 }
5509 }
5510 else if (sequence1_listp)
5511 {
5512 if (STRINGP (sequence2))
5513 {
5514 Ibyte *s2_data = XSTRING_DATA (sequence2),
5515 *s2_end = s2_data + XSTRING_LENGTH (sequence2);
5516 Elemcount char_count = 0;
5517 Lisp_Object character;
5518
5519 while (char_count < starting2 && s2_data < s2_end)
5520 {
5521 INC_IBYTEPTR (s2_data);
5522 char_count++;
5523 }
5524
5525 while (starting1 < ending1 && starting2 < ending2
5526 && s2_data < s2_end && !NILP (sequence1))
5527 {
5528 character = make_char (itext_ichar (s2_data));
5529 CONSP (sequence1) ?
5530 XSETCAR (sequence1, character)
5531 : Fsetcar (sequence1, character);
5532 sequence1 = XCDR (sequence1);
5533 starting1++;
5534 starting2++;
5535 char_count++;
5536 INC_IBYTEPTR (s2_data);
5537 }
5538
5539 if (NILP (sequence1))
5540 {
5541 check_sequence_range (sequence1, start1, end1,
5542 make_fixnum (XFIXNUM (start1) + starting1));
5543 }
5544
5545 if (s2_data == s2_end)
5546 {
5547 check_sequence_range (sequence2, start2, end2,
5548 make_fixnum (char_count));
5549 }
5550 }
5551 else
5552 {
5553 Elemcount len2 = XFIXNUM (Flength (sequence2));
5554 check_sequence_range (sequence2, start2, end2, make_fixnum (len2));
5555
5556 ending2 = min (ending2, len2);
5557 while (starting2 < ending2
5558 && starting1 < ending1 && !NILP (sequence1))
5559 {
5560 CHECK_CONS (sequence1);
5561 XSETCAR (sequence1, Faref (sequence2, make_fixnum (starting2)));
5562 sequence1 = XCDR (sequence1);
5563 starting1++;
5564 starting2++;
5565 }
5566
5567 if (NILP (sequence1))
5568 {
5569 check_sequence_range (args[0], start1, end1,
5570 make_fixnum (XFIXNUM (start1) + starting1));
5571 }
5572 }
5573 }
5574 else if (sequence2_listp)
5575 {
5576 if (STRINGP (sequence1))
5577 {
5578 Elemcount ii = 0, count, len = string_char_length (sequence1);
5579 Ibyte *staging, *cursor;
5580 Lisp_Object obj;
5581
5582 check_sequence_range (sequence1, start1, end1, make_fixnum (len));
5583 ending1 = min (ending1, len);
5584 count = ending1 - starting1;
5585 staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
5586
5587 while (ii < count && !NILP (sequence2))
5588 {
5589 obj = CONSP (sequence2) ? XCAR (sequence2)
5590 : Fcar (sequence2);
5591
5592 CHECK_CHAR_COERCE_INT (obj);
5593 cursor += set_itext_ichar (cursor, XCHAR (obj));
5594 ii++;
5595 sequence2 = XCDR (sequence2);
5596 }
5597
5598 if (NILP (sequence2))
5599 {
5600 check_sequence_range (sequence2, start2, end2,
5601 make_fixnum (XFIXNUM (start2) + ii));
5602 }
5603
5604 replace_string_range (result, start1, make_fixnum (XFIXNUM (start1) + ii),
5605 staging, cursor);
5606 }
5607 else
5608 {
5609 Elemcount len = XFIXNUM (Flength (sequence1));
5610
5611 check_sequence_range (sequence1, start2, end1, make_fixnum (len));
5612 ending1 = min (ending2, min (ending1, len));
5613
5614 while (starting1 < ending1 && !NILP (sequence2))
5615 {
5616 Faset (sequence1, make_fixnum (starting1),
5617 CONSP (sequence2) ? XCAR (sequence2)
5618 : Fcar (sequence2));
5619 sequence2 = XCDR (sequence2);
5620 starting1++;
5621 starting2++;
5622 }
5623
5624 if (NILP (sequence2))
5625 {
5626 check_sequence_range (args[1], start2, end2,
5627 make_fixnum (XFIXNUM (start2) + starting2));
5628 }
5629 }
5630 }
5631 else
5632 {
5633 if (STRINGP (sequence1) && STRINGP (sequence2))
5634 {
5635 Ibyte *p2 = XSTRING_DATA (sequence2),
5636 *p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor;
5637 Charcount ii = 0, len1 = string_char_length (sequence1);
5638
5639 check_sequence_range (sequence1, start1, end1, make_fixnum (len1));
5640
5641 while (ii < starting2 && p2 < p2end)
5642 {
5643 INC_IBYTEPTR (p2);
5644 ii++;
5645 }
5646
5647 p2cursor = p2;
5648 ending1 = min (ending1, len1);
5649
5650 while (ii < ending2 && starting1 < ending1 && p2cursor < p2end)
5651 {
5652 INC_IBYTEPTR (p2cursor);
5653 ii++;
5654 starting1++;
5655 }
5656
5657 if (p2cursor == p2end)
5658 {
5659 check_sequence_range (sequence2, start2, end2, make_fixnum (ii));
5660 }
5661
5662 /* This isn't great; any error message won't necessarily reflect
5663 the END1 that was supplied to #'replace. */
5664 replace_string_range (result, start1, make_fixnum (starting1),
5665 p2, p2cursor);
5666 }
5667 else if (STRINGP (sequence1))
5668 {
5669 Ibyte *staging, *cursor;
5670 Elemcount count, len1 = string_char_length (sequence1);
5671 Elemcount len2 = XFIXNUM (Flength (sequence2)), ii = 0;
5672 Lisp_Object obj;
5673
5674 check_sequence_range (sequence1, start1, end1, make_fixnum (len1));
5675 check_sequence_range (sequence2, start2, end2, make_fixnum (len2));
5676
5677 ending1 = min (ending1, len1);
5678 ending2 = min (ending2, len2);
5679 count = min (ending1 - starting1, ending2 - starting2);
5680 staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
5681
5682 ii = 0;
5683 while (ii < count)
5684 {
5685 obj = Faref (sequence2, make_fixnum (starting2));
5686
5687 CHECK_CHAR_COERCE_INT (obj);
5688 cursor += set_itext_ichar (cursor, XCHAR (obj));
5689 starting2++, ii++;
5690 }
5691
5692 replace_string_range (result, start1,
5693 make_fixnum (XFIXNUM (start1) + count),
5694 staging, cursor);
5695 }
5696 else if (STRINGP (sequence2))
5697 {
5698 Ibyte *p2 = XSTRING_DATA (sequence2),
5699 *p2end = p2 + XSTRING_LENGTH (sequence2);
5700 Elemcount len1 = XFIXNUM (Flength (sequence1)), ii = 0;
5701
5702 check_sequence_range (sequence1, start1, end1, make_fixnum (len1));
5703 ending1 = min (ending1, len1);
5704
5705 while (ii < starting2 && p2 < p2end)
5706 {
5707 INC_IBYTEPTR (p2);
5708 ii++;
5709 }
5710
5711 while (p2 < p2end && starting1 < ending1 && starting2 < ending2)
5712 {
5713 Faset (sequence1, make_fixnum (starting1),
5714 make_char (itext_ichar (p2)));
5715 INC_IBYTEPTR (p2);
5716 starting1++;
5717 starting2++;
5718 ii++;
5719 }
5720
5721 if (p2 == p2end)
5722 {
5723 check_sequence_range (sequence2, start2, end2, make_fixnum (ii));
5724 }
5725 }
5726 else
5727 {
5728 Elemcount len1 = XFIXNUM (Flength (sequence1)),
5729 len2 = XFIXNUM (Flength (sequence2));
5730
5731 check_sequence_range (sequence1, start1, end1, make_fixnum (len1));
5732 check_sequence_range (sequence2, start2, end2, make_fixnum (len2));
5733
5734 ending1 = min (ending1, len1);
5735 ending2 = min (ending2, len2);
5736
5737 while (starting1 < ending1 && starting2 < ending2)
5738 {
5739 Faset (sequence1, make_fixnum (starting1),
5740 Faref (sequence2, make_fixnum (starting2)));
5741 starting1++;
5742 starting2++;
5743 }
5744 }
5745 }
5746
5747 return result;
5748 }
5749
5750 DEFUN ("nsubstitute", Fnsubstitute, 3, MANY, 0, /*
5751 Substitute NEW for OLD in SEQUENCE.
5752
5753 This is a destructive function; it reuses the storage of SEQUENCE whenever
5754 possible. See `remove*' for the meaning of the keywords.
5755
5756 arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT)
5757 */
5758 (int nargs, Lisp_Object *args))
5759 {
5760 Lisp_Object new_ = args[0], item = args[1], sequence = args[2];
5761 Lisp_Object object_, position0;
5762 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0;
5763 Elemcount len, ii = 0, counting = MOST_POSITIVE_FIXNUM, presenting = 0;
5764 Boolint test_not_unboundp = 1;
5765 check_test_func_t check_test = NULL;
5766
5767 PARSE_KEYWORDS (Fnsubstitute, nargs, args, 9,
5768 (test, if_, if_not, test_not, key, start, end, count,
5769 from_end), (start = Qzero));
5770
5771 CHECK_SEQUENCE (sequence);
5772 CHECK_NATNUM (start);
5773 starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
5774
5775 if (!NILP (end))
5776 {
5777 CHECK_NATNUM (end);
5778 ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
5779 }
5780
5781 if (!NILP (count))
5782 {
5783 CHECK_INTEGER (count);
5784 if (FIXNUMP (count))
5785 {
5786 counting = XFIXNUM (count);
5787 }
5788 #ifdef HAVE_BIGNUM
5789 else
5790 {
5791 counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
5792 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM;
5793 }
5794 #endif
5795
5796 if (counting <= 0)
5797 {
5798 return sequence;
5799 }
5800 }
5801
5802 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
5803 key, &test_not_unboundp);
5804
5805 if (CONSP (sequence))
5806 {
5807 if (!NILP (count) && !NILP (from_end))
5808 {
5809 Lisp_Object present = count_with_tail (&object_, nargs - 1, args + 1,
5810 Qnsubstitute);
5811
5812 if (ZEROP (present))
5813 {
5814 return sequence;
5815 }
5816
5817 presenting = XFIXNUM (present);
5818 presenting = presenting <= counting ? 0 : presenting - counting;
5819 }
5820
5821 {
5822 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
5823 {
5824 if (!(ii < ending))
5825 {
5826 break;
5827 }
5828
5829 if (starting <= ii &&
5830 check_test (test, key, item, elt) == test_not_unboundp
5831 && (presenting ? encountered++ >= presenting
5832 : encountered++ < counting))
5833 {
5834 CHECK_LISP_WRITEABLE (tail);
5835 XSETCAR (tail, new_);
5836 }
5837 else if (!presenting && encountered >= counting)
5838 {
5839 break;
5840 }
5841
5842 ii++;
5843 }
5844 END_GC_EXTERNAL_LIST_LOOP (elt);
5845 }
5846
5847 if ((ii < starting || (ii < ending && !NILP (end)))
5848 && encountered < counting)
5849 {
5850 check_sequence_range (args[0], start, end, Flength (args[0]));
5851 }
5852 }
5853 else if (STRINGP (sequence))
5854 {
5855 Ibyte *staging, new_bytes[MAX_ICHAR_LEN], *staging_cursor;
5856 Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp;
5857 Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence);
5858 Bytecount new_len;
5859 Lisp_Object character;
5860
5861 CHECK_CHAR_COERCE_INT (new_);
5862
5863 new_len = set_itext_ichar (new_bytes, XCHAR (new_));
5864
5865 /* Worst case scenario; new char is four octets long, all the old ones
5866 were one octet long, all the old ones match. */
5867 staging = alloca_ibytes (XSTRING_LENGTH (sequence) * new_len);
5868 staging_cursor = staging;
5869
5870 if (!NILP (count) && !NILP (from_end))
5871 {
5872 Lisp_Object present = count_with_tail (&character, nargs - 1,
5873 args + 1, Qnsubstitute);
5874
5875 if (ZEROP (present))
5876 {
5877 return sequence;
5878 }
5879
5880 presenting = XFIXNUM (present);
5881
5882 /* If there are fewer items in the string than we have
5883 permission to change, we don't need to differentiate
5884 between the :from-end nil and :from-end t
5885 cases. Otherwise, presenting is the number of matching
5886 items we need to ignore before we start to change. */
5887 presenting = presenting <= counting ? 0 : presenting - counting;
5888 }
5889
5890 ii = 0;
5891 while (cursor_offset < byte_len && ii < ending)
5892 {
5893 if (ii >= starting)
5894 {
5895 character = make_char (itext_ichar (cursor));
5896
5897 if ((check_test (test, key, item, character)
5898 == test_not_unboundp)
5899 && (presenting ? encountered++ >= presenting :
5900 encountered++ < counting))
5901 {
5902 staging_cursor
5903 += itext_copy_ichar (new_bytes, staging_cursor);
5904 }
5905 else
5906 {
5907 staging_cursor
5908 += itext_copy_ichar (cursor, staging_cursor);
5909 }
5910
5911 startp = XSTRING_DATA (sequence);
5912 cursor = startp + cursor_offset;
5913
5914 if (byte_len != XSTRING_LENGTH (sequence)
5915 || !valid_ibyteptr_p (cursor))
5916 {
5917 mapping_interaction_error (Qnsubstitute, sequence);
5918 }
5919 }
5920 else
5921 {
5922 staging_cursor += itext_copy_ichar (cursor, staging_cursor);
5923 }
5924
5925 INC_IBYTEPTR (cursor);
5926 cursor_offset = cursor - startp;
5927 ii++;
5928 }
5929
5930 if (ii < starting || (ii < ending && !NILP (end)))
5931 {
5932 check_sequence_range (sequence, start, end, Flength (sequence));
5933 }
5934
5935 if (0 != encountered)
5936 {
5937 CHECK_LISP_WRITEABLE (sequence);
5938 replace_string_range (sequence, Qzero, make_fixnum (ii),
5939 staging, staging_cursor);
5940 }
5941 }
5942 else
5943 {
5944 Elemcount positioning;
5945 Lisp_Object object = Qnil;
5946
5947 len = XFIXNUM (Flength (sequence));
5948 check_sequence_range (sequence, start, end, make_fixnum (len));
5949
5950 position0 = position (&object, item, sequence, check_test,
5951 test_not_unboundp, test, key, start, end, from_end,
5952 Qnil, Qnsubstitute);
5953
5954 if (NILP (position0))
5955 {
5956 return sequence;
5957 }
5958
5959 positioning = XFIXNUM (position0);
5960 ending = min (len, ending);
5961
5962 Faset (sequence, position0, new_);
5963 encountered = 1;
5964
5965 if (NILP (from_end))
5966 {
5967 for (ii = positioning + 1; ii < ending; ii++)
5968 {
5969 object_ = Faref (sequence, make_fixnum (ii));
5970
5971 if (check_test (test, key, item, object_) == test_not_unboundp
5972 && encountered++ < counting)
5973 {
5974 Faset (sequence, make_fixnum (ii), new_);
5975 }
5976 else if (encountered == counting)
5977 {
5978 break;
5979 }
5980 }
5981 }
5982 else
5983 {
5984 for (ii = positioning - 1; ii >= starting; ii--)
5985 {
5986 object_ = Faref (sequence, make_fixnum (ii));
5987
5988 if (check_test (test, key, item, object_) == test_not_unboundp
5989 && encountered++ < counting)
5990 {
5991 Faset (sequence, make_fixnum (ii), new_);
5992 }
5993 else if (encountered == counting)
5994 {
5995 break;
5996 }
5997 }
5998 }
5999 }
6000
6001 return sequence;
6002 }
6003
6004 DEFUN ("substitute", Fsubstitute, 3, MANY, 0, /*
6005 Substitute NEW for OLD in SEQUENCE.
6006
6007 This is a non-destructive function; it makes a copy of SEQUENCE if necessary
6008 to avoid corrupting the original SEQUENCE.
6009
6010 See `remove*' for the meaning of the keywords.
6011
6012 arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) COUNT)
6013 */
6014 (int nargs, Lisp_Object *args))
6015 {
6016 Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil;
6017 Lisp_Object result = Qnil, result_tail = Qnil;
6018 Lisp_Object object, position0, matched_count;
6019 Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0;
6020 Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, presenting = 0;
6021 Boolint test_not_unboundp = 1;
6022 check_test_func_t check_test = NULL;
6023 struct gcpro gcpro1;
6024
6025 PARSE_KEYWORDS (Fsubstitute, nargs, args, 9,
6026 (test, if_, if_not, test_not, key, start, end, count,
6027 from_end), (start = Qzero, count = Qunbound));
6028
6029 CHECK_SEQUENCE (sequence);
6030
6031 CHECK_NATNUM (start);
6032 starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start);
6033
6034 if (!NILP (end))
6035 {
6036 CHECK_NATNUM (end);
6037 ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
6038 }
6039
6040 check_test = get_check_test_function (item, &test, test_not, if_, if_not,
6041 key, &test_not_unboundp);
6042
6043 if (!UNBOUNDP (count))
6044 {
6045 if (!NILP (count))
6046 {
6047 CHECK_INTEGER (count);
6048 if (FIXNUMP (count))
6049 {
6050 counting = XFIXNUM (count);
6051 }
6052 #ifdef HAVE_BIGNUM
6053 else
6054 {
6055 counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
6056 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM;
6057 }
6058 #endif
6059
6060 if (counting <= 0)
6061 {
6062 return sequence;
6063 }
6064 }
6065 }
6066
6067 if (!CONSP (sequence))
6068 {
6069 position0 = position (&object, item, sequence, check_test,
6070 test_not_unboundp, test, key, start, end, from_end,
6071 Qnil, Qsubstitute);
6072
6073 if (NILP (position0))
6074 {
6075 return sequence;
6076 }
6077 else
6078 {
6079 args[2] = Fcopy_sequence (sequence);
6080 return Fnsubstitute (nargs, args);
6081 }
6082 }
6083
6084 matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute);
6085
6086 if (ZEROP (matched_count))
6087 {
6088 return sequence;
6089 }
6090
6091 if (!NILP (count) && !NILP (from_end))
6092 {
6093 presenting = XFIXNUM (matched_count);
6094 presenting = presenting <= counting ? 0 : presenting - counting;
6095 }
6096
6097 GCPRO1 (result);
6098 {
6099 GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tailing)
6100 {
6101 if (EQ (tail, tailing))
6102 {
6103 XUNGCPRO (elt);
6104 UNGCPRO;
6105
6106 if (NILP (result))
6107 {
6108 return XCDR (tail);
6109 }
6110
6111 XSETCDR (result_tail, XCDR (tail));
6112 return result;
6113 }
6114 else if (starting <= ii && ii < ending &&
6115 (check_test (test, key, item, elt) == test_not_unboundp)
6116 && (presenting ? encountered++ >= presenting
6117 : encountered++ < counting))
6118 {
6119 if (NILP (result))
6120 {
6121 result = result_tail = Fcons (new_, Qnil);
6122 }
6123 else
6124 {
6125 XSETCDR (result_tail, Fcons (new_, Qnil));
6126 result_tail = XCDR (result_tail);
6127 }
6128 }
6129 else if (NILP (result))
6130 {
6131 result = result_tail = Fcons (elt, Qnil);
6132 }
6133 else
6134 {
6135 XSETCDR (result_tail, Fcons (elt, Qnil));
6136 result_tail = XCDR (result_tail);
6137 }
6138
6139 if (ii == ending)
6140 {
6141 break;
6142 }
6143
6144 ii++;
6145 }
6146 END_GC_EXTERNAL_LIST_LOOP (elt);
6147 }
6148 UNGCPRO;
6149
6150 if (ii < starting || (ii < ending && !NILP (end)))
6151 {
6152 check_sequence_range (args[0], start, end, Flength (args[0]));
6153 }
6154
6155 return result;
6156 }
6157
6158 static Lisp_Object
6159 subst (Lisp_Object new_, Lisp_Object old, Lisp_Object tree, int depth)
6160 {
6161 if (depth + lisp_eval_depth > max_lisp_eval_depth)
6162 {
6163 stack_overflow ("Stack overflow in subst", tree);
6164 }
6165
6166 if (EQ (tree, old))
6167 {
6168 return new_;
6169 }
6170 else if (CONSP (tree))
6171 {
6172 Lisp_Object aa = subst (new_, old, XCAR (tree), depth + 1);
6173 Lisp_Object dd = subst (new_, old, XCDR (tree), depth + 1);
6174
6175 if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree)))
6176 {
6177 return tree;
6178 }
6179 else
6180 {
6181 return Fcons (aa, dd);
6182 }
6183 }
6184 else
6185 {
6186 return tree;
6187 }
6188 }
6189
6190 static Lisp_Object
6191 sublis (Lisp_Object alist, Lisp_Object tree,
6192 check_test_func_t check_test, Boolint test_not_unboundp,
6193 Lisp_Object test, Lisp_Object key, int depth)
6194 {
6195 Lisp_Object keyed = KEY (key, tree), aa, dd;
6196
6197 if (depth + lisp_eval_depth > max_lisp_eval_depth)
6198 {
6199 stack_overflow ("Stack overflow in sublis", tree);
6200 }
6201
6202 {
6203 GC_EXTERNAL_LIST_LOOP_2 (elt, alist)
6204 {
6205 if (CONSP (elt) &&
6206 check_test (test, key, XCAR (elt), keyed) == test_not_unboundp)
6207 {
6208 XUNGCPRO (elt);
6209 return XCDR (elt);
6210 }
6211 }
6212 END_GC_EXTERNAL_LIST_LOOP (elt);
6213 }
6214
6215 if (!CONSP (tree))
6216 {
6217 return tree;
6218 }
6219
6220 aa = sublis (alist, XCAR (tree), check_test, test_not_unboundp, test, key,
6221 depth + 1);
6222 dd = sublis (alist, XCDR (tree), check_test, test_not_unboundp, test, key,
6223 depth + 1);
6224
6225 if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree)))
6226 {
6227 return tree;
6228 }
6229
6230 return Fcons (aa, dd);
6231 }
6232
6233 DEFUN ("sublis", Fsublis, 2, MANY, 0, /*
6234 Perform substitutions indicated by ALIST in TREE (non-destructively).
6235 Return a copy of TREE with all matching elements replaced.
6236
6237 See `member*' for the meaning of :test, :test-not and :key.
6238
6239 arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
6240 */
6241 (int nargs, Lisp_Object *args))
6242 {
6243 Lisp_Object alist = args[0], tree = args[1];
6244 Boolint test_not_unboundp = 1;
6245 check_test_func_t check_test = NULL;
6246
6247 PARSE_KEYWORDS (Fsublis, nargs, args, 5, (test, if_, test_not, if_not, key),
6248 (key = Qidentity));
6249
6250 if (NILP (key))
6251 {
6252 key = Qidentity;
6253 }
6254
6255 get_check_match_function (&test, test_not, if_, if_not,
6256 /* sublis() is going to apply the key, don't ask
6257 for a match function that will do it for
6258 us. */
6259 Qidentity, &test_not_unboundp, &check_test);
6260
6261 if (CONSP (alist) && NILP (XCDR (alist)) && CONSP (XCAR (alist))
6262 && EQ (key, Qidentity) && 1 == test_not_unboundp
6263 && (check_eq_nokey == check_test ||
6264 (check_eql_nokey == check_test &&
6265 !NON_FIXNUM_NUMBER_P (XCAR (XCAR (alist))))))
6266 {
6267 /* #'subst with #'eq is very cheap indeed; call it. */
6268 return subst (XCDR (XCAR (alist)), XCAR (XCAR (alist)), tree, 0);
6269 }
6270
6271 return sublis (alist, tree, check_test, test_not_unboundp, test, key, 0);
6272 }
6273
6274 static Lisp_Object
6275 nsublis (Lisp_Object alist, Lisp_Object tree,
6276 check_test_func_t check_test,
6277 Boolint test_not_unboundp,
6278 Lisp_Object test, Lisp_Object key, int depth)
6279 {
6280 Lisp_Object tree_saved = tree, tortoise = tree, keyed = Qnil;
6281 struct gcpro gcpro1, gcpro2;
6282 int count = 0;
6283
6284 if (depth + lisp_eval_depth > max_lisp_eval_depth)
6285 {
6286 stack_overflow ("Stack overflow in nsublis", tree);
6287 }
6288
6289 GCPRO2 (tree_saved, keyed);
6290
6291 while (CONSP (tree))
6292 {
6293 Boolint replaced = 0;
6294 keyed = KEY (key, XCAR (tree));
6295
6296 {
6297 GC_EXTERNAL_LIST_LOOP_2 (elt, alist)
6298 {
6299 if (CONSP (elt) &&
6300 check_test (test, key, XCAR (elt), keyed) == test_not_unboundp)
6301 {
6302 CHECK_LISP_WRITEABLE (tree);
6303 /* See comment in sublis() on using elt_cdr. */
6304 XSETCAR (tree, XCDR (elt));
6305 replaced = 1;
6306 break;
6307 }
6308 }
6309 END_GC_EXTERNAL_LIST_LOOP (elt);
6310 }
6311
6312 if (!replaced)
6313 {
6314 if (CONSP (XCAR (tree)))
6315 {
6316 nsublis (alist, XCAR (tree), check_test, test_not_unboundp,
6317 test, key, depth + 1);
6318 }
6319 }
6320
6321 keyed = KEY (key, XCDR (tree));
6322 replaced = 0;
6323
6324 {
6325 GC_EXTERNAL_LIST_LOOP_2 (elt, alist)
6326 {
6327 if (CONSP (elt) &&
6328 check_test (test, key, XCAR (elt), keyed) == test_not_unboundp)
6329 {
6330 CHECK_LISP_WRITEABLE (tree);
6331 XSETCDR (tree, XCDR (elt));
6332 tree = Qnil;
6333 break;
6334 }
6335 }
6336 END_GC_EXTERNAL_LIST_LOOP (elt);
6337 }
6338
6339 if (!NILP (tree))
6340 {
6341 tree = XCDR (tree);
6342 }
6343
6344 if (++count > CIRCULAR_LIST_SUSPICION_LENGTH)
6345 {
6346 if (count & 1)
6347 {
6348 tortoise = XCDR (tortoise);
6349 }
6350
6351 if (EQ (tortoise, tree))
6352 {
6353 signal_circular_list_error (tree);
6354 }
6355 }
6356 }
6357
6358 RETURN_UNGCPRO (tree_saved);
6359 }
6360
6361 DEFUN ("nsublis", Fnsublis, 2, MANY, 0, /*
6362 Perform substitutions indicated by ALIST in TREE (destructively).
6363 Any matching element of TREE is changed via a call to `setcar'.
6364
6365 See `member*' for the meaning of :test, :test-not and :key.
6366
6367 arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
6368 */
6369 (int nargs, Lisp_Object *args))
6370 {
6371 Lisp_Object alist = args[0], tree = args[1], tailed = Qnil, keyed = Qnil;
6372 Boolint test_not_unboundp = 1;
6373 check_test_func_t check_test = NULL;
6374 struct gcpro gcpro1, gcpro2;
6375
6376 PARSE_KEYWORDS (Fnsublis, nargs, args, 5, (test, if_, test_not, if_not, key),
6377 (key = Qidentity));
6378
6379 if (NILP (key))
6380 {
6381 key = Qidentity;
6382 }
6383
6384 get_check_match_function (&test, test_not, if_, if_not,
6385 /* nsublis() is going to apply the key, don't ask
6386 for a match function that will do it for
6387 us. */
6388 Qidentity, &test_not_unboundp, &check_test);
6389
6390 GCPRO2 (tailed, keyed);
6391
6392 keyed = KEY (key, tree);
6393
6394 {
6395 /* nsublis() won't attempt to replace a cons handed to it, do that
6396 ourselves. */
6397 GC_EXTERNAL_LIST_LOOP_2 (elt, alist)
6398 {
6399 if (CONSP (elt) &&
6400 check_test (test, key, XCAR (elt), keyed) == test_not_unboundp)
6401 {
6402 XUNGCPRO (elt);
6403 return XCDR (elt);
6404 }
6405 }
6406 END_GC_EXTERNAL_LIST_LOOP (elt);
6407 }
6408
6409 UNGCPRO;
6410
6411 return nsublis (alist, tree, check_test, test_not_unboundp, test, key, 0);
6412 }
6413
6414 DEFUN ("subst", Fsubst, 3, MANY, 0, /*
6415 Substitute NEW for OLD everywhere in TREE (non-destructively).
6416
6417 Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
6418
6419 See `member*' for the meaning of :test, :test-not and :key.
6420
6421 arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
6422 */
6423 (int nargs, Lisp_Object *args))
6424 {
6425 Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]),
6426 Qnil);
6427 args[1] = alist;
6428 result = Fsublis (nargs - 1, args + 1);
6429 free_cons (XCAR (alist));
6430 free_cons (alist);
6431
6432 return result;
6433 }
6434
6435 DEFUN ("nsubst", Fnsubst, 3, MANY, 0, /*
6436 Substitute NEW for OLD everywhere in TREE (destructively).
6437
6438 Any element of TREE which is `eql' to OLD is changed to NEW (via a call to
6439 `setcar').
6440
6441 See `member*' for the meaning of the keywords. The keyword
6442 :descend-structures, not specified by Common Lisp, allows callers to specify
6443 that non-cons objects (vectors and range tables, among others) should also
6444 undergo substitution.
6445
6446 arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT DESCEND-STRUCTURES)
6447 */
6448 (int nargs, Lisp_Object *args))
6449 {
6450 Lisp_Object new_ = args[0], old = args[1], tree = args[2], result, alist;
6451 Boolint test_not_unboundp = 1;
6452 check_test_func_t check_test = NULL;
6453
6454 PARSE_KEYWORDS (Fnsubst, nargs, args, 6, (test, if_, test_not, if_not, key,
6455 descend_structures), NULL);
6456 if (!NILP (descend_structures))
6457 {
6458 check_test = get_check_test_function (old, &test, test_not, if_, if_not,
6459 key, &test_not_unboundp);
6460
6461 return nsubst_structures (new_, old, tree, check_test, test_not_unboundp,
6462 test, key);
6463
6464 }
6465
6466 alist = noseeum_cons (noseeum_cons (old, new_), Qnil);
6467 args[1] = alist;
6468 result = Fnsublis (nargs - 1, args + 1);
6469 free_cons (XCAR (alist));
6470 free_cons (alist);
6471
6472 return result;
6473 }
6474
6475 static Boolint
6476 tree_equal (Lisp_Object tree1, Lisp_Object tree2,
6477 check_test_func_t check_test, Boolint test_not_unboundp,
6478 Lisp_Object test, Lisp_Object key, int depth)
6479 {
6480 Lisp_Object tortoise1 = tree1, tortoise2 = tree2;
6481 struct gcpro gcpro1, gcpro2;
6482 int count = 0;
6483 Boolint result;
6484
6485 if (depth + lisp_eval_depth > max_lisp_eval_depth)
6486 {
6487 stack_overflow ("Stack overflow in tree-equal", tree1);
6488 }
6489
6490 GCPRO2 (tree1, tree2);
6491
6492 while (CONSP (tree1) && CONSP (tree2)
6493 && tree_equal (XCAR (tree1), XCAR (tree2), check_test,
6494 test_not_unboundp, test, key, depth + 1))
6495 {
6496 tree1 = XCDR (tree1);
6497 tree2 = XCDR (tree2);
6498
6499 if (++count > CIRCULAR_LIST_SUSPICION_LENGTH)
6500 {
6501 if (count & 1)
6502 {
6503 tortoise1 = XCDR (tortoise1);
6504 tortoise2 = XCDR (tortoise2);
6505 }
6506
6507 if (EQ (tortoise1, tree1))
6508 {
6509 signal_circular_list_error (tree1);
6510 }
6511
6512 if (EQ (tortoise2, tree2))
6513 {
6514 signal_circular_list_error (tree2);
6515 }
6516 }
6517 }
6518
6519 if (CONSP (tree1) || CONSP (tree2))
6520 {
6521 UNGCPRO;
6522 return 0;
6523 }
6524
6525 result = check_test (test, key, tree1, tree2) == test_not_unboundp;
6526 UNGCPRO;
6527
6528 return result;
6529 }
6530
6531 DEFUN ("tree-equal", Ftree_equal, 2, MANY, 0, /*
6532 Return t if TREE1 and TREE2 have `eql' leaves.
6533
6534 Atoms are compared by `eql', unless another test is specified using
6535 :test; cons cells are compared recursively.
6536
6537 See `union' for the meaning of :test, :test-not and :key.
6538
6539 arguments: (TREE1 TREE2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
6540 */
6541 (int nargs, Lisp_Object *args))
6542 {
6543 Lisp_Object tree1 = args[0], tree2 = args[1];
6544 Boolint test_not_unboundp = 1;
6545 check_test_func_t check_test = NULL;
6546
6547 PARSE_KEYWORDS (Ftree_equal, nargs, args, 3, (test, key, test_not),
6548 (key = Qidentity));
6549
6550 get_check_match_function (&test, test_not, Qnil, Qnil, key,
6551 &test_not_unboundp, &check_test);
6552
6553 return tree_equal (tree1, tree2, check_test, test_not_unboundp, test, key,
6554 0) ? Qt : Qnil;
6555 }
6556
6557 static Lisp_Object
6558 mismatch_from_end (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
6559 Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
6560 check_test_func_t check_match, Boolint test_not_unboundp,
6561 Lisp_Object test, Lisp_Object key,
6562 Boolint UNUSED (return_sequence1_index))
6563 {
6564 Elemcount sequence1_len = XFIXNUM (Flength (sequence1));
6565 Elemcount sequence2_len = XFIXNUM (Flength (sequence2)), ii = 0;
6566 Elemcount starting1, ending1, starting2, ending2;
6567 Lisp_Object *sequence1_storage = NULL, *sequence2_storage = NULL;
6568 struct gcpro gcpro1, gcpro2;
6569
6570 check_sequence_range (sequence1, start1, end1, make_fixnum (sequence1_len));
6571 starting1 = XFIXNUM (start1);
6572 ending1 = FIXNUMP (end1) ? XFIXNUM (end1) : 1 + MOST_POSITIVE_FIXNUM;
6573 ending1 = min (ending1, sequence1_len);
6574
6575 check_sequence_range (sequence2, start2, end2, make_fixnum (sequence2_len));
6576 starting2 = XFIXNUM (start2);
6577 ending2 = FIXNUMP (end2) ? XFIXNUM (end2) : 1 + MOST_POSITIVE_FIXNUM;
6578 ending2 = min (ending2, sequence2_len);
6579
6580 if (LISTP (sequence1))
6581 {
6582 Lisp_Object *saving;
6583 sequence1_storage = saving
6584 = alloca_array (Lisp_Object, ending1 - starting1);
6585
6586 {
6587 EXTERNAL_LIST_LOOP_2 (elt, sequence1)
6588 {
6589 if (starting1 <= ii && ii < ending1)
6590 {
6591 *saving++ = elt;
6592 }
6593 else if (ii == ending1)
6594 {
6595 break;
6596 }
6597
6598 ++ii;
6599 }
6600 }
6601 }
6602 else if (STRINGP (sequence1))
6603 {
6604 const Ibyte *cursor = string_char_addr (sequence1, starting1);
6605
6606 STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence1_storage, ii,
6607 ending1 - starting1);
6608
6609 }
6610 else if (BIT_VECTORP (sequence1))
6611 {
6612 Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence1);
6613 sequence1_storage = alloca_array (Lisp_Object, ending1 - starting1);
6614 for (ii = starting1; ii < ending1; ++ii)
6615 {
6616 sequence1_storage[ii - starting1]
6617 = make_fixnum (bit_vector_bit (vv, ii));
6618 }
6619 }
6620 else
6621 {
6622 sequence1_storage = XVECTOR_DATA (sequence1) + starting1;
6623 }
6624
6625 ii = 0;
6626
6627 if (LISTP (sequence2))
6628 {
6629 Lisp_Object *saving;
6630 sequence2_storage = saving
6631 = alloca_array (Lisp_Object, ending2 - starting2);
6632
6633 {
6634 EXTERNAL_LIST_LOOP_2 (elt, sequence2)
6635 {
6636 if (starting2 <= ii && ii < ending2)
6637 {
6638 *saving++ = elt;
6639 }
6640 else if (ii == ending2)
6641 {
6642 break;
6643 }
6644
6645 ++ii;
6646 }
6647 }
6648 }
6649 else if (STRINGP (sequence2))
6650 {
6651 const Ibyte *cursor = string_char_addr (sequence2, starting2);
6652
6653 STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence2_storage, ii,
6654 ending2 - starting2);
6655
6656 }
6657 else if (BIT_VECTORP (sequence2))
6658 {
6659 Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence2);
6660 sequence2_storage = alloca_array (Lisp_Object, ending2 - starting2);
6661 for (ii = starting2; ii < ending2; ++ii)
6662 {
6663 sequence2_storage[ii - starting2]
6664 = make_fixnum (bit_vector_bit (vv, ii));
6665 }
6666 }
6667 else
6668 {
6669 sequence2_storage = XVECTOR_DATA (sequence2) + starting2;
6670 }
6671
6672 GCPRO2 (sequence1_storage[0], sequence2_storage[0]);
6673 gcpro1.nvars = ending1 - starting1;
6674 gcpro2.nvars = ending2 - starting2;
6675
6676 while (ending1 > starting1 && ending2 > starting2)
6677 {
6678 --ending1;
6679 --ending2;
6680
6681 if (check_match (test, key, sequence1_storage[ending1 - starting1],
6682 sequence2_storage[ending2 - starting2])
6683 != test_not_unboundp)
6684 {
6685 UNGCPRO;
6686 return make_integer (ending1 + 1);
6687 }
6688 }
6689
6690 UNGCPRO;
6691
6692 if (ending1 > starting1 || ending2 > starting2)
6693 {
6694 return make_integer (ending1);
6695 }
6696
6697 return Qnil;
6698 }
6699
6700 static Lisp_Object
6701 mismatch_list_list (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
6702 Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
6703 check_test_func_t check_match, Boolint test_not_unboundp,
6704 Lisp_Object test, Lisp_Object key,
6705 Boolint UNUSED (return_list_index))
6706 {
6707 Lisp_Object sequence1_tortoise = sequence1, sequence2_tortoise = sequence2;
6708 Lisp_Object orig_sequence1 = sequence1, orig_sequence2 = sequence2;
6709 Elemcount ending1 = MOST_POSITIVE_FIXNUM, ending2 = MOST_POSITIVE_FIXNUM;
6710 Elemcount starting1, starting2, counting, startcounting;
6711 Elemcount shortest_len = 0;
6712 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
6713
6714 starting1 = FIXNUMP (start1) ? XFIXNUM (start1) : 1 + MOST_POSITIVE_FIXNUM;
6715 starting2 = FIXNUMP (start2) ? XFIXNUM (start2) : 1 + MOST_POSITIVE_FIXNUM;
6716
6717 if (!NILP (end1))
6718 {
6719 ending1 = FIXNUMP (end1) ? XFIXNUM (end1) : 1 + MOST_POSITIVE_FIXNUM;
6720 }
6721
6722 if (!NILP (end2))
6723 {
6724 ending2 = FIXNUMP (end2) ? XFIXNUM (end2) : 1 + MOST_POSITIVE_FIXNUM;
6725 }
6726
6727 if (!ZEROP (start1))
6728 {
6729 sequence1 = Fnthcdr (start1, sequence1);
6730
6731 if (NILP (sequence1))
6732 {
6733 check_sequence_range (sequence1_tortoise, start1, end1,
6734 Flength (sequence1_tortoise));
6735 /* Give up early here. */
6736 return Qnil;
6737 }
6738
6739 ending1 -= starting1;
6740 starting1 = 0;
6741 sequence1_tortoise = sequence1;
6742 }
6743
6744 if (!ZEROP (start2))
6745 {
6746 sequence2 = Fnthcdr (start2, sequence2);
6747
6748 if (NILP (sequence2))
6749 {
6750 check_sequence_range (sequence2_tortoise, start2, end2,
6751 Flength (sequence2_tortoise));
6752 return Qnil;
6753 }
6754
6755 ending2 -= starting2;
6756 starting2 = 0;
6757 sequence2_tortoise = sequence2;
6758 }
6759
6760 GCPRO4 (sequence1, sequence2, sequence1_tortoise, sequence2_tortoise);
6761
6762 counting = startcounting = min (ending1, ending2);
6763
6764 while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2))
6765 {
6766 if (check_match (test, key,
6767 CONSP (sequence1) ? XCAR (sequence1)
6768 : Fcar (sequence1),
6769 CONSP (sequence2) ? XCAR (sequence2)
6770 : Fcar (sequence2) ) != test_not_unboundp)
6771 {
6772 UNGCPRO;
6773 return make_integer (XFIXNUM (start1) + shortest_len);
6774 }
6775
6776 sequence1 = CONSP (sequence1) ? XCDR (sequence1) : Fcdr (sequence1);
6777 sequence2 = CONSP (sequence2) ? XCDR (sequence2) : Fcdr (sequence2);
6778
6779 shortest_len++;
6780
6781 if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH)
6782 {
6783 if (counting & 1)
6784 {
6785 sequence1_tortoise = XCDR (sequence1_tortoise);
6786 sequence2_tortoise = XCDR (sequence2_tortoise);
6787 }
6788
6789 if (EQ (sequence1, sequence1_tortoise))
6790 {
6791 signal_circular_list_error (sequence1);
6792 }
6793
6794 if (EQ (sequence2, sequence2_tortoise))
6795 {
6796 signal_circular_list_error (sequence2);
6797 }
6798 }
6799 }
6800
6801 UNGCPRO;
6802
6803 if (NILP (sequence1))
6804 {
6805 Lisp_Object args[] = { start1, make_fixnum (shortest_len) };
6806 check_sequence_range (orig_sequence1, start1, end1,
6807 Fplus (countof (args), args));
6808 }
6809
6810 if (NILP (sequence2))
6811 {
6812 Lisp_Object args[] = { start2, make_fixnum (shortest_len) };
6813 check_sequence_range (orig_sequence2, start2, end2,
6814 Fplus (countof (args), args));
6815 }
6816
6817 if ((!NILP (end1) && shortest_len != ending1 - starting1) ||
6818 (!NILP (end2) && shortest_len != ending2 - starting2))
6819 {
6820 return make_integer (XFIXNUM (start1) + shortest_len);
6821 }
6822
6823 if ((NILP (end1) && CONSP (sequence1)) || (NILP (end2) && CONSP (sequence2)))
6824 {
6825 return make_integer (XFIXNUM (start1) + shortest_len);
6826 }
6827
6828 return Qnil;
6829 }
6830
6831 static Lisp_Object
6832 mismatch_list_string (Lisp_Object list, Lisp_Object list_start,
6833 Lisp_Object list_end,
6834 Lisp_Object string, Lisp_Object string_start,
6835 Lisp_Object string_end,
6836 check_test_func_t check_match,
6837 Boolint test_not_unboundp,
6838 Lisp_Object test, Lisp_Object key,
6839 Boolint return_list_index)
6840 {
6841 Ibyte *string_data = XSTRING_DATA (string), *startp = string_data;
6842 Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string);
6843 Elemcount char_count = 0, list_starting, list_ending;
6844 Elemcount string_starting, string_ending;
6845 Lisp_Object character, orig_list = list;
6846 struct gcpro gcpro1;
6847
6848 list_ending = FIXNUMP (list_end) ? XFIXNUM (list_end) : 1 + MOST_POSITIVE_FIXNUM;
6849 list_starting = FIXNUMP (list_start) ? XFIXNUM (list_start) : 1 + MOST_POSITIVE_FIXNUM;
6850
6851 string_ending = FIXNUMP (string_end) ? XFIXNUM (string_end) : 1 + MOST_POSITIVE_FIXNUM;
6852 string_starting
6853 = FIXNUMP (string_start) ? XFIXNUM (string_start) : 1 + MOST_POSITIVE_FIXNUM;
6854
6855 while (char_count < string_starting && string_offset < string_len)
6856 {
6857 INC_IBYTEPTR (string_data);
6858 string_offset = string_data - startp;
6859 char_count++;
6860 }
6861
6862 if (!ZEROP (list_start))
6863 {
6864 list = Fnthcdr (list_start, list);
6865 if (NILP (list))
6866 {
6867 check_sequence_range (orig_list, list_start, list_end,
6868 Flength (orig_list));
6869 return Qnil;
6870 }
6871
6872 list_ending -= list_starting;
6873 list_starting = 0;
6874 }
6875
6876 GCPRO1 (list);
6877
6878 while (list_starting < list_ending && string_starting < string_ending
6879 && string_offset < string_len && !NILP (list))
6880 {
6881 character = make_char (itext_ichar (string_data));
6882
6883 if (return_list_index)
6884 {
6885 if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list),
6886 character)
6887 != test_not_unboundp)
6888 {
6889 UNGCPRO;
6890 return make_integer (XFIXNUM (list_start) + char_count);
6891 }
6892 }
6893 else
6894 {
6895 if (check_match (test, key, character,
6896 CONSP (list) ? XCAR (list) : Fcar (list))
6897 != test_not_unboundp)
6898 {
6899 UNGCPRO;
6900 return make_integer (char_count);
6901 }
6902 }
6903
6904 list = CONSP (list) ? XCDR (list) : Fcdr (list);
6905
6906 startp = XSTRING_DATA (string);
6907 string_data = startp + string_offset;
6908 if (string_len != XSTRING_LENGTH (string)
6909 || !valid_ibyteptr_p (string_data))
6910 {
6911 mapping_interaction_error (Qmismatch, string);
6912 }
6913
6914 list_starting++;
6915 string_starting++;
6916 char_count++;
6917 INC_IBYTEPTR (string_data);
6918 string_offset = string_data - startp;
6919 }
6920
6921 UNGCPRO;
6922
6923 if (NILP (list))
6924 {
6925 Lisp_Object args[] = { list_start, make_fixnum (char_count) };
6926 check_sequence_range (orig_list, list_start, list_end,
6927 Fplus (countof (args), args));
6928 }
6929
6930 if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string))
6931 {
6932 check_sequence_range (string, string_start, string_end,
6933 make_fixnum (char_count));
6934 }
6935
6936 if ((NILP (string_end) ?
6937 string_offset < string_len : string_starting < string_ending) ||
6938 (NILP (list_end) ? !NILP (list) : list_starting < list_ending))
6939 {
6940 return make_integer (return_list_index ? XFIXNUM (list_start) + char_count :
6941 char_count);
6942 }
6943
6944 return Qnil;
6945 }
6946
6947 static Lisp_Object
6948 mismatch_list_array (Lisp_Object list, Lisp_Object list_start,
6949 Lisp_Object list_end,
6950 Lisp_Object array, Lisp_Object array_start,
6951 Lisp_Object array_end,
6952 check_test_func_t check_match,
6953 Boolint test_not_unboundp,
6954 Lisp_Object test, Lisp_Object key,
6955 Boolint return_list_index)
6956 {
6957 Elemcount ii = 0, list_starting, list_ending;
6958 Elemcount array_starting, array_ending, array_len;
6959 Lisp_Object orig_list = list;
6960 struct gcpro gcpro1;
6961
6962 list_ending = FIXNUMP (list_end) ? XFIXNUM (list_end) : 1 + MOST_POSITIVE_FIXNUM;
6963 list_starting = FIXNUMP (list_start) ? XFIXNUM (list_start) : 1 + MOST_POSITIVE_FIXNUM;
6964
6965 array_ending = FIXNUMP (array_end) ? XFIXNUM (array_end) : 1 + MOST_POSITIVE_FIXNUM;
6966 array_starting = FIXNUMP (array_start) ? XFIXNUM (array_start) : 1 + MOST_POSITIVE_FIXNUM;
6967 array_len = XFIXNUM (Flength (array));
6968
6969 array_ending = min (array_ending, array_len);
6970
6971 check_sequence_range (array, array_start, array_end, make_fixnum (array_len));
6972
6973 if (!ZEROP (list_start))
6974 {
6975 list = Fnthcdr (list_start, list);
6976 if (NILP (list))
6977 {
6978 check_sequence_range (orig_list, list_start, list_end,
6979 Flength (orig_list));
6980 return Qnil;
6981 }
6982
6983 list_ending -= list_starting;
6984 list_starting = 0;
6985 }
6986
6987 GCPRO1 (list);
6988
6989 while (list_starting < list_ending && array_starting < array_ending
6990 && !NILP (list))
6991 {
6992 if (return_list_index)
6993 {
6994 if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list),
6995 Faref (array, make_fixnum (array_starting)))
6996 != test_not_unboundp)
6997 {
6998 UNGCPRO;
6999 return make_integer (XFIXNUM (list_start) + ii);
7000 }
7001 }
7002 else
7003 {
7004 if (check_match (test, key, Faref (array, make_fixnum (array_starting)),
7005 CONSP (list) ? XCAR (list) : Fcar (list))
7006 != test_not_unboundp)
7007 {
7008 UNGCPRO;
7009 return make_integer (array_starting);
7010 }
7011 }
7012
7013 list = CONSP (list) ? XCDR (list) : Fcdr (list);
7014 list_starting++;
7015 array_starting++;
7016 ii++;
7017 }
7018
7019 UNGCPRO;
7020
7021 if (NILP (list))
7022 {
7023 Lisp_Object args[] = { list_start, make_fixnum (ii) };
7024 check_sequence_range (orig_list, list_start, list_end,
7025 Fplus (countof (args), args));
7026 }
7027
7028 if (array_starting < array_ending ||
7029 (NILP (list_end) ? !NILP (list) : list_starting < list_ending))
7030 {
7031 return make_integer (return_list_index ? XFIXNUM (list_start) + ii :
7032 array_starting);
7033 }
7034
7035 return Qnil;
7036 }
7037
7038 static Lisp_Object
7039 mismatch_string_array (Lisp_Object string, Lisp_Object string_start,
7040 Lisp_Object string_end,
7041 Lisp_Object array, Lisp_Object array_start,
7042 Lisp_Object array_end,
7043 check_test_func_t check_match, Boolint test_not_unboundp,
7044 Lisp_Object test, Lisp_Object key,
7045 Boolint return_string_index)
7046 {
7047 Ibyte *string_data = XSTRING_DATA (string), *startp = string_data;
7048 Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string);
7049 Elemcount char_count = 0, array_starting, array_ending, array_length;
7050 Elemcount string_starting, string_ending;
7051 Lisp_Object character;
7052
7053 array_starting = FIXNUMP (array_start) ? XFIXNUM (array_start) : 1 + MOST_POSITIVE_FIXNUM;
7054 array_ending = FIXNUMP (array_end) ? XFIXNUM (array_end) : 1 + MOST_POSITIVE_FIXNUM;
7055 array_length = XFIXNUM (Flength (array));
7056 check_sequence_range (array, array_start, array_end, make_fixnum (array_length));
7057 array_ending = min (array_ending, array_length);
7058
7059 string_ending = FIXNUMP (string_end) ? XFIXNUM (string_end) : 1 + MOST_POSITIVE_FIXNUM;
7060 string_starting
7061 = FIXNUMP (string_start) ? XFIXNUM (string_start) : 1 + MOST_POSITIVE_FIXNUM;
7062
7063 while (char_count < string_starting && string_offset < string_len)
7064 {
7065 INC_IBYTEPTR (string_data);
7066 string_offset = string_data - startp;
7067 char_count++;
7068 }
7069
7070 while (array_starting < array_ending && string_starting < string_ending
7071 && string_offset < string_len)
7072 {
7073 character = make_char (itext_ichar (string_data));
7074
7075 if (return_string_index)
7076 {
7077 if (check_match (test, key, character,
7078 Faref (array, make_fixnum (array_starting)))
7079 != test_not_unboundp)
7080 {
7081 return make_integer (char_count);
7082 }
7083 }
7084 else
7085 {
7086 if (check_match (test, key,
7087 Faref (array, make_fixnum (array_starting)),
7088 character)
7089 != test_not_unboundp)
7090 {
7091 return make_integer (XFIXNUM (array_start) + char_count);
7092 }
7093 }
7094
7095 startp = XSTRING_DATA (string);
7096 string_data = startp + string_offset;
7097 if (string_len != XSTRING_LENGTH (string)
7098 || !valid_ibyteptr_p (string_data))
7099 {
7100 mapping_interaction_error (Qmismatch, string);
7101 }
7102
7103 array_starting++;
7104 string_starting++;
7105 char_count++;
7106 INC_IBYTEPTR (string_data);
7107 string_offset = string_data - startp;
7108 }
7109
7110 if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string))
7111 {
7112 check_sequence_range (string, string_start, string_end,
7113 make_fixnum (char_count));
7114 }
7115
7116 if ((NILP (string_end) ?
7117 string_offset < string_len : string_starting < string_ending) ||
7118 (NILP (array_end) ? !NILP (array) : array_starting < array_ending))
7119 {
7120 return make_integer (return_string_index ? char_count :
7121 XFIXNUM (array_start) + char_count);
7122 }
7123
7124 return Qnil;
7125 }
7126
7127 static Lisp_Object
7128 mismatch_string_string (Lisp_Object string1,
7129 Lisp_Object string1_start, Lisp_Object string1_end,
7130 Lisp_Object string2, Lisp_Object string2_start,
7131 Lisp_Object string2_end,
7132 check_test_func_t check_match,
7133 Boolint test_not_unboundp,
7134 Lisp_Object test, Lisp_Object key,
7135 Boolint UNUSED (return_string1_index))
7136 {
7137 Ibyte *string1_data = XSTRING_DATA (string1), *startp1 = string1_data;
7138 Bytecount string1_offset = 0, string1_len = XSTRING_LENGTH (string1);
7139 Ibyte *string2_data = XSTRING_DATA (string2), *startp2 = string2_data;
7140 Bytecount string2_offset = 0, string2_len = XSTRING_LENGTH (string2);
7141 Elemcount char_count1 = 0, string1_starting, string1_ending;
7142 Elemcount char_count2 = 0, string2_starting, string2_ending;
7143 Lisp_Object character1, character2;
7144
7145 string1_ending = FIXNUMP (string1_end) ? XFIXNUM (string1_end) : 1 + MOST_POSITIVE_FIXNUM;
7146 string1_starting
7147 = FIXNUMP (string1_start) ? XFIXNUM (string1_start) : 1 + MOST_POSITIVE_FIXNUM;
7148
7149 string2_starting
7150 = FIXNUMP (string2_start) ? XFIXNUM (string2_start) : 1 + MOST_POSITIVE_FIXNUM;
7151 string2_ending = FIXNUMP (string2_end) ? XFIXNUM (string2_end) : 1 + MOST_POSITIVE_FIXNUM;
7152
7153 while (char_count1 < string1_starting && string1_offset < string1_len)
7154 {
7155 INC_IBYTEPTR (string1_data);
7156 string1_offset = string1_data - startp1;
7157 char_count1++;
7158 }
7159
7160 while (char_count2 < string2_starting && string2_offset < string2_len)
7161 {
7162 INC_IBYTEPTR (string2_data);
7163 string2_offset = string2_data - startp2;
7164 char_count2++;
7165 }
7166
7167 while (string2_starting < string2_ending && string1_starting < string1_ending
7168 && string1_offset < string1_len && string2_offset < string2_len)
7169 {
7170 character1 = make_char (itext_ichar (string1_data));
7171 character2 = make_char (itext_ichar (string2_data));
7172
7173 if (check_match (test, key, character1, character2)
7174 != test_not_unboundp)
7175 {
7176 return make_integer (char_count1);
7177 }
7178
7179 startp1 = XSTRING_DATA (string1);
7180 string1_data = startp1 + string1_offset;
7181 if (string1_len != XSTRING_LENGTH (string1)
7182 || !valid_ibyteptr_p (string1_data))
7183 {
7184 mapping_interaction_error (Qmismatch, string1);
7185 }
7186
7187 startp2 = XSTRING_DATA (string2);
7188 string2_data = startp2 + string2_offset;
7189 if (string2_len != XSTRING_LENGTH (string2)
7190 || !valid_ibyteptr_p (string2_data))
7191 {
7192 mapping_interaction_error (Qmismatch, string2);
7193 }
7194
7195 string2_starting++;
7196 string1_starting++;
7197 char_count1++;
7198 char_count2++;
7199 INC_IBYTEPTR (string1_data);
7200 string1_offset = string1_data - startp1;
7201 INC_IBYTEPTR (string2_data);
7202 string2_offset = string2_data - startp2;
7203 }
7204
7205 if (string1_data == XSTRING_DATA (string1) + XSTRING_LENGTH (string1))
7206 {
7207 check_sequence_range (string1, string1_start, string1_end,
7208 make_fixnum (char_count1));
7209 }
7210
7211 if (string2_data == XSTRING_DATA (string2) + XSTRING_LENGTH (string2))
7212 {
7213 check_sequence_range (string2, string2_start, string2_end,
7214 make_fixnum (char_count2));
7215 }
7216
7217 if ((!NILP (string1_end) && string1_starting < string1_ending) ||
7218 (!NILP (string2_end) && string2_starting < string2_ending))
7219 {
7220 return make_integer (char_count1);
7221 }
7222
7223 if ((NILP (string1_end) && string1_data
7224 < (XSTRING_DATA (string1) + XSTRING_LENGTH (string1))) ||
7225 (NILP (string2_end) && string2_data
7226 < (XSTRING_DATA (string2) + XSTRING_LENGTH (string2))))
7227 {
7228 return make_integer (char_count1);
7229 }
7230
7231 return Qnil;
7232 }
7233
7234 static Lisp_Object
7235 mismatch_array_array (Lisp_Object array1, Lisp_Object start1, Lisp_Object end1,
7236 Lisp_Object array2, Lisp_Object start2, Lisp_Object end2,
7237 check_test_func_t check_match, Boolint test_not_unboundp,
7238 Lisp_Object test, Lisp_Object key,
7239 Boolint UNUSED (return_array1_index))
7240 {
7241 Elemcount len1 = XFIXNUM (Flength (array1)), len2 = XFIXNUM (Flength (array2));
7242 Elemcount ending1 = MOST_POSITIVE_FIXNUM, ending2 = MOST_POSITIVE_FIXNUM;
7243 Elemcount starting1, starting2;
7244
7245 check_sequence_range (array1, start1, end1, make_fixnum (len1));
7246 check_sequence_range (array2, start2, end2, make_fixnum (len2));
7247
7248 starting1 = FIXNUMP (start1) ? XFIXNUM (start1) : 1 + MOST_POSITIVE_FIXNUM;
7249 starting2 = FIXNUMP (start2) ? XFIXNUM (start2) : 1 + MOST_POSITIVE_FIXNUM;
7250
7251 if (!NILP (end1))
7252 {
7253 ending1 = FIXNUMP (end1) ? XFIXNUM (end1) : 1 + MOST_POSITIVE_FIXNUM;
7254 }
7255
7256 if (!NILP (end2))
7257 {
7258 ending2 = FIXNUMP (end2) ? XFIXNUM (end2) : 1 + MOST_POSITIVE_FIXNUM;
7259 }
7260
7261 ending1 = min (ending1, len1);
7262 ending2 = min (ending2, len2);
7263
7264 while (starting1 < ending1 && starting2 < ending2)
7265 {
7266 if (check_match (test, key, Faref (array1, make_fixnum (starting1)),
7267 Faref (array2, make_fixnum (starting2)))
7268 != test_not_unboundp)
7269 {
7270 return make_integer (starting1);
7271 }
7272 starting1++;
7273 starting2++;
7274 }
7275
7276 if (starting1 < ending1 || starting2 < ending2)
7277 {
7278 return make_integer (starting1);
7279 }
7280
7281 return Qnil;
7282 }
7283
7284 typedef Lisp_Object
7285 (*mismatch_func_t) (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1,
7286 Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2,
7287 check_test_func_t check_match, Boolint test_not_unboundp,
7288 Lisp_Object test, Lisp_Object key,
7289 Boolint return_list_index);
7290
7291 static mismatch_func_t
7292 get_mismatch_func (Lisp_Object sequence1, Lisp_Object sequence2,
7293 Lisp_Object from_end, Boolint *return_sequence1_index_out)
7294 {
7295 CHECK_SEQUENCE (sequence1);
7296 CHECK_SEQUENCE (sequence2);
7297
7298 if (!NILP (from_end))
7299 {
7300 *return_sequence1_index_out = 1;
7301 return mismatch_from_end;
7302 }
7303
7304 if (LISTP (sequence1))
7305 {
7306 if (LISTP (sequence2))
7307 {
7308 *return_sequence1_index_out = 1;
7309 return mismatch_list_list;
7310 }
7311
7312 if (STRINGP (sequence2))
7313 {
7314 *return_sequence1_index_out = 1;
7315 return mismatch_list_string;
7316 }
7317
7318 *return_sequence1_index_out = 1;
7319 return mismatch_list_array;
7320 }
7321
7322 if (STRINGP (sequence1))
7323 {
7324 if (STRINGP (sequence2))
7325 {
7326 *return_sequence1_index_out = 1;
7327 return mismatch_string_string;
7328 }
7329
7330 if (LISTP (sequence2))
7331 {
7332 *return_sequence1_index_out = 0;
7333 return mismatch_list_string;
7334 }
7335
7336 *return_sequence1_index_out = 1;
7337 return mismatch_string_array;
7338 }
7339
7340 if (ARRAYP (sequence1))
7341 {
7342 if (STRINGP (sequence2))
7343 {
7344 *return_sequence1_index_out = 0;
7345 return mismatch_string_array;
7346 }
7347
7348 if (LISTP (sequence2))
7349 {
7350 *return_sequence1_index_out = 0;
7351 return mismatch_list_array;
7352 }
7353
7354 *return_sequence1_index_out = 1;
7355 return mismatch_array_array;
7356 }
7357
7358 RETURN_NOT_REACHED (NULL);
7359 return NULL;
7360 }
7361
7362 DEFUN ("mismatch", Fmismatch, 2, MANY, 0, /*
7363 Compare SEQUENCE1 with SEQUENCE2, return index of first mismatching element.
7364
7365 Return nil if the sequences match. If one sequence is a prefix of the
7366 other, the return value indicates the end of the shorter sequence. A
7367 non-nil return value always reflects an index into SEQUENCE1.
7368
7369 See `search' for the meaning of the keywords."
7370
7371 arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT)
7372 */
7373 (int nargs, Lisp_Object *args))
7374 {
7375 Lisp_Object sequence1 = args[0], sequence2 = args[1];
7376 Boolint test_not_unboundp = 1, return_first_index = 0;
7377 check_test_func_t check_match = NULL;
7378 mismatch_func_t mismatch = NULL;
7379
7380 PARSE_KEYWORDS (Fmismatch, nargs, args, 8,
7381 (test, key, from_end, start1, end1, start2, end2, test_not),
7382 (start1 = start2 = Qzero));
7383
7384 CHECK_SEQUENCE (sequence1);
7385 CHECK_SEQUENCE (sequence2);
7386
7387 CHECK_NATNUM (start1);
7388 CHECK_NATNUM (start2);
7389
7390 if (!NILP (end1))
7391 {
7392 CHECK_NATNUM (end1);
7393 }
7394
7395 if (!NILP (end2))
7396 {
7397 CHECK_NATNUM (end2);
7398 }
7399
7400 check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
7401 &test_not_unboundp, NULL);
7402 mismatch = get_mismatch_func (sequence1, sequence2, from_end,
7403 &return_first_index);
7404
7405 if (return_first_index)
7406 {
7407 return mismatch (sequence1, start1, end1, sequence2, start2, end2,
7408 check_match, test_not_unboundp, test, key, 1);
7409 }
7410
7411 return mismatch (sequence2, start2, end2, sequence1, start1, end1,
7412 check_match, test_not_unboundp, test, key, 0);
7413 }
7414
7415 DEFUN ("search", Fsearch, 2, MANY, 0, /*
7416 Search for SEQUENCE1 as a subsequence of SEQUENCE2.
7417
7418 Return the index of the leftmost element of the first match found; return
7419 nil if there are no matches.
7420
7421 In this function, :start1 and :end1 specify a subsequence of SEQUENCE1, and
7422 :start2 and :end2 specify a subsequence of SEQUENCE2. See `remove*' for
7423 details of the other keywords.
7424
7425 arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT)
7426 */
7427 (int nargs, Lisp_Object *args))
7428 {
7429 Lisp_Object sequence1 = args[0], sequence2 = args[1], position0 = Qnil;
7430 Boolint test_not_unboundp = 1, return_first = 0;
7431 check_test_func_t check_test = NULL, check_match = NULL;
7432 mismatch_func_t mismatch = NULL;
7433 Elemcount starting1 = 0, ending1 = 1 + MOST_POSITIVE_FIXNUM, starting2 = 0;
7434 Elemcount ending2 = 1 + MOST_POSITIVE_FIXNUM, ii = 0;
7435 Elemcount length1;
7436 Lisp_Object object = Qnil;
7437 struct gcpro gcpro1, gcpro2;
7438
7439 PARSE_KEYWORDS (Fsearch, nargs, args, 8,
7440 (test, key, from_end, start1, end1, start2, end2, test_not),
7441 (start1 = start2 = Qzero));
7442
7443 CHECK_SEQUENCE (sequence1);
7444 CHECK_SEQUENCE (sequence2);
7445 CHECK_KEY_ARGUMENT (key);
7446
7447 CHECK_NATNUM (start1);
7448 starting1 = FIXNUMP (start1) ? XFIXNUM (start1) : 1 + MOST_POSITIVE_FIXNUM;
7449 CHECK_NATNUM (start2);
7450 starting2 = FIXNUMP (start2) ? XFIXNUM (start2) : 1 + MOST_POSITIVE_FIXNUM;
7451
7452 if (!NILP (end1))
7453 {
7454 Lisp_Object len1 = Flength (sequence1);
7455
7456 CHECK_NATNUM (end1);
7457 check_sequence_range (sequence1, start1, end1, len1);
7458 ending1 = min (XFIXNUM (end1), XFIXNUM (len1));
7459 }
7460 else
7461 {
7462 end1 = Flength (sequence1);
7463 check_sequence_range (sequence1, start1, end1, end1);
7464 ending1 = XFIXNUM (end1);
7465 }
7466
7467 length1 = ending1 - starting1;
7468
7469 if (!NILP (end2))
7470 {
7471 Lisp_Object len2 = Flength (sequence2);
7472
7473 CHECK_NATNUM (end2);
7474 check_sequence_range (sequence2, start2, end2, len2);
7475 ending2 = min (XFIXNUM (end2), XFIXNUM (len2));
7476 }
7477 else
7478 {
7479 end2 = Flength (sequence2);
7480 check_sequence_range (sequence2, start2, end2, end2);
7481 ending2 = XFIXNUM (end2);
7482 }
7483
7484 check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
7485 &test_not_unboundp, &check_test);
7486 mismatch = get_mismatch_func (sequence1, sequence2, from_end, &return_first);
7487
7488 if (bytecode_arithcompare (start1, make_integer (ending1)) >= 0)
7489 {
7490 if (NILP (from_end))
7491 {
7492 return start2;
7493 }
7494
7495 if (NILP (end2))
7496 {
7497 return Flength (sequence2);
7498 }
7499
7500 return end2;
7501 }
7502
7503 if (NILP (from_end))
7504 {
7505 Lisp_Object mismatch_start1 = Fadd1 (start1);
7506 Lisp_Object first = KEY (key, Felt (sequence1, start1));
7507 GCPRO2 (first, mismatch_start1);
7508
7509 ii = starting2;
7510 while (ii < ending2)
7511 {
7512 position0 = position (&object, first, sequence2, check_test,
7513 test_not_unboundp, test, key, make_fixnum (ii),
7514 end2, Qnil, Qnil, Qsearch);
7515 if (NILP (position0))
7516 {
7517 UNGCPRO;
7518 return Qnil;
7519 }
7520
7521 if (length1 + XFIXNUM (position0) <= ending2 &&
7522 (return_first ?
7523 NILP (mismatch (sequence1, mismatch_start1, end1,
7524 sequence2,
7525 make_fixnum (1 + XFIXNUM (position0)),
7526 make_fixnum (length1 + XFIXNUM (position0)),
7527 check_match, test_not_unboundp, test, key, 1)) :
7528 NILP (mismatch (sequence2,
7529 make_fixnum (1 + XFIXNUM (position0)),
7530 make_fixnum (length1 + XFIXNUM (position0)),
7531 sequence1, mismatch_start1, end1,
7532 check_match, test_not_unboundp, test, key, 0))))
7533
7534
7535 {
7536 UNGCPRO;
7537 return position0;
7538 }
7539
7540 ii = XFIXNUM (position0) + 1;
7541 }
7542
7543 UNGCPRO;
7544 }
7545 else
7546 {
7547 Lisp_Object mismatch_end1 = make_integer (ending1 - 1);
7548 Lisp_Object last = KEY (key, Felt (sequence1, mismatch_end1));
7549 GCPRO2 (last, mismatch_end1);
7550
7551 ii = ending2;
7552 while (ii > starting2)
7553 {
7554 position0 = position (&object, last, sequence2, check_test,
7555 test_not_unboundp, test, key, start2,
7556 make_fixnum (ii), Qt, Qnil, Qsearch);
7557
7558 if (NILP (position0))
7559 {
7560 UNGCPRO;
7561 return Qnil;
7562 }
7563
7564 if (XFIXNUM (position0) - length1 + 1 >= starting2 &&
7565 (return_first ?
7566 NILP (mismatch (sequence1, start1, mismatch_end1,
7567 sequence2,
7568 make_fixnum (XFIXNUM (position0) - length1 + 1),
7569 make_fixnum (XFIXNUM (position0)),
7570 check_match, test_not_unboundp, test, key, 1)) :
7571 NILP (mismatch (sequence2,
7572 make_fixnum (XFIXNUM (position0) - length1 + 1),
7573 make_fixnum (XFIXNUM (position0)),
7574 sequence1, start1, mismatch_end1,
7575 check_match, test_not_unboundp, test, key, 0))))
7576 {
7577 UNGCPRO;
7578 return make_fixnum (XFIXNUM (position0) - length1 + 1);
7579 }
7580
7581 ii = XFIXNUM (position0);
7582 }
7583
7584 UNGCPRO;
7585 }
7586
7587 return Qnil;
7588 }
7589
7590 /* These two functions do set operations, those that can be visualised with
7591 Venn diagrams. */
7592 static Lisp_Object
7593 venn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp)
7594 {
7595 Lisp_Object liszt1 = args[0], liszt2 = args[1];
7596 Lisp_Object result = EQ (caller, Qsubsetp) ? Qt : Qnil, result_tail = Qnil;
7597 Lisp_Object keyed = Qnil, ignore = Qnil;
7598 Boolint test_not_unboundp = 1;
7599 check_test_func_t check_test = NULL;
7600 struct gcpro gcpro1, gcpro2;
7601
7602 PARSE_KEYWORDS_8 (caller, nargs, args, 4, (test, key, test_not, stable),
7603 NULL, 2, 0);
7604
7605 CHECK_LIST (liszt1);
7606 CHECK_LIST (liszt2);
7607
7608 CHECK_KEY_ARGUMENT (key);
7609
7610 if (NILP (liszt1) && intersectionp)
7611 {
7612 return Qnil;
7613 }
7614
7615 if (NILP (liszt2))
7616 {
7617 return intersectionp ? Qnil : liszt1;
7618 }
7619
7620 get_check_match_function (&test, test_not, Qnil, Qnil, key,
7621 &test_not_unboundp, &check_test);
7622
7623 GCPRO2 (keyed, result);
7624
7625 {
7626 GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1)
7627 {
7628 keyed = KEY (key, elt);
7629 if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
7630 check_test, test_not_unboundp,
7631 test, key, 0, Qzero, Qnil))
7632 != intersectionp)
7633 {
7634 if (EQ (Qsubsetp, caller))
7635 {
7636 result = Qnil;
7637 break;
7638 }
7639 else if (NILP (stable))
7640 {
7641 result = Fcons (elt, result);
7642 }
7643 else if (NILP (result))
7644 {
7645 result = result_tail = Fcons (elt, Qnil);
7646 }
7647 else
7648 {
7649 XSETCDR (result_tail, Fcons (elt, Qnil));
7650 result_tail = XCDR (result_tail);
7651 }
7652 }
7653 }
7654 END_GC_EXTERNAL_LIST_LOOP (elt);
7655 }
7656
7657 UNGCPRO;
7658
7659 return result;
7660 }
7661
7662 static Lisp_Object
7663 nvenn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp)
7664 {
7665 Lisp_Object liszt1 = args[0], liszt2 = args[1], tortoise_elt, ignore = Qnil;
7666 Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, prev_tail = Qnil;
7667 Elemcount count;
7668 Boolint test_not_unboundp = 1;
7669 check_test_func_t check_test = NULL;
7670 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
7671
7672 PARSE_KEYWORDS_8 (caller, nargs, args, 3, (test, key, test_not),
7673 NULL, 2, 0);
7674
7675 CHECK_LIST (liszt1);
7676 CHECK_LIST (liszt2);
7677
7678 CHECK_KEY_ARGUMENT (key);
7679
7680 if (NILP (liszt1) && intersectionp)
7681 {
7682 return Qnil;
7683 }
7684
7685 if (NILP (liszt2))
7686 {
7687 return intersectionp ? Qnil : liszt1;
7688 }
7689
7690 get_check_match_function (&test, test_not, Qnil, Qnil, key,
7691 &test_not_unboundp, &check_test);
7692
7693 tortoise_elt = tail = liszt1, count = 0;
7694
7695 GCPRO4 (tail, keyed, liszt1, tortoise_elt);
7696
7697 while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
7698 (signal_malformed_list_error (liszt1), 0))
7699 {
7700 keyed = KEY (key, elt);
7701 if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
7702 check_test, test_not_unboundp,
7703 test, key, 0, Qzero, Qnil))
7704 == intersectionp)
7705 {
7706 if (NILP (prev_tail))
7707 {
7708 liszt1 = XCDR (tail);
7709 }
7710 else
7711 {
7712 XSETCDR (prev_tail, XCDR (tail));
7713 }
7714
7715 tail = XCDR (tail);
7716 /* List is definitely not circular now! */
7717 count = 0;
7718 }
7719 else
7720 {
7721 prev_tail = tail;
7722 tail = XCDR (tail);
7723 }
7724
7725 if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
7726
7727 if (count & 1)
7728 {
7729 tortoise_elt = XCDR (tortoise_elt);
7730 }
7731
7732 if (EQ (elt, tortoise_elt))
7733 {
7734 signal_circular_list_error (liszt1);
7735 }
7736 }
7737
7738 UNGCPRO;
7739
7740 return liszt1;
7741 }
7742
7743 DEFUN ("intersection", Fintersection, 2, MANY, 0, /*
7744 Combine LIST1 and LIST2 using a set-intersection operation.
7745
7746 The result list contains all items that appear in both LIST1 and LIST2.
7747 This is a non-destructive function; it makes a copy of the data if necessary
7748 to avoid corrupting the original LIST1 and LIST2.
7749
7750 A non-nil value for the :stable keyword, not specified by Common Lisp, means
7751 return the items in the order they appear in LIST1.
7752
7753 See `union' for the meaning of :test, :test-not and :key."
7754
7755 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
7756 */
7757 (int nargs, Lisp_Object *args))
7758 {
7759 return venn (Qintersection, nargs, args, 1);
7760 }
7761
7762 DEFUN ("nintersection", Fnintersection, 2, MANY, 0, /*
7763 Combine LIST1 and LIST2 using a set-intersection operation.
7764
7765 The result list contains all items that appear in both LIST1 and LIST2.
7766 This is a destructive function; it reuses the storage of LIST1 whenever
7767 possible.
7768
7769 See `union' for the meaning of :test, :test-not and :key."
7770
7771 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
7772 */
7773 (int nargs, Lisp_Object *args))
7774 {
7775 return nvenn (Qnintersection, nargs, args, 1);
7776 }
7777
7778 DEFUN ("subsetp", Fsubsetp, 2, MANY, 0, /*
7779 Return non-nil if every element of LIST1 also appears in LIST2.
7780
7781 See `union' for the meaning of the keyword arguments.
7782
7783 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
7784 */
7785 (int nargs, Lisp_Object *args))
7786 {
7787 return venn (Qsubsetp, nargs, args, 0);
7788 }
7789
7790 DEFUN ("set-difference", Fset_difference, 2, MANY, 0, /*
7791 Combine LIST1 and LIST2 using a set-difference operation.
7792
7793 The result list contains all items that appear in LIST1 but not LIST2. This
7794 is a non-destructive function; it makes a copy of the data if necessary to
7795 avoid corrupting the original LIST1 and LIST2.
7796
7797 See `union' for the meaning of :test, :test-not and :key.
7798
7799 A non-nil value for the :stable keyword, not specified by Common Lisp, means
7800 return the items in the order they appear in LIST1.
7801
7802 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
7803 */
7804 (int nargs, Lisp_Object *args))
7805 {
7806 return venn (Qset_difference, nargs, args, 0);
7807 }
7808
7809 DEFUN ("nset-difference", Fnset_difference, 2, MANY, 0, /*
7810 Combine LIST1 and LIST2 using a set-difference operation.
7811
7812 The result list contains all items that appear in LIST1 but not LIST2. This
7813 is a destructive function; it reuses the storage of LIST1 whenever possible.
7814
7815 See `union' for the meaning of :test, :test-not and :key."
7816
7817 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
7818 */
7819 (int nargs, Lisp_Object *args))
7820 {
7821 return nvenn (Qnset_difference, nargs, args, 0);
7822 }
7823
7824 DEFUN ("nunion", Fnunion, 2, MANY, 0, /*
7825 Combine LIST1 and LIST2 using a set-union operation.
7826 The result list contains all items that appear in either LIST1 or LIST2.
7827
7828 This is a destructive function, it reuses the storage of LIST1 whenever
7829 possible.
7830
7831 See `union' for the meaning of :test, :test-not and :key.
7832
7833 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
7834 */
7835 (int nargs, Lisp_Object *args))
7836 {
7837 args[0] = nvenn (Qnunion, nargs, args, 0);
7838 return bytecode_nconc2 (args);
7839 }
7840
7841 DEFUN ("union", Funion, 2, MANY, 0, /*
7842 Combine LIST1 and LIST2 using a set-union operation.
7843 The result list contains all items that appear in either LIST1 or LIST2.
7844 This is a non-destructive function; it makes a copy of the data if necessary
7845 to avoid corrupting the original LIST1 and LIST2.
7846
7847 The keywords :test and :test-not specify two-argument test and negated-test
7848 predicates, respectively; :test defaults to `eql'. See `member*' for more
7849 information.
7850
7851 :key specifies a one-argument function that transforms elements of LIST1
7852 and LIST2 into \"comparison keys\" before the test predicate is applied.
7853 For example, if :key is #'car, then the car of elements from LIST1 is
7854 compared with the car of elements from LIST2. The :key function, however,
7855 does not affect the elements in the returned list, which are taken directly
7856 from the elements in LIST1 and LIST2.
7857
7858 A non-nil value for the :stable keyword, not specified by Common Lisp, means
7859 return the items of LIST1 in order, followed by the remaining items of LIST2
7860 in the order they occur in LIST2.
7861
7862 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
7863 */
7864 (int nargs, Lisp_Object *args))
7865 {
7866 Lisp_Object liszt1 = args[0], liszt2 = args[1], ignore = Qnil;
7867 Lisp_Object keyed = Qnil, result, result_tail;
7868 Boolint test_not_unboundp = 1;
7869 check_test_func_t check_test = NULL, check_match = NULL;
7870 struct gcpro gcpro1, gcpro2;
7871
7872 PARSE_KEYWORDS (Funion, nargs, args, 4, (test, key, test_not, stable), NULL);
7873
7874 CHECK_LIST (liszt1);
7875 CHECK_LIST (liszt2);
7876
7877 CHECK_KEY_ARGUMENT (key);
7878
7879 if (NILP (liszt1))
7880 {
7881 return liszt2;
7882 }
7883
7884 if (NILP (liszt2))
7885 {
7886 return liszt1;
7887 }
7888
7889 check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
7890 &test_not_unboundp, &check_test);
7891
7892 GCPRO2 (keyed, result);
7893
7894 if (NILP (stable))
7895 {
7896 result = liszt2;
7897 {
7898 GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1)
7899 {
7900 keyed = KEY (key, elt);
7901 if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
7902 check_test, test_not_unboundp,
7903 test, key, 0, Qzero, Qnil)))
7904 {
7905 /* The Lisp version of #'union used to check which list was
7906 longer, and use that as the tail of the constructed
7907 list. That fails when the order of arguments to TEST is
7908 specified, as is the case for these functions. We could
7909 pass the reverse_check argument to
7910 list_position_cons_before, but that means any key argument
7911 is called an awful lot more, so it's a space win but not
7912 a time win. */
7913 result = Fcons (elt, result);
7914 }
7915 }
7916 END_GC_EXTERNAL_LIST_LOOP (elt);
7917 }
7918 }
7919 else
7920 {
7921 result = result_tail = Qnil;
7922
7923 /* The standard `union' doesn't produce a "stable" union -- it
7924 iterates over the second list instead of the first one, and returns
7925 the values in backwards order. According to the CLTL2
7926 documentation, `union' is not required to preserve the ordering of
7927 elements in any fashion; providing the functionality for a stable
7928 union is an XEmacs extension. */
7929 {
7930 GC_EXTERNAL_LIST_LOOP_2 (elt, liszt2)
7931 {
7932 if (NILP (list_position_cons_before (&ignore, elt, liszt1,
7933 check_match, test_not_unboundp,
7934 test, key, 1, Qzero, Qnil)))
7935 {
7936 if (NILP (result))
7937 {
7938 result = result_tail = Fcons (elt, Qnil);
7939 }
7940 else
7941 {
7942 XSETCDR (result_tail, Fcons (elt, Qnil));
7943 result_tail = XCDR (result_tail);
7944 }
7945 }
7946 }
7947 END_GC_EXTERNAL_LIST_LOOP (elt);
7948 }
7949
7950 result = NILP (result) ? liszt1 : nconc2 (Fcopy_list (liszt1), result);
7951 }
7952
7953 UNGCPRO;
7954
7955 return result;
7956 }
7957
7958 DEFUN ("set-exclusive-or", Fset_exclusive_or, 2, MANY, 0, /*
7959 Combine LIST1 and LIST2 using a set-exclusive-or operation.
7960
7961 The result list contains all items that appear in exactly one of LIST1, LIST2.
7962 This is a non-destructive function; it makes a copy of the data if necessary
7963 to avoid corrupting the original LIST1 and LIST2.
7964
7965 See `union' for the meaning of :test, :test-not and :key.
7966
7967 A non-nil value for the :stable keyword, not specified by Common Lisp, means
7968 return the items in the order they appear in LIST1, followed by the
7969 remaining items in the order they appear in LIST2.
7970
7971 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE)
7972 */
7973 (int nargs, Lisp_Object *args))
7974 {
7975 Lisp_Object liszt1 = args[0], liszt2 = args[1];
7976 Lisp_Object result = Qnil, result_tail = Qnil, keyed = Qnil, ignore = Qnil;
7977 Boolint test_not_unboundp = 1;
7978 check_test_func_t check_match = NULL, check_test = NULL;
7979 struct gcpro gcpro1, gcpro2;
7980
7981 PARSE_KEYWORDS (Fset_exclusive_or, nargs, args, 4,
7982 (test, key, test_not, stable), NULL);
7983
7984 CHECK_LIST (liszt1);
7985 CHECK_LIST (liszt2);
7986
7987 CHECK_KEY_ARGUMENT (key);
7988
7989 if (NILP (liszt2))
7990 {
7991 return liszt1;
7992 }
7993
7994 check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
7995 &test_not_unboundp, &check_test);
7996
7997 GCPRO2 (keyed, result);
7998 {
7999 GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1)
8000 {
8001 keyed = KEY (key, elt);
8002 if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
8003 check_test, test_not_unboundp,
8004 test, key, 0, Qzero, Qnil)))
8005 {
8006 if (NILP (stable))
8007 {
8008 result = Fcons (elt, result);
8009 }
8010 else if (NILP (result))
8011 {
8012 result = result_tail = Fcons (elt, Qnil);
8013 }
8014 else
8015 {
8016 XSETCDR (result_tail, Fcons (elt, Qnil));
8017 result_tail = XCDR (result_tail);
8018 }
8019 }
8020 }
8021 END_GC_EXTERNAL_LIST_LOOP (elt);
8022 }
8023
8024 {
8025 GC_EXTERNAL_LIST_LOOP_2 (elt, liszt2)
8026 {
8027 if (NILP (list_position_cons_before (&ignore, elt, liszt1,
8028 check_match, test_not_unboundp,
8029 test, key, 1, Qzero, Qnil)))
8030 {
8031 if (NILP (stable))
8032 {
8033 result = Fcons (elt, result);
8034 }
8035 else if (NILP (result))
8036 {
8037 result = result_tail = Fcons (elt, Qnil);
8038 }
8039 else
8040 {
8041 XSETCDR (result_tail, Fcons (elt, Qnil));
8042 result_tail = XCDR (result_tail);
8043 }
8044 }
8045 }
8046 END_GC_EXTERNAL_LIST_LOOP (elt);
8047 }
8048
8049 UNGCPRO;
8050
8051 return result;
8052 }
8053
8054 DEFUN ("nset-exclusive-or", Fnset_exclusive_or, 2, MANY, 0, /*
8055 Combine LIST1 and LIST2 using a set-exclusive-or operation.
8056
8057 The result list contains all items that appear in exactly one of LIST1 and
8058 LIST2. This is a destructive function; it reuses the storage of LIST1 and
8059 LIST2 whenever possible.
8060
8061 See `union' for the meaning of :test, :test-not and :key.
8062
8063 arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT)
8064 */
8065 (int nargs, Lisp_Object *args))
8066 {
8067 Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil;
8068 Lisp_Object result = Qnil, tortoise_elt = Qnil, keyed = Qnil, swap;
8069 Lisp_Object prev_tail = Qnil, ignore = Qnil;
8070 Elemcount count;
8071 Boolint test_not_unboundp = 1;
8072 check_test_func_t check_match = NULL, check_test = NULL;
8073 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
8074
8075 PARSE_KEYWORDS (Fnset_exclusive_or, nargs, args, 4,
8076 (test, key, test_not, stable), NULL);
8077
8078 CHECK_LIST (liszt1);
8079 CHECK_LIST (liszt2);
8080
8081 CHECK_KEY_ARGUMENT (key);
8082
8083 if (NILP (liszt2))
8084 {
8085 return liszt1;
8086 }
8087
8088 check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key,
8089 &test_not_unboundp, &check_test);
8090
8091 tortoise_elt = tail = liszt1, count = 0;
8092
8093 GCPRO4 (tail, keyed, result, tortoise_elt);
8094
8095 while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
8096 (signal_malformed_list_error (liszt1), 0))
8097 {
8098 keyed = KEY (key, elt);
8099 if (NILP (list_position_cons_before (&ignore, keyed, liszt2,
8100 check_test, test_not_unboundp,
8101 test, key, 0, Qzero, Qnil)))
8102 {
8103 swap = XCDR (tail);
8104
8105 if (NILP (prev_tail))
8106 {
8107 liszt1 = XCDR (tail);
8108 }
8109 else
8110 {
8111 XSETCDR (prev_tail, swap);
8112 }
8113
8114 XSETCDR (tail, result);
8115 result = tail;
8116 tail = swap;
8117
8118 /* List is definitely not circular now! */
8119 count = 0;
8120 }
8121 else
8122 {
8123 prev_tail = tail;
8124 tail = XCDR (tail);
8125 }
8126
8127 if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
8128
8129 if (count & 1)
8130 {
8131 tortoise_elt = XCDR (tortoise_elt);
8132 }
8133
8134 if (EQ (elt, tortoise_elt))
8135 {
8136 signal_circular_list_error (liszt1);
8137 }
8138 }
8139
8140 tortoise_elt = tail = liszt2, count = 0;
8141
8142 while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 :
8143 (signal_malformed_list_error (liszt2), 0))
8144 {
8145 /* Need to leave the key calculation to list_position_cons_before(). */
8146 if (NILP (list_position_cons_before (&ignore, elt, liszt1,
8147 check_match, test_not_unboundp,
8148 test, key, 1, Qzero, Qnil)))
8149 {
8150 swap = XCDR (tail);
8151 XSETCDR (tail, result);
8152 result = tail;
8153 tail = swap;
8154 count = 0;
8155 }
8156 else
8157 {
8158 tail = XCDR (tail);
8159 }
8160
8161 if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
8162
8163 if (count & 1)
8164 {
8165 tortoise_elt = XCDR (tortoise_elt);
8166 }
8167
8168 if (EQ (elt, tortoise_elt))
8169 {
8170 signal_circular_list_error (liszt1);
8171 }
8172 }
8173
8174 UNGCPRO;
8175
8176 return result;
8177 }
8178
8179 void
8180 syms_of_sequence (void)
8181 {
8182 DEFSYMBOL (Qstring_lessp);
8183 DEFSYMBOL (Qmerge);
8184 DEFSYMBOL (Qfill);
8185 DEFSYMBOL (Qidentity);
8186 DEFSYMBOL (Qvector);
8187 DEFSYMBOL (Qarray);
8188 DEFSYMBOL (Qstring);
8189 DEFSYMBOL (Qlist);
8190 DEFSYMBOL (Qbit_vector);
8191 defsymbol (&QsortX, "sort*");
8192 DEFSYMBOL (Qreduce);
8193 DEFSYMBOL (Qreplace);
8194 DEFSYMBOL (Qposition);
8195 DEFSYMBOL (Qfind);
8196 defsymbol (&QdeleteX, "delete*");
8197 defsymbol (&QremoveX, "remove*");
8198
8199 DEFSYMBOL (Qmapconcat);
8200 defsymbol (&QmapcarX, "mapcar*");
8201 DEFSYMBOL (Qmapvector);
8202 DEFSYMBOL (Qmapcan);
8203 DEFSYMBOL (Qmapc);
8204 DEFSYMBOL (Qmap);
8205 DEFSYMBOL (Qmap_into);
8206 DEFSYMBOL (Qsome);
8207 DEFSYMBOL (Qevery);
8208 DEFSYMBOL (Qnsubstitute);
8209 DEFSYMBOL (Qdelete_duplicates);
8210 DEFSYMBOL (Qsubstitute);
8211 DEFSYMBOL (Qmismatch);
8212 DEFSYMBOL (Qintersection);
8213 DEFSYMBOL (Qnintersection);
8214 DEFSYMBOL (Qsubsetp);
8215 DEFSYMBOL (Qcar_less_than_car);
8216 DEFSYMBOL (Qset_difference);
8217 DEFSYMBOL (Qnset_difference);
8218 DEFSYMBOL (Qnunion);
8219
8220 DEFKEYWORD (Q_from_end);
8221 DEFKEYWORD (Q_initial_value);
8222 DEFKEYWORD (Q_start1);
8223 DEFKEYWORD (Q_start2);
8224 DEFKEYWORD (Q_end1);
8225 DEFKEYWORD (Q_end2);
8226 defkeyword (&Q_if_, ":if");
8227 DEFKEYWORD (Q_if_not);
8228 DEFKEYWORD (Q_test_not);
8229 DEFKEYWORD (Q_count);
8230 DEFKEYWORD (Q_stable);
8231 DEFKEYWORD (Q_descend_structures);
8232
8233 DEFSUBR (Flength);
8234 DEFSUBR (Fcount);
8235 DEFSUBR (Fsubseq);
8236 DEFSUBR (Felt);
8237 DEFSUBR (Fcopy_tree);
8238 DEFSUBR (Fmember);
8239 DEFSUBR (Fmemq);
8240 DEFSUBR (FmemberX);
8241 DEFSUBR (Fadjoin);
8242 DEFSUBR (Fassoc);
8243 DEFSUBR (Fassq);
8244 DEFSUBR (FassocX);
8245 DEFSUBR (Frassoc);
8246 DEFSUBR (Frassq);
8247 DEFSUBR (FrassocX);
8248 DEFSUBR (Fposition);
8249 DEFSUBR (Ffind);
8250 DEFSUBR (FdeleteX);
8251 DEFSUBR (FremoveX);
8252 DEFSUBR (Fdelete_duplicates);
8253 DEFSUBR (Fremove_duplicates);
8254 DEFSUBR (Fnreverse);
8255 DEFSUBR (Freverse);
8256 DEFSUBR (Fmerge);
8257 DEFSUBR (FsortX);
8258 DEFSUBR (Ffill);
8259 DEFSUBR (Fmapconcat);
8260 DEFSUBR (FmapcarX);
8261 DEFSUBR (Fmapvector);
8262 DEFSUBR (Fmapcan);
8263 DEFSUBR (Fmapc);
8264 Ffset (intern ("mapc-internal"), Qmapc);
8265 Ffset (intern ("mapcar"), QmapcarX);
8266 DEFSUBR (Fmap);
8267 DEFSUBR (Fmap_into);
8268 DEFSUBR (Fsome);
8269 DEFSUBR (Fevery);
8270 DEFSUBR (Freduce);
8271 DEFSUBR (Freplace);
8272 DEFSUBR (Fnsubstitute);
8273 DEFSUBR (Fsubstitute);
8274 DEFSUBR (Fsublis);
8275 DEFSUBR (Fnsublis);
8276 DEFSUBR (Fsubst);
8277 DEFSUBR (Fnsubst);
8278 DEFSUBR (Ftree_equal);
8279 DEFSUBR (Fmismatch);
8280 DEFSUBR (Fsearch);
8281 DEFSUBR (Fintersection);
8282 DEFSUBR (Fnintersection);
8283 DEFSUBR (Fsubsetp);
8284 DEFSUBR (Fset_difference);
8285 DEFSUBR (Fnset_difference);
8286 DEFSUBR (Fnunion);
8287 DEFSUBR (Funion);
8288 DEFSUBR (Fset_exclusive_or);
8289 DEFSUBR (Fnset_exclusive_or);
8290 }