Mercurial > hg > xemacs-beta
diff src/sequence.c @ 5607:1a507c4c6c42
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 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sequence.c Sun Dec 04 18:42:50 2011 +0000 @@ -0,0 +1,8290 @@ +/* Various functions that operate on sequences, split out from fns.c + Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. + Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software: you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation, either version 3 of the License, or (at your +option) any later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> +#include "lisp.h" +#include "extents.h" + +Lisp_Object Qadjoin, Qarray, QassocX, Qbit_vector, Qcar_less_than_car; +Lisp_Object QdeleteX, Qdelete_duplicates, Qevery, Qfill, Qfind, Qidentity; +Lisp_Object Qintersection, Qmap, Qmap_into, Qmapc, Qmapcan, QmapcarX; +Lisp_Object Qmapconcat, Qmapvector, Qmerge, Qmismatch, Qnintersection; +Lisp_Object Qnset_difference, Qnsubstitute, Qnunion, Qposition, QrassocX; +Lisp_Object Qreduce, QremoveX, Qreplace, Qset_difference, Qsome, QsortX; +Lisp_Object Qstring_lessp, Qsubsetp, Qsubstitute, Qvector; + +Lisp_Object Q_count, Q_descend_structures, Q_end1, Q_end2, Q_from_end; +Lisp_Object Q_if_, Q_if_not, Q_initial_value, Q_stable, Q_start1, Q_start2; +Lisp_Object Q_test_not; + +extern Fixnum max_lisp_eval_depth; +extern int lisp_eval_depth; + +Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); + +static DOESNT_RETURN +mapping_interaction_error (Lisp_Object func, Lisp_Object object) +{ + invalid_state_2 ("object modified while traversing it", func, object); +} + +static void +check_sequence_range (Lisp_Object sequence, Lisp_Object start, + Lisp_Object end, Lisp_Object length) +{ + Lisp_Object args[] = { Qzero, start, NILP (end) ? length : end, length }; + + if (NILP (Fleq (countof (args), args))) + { + args_out_of_range_3 (sequence, start, end); + } +} + +DEFUN ("length", Flength, 1, 1, 0, /* +Return the length of vector, bit vector, list or string SEQUENCE. +*/ + (sequence)) +{ + retry: + if (STRINGP (sequence)) + return make_fixnum (string_char_length (sequence)); + else if (CONSP (sequence)) + { + Elemcount len; + GET_EXTERNAL_LIST_LENGTH (sequence, len); + return make_fixnum (len); + } + else if (VECTORP (sequence)) + return make_fixnum (XVECTOR_LENGTH (sequence)); + else if (NILP (sequence)) + return Qzero; + else if (BIT_VECTORP (sequence)) + return make_fixnum (bit_vector_length (XBIT_VECTOR (sequence))); + else + { + check_losing_bytecode ("length", sequence); + sequence = wrong_type_argument (Qsequencep, sequence); + goto retry; + } +} + +/* Various test functions for #'member*, #'assoc* and the other functions + that take both TEST and KEY arguments. */ + +Boolint +check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return EQ (item, elt); +} + +static Boolint +check_eq_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item, + Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return EQ (item, elt); +} + +/* The next two are not used by #'member* and #'assoc*, since we can decide + on #'eq vs. #'equal when we have the type of ITEM. */ +static Boolint +check_eql_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object elt1, Lisp_Object elt2) +{ + return EQ (elt1, elt2) + || (NON_FIXNUM_NUMBER_P (elt1) && internal_equal (elt1, elt2, 0)); +} + +static Boolint +check_eql_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item, + Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return EQ (item, elt) + || (NON_FIXNUM_NUMBER_P (item) && internal_equal (item, elt, 0)); +} + +static Boolint +check_equal_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return internal_equal (item, elt, 0); +} + +static Boolint +check_equal_key (Lisp_Object UNUSED (test), Lisp_Object key, Lisp_Object item, + Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return internal_equal (item, elt, 0); +} + +static Boolint +check_equalp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return internal_equalp (item, elt, 0); +} + +static Boolint +check_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object item, Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return internal_equalp (item, elt, 0); +} + +static Boolint +check_string_match_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + return !NILP (Fstring_match (item, elt, Qnil, Qnil)); +} + +static Boolint +check_string_match_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object item, Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (key, elt)); + return !NILP (Fstring_match (item, elt, Qnil, Qnil)); +} + +static Boolint +check_other_nokey (Lisp_Object test, Lisp_Object UNUSED (key), + Lisp_Object item, Lisp_Object elt) +{ + Lisp_Object args[] = { test, item, elt }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (item); +} + +static Boolint +check_other_key (Lisp_Object test, Lisp_Object key, + Lisp_Object item, Lisp_Object elt) +{ + Lisp_Object args[] = { item, key, elt }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args) - 1, args + 1)); + args[1] = item; + args[0] = test; + item = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (item); +} + +static Boolint +check_if_nokey (Lisp_Object test, Lisp_Object UNUSED (key), + Lisp_Object UNUSED (item), Lisp_Object elt) +{ + elt = IGNORE_MULTIPLE_VALUES (call1 (test, elt)); + return !NILP (elt); +} + +static Boolint +check_if_key (Lisp_Object test, Lisp_Object key, + Lisp_Object UNUSED (item), Lisp_Object elt) +{ + Lisp_Object args[] = { key, elt }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + args[0] = test; + elt = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (elt); +} + +static Boolint +check_match_eq_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return EQ (args[0], args[1]); +} + +static Boolint +check_match_eql_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return EQ (args[0], args[1]) || + (NON_FIXNUM_NUMBER_P (args[0]) && internal_equal (args[0], args[1], 0)); +} + +static Boolint +check_match_equal_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return internal_equal (args[0], args[1], 0); +} + +static Boolint +check_match_equalp_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return internal_equalp (args[0], args[1], 0); +} + +static Boolint +check_match_other_key (Lisp_Object test, Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[2] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + args[1] = args[0]; + args[0] = test; + + elt1 = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !NILP (elt1); +} + +static Boolint +check_lss_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object elt1, Lisp_Object elt2) +{ + return bytecode_arithcompare (elt1, elt2) < 0; +} + +static Boolint +check_lss_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return bytecode_arithcompare (args[0], args[1]) < 0; +} + +Boolint +check_lss_key_car (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object elt1, Lisp_Object elt2) +{ + struct gcpro gcpro1, gcpro2; + + GCPRO2 (elt1, elt2); + elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1); + elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2); + UNGCPRO; + + return bytecode_arithcompare (elt1, elt2) < 0; +} + +Boolint +check_string_lessp_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key), + Lisp_Object elt1, Lisp_Object elt2) +{ + return !NILP (Fstring_lessp (elt1, elt2)); +} + +static Boolint +check_string_lessp_key (Lisp_Object UNUSED (test), Lisp_Object key, + Lisp_Object elt1, Lisp_Object elt2) +{ + Lisp_Object args[] = { key, elt1, elt2 }; + struct gcpro gcpro1; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + args[0] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args)); + args[1] = key; + args[1] = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args + 1)); + UNGCPRO; + + return !NILP (Fstring_lessp (args[0], args[1])); +} + +static Boolint +check_string_lessp_key_car (Lisp_Object UNUSED (test), + Lisp_Object UNUSED (key), + Lisp_Object elt1, Lisp_Object elt2) +{ + struct gcpro gcpro1, gcpro2; + + GCPRO2 (elt1, elt2); + elt1 = CONSP (elt1) ? XCAR (elt1) : Fcar (elt1); + elt2 = CONSP (elt2) ? XCAR (elt2) : Fcar (elt2); + UNGCPRO; + + return !NILP (Fstring_lessp (elt1, elt2)); +} + +static check_test_func_t +get_check_match_function_1 (Lisp_Object item, + Lisp_Object *test_inout, Lisp_Object test_not, + Lisp_Object if_, Lisp_Object if_not, + Lisp_Object key, Boolint *test_not_unboundp_out, + check_test_func_t *test_func_out) +{ + Lisp_Object test = *test_inout; + check_test_func_t result = NULL, test_func = NULL; + Boolint force_if = 0; + + if (!NILP (if_)) + { + if (!(NILP (test) && NILP (test_not) && NILP (if_not))) + { + invalid_argument ("only one keyword among :test :test-not " + ":if :if-not allowed", if_); + } + + test = *test_inout = if_; + force_if = 1; + } + else if (!NILP (if_not)) + { + if (!(NILP (test) && NILP (test_not))) + { + invalid_argument ("only one keyword among :test :test-not " + ":if :if-not allowed", if_not); + } + + test_not = if_not; + force_if = 1; + } + + if (NILP (test)) + { + if (!NILP (test_not)) + { + test = *test_inout = test_not; + if (NULL != test_not_unboundp_out) + { + *test_not_unboundp_out = 0; + } + } + else + { + test = Qeql; + if (NULL != test_not_unboundp_out) + { + *test_not_unboundp_out = 1; + } + } + } + else if (!NILP (test_not)) + { + invalid_argument_2 ("conflicting :test and :test-not keyword arguments", + test, test_not); + } + + test = indirect_function (test, 1); + + if (NILP (key) || + EQ (indirect_function (key, 1), XSYMBOL_FUNCTION (Qidentity))) + { + key = Qidentity; + } + + if (force_if) + { + result = EQ (key, Qidentity) ? check_if_nokey : check_if_key; + + if (NULL != test_func_out) + { + *test_func_out = result; + } + + return result; + } + + if (!UNBOUNDP (item) && EQ (test, XSYMBOL_FUNCTION (Qeql))) + { + test = XSYMBOL_FUNCTION (NON_FIXNUM_NUMBER_P (item) ? Qequal : Qeq); + } + +#define FROB(known_test, eq_condition) \ + if (EQ (test, XSYMBOL_FUNCTION (Q##known_test))) do \ + { \ + if (eq_condition) \ + { \ + test = XSYMBOL_FUNCTION (Qeq); \ + goto force_eq_check; \ + } \ + \ + if (!EQ (Qidentity, key)) \ + { \ + test_func = check_##known_test##_key; \ + result = check_match_##known_test##_key; \ + } \ + else \ + { \ + result = test_func = check_##known_test##_nokey; \ + } \ + } while (0) + + FROB (eql, 0); + else if (SUBRP (test)) + { + force_eq_check: + FROB (eq, 0); + else FROB (equal, (SYMBOLP (item) || FIXNUMP (item) || CHARP (item))); + else FROB (equalp, (SYMBOLP (item))); + else if (EQ (test, XSYMBOL_FUNCTION (Qstring_match))) + { + if (EQ (Qidentity, key)) + { + test_func = result = check_string_match_nokey; + } + else + { + test_func = check_string_match_key; + result = check_other_key; + } + } + } + + if (NULL == result) + { + if (EQ (Qidentity, key)) + { + test_func = result = check_other_nokey; + } + else + { + test_func = check_other_key; + result = check_match_other_key; + } + } + + if (NULL != test_func_out) + { + *test_func_out = test_func; + } + + return result; +} +#undef FROB + +/* Given TEST, TEST_NOT, IF, IF_NOT, KEY, and ITEM, return a C function + pointer appropriate for use in deciding whether a given element of a + sequence satisfies TEST. + + Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero + if it was bound, and set *test_inout to the value it was bound to. If + TEST was not bound, leave *test_inout alone; the value is not used by + check_eq_*key() or check_equal_*key(), which are the defaults, depending + on the type of ITEM. + + The returned function takes arguments (TEST, KEY, ITEM, ELT), where ITEM + is the item being searched for and ELT is the element of the sequence + being examined. + + Error if both TEST and TEST_NOT were specified, which Common Lisp says is + undefined behaviour. */ + +static check_test_func_t +get_check_test_function (Lisp_Object item, + Lisp_Object *test_inout, Lisp_Object test_not, + Lisp_Object if_, Lisp_Object if_not, + Lisp_Object key, Boolint *test_not_unboundp_out) +{ + check_test_func_t result = NULL; + get_check_match_function_1 (item, test_inout, test_not, if_, if_not, + key, test_not_unboundp_out, &result); + return result; +} + +/* Given TEST, TEST_NOT, IF, IF_NOT and KEY, return a C function pointer + appropriate for use in deciding whether two given elements of a sequence + satisfy TEST. + + Set *test_not_unboundp_out to 1 if TEST_NOT was not bound; set it to zero + if it was bound, and set *test_inout to the value it was bound to. If + TEST was not bound, leave *test_inout alone; the value is not used by + check_eql_*key(). + + The returned function takes arguments (TEST, KEY, ELT1, ELT2), where ELT1 + and ELT2 are elements of the sequence being examined. + + The value that would be given by get_check_test_function() is returned in + *TEST_FUNC_OUT, which allows calling functions to do their own key checks + if they're processing one element at a time. + + Error if both TEST and TEST_NOT were specified, which Common Lisp says is + undefined behaviour. */ + +static check_test_func_t +get_check_match_function (Lisp_Object *test_inout, Lisp_Object test_not, + Lisp_Object if_, Lisp_Object if_not, + Lisp_Object key, Boolint *test_not_unboundp_out, + check_test_func_t *test_func_out) +{ + return get_check_match_function_1 (Qunbound, test_inout, test_not, + if_, if_not, key, + test_not_unboundp_out, test_func_out); +} + +/* Given PREDICATE and KEY, return a C function pointer appropriate for use + in deciding whether one given element of a sequence is less than + another. */ + +static check_test_func_t +get_merge_predicate (Lisp_Object predicate, Lisp_Object key) +{ + predicate = indirect_function (predicate, 1); + + if (NILP (key)) + { + key = Qidentity; + } + else + { + key = indirect_function (key, 1); + if (EQ (key, XSYMBOL_FUNCTION (Qidentity))) + { + key = Qidentity; + } + } + + if (EQ (key, Qidentity) && EQ (predicate, + XSYMBOL_FUNCTION (Qcar_less_than_car))) + { + key = XSYMBOL_FUNCTION (Qcar); + predicate = XSYMBOL_FUNCTION (Qlss); + } + + if (EQ (predicate, XSYMBOL_FUNCTION (Qlss))) + { + if (EQ (key, Qidentity)) + { + return check_lss_nokey; + } + + if (EQ (key, XSYMBOL_FUNCTION (Qcar))) + { + return check_lss_key_car; + } + + return check_lss_key; + } + + if (EQ (predicate, XSYMBOL_FUNCTION (Qstring_lessp))) + { + if (EQ (key, Qidentity)) + { + return check_string_lessp_nokey; + } + + if (EQ (key, XSYMBOL_FUNCTION (Qcar))) + { + return check_string_lessp_key_car; + } + + return check_string_lessp_key; + } + + if (EQ (key, Qidentity)) + { + return check_other_nokey; + } + + return check_match_other_key; +} + + +static Lisp_Object string_count_from_end (Lisp_Object, Lisp_Object , + check_test_func_t, Boolint, + Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); + +static Lisp_Object list_count_from_end (Lisp_Object, Lisp_Object, + check_test_func_t, Boolint, + Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); + +/* Count the number of occurrences of ITEM in SEQUENCE; if SEQUENCE is a + list, store the cons cell of which the car is the last ITEM in SEQUENCE, + at the address given by tail_out. */ + +static Lisp_Object +count_with_tail (Lisp_Object *tail_out, int nargs, Lisp_Object *args, + Lisp_Object caller) +{ + Lisp_Object item = args[0], sequence = args[1]; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0; + Elemcount len, ii = 0, counting = MOST_POSITIVE_FIXNUM; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS_8 (caller, nargs, args, 9, + (test, key, start, end, from_end, test_not, count, + if_, if_not), (start = Qzero), 2, 0); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); + } + + if (!NILP (count)) + { + CHECK_INTEGER (count); + counting = BIGNUMP (count) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (count); + + /* Our callers should have filtered out non-positive COUNT. */ + assert (counting >= 0); + /* And we're not prepared to handle COUNT from any other caller at the + moment. */ + assert (EQ (caller, QremoveX)|| EQ (caller, QdeleteX)); + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + *tail_out = Qnil; + + if (CONSP (sequence)) + { + if (EQ (caller, Qcount) && !NILP (from_end) + && (!EQ (key, Qnil) || + check_test == check_other_nokey || check_test == check_if_nokey)) + { + /* #'count, #'count-if, and #'count-if-not are documented to have + a given traversal order if :from-end t is passed in, even + though forward traversal of the sequence has the same result + and is algorithmically less expensive for lists and strings. + This order isn't necessary for other callers, though. */ + return list_count_from_end (item, sequence, check_test, + test_not_unboundp, test, key, + start, end); + } + + /* If COUNT is non-nil and FROM-END is t, we can give the tail + containing the last match, since that's what #'remove* is + interested in (a zero or negative COUNT won't ever reach + count_with_tail(), our callers will return immediately on seeing + it). */ + if (!NILP (count) && !NILP (from_end)) + { + counting = MOST_POSITIVE_FIXNUM; + } + + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (!(ii < ending)) + { + break; + } + + if (starting <= ii && + check_test (test, key, item, elt) == test_not_unboundp) + { + encountered++; + *tail_out = tail; + + if (encountered == counting) + { + break; + } + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + if ((ii < starting || (ii < ending && !NILP (end))) && + encountered != counting) + { + check_sequence_range (args[1], start, end, Flength (args[1])); + } + } + else if (STRINGP (sequence)) + { + Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp; + Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0; + Lisp_Object character = Qnil; + + if (EQ (caller, Qcount) && !NILP (from_end) + && (!EQ (key, Qnil) || + check_test == check_other_nokey || check_test == check_if_nokey)) + { + /* See comment above in the list code. */ + return string_count_from_end (item, sequence, + check_test, test_not_unboundp, + test, key, start, end); + } + + while (cursor_offset < byte_len && ii < ending && encountered < counting) + { + if (ii >= starting) + { + character = make_char (itext_ichar (cursor)); + + if (check_test (test, key, item, character) + == test_not_unboundp) + { + encountered++; + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (caller, sequence); + } + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else + { + Lisp_Object object = Qnil; + + len = XFIXNUM (Flength (sequence)); + check_sequence_range (sequence, start, end, make_fixnum (len)); + + ending = min (ending, len); + if (0 == len) + { + /* Catches the case where we have nil. */ + return make_integer (encountered); + } + + if (NILP (from_end)) + { + for (ii = starting; ii < ending && encountered < counting; ii++) + { + object = Faref (sequence, make_fixnum (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + encountered++; + } + } + } + else + { + for (ii = ending - 1; ii >= starting && encountered < counting; ii--) + { + object = Faref (sequence, make_fixnum (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + encountered++; + } + } + } + } + + return make_integer (encountered); +} + +static Lisp_Object +list_count_from_end (Lisp_Object item, Lisp_Object sequence, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Lisp_Object start, Lisp_Object end) +{ + Elemcount length = XFIXNUM (Flength (sequence)), ii = 0, starting = XFIXNUM (start); + Elemcount ending = NILP (end) ? length : XFIXNUM (end), encountered = 0; + Lisp_Object *storage; + struct gcpro gcpro1; + + check_sequence_range (sequence, start, end, make_integer (length)); + + storage = alloca_array (Lisp_Object, ending - starting); + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (starting <= ii && ii < ending) + { + storage[ii - starting] = elt; + } + ii++; + } + } + + GCPRO1 (storage[0]); + gcpro1.nvars = ending - starting; + + for (ii = ending - 1; ii >= starting; ii--) + { + if (check_test (test, key, item, storage[ii - starting]) + == test_not_unboundp) + { + encountered++; + } + } + + UNGCPRO; + + return make_integer (encountered); +} + +static Lisp_Object +string_count_from_end (Lisp_Object item, Lisp_Object sequence, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Lisp_Object start, Lisp_Object end) +{ + Elemcount length = string_char_length (sequence), ii = 0; + Elemcount starting = XFIXNUM (start), ending = NILP (end) ? length : XFIXNUM (end); + Elemcount encountered = 0; + Ibyte *cursor = XSTRING_DATA (sequence); + Ibyte *endp = cursor + XSTRING_LENGTH (sequence); + Ichar *storage; + + check_sequence_range (sequence, start, end, make_integer (length)); + + storage = alloca_array (Ichar, ending - starting); + + while (cursor < endp && ii < ending) + { + if (starting <= ii && ii < ending) + { + storage [ii - starting] = itext_ichar (cursor); + } + + ii++; + INC_IBYTEPTR (cursor); + } + + for (ii = ending - 1; ii >= starting; ii--) + { + if (check_test (test, key, item, make_char (storage [ii - starting])) + == test_not_unboundp) + { + encountered++; + } + } + + return make_integer (encountered); +} + +DEFUN ("count", Fcount, 2, MANY, 0, /* +Count the number of occurrences of ITEM in SEQUENCE. + +See `remove*' for the meaning of the keywords. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object tail = Qnil; + + /* count_with_tail() accepts more keywords than we do, check those we've + been given. */ + PARSE_KEYWORDS (Fcount, nargs, args, 8, + (test, test_not, if_, if_not, key, start, end, from_end), + NULL); + + return count_with_tail (&tail, nargs, args, Qcount); +} + +DEFUN ("subseq", Fsubseq, 2, 3, 0, /* +Return the subsequence of SEQUENCE starting at START and ending before END. +END may be omitted; then the subsequence runs to the end of SEQUENCE. + +If START or END is negative, it counts from the end, in contravention of +Common Lisp. +The returned subsequence is always of the same type as SEQUENCE. +If SEQUENCE is a string, relevant parts of the string-extent-data +are copied to the new string. + +See also `substring-no-properties', which only operates on strings, and does +not copy extent data. +*/ + (sequence, start, end)) +{ + Elemcount len, ss, ee = MOST_POSITIVE_FIXNUM, ii; + Lisp_Object result = Qnil; + + CHECK_SEQUENCE (sequence); + CHECK_FIXNUM (start); + ss = XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_FIXNUM (end); + ee = XFIXNUM (end); + } + + if (STRINGP (sequence)) + { + Bytecount bstart, blen; + + get_string_range_char (sequence, start, end, &ss, &ee, + GB_HISTORICAL_STRING_BEHAVIOR); + bstart = string_index_char_to_byte (sequence, ss); + blen = string_offset_char_to_byte_len (sequence, bstart, ee - ss); + + result = make_string (XSTRING_DATA (sequence) + bstart, blen); + /* Copy any applicable extent information into the new string. */ + copy_string_extents (result, sequence, 0, bstart, blen); + } + else if (CONSP (sequence)) + { + Lisp_Object result_tail, saved = sequence; + + if (ss < 0 || ee < 0) + { + len = XFIXNUM (Flength (sequence)); + if (ss < 0) + { + ss = len + ss; + start = make_integer (ss); + } + + if (ee < 0) + { + ee = len + ee; + end = make_integer (ee); + } + else + { + ee = min (ee, len); + } + } + + if (0 != ss) + { + sequence = Fnthcdr (make_fixnum (ss), sequence); + } + + ii = ss + 1; + + if (ss < ee && !NILP (sequence)) + { + result = result_tail = Fcons (Fcar (sequence), Qnil); + sequence = Fcdr (sequence); + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (!(ii < ee)) + { + break; + } + + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + ii++; + } + } + } + + if (NILP (result) || (ii < ee && !NILP (end))) + { + /* We were handed a cons, which definitely has elements. nil + result means either ss >= ee or SEQUENCE was nil after the + nthcdr; in both cases that means START and END were incorrectly + specified for this sequence. ii < ee with a non-nil end means + the user handed us a bogus end value. */ + check_sequence_range (saved, start, end, Flength (saved)); + } + } + else + { + len = XFIXNUM (Flength (sequence)); + if (ss < 0) + { + ss = len + ss; + start = make_integer (ss); + } + + if (ee < 0) + { + ee = len + ee; + end = make_integer (ee); + } + else + { + ee = min (len, ee); + } + + check_sequence_range (sequence, start, end, make_fixnum (len)); + + if (VECTORP (sequence)) + { + result = Fvector (ee - ss, XVECTOR_DATA (sequence) + ss); + } + else if (BIT_VECTORP (sequence)) + { + result = make_bit_vector (ee - ss, Qzero); + + for (ii = ss; ii < ee; ii++) + { + set_bit_vector_bit (XBIT_VECTOR (result), ii - ss, + bit_vector_bit (XBIT_VECTOR (sequence), ii)); + } + } + else if (NILP (sequence)) + { + DO_NOTHING; + } + else + { + /* Won't happen, since CHECK_SEQUENCE didn't error. */ + ABORT (); + } + } + + return result; +} + +DEFUN ("elt", Felt, 2, 2, 0, /* +Return element of SEQUENCE at index N. +*/ + (sequence, n)) +{ + /* This function can GC */ + retry: + CHECK_FIXNUM_COERCE_CHAR (n); /* yuck! */ + if (LISTP (sequence)) + { + Lisp_Object tem = Fnthcdr (n, sequence); + /* #### Utterly, completely, fucking disgusting. + * #### The whole point of "elt" is that it operates on + * #### sequences, and does error- (bounds-) checking. + */ + if (CONSP (tem)) + return XCAR (tem); + else +#if 1 + /* This is The Way It Has Always Been. */ + return Qnil; +#else + /* This is The Way Mly and Cltl2 say It Should Be. */ + args_out_of_range (sequence, n); +#endif + } + else if (STRINGP (sequence) || + VECTORP (sequence) || + BIT_VECTORP (sequence)) + return Faref (sequence, n); + else + { + check_losing_bytecode ("elt", sequence); + sequence = wrong_type_argument (Qsequencep, sequence); + goto retry; + } +} + +DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /* +Return a copy of a list and substructures. +The argument is copied, and any lists contained within it are copied +recursively. Circularities and shared substructures are not preserved. +Second arg VECP causes vectors to be copied, too. Strings and bit vectors +are not copied. +*/ + (arg, vecp)) +{ + return safe_copy_tree (arg, vecp, 0); +} + +Lisp_Object +safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth) +{ + if (depth + lisp_eval_depth > max_lisp_eval_depth) + stack_overflow ("Stack overflow in copy-tree", arg); + + if (CONSP (arg)) + { + Lisp_Object rest; + rest = arg = Fcopy_sequence (arg); + while (CONSP (rest)) + { + Lisp_Object elt = XCAR (rest); + QUIT; + if (CONSP (elt) || VECTORP (elt)) + XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1); + if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */ + XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1); + rest = XCDR (rest); + } + } + else if (VECTORP (arg) && ! NILP (vecp)) + { + int i = XVECTOR_LENGTH (arg); + int j; + arg = Fcopy_sequence (arg); + for (j = 0; j < i; j++) + { + Lisp_Object elt = XVECTOR_DATA (arg) [j]; + QUIT; + if (CONSP (elt) || VECTORP (elt)) + XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1); + } + } + return arg; +} + +DEFUN ("member", Fmember, 2, 2, 0, /* +Return non-nil if ELT is an element of LIST. Comparison done with `equal'. +The value is actually the tail of LIST whose car is ELT. +*/ + (elt, list)) +{ + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) + { + if (internal_equal (elt, list_elt, 0)) + return tail; + } + return Qnil; +} + +DEFUN ("memq", Fmemq, 2, 2, 0, /* +Return non-nil if ELT is an element of LIST. Comparison done with `eq'. +The value is actually the tail of LIST whose car is ELT. +*/ + (elt, list)) +{ + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) + { + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) + return tail; + } + return Qnil; +} + +Lisp_Object +memq_no_quit (Lisp_Object elt, Lisp_Object list) +{ + LIST_LOOP_3 (list_elt, list, tail) + { + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) + return tail; + } + return Qnil; +} + +/* Return the first index of ITEM in LIST. In CONS_OUT, return the cons cell + before that containing the element. If the element is in the first cons + cell, return Qnil in CONS_OUT. TEST, KEY, START, END are as in + #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should have been initialized + with get_check_match_function() or get_check_test_function(). A non-zero + REVERSE_TEST_ORDER means call TEST with the element from LIST as its + first argument and ITEM as its second. Error if LIST is ill-formed, or + circular. */ +static Lisp_Object +list_position_cons_before (Lisp_Object *cons_out, + Lisp_Object item, Lisp_Object list, + check_test_func_t check_test, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint reverse_test_order, + Lisp_Object start, Lisp_Object end) +{ + struct gcpro gcpro1; + Lisp_Object tail_before = Qnil; + Elemcount ii = 0, starting = XFIXNUM (start); + Elemcount ending = NILP (end) ? MOST_POSITIVE_FIXNUM : XFIXNUM (end); + + GCPRO1 (tail_before); + + if (check_test == check_eq_nokey) + { + /* TEST is #'eq, no need to call any C functions, and the test order + won't be visible. */ + EXTERNAL_LIST_LOOP_3 (elt, list, tail) + { + if (starting <= ii && ii < ending && + EQ (item, elt) == test_not_unboundp) + { + *cons_out = tail_before; + RETURN_UNGCPRO (make_integer (ii)); + } + else + { + if (ii >= ending) + { + break; + } + } + ii++; + tail_before = tail; + } + } + else + { + GC_EXTERNAL_LIST_LOOP_3 (elt, list, tail) + { + if (starting <= ii && ii < ending && + (reverse_test_order ? + check_test (test, key, elt, item) : + check_test (test, key, item, elt)) == test_not_unboundp) + { + *cons_out = tail_before; + XUNGCPRO (elt); + UNGCPRO; + return make_integer (ii); + } + else + { + if (ii >= ending) + { + break; + } + } + ii++; + tail_before = tail; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + RETURN_UNGCPRO (Qnil); +} + +DEFUN ("member*", FmemberX, 2, MANY, 0, /* +Return the first sublist of LIST with car ITEM, or nil if no such sublist. + +The keyword :test specifies a two-argument function that is used to compare +ITEM with elements in LIST; if omitted, it defaults to `eql'. + +The keyword :test-not is similar, but specifies a negated function. That +is, ITEM is considered equal to an element in LIST if the given function +returns nil. Common Lisp deprecates :test-not, and if both are specified, +XEmacs signals an error. + +:key specifies a one-argument function that transforms elements of LIST into +\"comparison keys\" before the test predicate is applied. For example, +if :key is #'car, then ITEM is compared with the car of elements from LIST. +The :key function, however, is not applied to ITEM, and does not affect the +elements in the returned list, which are taken directly from the elements in +LIST. + +arguments: (ITEM LIST &key (TEST #'eql) TEST-NOT (KEY #'identity)) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], list = args[1], result = Qnil, position0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FmemberX, nargs, args, 5, (test, if_not, if_, test_not, key), + NULL); + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + position0 + = list_position_cons_before (&result, item, list, check_test, + test_not_unboundp, test, key, 0, Qzero, Qnil); + + return CONSP (result) ? XCDR (result) : ZEROP (position0) ? list : Qnil; +} + +/* This macro might eventually find a better home than here. */ + +#define CHECK_KEY_ARGUMENT(key) \ + do { \ + if (NILP (key)) \ + { \ + key = Qidentity; \ + } \ + \ + if (!EQ (key, Qidentity)) \ + { \ + key = indirect_function (key, 1); \ + if (EQ (key, XSYMBOL_FUNCTION (Qidentity))) \ + { \ + key = Qidentity; \ + } \ + } \ + } while (0) + +#define KEY(key, item) (EQ (Qidentity, key) ? item : \ + IGNORE_MULTIPLE_VALUES (call1 (key, item))) + +DEFUN ("adjoin", Fadjoin, 2, MANY, 0, /* +Return ITEM consed onto the front of LIST, if not already in LIST. + +Otherwise, return LIST unmodified. + +See `member*' for the meaning of the keywords. + +arguments: (ITEM LIST &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], list = args[1], keyed = Qnil, ignore = Qnil; + struct gcpro gcpro1; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fadjoin, nargs, args, 3, (test, key, test_not), + NULL); + + CHECK_KEY_ARGUMENT (key); + + keyed = KEY (key, item); + + GCPRO1 (keyed); + check_test = get_check_test_function (keyed, &test, test_not, Qnil, Qnil, + key, &test_not_unboundp); + if (NILP (list_position_cons_before (&ignore, keyed, list, check_test, + test_not_unboundp, test, key, 0, Qzero, + Qnil))) + { + RETURN_UNGCPRO (Fcons (item, list)); + } + + RETURN_UNGCPRO (list); +} + +DEFUN ("assoc", Fassoc, 2, 2, 0, /* +Return non-nil if KEY is `equal' to the car of an element of ALIST. +The value is actually the element of ALIST whose car equals KEY. +*/ + (key, alist)) +{ + /* This function can GC. */ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (internal_equal (key, elt_car, 0)) + return elt; + } + return Qnil; +} + +Lisp_Object +assoc_no_quit (Lisp_Object key, Lisp_Object alist) +{ + int speccount = specpdl_depth (); + specbind (Qinhibit_quit, Qt); + return unbind_to_1 (speccount, Fassoc (key, alist)); +} + +DEFUN ("assq", Fassq, 2, 2, 0, /* +Return non-nil if KEY is `eq' to the car of an element of ALIST. +The value is actually the element of ALIST whose car is KEY. +Elements of ALIST that are not conses are ignored. +*/ + (key, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) + return elt; + } + return Qnil; +} + +/* Like Fassq but never report an error and do not allow quits. + Use only on lists known never to be circular. */ + +Lisp_Object +assq_no_quit (Lisp_Object key, Lisp_Object alist) +{ + /* This cannot GC. */ + LIST_LOOP_2 (elt, alist) + { + Lisp_Object elt_car = XCAR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) + return elt; + } + return Qnil; +} + +DEFUN ("assoc*", FassocX, 2, MANY, 0, /* +Find the first item whose car matches ITEM in ALIST. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], alist = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FassocX, nargs, args, 5, (test, if_, if_not, test_not, key), + NULL); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (check_test == check_eq_nokey) + { + /* TEST is #'eq, no need to call any C functions. */ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ (item, elt_car) == test_not_unboundp) + { + return elt; + } + } + } + else + { + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, item, XCAR (elt)) == test_not_unboundp) + { + XUNGCPRO (elt); + return elt; + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + return Qnil; +} + +DEFUN ("rassoc", Frassoc, 2, 2, 0, /* +Return non-nil if VALUE is `equal' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr equals VALUE. +*/ + (value, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (internal_equal (value, elt_cdr, 0)) + return elt; + } + return Qnil; +} + +DEFUN ("rassq", Frassq, 2, 2, 0, /* +Return non-nil if VALUE is `eq' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr is VALUE. +*/ + (value, alist)) +{ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) + return elt; + } + return Qnil; +} + +/* Like Frassq, but caller must ensure that ALIST is properly + nil-terminated and ebola-free. */ +Lisp_Object +rassq_no_quit (Lisp_Object value, Lisp_Object alist) +{ + LIST_LOOP_2 (elt, alist) + { + Lisp_Object elt_cdr = XCDR (elt); + if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) + return elt; + } + return Qnil; +} + +DEFUN ("rassoc*", FrassocX, 2, MANY, 0, /* +Find the first item whose cdr matches ITEM in ALIST. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ITEM ALIST &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], alist = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FrassocX, nargs, args, 5, (test, if_, if_not, test_not, key), + NULL); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (check_test == check_eq_nokey) + { + /* TEST is #'eq, no need to call any C functions. */ + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) + { + if (EQ (item, elt_cdr) == test_not_unboundp) + { + return elt; + } + } + } + else + { + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, item, XCDR (elt)) == test_not_unboundp) + { + XUNGCPRO (elt); + return elt; + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + return Qnil; +} + +/* This is the implementation of both #'find and #'position. */ +static Lisp_Object +position (Lisp_Object *object_out, Lisp_Object item, Lisp_Object sequence, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, Lisp_Object start, Lisp_Object end, + Lisp_Object from_end, Lisp_Object default_, Lisp_Object caller) +{ + Lisp_Object result = Qnil; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, len, ii = 0; + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = FIXNUMP (start) ? XFIXNUM (start) : 1 + MOST_POSITIVE_FIXNUM; + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = FIXNUMP (end) ? XFIXNUM (end) : 1 + MOST_POSITIVE_FIXNUM; + } + + *object_out = default_; + + if (CONSP (sequence)) + { + if (!(starting < ending)) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + /* starting could be equal to ending, in which case nil is what + we want to return. */ + return Qnil; + } + + { + GC_EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (starting <= ii && ii < ending + && check_test (test, key, item, elt) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = elt; + + if (NILP (from_end)) + { + XUNGCPRO (elt); + return result; + } + } + else if (ii == ending) + { + break; + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else if (STRINGP (sequence)) + { + Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp; + Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0; + Lisp_Object character = Qnil; + + while (cursor_offset < byte_len && ii < ending) + { + if (ii >= starting) + { + character = make_char (itext_ichar (cursor)); + + if (check_test (test, key, item, character) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = character; + + if (NILP (from_end)) + { + return result; + } + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (caller, sequence); + } + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else + { + Lisp_Object object = Qnil; + len = XFIXNUM (Flength (sequence)); + check_sequence_range (sequence, start, end, make_fixnum (len)); + + ending = min (ending, len); + if (0 == len) + { + /* Catches the case where we have nil. */ + return result; + } + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ii++) + { + object = Faref (sequence, make_fixnum (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = object; + return result; + } + } + } + else + { + for (ii = ending - 1; ii >= starting; ii--) + { + object = Faref (sequence, make_fixnum (ii)); + if (check_test (test, key, item, object) == test_not_unboundp) + { + result = make_integer (ii); + *object_out = object; + return result; + } + } + } + } + + return result; +} + +DEFUN ("position", Fposition, 2, MANY, 0, /* +Return the index of the first occurrence of ITEM in SEQUENCE. + +Return nil if not found. See `remove*' for the meaning of the keywords. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object object = Qnil, item = args[0], sequence = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fposition, nargs, args, 8, + (test, if_, test_not, if_not, key, start, end, from_end), + (start = Qzero)); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + return position (&object, item, sequence, check_test, test_not_unboundp, + test, key, start, end, from_end, Qnil, Qposition); +} + +DEFUN ("find", Ffind, 2, MANY, 0, /* +Find the first occurrence of ITEM in SEQUENCE. + +Return the matching ITEM, or nil if not found. See `remove*' for the +meaning of the keywords. + +The keyword :default, not specified by Common Lisp, designates an object to +return instead of nil if ITEM is not found. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) DEFAULT FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object object = Qnil, item = args[0], sequence = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Ffind, nargs, args, 9, + (test, if_, test_not, if_not, key, start, end, from_end, + default_), + (start = Qzero)); + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + position (&object, item, sequence, check_test, test_not_unboundp, + test, key, start, end, from_end, default_, Qposition); + + return object; +} + +/* Like #'delq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ + +Lisp_Object +delq_no_quit (Lisp_Object elt, Lisp_Object list) +{ + LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); + return list; +} + +/* Be VERY careful with this. This is like delq_no_quit() but + also calls free_cons() on the removed conses. You must be SURE + that no pointers to the freed conses remain around (e.g. + someone else is pointing to part of the list). This function + is useful on internal lists that are used frequently and where + the actual list doesn't escape beyond known code bounds. */ + +Lisp_Object +delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) +{ + REGISTER Lisp_Object tail = list; + REGISTER Lisp_Object prev = Qnil; + + while (!NILP (tail)) + { + REGISTER Lisp_Object tem = XCAR (tail); + if (EQ (elt, tem)) + { + Lisp_Object cons_to_free = tail; + if (NILP (prev)) + list = XCDR (tail); + else + XCDR (prev) = XCDR (tail); + tail = XCDR (tail); + free_cons (cons_to_free); + } + else + { + prev = tail; + tail = XCDR (tail); + } + } + return list; +} + +DEFUN ("delete*", FdeleteX, 2, MANY, 0, /* +Remove all occurrences of ITEM in SEQUENCE, destructively. + +If SEQUENCE is a non-nil list, this modifies the list directly. A non-list +SEQUENCE will not be destructively modified, rather, if ITEM occurs in it, a +new SEQUENCE of the same type without ITEM will be returned. + +See `remove*' for a non-destructive alternative, and for explanation of the +keyword arguments. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], sequence = args[1]; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, counting = MOST_POSITIVE_FIXNUM; + Elemcount len, ii = 0, encountered = 0, presenting = 0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FdeleteX, nargs, args, 9, + (test, if_not, if_, test_not, key, start, end, from_end, + count), (start = Qzero, count = Qunbound)); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); + } + + if (!UNBOUNDP (count)) + { + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } +#ifdef HAVE_BIGNUM + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1; + } +#endif + + if (counting < 1) + { + return sequence; + } + + if (!NILP (from_end)) + { + /* Sigh, this is inelegant. Force count_with_tail () to ignore + the count keyword, so we get the actual number of matching + elements, and can start removing from the beginning for the + from-end case. */ + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } + } + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (CONSP (sequence)) + { + Lisp_Object prev_tail_list_elt = Qnil, ignore = Qnil; + Elemcount list_len = 0, deleted = 0; + struct gcpro gcpro1; + + if (!NILP (count) && !NILP (from_end)) + { + /* Both COUNT and FROM-END were specified; we need to traverse the + list twice. */ + Lisp_Object present = count_with_tail (&ignore, nargs, args, + QdeleteX); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XFIXNUM (present); + + /* If there are fewer items in the list than we have permission to + delete, we don't need to differentiate between the :from-end + nil and :from-end t cases. Otherwise, presenting is the number + of matching items we need to ignore before we start to + delete. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + GCPRO1 (prev_tail_list_elt); + ii = -1; + + { + GC_EXTERNAL_LIST_LOOP_4 (list_elt, sequence, tail, list_len) + { + ii++; + + if (starting <= ii && ii < ending && + (check_test (test, key, item, list_elt) == test_not_unboundp) + && (presenting ? encountered++ >= presenting + : encountered++ < counting)) + { + if (NILP (prev_tail_list_elt)) + { + sequence = XCDR (tail); + } + else + { + XSETCDR (prev_tail_list_elt, XCDR (tail)); + } + + /* Keep tortoise from ever passing hare. */ + list_len = 0; + deleted++; + } + else + { + prev_tail_list_elt = tail; + if (ii >= ending || (!presenting && encountered > counting)) + { + break; + } + } + } + END_GC_EXTERNAL_LIST_LOOP (list_elt); + } + + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end))) && + !(presenting ? encountered == presenting : encountered == counting)) + { + check_sequence_range (args[1], start, end, + make_fixnum (deleted + XFIXNUM (Flength (args[1])))); + } + + return sequence; + } + else if (STRINGP (sequence)) + { + Ibyte *staging = alloca_ibytes (XSTRING_LENGTH (sequence)); + Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence); + Ibyte *cursor = startp; + Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence); + Lisp_Object character, result = sequence; + + if (!NILP (count) && !NILP (from_end)) + { + Lisp_Object present = count_with_tail (&character, nargs, args, + QdeleteX); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XFIXNUM (present); + + /* If there are fewer items in the list than we have permission to + delete, we don't need to differentiate between the :from-end + nil and :from-end t cases. Otherwise, presenting is the number + of matching items we need to ignore before we start to + delete. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + ii = 0; + while (cursor_offset < byte_len) + { + if (ii >= starting && ii < ending) + { + character = make_char (itext_ichar (cursor)); + + if ((check_test (test, key, item, character) + == test_not_unboundp) + && (presenting ? encountered++ >= presenting : + encountered++ < counting)) + { + DO_NOTHING; + } + else + { + staging_cursor + += set_itext_ichar (staging_cursor, XCHAR (character)); + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (QdeleteX, sequence); + } + } + else + { + staging_cursor += itext_copy_ichar (cursor, staging_cursor); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + + if (0 != encountered) + { + result = make_string (staging, staging_cursor - staging); + copy_string_extents (result, sequence, 0, 0, + staging_cursor - staging); + sequence = result; + } + + return sequence; + } + else + { + Lisp_Object position0 = Qnil, object = Qnil; + Lisp_Object *staging = NULL, *staging_cursor, *staging_limit; + Elemcount positioning; + + len = XFIXNUM (Flength (sequence)); + + check_sequence_range (sequence, start, end, make_fixnum (len)); + + position0 = position (&object, item, sequence, check_test, + test_not_unboundp, test, key, start, end, + from_end, Qnil, QdeleteX); + if (NILP (position0)) + { + return sequence; + } + + ending = min (ending, len); + positioning = XFIXNUM (position0); + encountered = 1; + + if (NILP (from_end)) + { + staging = alloca_array (Lisp_Object, len - 1); + staging_cursor = staging; + + ii = 0; + while (ii < positioning) + { + *staging_cursor++ = Faref (sequence, make_fixnum (ii)); + ii++; + } + + ii = positioning + 1; + while (ii < ending) + { + object = Faref (sequence, make_fixnum (ii)); + if (encountered < counting + && (check_test (test, key, item, object) + == test_not_unboundp)) + { + encountered++; + } + else + { + *staging_cursor++ = object; + } + ii++; + } + + while (ii < len) + { + *staging_cursor++ = Faref (sequence, make_fixnum (ii)); + ii++; + } + } + else + { + staging = alloca_array (Lisp_Object, len - 1); + staging_cursor = staging_limit = staging + len - 1; + + ii = len - 1; + while (ii > positioning) + { + *--staging_cursor = Faref (sequence, make_fixnum (ii)); + ii--; + } + + ii = positioning - 1; + while (ii >= starting) + { + object = Faref (sequence, make_fixnum (ii)); + if (encountered < counting + && (check_test (test, key, item, object) == + test_not_unboundp)) + { + encountered++; + } + else + { + *--staging_cursor = object; + } + + ii--; + } + + while (ii >= 0) + { + *--staging_cursor = Faref (sequence, make_fixnum (ii)); + ii--; + } + + staging = staging_cursor; + staging_cursor = staging_limit; + } + + if (VECTORP (sequence)) + { + return Fvector (staging_cursor - staging, staging); + } + else if (BIT_VECTORP (sequence)) + { + return Fbit_vector (staging_cursor - staging, staging); + } + + /* A nil sequence will have given us a nil #'position, + above. */ + ABORT (); + + return Qnil; + } +} + +DEFUN ("remove*", FremoveX, 2, MANY, 0, /* +Remove all occurrences of ITEM in SEQUENCE, non-destructively. + +If SEQUENCE is a list, `remove*' makes a copy if that is necessary to avoid +corrupting the original SEQUENCE. + +The keywords :test and :test-not specify two-argument test and negated-test +predicates, respectively; :test defaults to `eql'. :key specifies a +one-argument function that transforms elements of SEQUENCE into \"comparison +keys\" before the test predicate is applied. See `member*' for more +information on these keywords. + +:start and :end, if given, specify indices of a subsequence of SEQUENCE to +be processed. Indices are 0-based and processing involves the subsequence +starting at the index given by :start and ending just before the index given +by :end. + +:count, if given, limits the number of items removed to the number +specified. :from-end, if given, causes processing to proceed starting from +the end instead of the beginning; in this case, this matters only if :count +is given. + +arguments: (ITEM SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object item = args[0], sequence = args[1], matched_count = Qnil, + tail = Qnil; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, counting = MOST_POSITIVE_FIXNUM; + Elemcount ii = 0, encountered = 0, presenting = 0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (FremoveX, nargs, args, 9, + (test, if_not, if_, test_not, key, start, end, from_end, + count), (start = Qzero)); + + if (!CONSP (sequence)) + { + return FdeleteX (nargs, args); + } + + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); + } + + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } +#ifdef HAVE_BIGNUM + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM; + } +#endif + + if (counting <= 0) + { + return sequence; + } + + if (!NILP (from_end)) + { + /* Sigh, this is inelegant. Force count_with_tail () to ignore the + count keyword, so we get the actual number of matching + elements, and can start removing from the beginning for the + from-end case. */ + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FremoveX))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + matched_count = count_with_tail (&tail, nargs, args, QremoveX); + + if (!ZEROP (matched_count)) + { + Lisp_Object result = Qnil, result_tail = Qnil; + struct gcpro gcpro1, gcpro2; + + if (!NILP (count) && !NILP (from_end)) + { + presenting = XFIXNUM (matched_count); + + /* If there are fewer matching elements in the list than we have + permission to delete, we don't need to differentiate between + the :from-end nil and :from-end t cases. Otherwise, presenting + is the number of matching items we need to ignore before we + start to delete. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + GCPRO2 (result, tail); + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tailing) + { + if (EQ (tail, tailing)) + { + XUNGCPRO (elt); + UNGCPRO; + + if (NILP (result)) + { + return XCDR (tail); + } + + XSETCDR (result_tail, XCDR (tail)); + return result; + } + else if (starting <= ii && ii < ending && + (check_test (test, key, item, elt) == test_not_unboundp) + && (presenting ? encountered++ >= presenting + : encountered++ < counting)) + { + DO_NOTHING; + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + + if (ii == ending) + { + break; + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + + return result; + } + + return sequence; +} + +Lisp_Object +remassoc_no_quit (Lisp_Object key, Lisp_Object alist) +{ + LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + internal_equal (key, XCAR (elt), 0))); + return alist; +} + +/* no quit, no errors; be careful */ + +Lisp_Object +remassq_no_quit (Lisp_Object key, Lisp_Object alist) +{ + LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); + return alist; +} + +/* Like Fremrassq, fast and unsafe; be careful */ +Lisp_Object +remrassq_no_quit (Lisp_Object value, Lisp_Object alist) +{ + LIST_LOOP_DELETE_IF (elt, alist, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); + return alist; +} + +/* Remove duplicate elements between START and END from LIST, a non-nil + list; if COPY is zero, do so destructively. Items to delete are selected + according to the algorithm used when :from-end t is passed to + #'delete-duplicates. Error if LIST is ill-formed or circular. + + TEST and KEY are as in #'remove*; CHECK_TEST and TEST_NOT_UNBOUNDP should + reflect them, having been initialised with get_check_match_function() or + get_check_test_function(). */ +static Lisp_Object +list_delete_duplicates_from_end (Lisp_Object list, + check_test_func_t check_test, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Lisp_Object start, + Lisp_Object end, Boolint copy) +{ + Lisp_Object checking = Qnil, result = list; + Lisp_Object keyed, positioned, position_cons = Qnil, result_tail; + Elemcount len = XFIXNUM (Flength (list)), pos, starting = XFIXNUM (start); + Elemcount ending = (NILP (end) ? len : XFIXNUM (end)), greatest_pos_seen = -1; + Elemcount ii = 0; + struct gcpro gcpro1; + + /* We can't delete (or remove) as we go, because that breaks START and + END. We could if END were nil, and that would change an ON(N + 2) + algorithm to an ON^2 algorithm. Here and now it doesn't matter, though, + #'delete-duplicates is relatively expensive no matter what. */ + struct Lisp_Bit_Vector *deleting + = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + + check_sequence_range (list, start, end, make_integer (len)); + + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + GCPRO1 (keyed); + + { + GC_EXTERNAL_LIST_LOOP_3 (elt, list, tail) + { + if (!(starting <= ii && ii <= ending) || bit_vector_bit (deleting, ii)) + { + ii++; + continue; + } + + keyed = KEY (key, elt); + checking = XCDR (tail); + pos = ii + 1; + + while (!NILP ((positioned = list_position_cons_before + (&position_cons, keyed, checking, check_test, + test_not_unboundp, test, key, 0, + make_fixnum (max (starting - pos, 0)), + make_fixnum (ending - pos))))) + { + pos = XFIXNUM (positioned) + pos; + set_bit_vector_bit (deleting, pos, 1); + greatest_pos_seen = max (greatest_pos_seen, pos); + checking = NILP (position_cons) ? + XCDR (checking) : XCDR (XCDR (position_cons)); + pos += 1; + } + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + UNGCPRO; + + ii = 0; + + if (greatest_pos_seen > -1) + { + if (copy) + { + result = result_tail = Fcons (XCAR (list), Qnil); + list = XCDR (list); + ii = 1; + + { + EXTERNAL_LIST_LOOP_3 (elt, list, tail) + { + if (ii == greatest_pos_seen) + { + XSETCDR (result_tail, XCDR (tail)); + break; + } + else if (!bit_vector_bit (deleting, ii)) + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + ii++; + } + } + } + else + { + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + bit_vector_bit (deleting, ii++)); + } + } + + return result; +} + +DEFUN ("delete-duplicates", Fdelete_duplicates, 1, MANY, 0, /* +Remove all duplicate elements from SEQUENCE, destructively. + +If SEQUENCE is a list and has duplicates, modify and return it. Note that +SEQUENCE may start with an element to be deleted; because of this, if +modifying a variable, be sure to write `(setq VARIABLE (delete-duplicates +VARIABLE))' to be certain to have a list without duplicate elements. + +If SEQUENCE is an array and has duplicates, return a newly-allocated array +of the same type comprising all unique elements of SEQUENCE. + +If there are no duplicate elements in SEQUENCE, return it unmodified. + +See `remove*' for the meaning of the keywords. See `remove-duplicates' for +a non-destructive version of this function. + +arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0], keyed = Qnil; + Lisp_Object positioned = Qnil, ignore = Qnil; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, len, ii = 0, jj = 0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fdelete_duplicates, nargs, args, 6, + (test, key, test_not, start, end, from_end), + (start = Qzero)); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); + } + + CHECK_KEY_ARGUMENT (key); + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + if (CONSP (sequence)) + { + if (NILP (from_end)) + { + Lisp_Object prev_tail = Qnil; + Elemcount deleted = 0; + + GCPRO2 (keyed, prev_tail); + + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (starting <= ii && ii < ending) + { + keyed = KEY (key, elt); + positioned + = list_position_cons_before (&ignore, keyed, + XCDR (tail), check_test, + test_not_unboundp, test, key, + 0, make_fixnum (max (starting + - (ii + 1), + 0)), + make_fixnum (ending + - (ii + 1))); + if (!NILP (positioned)) + { + sequence = XCDR (tail); + deleted++; + } + else + { + break; + } + } + else + { + break; + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (!(starting <= ii && ii <= ending)) + { + prev_tail = tail; + ii++; + continue; + } + + keyed = KEY (key, elt); + positioned + = list_position_cons_before (&ignore, keyed, XCDR (tail), + check_test, test_not_unboundp, + test, key, 0, + make_fixnum (max (starting + - (ii + 1), 0)), + make_fixnum (ending - (ii + 1))); + if (!NILP (positioned)) + { + /* We know this isn't the first iteration of the loop, + because we advanced above to the point where we have at + least one non-duplicate entry at the head of the + list. */ + XSETCDR (prev_tail, XCDR (tail)); + len = 0; + deleted++; + } + else + { + prev_tail = tail; + if (ii >= ending) + { + break; + } + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end)))) + { + check_sequence_range (args[0], start, end, + make_fixnum (deleted + + XFIXNUM (Flength (args[0])))); + } + } + else + { + sequence = list_delete_duplicates_from_end (sequence, check_test, + test_not_unboundp, + test, key, start, end, + 0); + } + } + else if (STRINGP (sequence)) + { + Lisp_Object elt = Qnil; + + if (EQ (Qidentity, key)) + { + /* We know all the elements will be characters; set check_test to + reflect that. This isn't useful if KEY is not #'identity, since + it may return non-characters for the elements. */ + check_test = get_check_test_function (make_char ('a'), + &test, test_not, + Qnil, Qnil, key, + &test_not_unboundp); + } + + if (NILP (from_end)) + { + Bytecount byte_len = XSTRING_LENGTH (sequence), cursor_offset = 0; + Ibyte *staging = alloca_ibytes (byte_len), *staging_cursor = staging; + Ibyte *cursor = XSTRING_DATA (sequence), *startp = cursor; + Elemcount deleted = 0; + + GCPRO1 (elt); + + while (cursor_offset < byte_len) + { + if (starting <= ii && ii < ending) + { + Ibyte *cursor0 = cursor; + Bytecount cursor0_offset; + Boolint delete_this = 0; + + elt = KEY (key, make_char (itext_ichar (cursor))); + INC_IBYTEPTR (cursor0); + cursor0_offset = cursor0 - startp; + + for (jj = ii + 1; jj < ending && cursor0_offset < byte_len; + jj++) + { + if (check_test (test, key, elt, + make_char (itext_ichar (cursor0))) + == test_not_unboundp) + { + delete_this = 1; + deleted++; + break; + } + + startp = XSTRING_DATA (sequence); + cursor0 = startp + cursor0_offset; + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor0)) + { + mapping_interaction_error (Qdelete_duplicates, + sequence); + } + + INC_IBYTEPTR (cursor0); + cursor0_offset = cursor0 - startp; + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qdelete_duplicates, sequence); + } + + if (!delete_this) + { + staging_cursor + += itext_copy_ichar (cursor, staging_cursor); + + } + } + else + { + staging_cursor += itext_copy_ichar (cursor, staging_cursor); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + + if (0 != deleted) + { + sequence = make_string (staging, staging_cursor - staging); + } + } + else + { + Elemcount deleted = 0; + Ibyte *staging = alloca_ibytes ((len = string_char_length (sequence)) + * MAX_ICHAR_LEN); + Ibyte *staging_cursor = staging, *startp = XSTRING_DATA (sequence); + Ibyte *endp = startp + XSTRING_LENGTH (sequence); + struct Lisp_Bit_Vector *deleting + = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + + check_sequence_range (sequence, start, end, make_integer (len)); + + /* For the from_end t case; transform contents to an array with + elements addressable in constant time, use the same algorithm + as for vectors. */ + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + while (startp < endp) + { + itext_copy_ichar (startp, staging + (ii * MAX_ICHAR_LEN)); + INC_IBYTEPTR (startp); + ii++; + } + + GCPRO1 (elt); + + ending = min (ending, len); + + for (ii = ending - 1; ii >= starting; ii--) + { + elt = KEY (key, make_char (itext_ichar (staging + + (ii * MAX_ICHAR_LEN)))); + for (jj = ii - 1; jj >= starting; jj--) + { + if (check_test (test, key, elt, + make_char (itext_ichar + (staging + (jj * MAX_ICHAR_LEN)))) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + + UNGCPRO; + + if (0 != deleted) + { + startp = XSTRING_DATA (sequence); + + for (ii = 0; ii < len; ii++) + { + if (!bit_vector_bit (deleting, ii)) + { + staging_cursor + += itext_copy_ichar (startp, staging_cursor); + } + + INC_IBYTEPTR (startp); + } + + sequence = make_string (staging, staging_cursor - staging); + } + } + } + else if (VECTORP (sequence)) + { + Elemcount deleted = 0; + Lisp_Object *content = XVECTOR_DATA (sequence); + struct Lisp_Bit_Vector *deleting; + Lisp_Object elt = Qnil; + + len = XVECTOR_LENGTH (sequence); + check_sequence_range (sequence, start, end, make_integer (len)); + + deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + GCPRO1 (elt); + + ending = min (ending, len); + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ii++) + { + elt = KEY (key, content[ii]); + + for (jj = ii + 1; jj < ending; jj++) + { + if (check_test (test, key, elt, content[jj]) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + else + { + for (ii = ending - 1; ii >= starting; ii--) + { + elt = KEY (key, content[ii]); + + for (jj = ii - 1; jj >= starting; jj--) + { + if (check_test (test, key, elt, content[jj]) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + + UNGCPRO; + + if (deleted) + { + Lisp_Object res = make_vector (len - deleted, Qnil), + *res_content = XVECTOR_DATA (res); + + for (ii = jj = 0; ii < len; ii++) + { + if (!bit_vector_bit (deleting, ii)) + { + res_content[jj++] = content[ii]; + } + } + + sequence = res; + } + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence); + Elemcount deleted = 0; + /* I'm a little irritated at this. Basically, the only reasonable + thing delete-duplicates should do if handed a bit vector is return + something of maximum length two and minimum length 0 (because + that's the possible number of distinct elements if EQ is regarded + as identity, which it should be). But to support arbitrary TEST + and KEY arguments, which may be non-deterministic from our + perspective, we need the same algorithm as for vectors. */ + struct Lisp_Bit_Vector *deleting; + Lisp_Object elt = Qnil; + + len = bit_vector_length (bv); + + if (EQ (Qidentity, key)) + { + /* We know all the elements will be bits; set check_test to + reflect that. This isn't useful if KEY is not #'identity, since + it may return non-bits for the elements. */ + check_test = get_check_test_function (Qzero, &test, test_not, + Qnil, Qnil, key, + &test_not_unboundp); + } + + check_sequence_range (sequence, start, end, make_integer (len)); + + deleting = (Lisp_Bit_Vector *) ALLOCA (sizeof (struct Lisp_Bit_Vector) + + (sizeof (long) + * (BIT_VECTOR_LONG_STORAGE (len) + - 1))); + deleting->size = len; + memset (&(deleting->bits), 0, + sizeof (long) * BIT_VECTOR_LONG_STORAGE (len)); + + ending = min (ending, len); + + GCPRO1 (elt); + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ii++) + { + elt = KEY (key, make_fixnum (bit_vector_bit (bv, ii))); + + for (jj = ii + 1; jj < ending; jj++) + { + if (check_test (test, key, elt, + make_fixnum (bit_vector_bit (bv, jj))) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + else + { + for (ii = ending - 1; ii >= starting; ii--) + { + elt = KEY (key, make_fixnum (bit_vector_bit (bv, ii))); + + for (jj = ii - 1; jj >= starting; jj--) + { + if (check_test (test, key, elt, + make_fixnum (bit_vector_bit (bv, jj))) + == test_not_unboundp) + { + set_bit_vector_bit (deleting, ii, 1); + deleted++; + break; + } + } + } + } + + UNGCPRO; + + if (deleted) + { + Lisp_Object res = make_bit_vector (len - deleted, Qzero); + Lisp_Bit_Vector *resbv = XBIT_VECTOR (res); + + for (ii = jj = 0; ii < len; ii++) + { + if (!bit_vector_bit (deleting, ii)) + { + set_bit_vector_bit (resbv, jj++, bit_vector_bit (bv, ii)); + } + } + + sequence = res; + } + } + + return sequence; +} + +DEFUN ("remove-duplicates", Fremove_duplicates, 1, MANY, 0, /* +Remove duplicate elements from SEQUENCE, non-destructively. + +If there are no duplicate elements in SEQUENCE, return it unmodified; +otherwise, return a new object. If SEQUENCE is a list, the new object may +share list structure with SEQUENCE. + +See `remove*' for the meaning of the keywords. + +arguments: (SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) END FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0], keyed, positioned = Qnil; + Lisp_Object result = sequence, result_tail = result, cursor = Qnil; + Lisp_Object cons_with_shared_tail = Qnil; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, ii = 0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fremove_duplicates, nargs, args, 6, + (test, key, test_not, start, end, from_end), + (start = Qzero)); + + CHECK_SEQUENCE (sequence); + + if (!CONSP (sequence)) + { + return Fdelete_duplicates (nargs, args); + } + + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); + } + + if (NILP (key)) + { + key = Qidentity; + } + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + if (NILP (from_end)) + { + Lisp_Object ignore = Qnil; + + GCPRO2 (keyed, result); + + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (starting <= ii && ii <= ending) + { + keyed = KEY (key, elt); + positioned + = list_position_cons_before (&ignore, keyed, XCDR (tail), + check_test, test_not_unboundp, + test, key, 0, + make_fixnum (max (starting + - (ii + 1), 0)), + make_fixnum (ending - (ii + 1))); + if (!NILP (positioned)) + { + sequence = result = result_tail = XCDR (tail); + } + else + { + break; + } + } + else + { + break; + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (!(starting <= ii && ii <= ending)) + { + ii++; + continue; + } + + /* For this algorithm, each time we encounter an object to be + removed, copy the output list from the tail beyond the last + removed cons to this one. Otherwise, the tail of the output list + is shared with the input list, which is OK. */ + + keyed = KEY (key, elt); + positioned + = list_position_cons_before (&ignore, keyed, XCDR (tail), + check_test, test_not_unboundp, + test, key, 0, + make_fixnum (max (starting - (ii + 1), + 0)), + make_fixnum (ending - (ii + 1))); + if (!NILP (positioned)) + { + if (EQ (result, sequence)) + { + result = cons_with_shared_tail + = Fcons (XCAR (sequence), XCDR (sequence)); + } + + result_tail = cons_with_shared_tail; + cursor = XCDR (cons_with_shared_tail); + + while (!EQ (cursor, tail) && !NILP (cursor)) + { + XSETCDR (result_tail, Fcons (XCAR (cursor), Qnil)); + result_tail = XCDR (result_tail); + cursor = XCDR (cursor); + } + + XSETCDR (result_tail, XCDR (tail)); + cons_with_shared_tail = result_tail; + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + UNGCPRO; + + if ((ii < starting || (ii < ending && !NILP (end)))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + } + else + { + result = list_delete_duplicates_from_end (sequence, check_test, + test_not_unboundp, test, key, + start, end, 1); + } + + return result; +} +#undef KEY + +DEFUN ("nreverse", Fnreverse, 1, 1, 0, /* +Reverse SEQUENCE, destructively. + +Return the beginning of the reversed sequence, which will be a distinct Lisp +object if SEQUENCE is a list with length greater than one. See also +`reverse', the non-destructive version of this function. +*/ + (sequence)) +{ + CHECK_SEQUENCE (sequence); + + if (CONSP (sequence)) + { + struct gcpro gcpro1, gcpro2; + Lisp_Object prev = Qnil; + Lisp_Object tail = sequence; + + /* We gcpro our args; see `nconc' */ + GCPRO2 (prev, tail); + while (!NILP (tail)) + { + REGISTER Lisp_Object next; + CONCHECK_CONS (tail); + next = XCDR (tail); + XCDR (tail) = prev; + prev = tail; + tail = next; + } + UNGCPRO; + return prev; + } + else if (VECTORP (sequence)) + { + Elemcount length = XVECTOR_LENGTH (sequence), ii = length; + Elemcount half = length / 2; + Lisp_Object swap = Qnil; + CHECK_LISP_WRITEABLE (sequence); + + while (ii > half) + { + swap = XVECTOR_DATA (sequence) [length - ii]; + XVECTOR_DATA (sequence) [length - ii] + = XVECTOR_DATA (sequence) [ii - 1]; + XVECTOR_DATA (sequence) [ii - 1] = swap; + --ii; + } + } + else if (STRINGP (sequence)) + { + Elemcount length = XSTRING_LENGTH (sequence); + Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length; + Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length; + + CHECK_LISP_WRITEABLE (sequence); + while (cursor < endp) + { + staging_end -= itext_ichar_len (cursor); + itext_copy_ichar (cursor, staging_end); + INC_IBYTEPTR (cursor); + } + + assert (staging == staging_end); + + memcpy (XSTRING_DATA (sequence), staging, length); + init_string_ascii_begin (sequence); + bump_string_modiff (sequence); + sledgehammer_check_ascii_begin (sequence); + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence); + Elemcount length = bit_vector_length (bv), ii = length; + Elemcount half = length / 2; + int swap = 0; + + CHECK_LISP_WRITEABLE (sequence); + while (ii > half) + { + swap = bit_vector_bit (bv, length - ii); + set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1)); + set_bit_vector_bit (bv, ii - 1, swap); + --ii; + } + } + else + { + assert (NILP (sequence)); + } + + return sequence; +} + +DEFUN ("reverse", Freverse, 1, 1, 0, /* +Reverse SEQUENCE, copying. Return the reversed sequence. +See also the function `nreverse', which is used more often. +*/ + (sequence)) +{ + Lisp_Object result = Qnil; + + CHECK_SEQUENCE (sequence); + + if (CONSP (sequence)) + { + EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + result = Fcons (elt, result); + } + } + else if (VECTORP (sequence)) + { + Elemcount length = XVECTOR_LENGTH (sequence), ii = length; + Lisp_Object *staging = alloca_array (Lisp_Object, length); + + while (ii > 0) + { + staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1]; + --ii; + } + + result = Fvector (length, staging); + } + else if (STRINGP (sequence)) + { + Elemcount length = XSTRING_LENGTH (sequence); + Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length; + Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length; + + while (cursor < endp) + { + staging_end -= itext_ichar_len (cursor); + itext_copy_ichar (cursor, staging_end); + INC_IBYTEPTR (cursor); + } + + assert (staging == staging_end); + + result = make_string (staging, length); + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res; + Elemcount length = bit_vector_length (bv), ii = length; + + result = make_bit_vector (length, Qzero); + res = XBIT_VECTOR (result); + + while (ii > 0) + { + set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1)); + --ii; + } + } + else + { + assert (NILP (sequence)); + } + + return result; +} + +Lisp_Object +list_merge (Lisp_Object org_l1, Lisp_Object org_l2, + check_test_func_t check_merge, + Lisp_Object predicate, Lisp_Object key) +{ + Lisp_Object value; + Lisp_Object tail; + Lisp_Object tem; + Lisp_Object l1, l2; + Lisp_Object tortoises[2]; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; + int l1_count = 0, l2_count = 0; + + l1 = org_l1; + l2 = org_l2; + tail = Qnil; + value = Qnil; + tortoises[0] = org_l1; + tortoises[1] = org_l2; + + /* It is sufficient to protect org_l1 and org_l2. When l1 and l2 are + updated, we copy the new values back into the org_ vars. */ + + GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]); + gcpro5.nvars = 2; + + while (1) + { + if (NILP (l1)) + { + UNGCPRO; + if (NILP (tail)) + return l2; + Fsetcdr (tail, l2); + return value; + } + if (NILP (l2)) + { + UNGCPRO; + if (NILP (tail)) + return l1; + Fsetcdr (tail, l1); + return value; + } + + if (check_merge (predicate, key, Fcar (l2), Fcar (l1)) == 0) + { + tem = l1; + l1 = Fcdr (l1); + org_l1 = l1; + + if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (l1_count & 1) + { + if (!CONSP (tortoises[0])) + { + mapping_interaction_error (Qmerge, tortoises[0]); + } + + tortoises[0] = XCDR (tortoises[0]); + } + + if (EQ (org_l1, tortoises[0])) + { + signal_circular_list_error (org_l1); + } + } + } + else + { + tem = l2; + l2 = Fcdr (l2); + org_l2 = l2; + + if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (l2_count & 1) + { + if (!CONSP (tortoises[1])) + { + mapping_interaction_error (Qmerge, tortoises[1]); + } + + tortoises[1] = XCDR (tortoises[1]); + } + + if (EQ (org_l2, tortoises[1])) + { + signal_circular_list_error (org_l2); + } + } + } + + if (NILP (tail)) + value = tem; + else + Fsetcdr (tail, tem); + + tail = tem; + } +} + +static void +array_merge (Lisp_Object *dest, Elemcount dest_len, + Lisp_Object *front, Elemcount front_len, + Lisp_Object *back, Elemcount back_len, + check_test_func_t check_merge, + Lisp_Object predicate, Lisp_Object key) +{ + Elemcount ii, fronting, backing; + Lisp_Object *front_staging = front; + Lisp_Object *back_staging = back; + struct gcpro gcpro1, gcpro2; + + assert (dest_len == (back_len + front_len)); + + if (0 == dest_len) + { + return; + } + + if (front >= dest && front < (dest + dest_len)) + { + front_staging = alloca_array (Lisp_Object, front_len); + + for (ii = 0; ii < front_len; ++ii) + { + front_staging[ii] = front[ii]; + } + } + + if (back >= dest && back < (dest + dest_len)) + { + back_staging = alloca_array (Lisp_Object, back_len); + + for (ii = 0; ii < back_len; ++ii) + { + back_staging[ii] = back[ii]; + } + } + + GCPRO2 (front_staging[0], back_staging[0]); + gcpro1.nvars = front_len; + gcpro2.nvars = back_len; + + for (ii = fronting = backing = 0; ii < dest_len; ++ii) + { + if (fronting >= front_len) + { + while (ii < dest_len) + { + dest[ii] = back_staging[backing]; + ++ii, ++backing; + } + UNGCPRO; + return; + } + + if (backing >= back_len) + { + while (ii < dest_len) + { + dest[ii] = front_staging[fronting]; + ++ii, ++fronting; + } + UNGCPRO; + return; + } + + if (check_merge (predicate, key, back_staging[backing], + front_staging[fronting]) == 0) + { + dest[ii] = front_staging[fronting]; + ++fronting; + } + else + { + dest[ii] = back_staging[backing]; + ++backing; + } + } + + UNGCPRO; +} + +static Lisp_Object +list_array_merge_into_list (Lisp_Object list, + Lisp_Object *array, Elemcount array_len, + check_test_func_t check_merge, + Lisp_Object predicate, Lisp_Object key, + Boolint reverse_order) +{ + Lisp_Object tail = Qnil, value = Qnil, tortoise = list; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + Elemcount array_index = 0; + int looped = 0; + + GCPRO4 (list, tail, value, tortoise); + + while (1) + { + if (NILP (list)) + { + UNGCPRO; + + if (NILP (tail)) + { + return Flist (array_len, array); + } + + Fsetcdr (tail, Flist (array_len - array_index, array + array_index)); + return value; + } + + if (array_index >= array_len) + { + UNGCPRO; + if (NILP (tail)) + { + return list; + } + + Fsetcdr (tail, list); + return value; + } + + + if (reverse_order ? + check_merge (predicate, key, Fcar (list), array [array_index]) + : !check_merge (predicate, key, array [array_index], Fcar (list))) + { + if (NILP (tail)) + { + value = tail = list; + } + else + { + Fsetcdr (tail, list); + tail = XCDR (tail); + } + + list = Fcdr (list); + } + else + { + if (NILP (tail)) + { + value = tail = Fcons (array [array_index], Qnil); + } + else + { + Fsetcdr (tail, Fcons (array [array_index], tail)); + tail = XCDR (tail); + } + ++array_index; + } + + if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (looped & 1) + { + tortoise = XCDR (tortoise); + } + + if (EQ (list, tortoise)) + { + signal_circular_list_error (list); + } + } + } +} + +static void +list_list_merge_into_array (Lisp_Object *output, Elemcount output_len, + Lisp_Object list_one, Lisp_Object list_two, + check_test_func_t check_merge, + Lisp_Object predicate, Lisp_Object key) +{ + Elemcount output_index = 0; + + while (output_index < output_len) + { + if (NILP (list_one)) + { + while (output_index < output_len) + { + output [output_index] = Fcar (list_two); + list_two = Fcdr (list_two), ++output_index; + } + return; + } + + if (NILP (list_two)) + { + while (output_index < output_len) + { + output [output_index] = Fcar (list_one); + list_one = Fcdr (list_one), ++output_index; + } + return; + } + + if (check_merge (predicate, key, Fcar (list_two), Fcar (list_one)) + == 0) + { + output [output_index] = XCAR (list_one); + list_one = XCDR (list_one); + } + else + { + output [output_index] = XCAR (list_two); + list_two = XCDR (list_two); + } + + ++output_index; + + /* No need to check for circularity. */ + } +} + +static void +list_array_merge_into_array (Lisp_Object *output, Elemcount output_len, + Lisp_Object list, + Lisp_Object *array, Elemcount array_len, + check_test_func_t check_merge, + Lisp_Object predicate, Lisp_Object key, + Boolint reverse_order) +{ + Elemcount output_index = 0, array_index = 0; + + while (output_index < output_len) + { + if (NILP (list)) + { + if (array_len - array_index != output_len - output_index) + { + mapping_interaction_error (Qmerge, list); + } + + while (array_index < array_len) + { + output [output_index++] = array [array_index++]; + } + + return; + } + + if (array_index >= array_len) + { + while (output_index < output_len) + { + output [output_index++] = Fcar (list); + list = Fcdr (list); + } + + return; + } + + if (reverse_order ? + check_merge (predicate, key, Fcar (list), array [array_index]) : + !check_merge (predicate, key, array [array_index], Fcar (list))) + { + output [output_index] = XCAR (list); + list = XCDR (list); + } + else + { + output [output_index] = array [array_index]; + ++array_index; + } + + ++output_index; + } +} + +#define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \ + do { \ + c_array = alloca_array (Lisp_Object, len); \ + for (counter = 0; counter < len; ++counter) \ + { \ + c_array[counter] = make_char (itext_ichar (strdata)); \ + INC_IBYTEPTR (strdata); \ + } \ + } while (0) + +#define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \ + c_array = alloca_array (Lisp_Object, len); \ + for (counter = 0; counter < len; ++counter) \ + { \ + c_array[counter] = make_fixnum (bit_vector_bit (v, counter)); \ + } \ + } while (0) + +DEFUN ("merge", Fmerge, 4, MANY, 0, /* +Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence. + +TYPE is the type of sequence to return. PREDICATE is a `less-than' +predicate on the elements. + +Optional keyword argument KEY is a function used to extract an object to be +used for comparison from each element of SEQUENCE-ONE and SEQUENCE-TWO. + +arguments: (TYPE SEQUENCE-ONE SEQUENCE-TWO PREDICATE &key (KEY #'IDENTITY)) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2], + predicate = args[3], result = Qnil; + check_test_func_t check_merge = NULL; + + PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL); + + CHECK_SEQUENCE (sequence_one); + CHECK_SEQUENCE (sequence_two); + + CHECK_KEY_ARGUMENT (key); + + check_merge = get_merge_predicate (predicate, key); + + if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two))) + { + if (NILP (sequence_two)) + { + result = Fappend (2, args + 1); + } + else if (NILP (sequence_one)) + { + args[3] = Qnil; /* Overwriting PREDICATE, and losing its GC + protection, but that doesn't matter. */ + result = Fappend (2, args + 2); + } + else if (CONSP (sequence_one) && CONSP (sequence_two)) + { + result = list_merge (sequence_one, sequence_two, check_merge, + predicate, key); + } + else + { + Lisp_Object *array_storage, swap; + Elemcount array_length, i; + Boolint reverse_order = 0; + + if (!CONSP (sequence_one)) + { + /* Make sequence_one the cons, sequence_two the array: */ + swap = sequence_one; + sequence_one = sequence_two; + sequence_two = swap; + reverse_order = 1; + } + + if (VECTORP (sequence_two)) + { + array_storage = XVECTOR_DATA (sequence_two); + array_length = XVECTOR_LENGTH (sequence_two); + } + else if (STRINGP (sequence_two)) + { + Ibyte *strdata = XSTRING_DATA (sequence_two); + array_length = string_char_length (sequence_two); + /* No need to GCPRO, characters are immediate. */ + STRING_DATA_TO_OBJECT_ARRAY (strdata, array_storage, i, + array_length); + + } + else + { + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence_two); + array_length = bit_vector_length (v); + /* No need to GCPRO, fixnums are immediate. */ + BIT_VECTOR_TO_OBJECT_ARRAY (v, array_storage, i, array_length); + } + + result = list_array_merge_into_list (sequence_one, + array_storage, array_length, + check_merge, predicate, key, + reverse_order); + } + } + else + { + Elemcount sequence_one_len = XFIXNUM (Flength (sequence_one)), + sequence_two_len = XFIXNUM (Flength (sequence_two)), i; + Elemcount output_len = 1 + sequence_one_len + sequence_two_len; + Lisp_Object *output = alloca_array (Lisp_Object, output_len), + *sequence_one_storage = NULL, *sequence_two_storage = NULL; + Boolint do_coerce = !(EQ (type, Qvector) || EQ (type, Qstring) + || EQ (type, Qbit_vector) || EQ (type, Qlist)); + Ibyte *strdata = NULL; + Lisp_Bit_Vector *v = NULL; + struct gcpro gcpro1; + + output[0] = do_coerce ? Qlist : type; + for (i = 1; i < output_len; ++i) + { + output[i] = Qnil; + } + + GCPRO1 (output[0]); + gcpro1.nvars = output_len; + + if (VECTORP (sequence_one)) + { + sequence_one_storage = XVECTOR_DATA (sequence_one); + } + else if (STRINGP (sequence_one)) + { + strdata = XSTRING_DATA (sequence_one); + STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_one_storage, + i, sequence_one_len); + } + else if (BIT_VECTORP (sequence_one)) + { + v = XBIT_VECTOR (sequence_one); + BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_one_storage, + i, sequence_one_len); + } + + if (VECTORP (sequence_two)) + { + sequence_two_storage = XVECTOR_DATA (sequence_two); + } + else if (STRINGP (sequence_two)) + { + strdata = XSTRING_DATA (sequence_two); + STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_two_storage, + i, sequence_two_len); + } + else if (BIT_VECTORP (sequence_two)) + { + v = XBIT_VECTOR (sequence_two); + BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_two_storage, + i, sequence_two_len); + } + + if (LISTP (sequence_one) && LISTP (sequence_two)) + { + list_list_merge_into_array (output + 1, output_len - 1, + sequence_one, sequence_two, + check_merge, predicate, key); + } + else if (LISTP (sequence_one)) + { + list_array_merge_into_array (output + 1, output_len - 1, + sequence_one, + sequence_two_storage, + sequence_two_len, + check_merge, predicate, key, 0); + } + else if (LISTP (sequence_two)) + { + list_array_merge_into_array (output + 1, output_len - 1, + sequence_two, + sequence_one_storage, + sequence_one_len, + check_merge, predicate, key, 1); + } + else + { + array_merge (output + 1, output_len - 1, + sequence_one_storage, sequence_one_len, + sequence_two_storage, sequence_two_len, + check_merge, predicate, + key); + } + + result = Ffuncall (output_len, output); + + if (do_coerce) + { + result = call2 (Qcoerce, result, type); + } + + UNGCPRO; + } + + return result; +} + +Lisp_Object +list_sort (Lisp_Object list, check_test_func_t check_merge, + Lisp_Object predicate, Lisp_Object key) +{ + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + Lisp_Object back, tem; + Lisp_Object front = list; + Lisp_Object len = Flength (list); + + if (XFIXNUM (len) < 2) + return list; + + len = make_fixnum (XFIXNUM (len) / 2 - 1); + tem = Fnthcdr (len, list); + back = Fcdr (tem); + Fsetcdr (tem, Qnil); + + GCPRO4 (front, back, predicate, key); + front = list_sort (front, check_merge, predicate, key); + back = list_sort (back, check_merge, predicate, key); + + RETURN_UNGCPRO (list_merge (front, back, check_merge, predicate, key)); +} + +static void +array_sort (Lisp_Object *array, Elemcount array_len, + check_test_func_t check_merge, + Lisp_Object predicate, Lisp_Object key) +{ + Elemcount split; + + if (array_len < 2) + return; + + split = array_len / 2; + + array_sort (array, split, check_merge, predicate, key); + array_sort (array + split, array_len - split, check_merge, predicate, + key); + array_merge (array, array_len, array, split, array + split, + array_len - split, check_merge, predicate, key); +} + +DEFUN ("sort*", FsortX, 2, MANY, 0, /* +Sort SEQUENCE, comparing elements using PREDICATE. +Returns the sorted sequence. SEQUENCE is modified by side effect. + +PREDICATE is called with two elements of SEQUENCE, and should return t if +the first element is `less' than the second. + +Optional keyword argument KEY is a function used to extract an object to be +used for comparison from each element of SEQUENCE. + +In this implementation, sorting is always stable; but call `stable-sort' if +this stability is important to you, other implementations may not make the +same guarantees. + +arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY)) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0], predicate = args[1]; + Lisp_Object *sequence_carray; + check_test_func_t check_merge = NULL; + Elemcount sequence_len, i; + + PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL); + + CHECK_SEQUENCE (sequence); + + CHECK_KEY_ARGUMENT (key); + + check_merge = get_merge_predicate (predicate, key); + + if (LISTP (sequence)) + { + sequence = list_sort (sequence, check_merge, predicate, key); + } + else if (VECTORP (sequence)) + { + array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence), + check_merge, predicate, key); + } + else if (STRINGP (sequence)) + { + Ibyte *strdata = XSTRING_DATA (sequence); + + sequence_len = string_char_length (sequence); + + STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len); + + /* No GCPRO necessary, characters are immediate. */ + array_sort (sequence_carray, sequence_len, check_merge, predicate, key); + + strdata = XSTRING_DATA (sequence); + + CHECK_LISP_WRITEABLE (sequence); + for (i = 0; i < sequence_len; ++i) + { + strdata += set_itext_ichar (strdata, XCHAR (sequence_carray[i])); + } + + init_string_ascii_begin (sequence); + bump_string_modiff (sequence); + sledgehammer_check_ascii_begin (sequence); + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); + sequence_len = bit_vector_length (v); + + BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len); + + /* No GCPRO necessary, bits are immediate. */ + array_sort (sequence_carray, sequence_len, check_merge, predicate, key); + + for (i = 0; i < sequence_len; ++i) + { + set_bit_vector_bit (v, i, XFIXNUM (sequence_carray [i])); + } + } + + return sequence; +} + + +static Lisp_Object replace_string_range_1 (Lisp_Object dest, + Lisp_Object start, + Lisp_Object end, + const Ibyte *source, + const Ibyte *source_limit, + Lisp_Object item); + +/* Fill the substring of DEST beginning at START and ending before END with + the character ITEM. If DEST does not have sufficient space for END - + START characters at START, write as many as is possible without changing + the character length of DEST. Update the string modification flag and do + any sledgehammer checks we have turned on. + + START must be a Lisp integer. END can be nil, indicating the length of the + string, or a Lisp integer. The condition (<= 0 START END (length DEST)) + must hold, or fill_string_range() will signal an error. */ +static Lisp_Object +fill_string_range (Lisp_Object dest, Lisp_Object item, Lisp_Object start, + Lisp_Object end) +{ + return replace_string_range_1 (dest, start, end, NULL, NULL, item); +} + +DEFUN ("fill", Ffill, 2, MANY, 0, /* +Destructively modify SEQUENCE by replacing each element with ITEM. +SEQUENCE is a list, vector, bit vector, or string. + +Optional keyword START is the index of the first element of SEQUENCE +to be modified, and defaults to zero. Optional keyword END is the +exclusive upper bound on the elements of SEQUENCE to be modified, and +defaults to the length of SEQUENCE. + +arguments: (SEQUENCE ITEM &key (START 0) (END (length SEQUENCE))) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0]; + Lisp_Object item = args[1]; + Elemcount starting, ending = MOST_POSITIVE_FIXNUM + 1, ii, len; + + PARSE_KEYWORDS (Ffill, nargs, args, 2, (start, end), (start = Qzero)); + + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end); + } + + retry: + if (STRINGP (sequence)) + { + CHECK_CHAR_COERCE_INT (item); + CHECK_LISP_WRITEABLE (sequence); + + fill_string_range (sequence, item, start, end); + } + else if (VECTORP (sequence)) + { + Lisp_Object *p = XVECTOR_DATA (sequence); + + CHECK_LISP_WRITEABLE (sequence); + len = XVECTOR_LENGTH (sequence); + + check_sequence_range (sequence, start, end, make_fixnum (len)); + ending = min (ending, len); + + for (ii = starting; ii < ending; ++ii) + { + p[ii] = item; + } + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); + int bit; + + CHECK_BIT (item); + bit = XFIXNUM (item); + CHECK_LISP_WRITEABLE (sequence); + len = bit_vector_length (v); + + check_sequence_range (sequence, start, end, make_fixnum (len)); + ending = min (ending, len); + + for (ii = starting; ii < ending; ++ii) + { + set_bit_vector_bit (v, ii, bit); + } + } + else if (LISTP (sequence)) + { + Elemcount counting = 0; + + { + EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (counting >= starting) + { + if (counting < ending) + { + XSETCAR (tail, item); + } + else if (counting == ending) + { + break; + } + } + ++counting; + } + } + + if (counting < starting || (counting != ending && !NILP (end))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + } + else + { + sequence = wrong_type_argument (Qsequencep, sequence); + goto retry; + } + return sequence; +} + + +/* Replace the substring of DEST beginning at START and ending before END + with the text at SOURCE, which is END - START characters long and + SOURCE_LIMIT - SOURCE octets long. If DEST does not have sufficient + space for END - START characters at START, write as many as is possible + without changing the length of DEST. Update the string modification flag + and do any sledgehammer checks we have turned on in this build. + + START must be a Lisp integer. END can be nil, indicating the length of the + string, or a Lisp integer. The condition (<= 0 START END (length DEST)) + must hold, or replace_string_range() will signal an error. */ +static Lisp_Object +replace_string_range (Lisp_Object dest, Lisp_Object start, Lisp_Object end, + const Ibyte *source, const Ibyte *source_limit) +{ + return replace_string_range_1 (dest, start, end, source, source_limit, + Qnil); +} + +/* This is the guts of several mapping functions. + + Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time, + taking the elements from SEQUENCES. If VALS is non-NULL, store the + results into VALS, a C array of Lisp_Objects; else, if LISP_VALS is + non-nil, store the results into LISP_VALS, a sequence with sufficient + room for CALL_COUNT results (but see the documentation of SOME_OR_EVERY.) + Else, do not accumulate any result. + + If VALS is non-NULL, NSEQUENCES is one, and SEQUENCES[0] is a cons, + mapcarX will store the elements of SEQUENCES[0] in stack and GCPRO them, + so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off + mapcarX. + + Otherwise, mapcarX signals an invalid state error (see + mapping_interaction_error(), above) if it encounters a non-cons, + non-array when traversing SEQUENCES. Common Lisp specifies in + MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION + destructively modifies SEQUENCES in a way that might affect the ongoing + traversal operation. + + CALLER is a symbol describing the Lisp-visible function that was called, + and any errors thrown because SEQUENCES was modified will reflect it. + + If CALLER is Qsome, return the (possibly multiple) values given by + FUNCTION the first time it is non-nil, and abandon the iterations. + LISP_VALS must be the result of calling STORE_VOID_IN_LISP on the address + of a Lisp object, and the return value will be stored at that address. + If CALLER is Qevery, LISP_VALS must also reflect a pointer to a Lisp + object, and Qnil will be stored at that address if FUNCTION gives nil; + otherwise it will be left alone. */ + +static void +mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals, + Lisp_Object function, int nsequences, Lisp_Object *sequences, + Lisp_Object caller) +{ + Lisp_Object called, *args; + struct gcpro gcpro1, gcpro2; + Ibyte *lisp_vals_staging = NULL, *cursor = NULL; + int i, j; + + assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1); + + args = alloca_array (Lisp_Object, nsequences + 1); + args[0] = function; + for (i = 1; i <= nsequences; ++i) + { + args[i] = Qnil; + } + + if (vals != NULL) + { + GCPRO2 (args[0], vals[0]); + gcpro1.nvars = nsequences + 1; + gcpro2.nvars = 0; + } + else + { + GCPRO1 (args[0]); + gcpro1.nvars = nsequences + 1; + } + + /* Be extra nice in the event that we've been handed one list and one + only; make it possible for FUNCTION to set cdrs not yet processed to + non-cons, non-nil objects without ill-effect, if we have been handed + the stack space to do that. */ + if (vals != NULL && 1 == nsequences && CONSP (sequences[0])) + { + Lisp_Object lst = sequences[0]; + Lisp_Object *val = vals; + for (i = 0; i < call_count; ++i) + { + *val++ = XCAR (lst); + lst = XCDR (lst); + } + gcpro2.nvars = call_count; + + for (i = 0; i < call_count; ++i) + { + args[1] = vals[i]; + vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args)); + } + } + else + { + enum lrecord_type lisp_vals_type = lrecord_type_symbol; + Binbyte *sequence_types = alloca_array (Binbyte, nsequences); + for (j = 0; j < nsequences; ++j) + { + sequence_types[j] = XRECORD_LHEADER (sequences[j])->type; + } + + if (!EQ (caller, Qsome) && !EQ (caller, Qevery)) + { + assert (LRECORDP (lisp_vals)); + + lisp_vals_type + = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; + + if (lrecord_type_string == lisp_vals_type) + { + lisp_vals_staging = cursor + = alloca_ibytes (call_count * MAX_ICHAR_LEN); + } + else if (ARRAYP (lisp_vals)) + { + CHECK_LISP_WRITEABLE (lisp_vals); + } + } + + for (i = 0; i < call_count; ++i) + { + for (j = 0; j < nsequences; ++j) + { + switch (sequence_types[j]) + { + case lrecord_type_cons: + { + if (!CONSP (sequences[j])) + { + /* This means FUNCTION has messed around with a cons + in one of the sequences, since we checked the + type (CHECK_SEQUENCE()) and the length and + structure (with Flength()) correctly in our + callers. */ + mapping_interaction_error (caller, sequences[j]); + } + args[j + 1] = XCAR (sequences[j]); + sequences[j] = XCDR (sequences[j]); + break; + } + case lrecord_type_vector: + { + args[j + 1] = XVECTOR_DATA (sequences[j])[i]; + break; + } + case lrecord_type_string: + { + args[j + 1] = make_char (string_ichar (sequences[j], i)); + break; + } + case lrecord_type_bit_vector: + { + args[j + 1] + = make_fixnum (bit_vector_bit (XBIT_VECTOR (sequences[j]), + i)); + break; + } + default: + ABORT(); + } + } + called = Ffuncall (nsequences + 1, args); + if (vals != NULL) + { + vals[i] = IGNORE_MULTIPLE_VALUES (called); + gcpro2.nvars += 1; + } + else if (EQ (Qsome, caller)) + { + if (!NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = called; + UNGCPRO; + return; + } + } + else if (EQ (Qevery, caller)) + { + if (NILP (IGNORE_MULTIPLE_VALUES (called))) + { + Lisp_Object *result + = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals); + *result = Qnil; + UNGCPRO; + return; + } + } + else + { + called = IGNORE_MULTIPLE_VALUES (called); + switch (lisp_vals_type) + { + case lrecord_type_symbol: + /* Discard the result of funcall. */ + break; + case lrecord_type_cons: + { + if (!CONSP (lisp_vals)) + { + /* If FUNCTION has inserted a non-cons non-nil + cdr into the list before we've processed the + relevant part, error. */ + mapping_interaction_error (caller, lisp_vals); + } + XSETCAR (lisp_vals, called); + lisp_vals = XCDR (lisp_vals); + break; + } + case lrecord_type_vector: + { + i < XVECTOR_LENGTH (lisp_vals) ? + (XVECTOR_DATA (lisp_vals)[i] = called) : + /* Let #'aset error. */ + Faset (lisp_vals, make_fixnum (i), called); + break; + } + case lrecord_type_string: + { + CHECK_CHAR_COERCE_INT (called); + cursor += set_itext_ichar (cursor, XCHAR (called)); + break; + } + case lrecord_type_bit_vector: + { + (BITP (called) && + i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? + set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, + XFIXNUM (called)) : + (void) Faset (lisp_vals, make_fixnum (i), called); + break; + } + default: + { + ABORT(); + break; + } + } + } + } + + if (lisp_vals_staging != NULL) + { + CHECK_LISP_WRITEABLE (lisp_vals); + replace_string_range (lisp_vals, Qzero, make_fixnum (call_count), + lisp_vals_staging, cursor); + } + } + + UNGCPRO; +} + +/* Given NSEQUENCES objects at the address pointed to by SEQUENCES, return + the length of the shortest sequence. Error if all are circular, or if any + one of them is not a sequence. */ +static Elemcount +shortest_length_among_sequences (int nsequences, Lisp_Object *sequences) +{ + Elemcount len = 1 + MOST_POSITIVE_FIXNUM; + Lisp_Object length = Qnil; + int i; + + for (i = 0; i < nsequences; ++i) + { + if (CONSP (sequences[i])) + { + length = Flist_length (sequences[i]); + if (!NILP (length)) + { + len = min (len, XFIXNUM (length)); + } + } + else + { + CHECK_SEQUENCE (sequences[i]); + length = Flength (sequences[i]); + len = min (len, XFIXNUM (length)); + } + } + + if (len == 1 + MOST_POSITIVE_FIXNUM) + { + signal_circular_list_error (sequences[0]); + } + + return len; +} + +DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /* +Call FUNCTION on each element of SEQUENCE, and concat results to a string. +Between each pair of results, insert SEPARATOR. + +Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR +results in spaces between the values returned by FUNCTION. SEQUENCE itself +may be a list, a vector, a bit vector, or a string. + +With optional SEQUENCES, call FUNCTION each time with as many arguments as +there are SEQUENCES, plus one for the element from SEQUENCE. One element +from each sequence will be used each time FUNCTION is called, and +`mapconcat' will give up once the shortest sequence is exhausted. + +arguments: (FUNCTION SEQUENCE SEPARATOR &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object function = args[0]; + Lisp_Object sequence = args[1]; + Lisp_Object separator = args[2]; + Elemcount len = MOST_POSITIVE_FIXNUM; + Lisp_Object *args0; + EMACS_INT i, nargs0; + + args[2] = sequence; + args[1] = separator; + + len = shortest_length_among_sequences (nargs - 2, args + 2); + + if (len == 0) return build_ascstring (""); + + nargs0 = len + len - 1; + args0 = alloca_array (Lisp_Object, nargs0); + + /* Special-case this, it's very common and doesn't require any + funcalls. Upside of doing it here, instead of cl-macs.el: no consing, + apart from the final string, we allocate everything on the stack. */ + if (EQ (function, Qidentity) && 3 == nargs && CONSP (sequence)) + { + for (i = 0; i < len; ++i) + { + args0[i] = XCAR (sequence); + sequence = XCDR (sequence); + } + } + else + { + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmapconcat); + } + + for (i = len - 1; i >= 0; i--) + args0[i + i] = args0[i]; + + for (i = 1; i < nargs0; i += 2) + args0[i] = separator; + + return Fconcat (nargs0, args0); +} + +DEFUN ("mapcar*", FmapcarX, 2, MANY, 0, /* +Call FUNCTION on each element of SEQUENCE; return a list of the results. +The result is a list of the same length as SEQUENCE. +SEQUENCE may be a list, a vector, a bit vector, or a string. + +With optional SEQUENCES, call FUNCTION each time with as many arguments as +there are SEQUENCES, plus one for the element from SEQUENCE. One element +from each sequence will be used each time FUNCTION is called, and `mapcar' +stops calling FUNCTION once the shortest sequence is exhausted. + +arguments: (FUNCTION SEQUENCE &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object function = args[0]; + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object *args0; + + args0 = alloca_array (Lisp_Object, len); + mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX); + + return Flist ((int) len, args0); +} + +DEFUN ("mapvector", Fmapvector, 2, MANY, 0, /* +Call FUNCTION on each element of SEQUENCE; return a vector of the results. +The result is a vector of the same length as SEQUENCE. +SEQUENCE may be a list, a vector, a bit vector, or a string. + +With optional SEQUENCES, call FUNCTION each time with as many arguments as +there are SEQUENCES, plus one for the element from SEQUENCE. One element +from each sequence will be used each time FUNCTION is called, and +`mapvector' stops calling FUNCTION once the shortest sequence is exhausted. + +arguments: (FUNCTION SEQUENCE &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object function = args[0]; + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object result = make_vector (len, Qnil); + + struct gcpro gcpro1; + GCPRO1 (result); + /* Don't pass result as the lisp_object argument, we want mapcarX to protect + a single list argument's elements from being garbage-collected. */ + mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1, + Qmapvector); + RETURN_UNGCPRO (result); +} + +DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /* +Call FUNCTION on each element of SEQUENCE; chain the results together. + +FUNCTION must normally return a list; the results will be concatenated +together using `nconc'. + +With optional SEQUENCES, call FUNCTION each time with as many arguments as +there are SEQUENCES, plus one for the element from SEQUENCE. One element +from each sequence will be used each time FUNCTION is called, and +`mapcan' stops calling FUNCTION once the shortest sequence is exhausted. + +arguments: (FUNCTION SEQUENCE &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object function = args[0], *result = alloca_array (Lisp_Object, len); + + mapcarX (len, result, Qnil, function, nargs - 1, args + 1, Qmapcan); + + /* #'nconc GCPROs its args in case of signals and error. */ + return Fnconc (len, result); +} + +DEFUN ("mapc", Fmapc, 2, MANY, 0, /* +Call FUNCTION on each element of SEQUENCE. + +SEQUENCE may be a list, a vector, a bit vector, or a string. +This function is like `mapcar' but does not accumulate the results, +which is more efficient if you do not use the results. + +With optional SEQUENCES, call FUNCTION each time with as many arguments as +there are SEQUENCES, plus one for the elements from SEQUENCE. One element +from each sequence will be used each time FUNCTION is called, and +`mapc' stops calling FUNCTION once the shortest sequence is exhausted. + +Return SEQUENCE. + +arguments: (FUNCTION SEQUENCE &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object sequence = args[1]; + struct gcpro gcpro1; + /* We need to GCPRO sequence, because mapcarX will modify the + elements of the args array handed to it, and this may involve + elements of sequence getting garbage collected. */ + GCPRO1 (sequence); + mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc); + RETURN_UNGCPRO (sequence); +} + +DEFUN ("map", Fmap, 3, MANY, 0, /* +Map FUNCTION across one or more sequences, returning a sequence. + +TYPE is the sequence type to return, FUNCTION is the function, SEQUENCE is +the first argument sequence, SEQUENCES are the other argument sequences. + +FUNCTION will be called with (1+ (length SEQUENCES)) arguments, and must be +capable of accepting this number of arguments. + +Certain TYPEs are recognised internally by `map', but others are not, and +`coerce' may throw an error on an attempt to convert to a TYPE it does not +understand. A null TYPE means do not accumulate any values. + +arguments: (TYPE FUNCTION SEQUENCE &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object type = args[0]; + Lisp_Object function = args[1]; + Lisp_Object result = Qnil; + Lisp_Object *args0 = NULL; + Elemcount len = shortest_length_among_sequences (nargs - 2, args + 2); + struct gcpro gcpro1; + + if (!NILP (type)) + { + args0 = alloca_array (Lisp_Object, len); + } + + mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmap); + + if (EQ (type, Qnil)) + { + return result; + } + + if (EQ (type, Qvector) || EQ (type, Qarray)) + { + result = Fvector (len, args0); + } + else if (EQ (type, Qstring)) + { + result = Fstring (len, args0); + } + else if (EQ (type, Qlist)) + { + result = Flist (len, args0); + } + else if (EQ (type, Qbit_vector)) + { + result = Fbit_vector (len, args0); + } + else + { + result = Flist (len, args0); + GCPRO1 (result); + result = call2 (Qcoerce, result, type); + UNGCPRO; + } + + return result; +} + +DEFUN ("map-into", Fmap_into, 2, MANY, 0, /* +Modify RESULT-SEQUENCE using the return values of FUNCTION on SEQUENCES. + +RESULT-SEQUENCE and SEQUENCES can be lists or arrays. + +FUNCTION must accept at least as many arguments as there are SEQUENCES +\(possibly zero). If RESULT-SEQUENCE and the elements of SEQUENCES are not +the same length, stop when the shortest is exhausted; any elements of +RESULT-SEQUENCE beyond that are unmodified. + +Return RESULT-SEQUENCE. + +arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Elemcount len; + Lisp_Object result_sequence = args[0]; + Lisp_Object function = args[1]; + + args[0] = function; + args[1] = result_sequence; + + len = shortest_length_among_sequences (nargs - 1, args + 1); + + mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, + Qmap_into); + + return result_sequence; +} + +DEFUN ("some", Fsome, 2, MANY, 0, /* +Return true if PREDICATE gives non-nil for an element of SEQUENCE. + +If so, return the value (possibly multiple) given by PREDICATE. + +With optional SEQUENCES, call PREDICATE each time with as many arguments as +there are SEQUENCES (plus one for the element from SEQUENCE). + +See also `find-if', which returns the corresponding element of SEQUENCE, +rather than the value given by PREDICATE, and accepts bounding index +keywords. + +arguments: (PREDICATE SEQUENCE &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result = Qnil, + result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome); + + return result; +} + +DEFUN ("every", Fevery, 2, MANY, 0, /* +Return true if PREDICATE is true of every element of SEQUENCE. + +With optional SEQUENCES, call PREDICATE each time with as many arguments as +there are SEQUENCES (plus one for the element from SEQUENCE). + +In contrast to `some', `every' never returns multiple values. + +arguments: (PREDICATE SEQUENCE &rest SEQUENCES) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result); + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + + mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery); + + return result; +} + + +DEFUN ("reduce", Freduce, 2, MANY, 0, /* +Combine the elements of SEQUENCE using FUNCTION, a binary operation. + +For example, `(reduce #'+ SEQUENCE)' returns the sum of all elements in +SEQUENCE, and `(reduce #'union SEQUENCE)' returns the union of all elements +in SEQUENCE. + +Keywords supported: :start :end :from-end :initial-value :key +See `remove*' for the meaning of :start, :end, :from-end and :key. + +:initial-value specifies an element (typically an identity element, such as +0) that is conceptually prepended to the sequence (or appended, when +:from-end is given). + +If the sequence has one element, that element is returned directly. +If the sequence has no elements, :initial-value is returned if given; +otherwise, FUNCTION is called with no arguments, and its result returned. + +arguments: (FUNCTION SEQUENCE &key (START 0) (END (length SEQUENCE)) FROM-END INITIAL-VALUE (KEY #'identity)) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object function = args[0], sequence = args[1], accum = Qunbound; + Elemcount starting, ending = MOST_POSITIVE_FIXNUM + 1, ii = 0; + + PARSE_KEYWORDS (Freduce, nargs, args, 5, + (start, end, from_end, initial_value, key), + (start = Qzero, initial_value = Qunbound)); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start); + CHECK_KEY_ARGUMENT (key); + +#define KEY(key, item) (EQ (Qidentity, key) ? item : \ + IGNORE_MULTIPLE_VALUES (call1 (key, item))) +#define CALL2(function, accum, item) \ + IGNORE_MULTIPLE_VALUES (call2 (function, accum, item)) + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end); + } + + if (VECTORP (sequence)) + { + Lisp_Vector *vv = XVECTOR (sequence); + struct gcpro gcpro1; + + check_sequence_range (sequence, start, end, make_fixnum (vv->size)); + + ending = min (ending, vv->size); + + GCPRO1 (accum); + + if (!UNBOUNDP (initial_value)) + { + accum = initial_value; + } + else if (ending - starting) + { + if (NILP (from_end)) + { + accum = KEY (key, vv->contents[starting]); + starting++; + } + else + { + accum = KEY (key, vv->contents[ending - 1]); + ending--; + } + } + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ++ii) + { + accum = CALL2 (function, accum, KEY (key, vv->contents[ii])); + } + } + else + { + for (ii = ending - 1; ii >= starting; --ii) + { + accum = CALL2 (function, KEY (key, vv->contents[ii]), accum); + } + } + + UNGCPRO; + } + else if (BIT_VECTORP (sequence)) + { + Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence); + struct gcpro gcpro1; + + check_sequence_range (sequence, start, end, make_fixnum (bv->size)); + ending = min (ending, bv->size); + + GCPRO1 (accum); + + if (!UNBOUNDP (initial_value)) + { + accum = initial_value; + } + else if (ending - starting) + { + if (NILP (from_end)) + { + accum = KEY (key, make_fixnum (bit_vector_bit (bv, starting))); + starting++; + } + else + { + accum = KEY (key, make_fixnum (bit_vector_bit (bv, ending - 1))); + ending--; + } + } + + if (NILP (from_end)) + { + for (ii = starting; ii < ending; ++ii) + { + accum = CALL2 (function, accum, + KEY (key, make_fixnum (bit_vector_bit (bv, ii)))); + } + } + else + { + for (ii = ending - 1; ii >= starting; --ii) + { + accum = CALL2 (function, KEY (key, + make_fixnum (bit_vector_bit (bv, + ii))), + accum); + } + } + + UNGCPRO; + + } + else if (STRINGP (sequence)) + { + struct gcpro gcpro1; + + GCPRO1 (accum); + + if (NILP (from_end)) + { + Bytecount byte_len = XSTRING_LENGTH (sequence); + Bytecount cursor_offset = 0; + const Ibyte *startp = XSTRING_DATA (sequence); + const Ibyte *cursor = startp; + + for (ii = 0; ii != starting && cursor_offset < byte_len; ++ii) + { + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + } + + if (!UNBOUNDP (initial_value)) + { + accum = initial_value; + } + else if (ending - starting && cursor_offset < byte_len) + { + accum = KEY (key, make_char (itext_ichar (cursor))); + starting++; + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + while (cursor_offset < byte_len && ii < ending) + { + accum = CALL2 (function, accum, + KEY (key, make_char (itext_ichar (cursor)))); + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ++ii; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else + { + Elemcount len = string_char_length (sequence); + Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence); + const Ibyte *cursor; + + check_sequence_range (sequence, start, end, make_fixnum (len)); + ending = min (ending, len); + starting = XFIXNUM (start); + + cursor = string_char_addr (sequence, ending - 1); + cursor_offset = cursor - XSTRING_DATA (sequence); + + if (!UNBOUNDP (initial_value)) + { + accum = initial_value; + } + else if (ending - starting) + { + accum = KEY (key, make_char (itext_ichar (cursor))); + ending--; + if (ending > 0) + { + cursor = XSTRING_DATA (sequence) + cursor_offset; + + if (!valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + + DEC_IBYTEPTR (cursor); + cursor_offset = cursor - XSTRING_DATA (sequence); + } + } + + for (ii = ending - 1; ii >= starting; --ii) + { + accum = CALL2 (function, KEY (key, + make_char (itext_ichar (cursor))), + accum); + if (ii > 0) + { + cursor = XSTRING_DATA (sequence) + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + + DEC_IBYTEPTR (cursor); + cursor_offset = cursor - XSTRING_DATA (sequence); + } + } + } + + UNGCPRO; + } + else if (LISTP (sequence)) + { + if (NILP (from_end)) + { + struct gcpro gcpro1; + + GCPRO1 (accum); + + if (!UNBOUNDP (initial_value)) + { + accum = initial_value; + } + else if (ending - starting) + { + GC_EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (ii == starting) + { + accum = KEY (key, elt); + starting++; + break; + } + ++ii; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + ii = 0; + + if (ending - starting) + { + GC_EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (ii >= starting) + { + if (ii < ending) + { + accum = CALL2 (function, accum, KEY (key, elt)); + } + else if (ii == ending) + { + break; + } + } + ++ii; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + } + else + { + Boolint need_accum = 0; + Lisp_Object *subsequence = NULL; + Elemcount counting = 0, len = 0; + struct gcpro gcpro1; + + len = XFIXNUM (Flength (sequence)); + check_sequence_range (sequence, start, end, make_fixnum (len)); + ending = min (ending, len); + + /* :from-end with a list; make an alloca copy of the relevant list + data, attempting to go backwards isn't worth the trouble. */ + if (!UNBOUNDP (initial_value)) + { + accum = initial_value; + if (ending - starting && starting < ending) + { + subsequence = alloca_array (Lisp_Object, ending - starting); + } + } + else if (ending - starting && starting < ending) + { + subsequence = alloca_array (Lisp_Object, ending - starting); + need_accum = 1; + } + + if (ending - starting && starting < ending) + { + EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (counting >= starting) + { + if (counting < ending) + { + subsequence[ii++] = elt; + } + else if (counting == ending) + { + break; + } + } + ++counting; + } + } + + if (subsequence != NULL) + { + len = ending - starting; + /* If we could be sure that neither FUNCTION nor KEY modify + SEQUENCE, this wouldn't be necessary, since all the + elements of SUBSEQUENCE would definitely always be + reachable via SEQUENCE. */ + GCPRO1 (subsequence[0]); + gcpro1.nvars = len; + } + + if (need_accum) + { + accum = KEY (key, subsequence[len - 1]); + --len; + } + + for (ii = len; ii != 0;) + { + --ii; + accum = CALL2 (function, KEY (key, subsequence[ii]), accum); + } + + if (subsequence != NULL) + { + UNGCPRO; + } + } + } + + /* At this point, if ACCUM is unbound, SEQUENCE has no elements; we + need to return the result of calling FUNCTION with zero + arguments. */ + if (UNBOUNDP (accum)) + { + accum = IGNORE_MULTIPLE_VALUES (call0 (function)); + } + + return accum; +} + +/* This function is the implementation of fill_string_range() and + replace_string_range(); see the comments for those functions. */ +static Lisp_Object +replace_string_range_1 (Lisp_Object dest, Lisp_Object start, Lisp_Object end, + const Ibyte *source, const Ibyte *source_limit, + Lisp_Object item) +{ + Ibyte *destp = XSTRING_DATA (dest), *p = destp, + *pend = p + XSTRING_LENGTH (dest), *pcursor, item_buf[MAX_ICHAR_LEN]; + Bytecount prefix_bytecount, source_len = source_limit - source; + Charcount ii = 0, ending, len; + Charcount starting = BIGNUMP (start) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start); + Elemcount delta; + + while (ii < starting && p < pend) + { + INC_IBYTEPTR (p); + ii++; + } + + pcursor = p; + + if (NILP (end)) + { + while (pcursor < pend) + { + INC_IBYTEPTR (pcursor); + ii++; + } + + ending = len = ii; + } + else + { + ending = BIGNUMP (end) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end); + while (ii < ending && pcursor < pend) + { + INC_IBYTEPTR (pcursor); + ii++; + } + } + + if (pcursor == pend) + { + /* We have the length, check it for our callers. */ + check_sequence_range (dest, start, end, make_fixnum (ii)); + } + + if (!(p == pend || p == pcursor)) + { + prefix_bytecount = p - destp; + + if (!NILP (item)) + { + assert (source == NULL && source_limit == NULL); + source_len = set_itext_ichar (item_buf, XCHAR (item)); + delta = (source_len * (ending - starting)) - (pcursor - p); + } + else + { + assert (source != NULL && source_limit != NULL); + delta = source_len - (pcursor - p); + } + + if (delta) + { + resize_string (dest, prefix_bytecount, delta); + destp = XSTRING_DATA (dest); + pcursor = destp + prefix_bytecount + (pcursor - p); + p = destp + prefix_bytecount; + } + + if (CHARP (item)) + { + while (starting < ending) + { + memcpy (p, item_buf, source_len); + p += source_len; + starting++; + } + } + else + { + while (starting < ending && source < source_limit) + { + source_len = itext_copy_ichar (source, p); + p += source_len, source += source_len; + } + } + + init_string_ascii_begin (dest); + bump_string_modiff (dest); + sledgehammer_check_ascii_begin (dest); + } + + return dest; +} + +DEFUN ("replace", Freplace, 2, MANY, 0, /* +Replace the elements of SEQUENCE-ONE with the elements of SEQUENCE-TWO. + +SEQUENCE-ONE is destructively modified, and returned. Its length is not +changed. + +Keywords :start1 and :end1 specify a subsequence of SEQUENCE-ONE, and +:start2 and :end2 a subsequence of SEQUENCE-TWO. See `search' for more +information. + +arguments: (SEQUENCE-ONE SEQUENCE-TWO &key (START1 0) (END1 (length SEQUENCE-ONE)) (START2 0) (END2 (length SEQUENCE-TWO))) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence1 = args[0], sequence2 = args[1], + result = sequence1; + Elemcount starting1, ending1 = MOST_POSITIVE_FIXNUM + 1, starting2; + Elemcount ending2 = MOST_POSITIVE_FIXNUM + 1, counting = 0, startcounting; + Boolint sequence1_listp, sequence2_listp, + overwriting = EQ (sequence1, sequence2); + + PARSE_KEYWORDS (Freplace, nargs, args, 4, (start1, end1, start2, end2), + (start1 = start2 = Qzero)); + + CHECK_SEQUENCE (sequence1); + CHECK_LISP_WRITEABLE (sequence1); + + CHECK_SEQUENCE (sequence2); + + CHECK_NATNUM (start1); + starting1 = BIGNUMP (start1) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start1); + CHECK_NATNUM (start2); + starting2 = BIGNUMP (start2) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (start2); + + if (!NILP (end1)) + { + CHECK_NATNUM (end1); + ending1 = BIGNUMP (end1) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end1); + } + + if (!NILP (end2)) + { + CHECK_NATNUM (end2); + ending2 = BIGNUMP (end2) ? MOST_POSITIVE_FIXNUM + 1 : XFIXNUM (end2); + } + + sequence1_listp = LISTP (sequence1); + sequence2_listp = LISTP (sequence2); + + overwriting = overwriting && starting2 <= starting1; + + if (sequence1_listp && !ZEROP (start1)) + { + sequence1 = Fnthcdr (start1, sequence1); + + if (NILP (sequence1)) + { + check_sequence_range (args[0], start1, end1, Flength (args[0])); + /* Give up early here. */ + return result; + } + + ending1 -= starting1; + starting1 = 0; + } + + if (sequence2_listp && !ZEROP (start2)) + { + sequence2 = Fnthcdr (start2, sequence2); + + if (NILP (sequence2)) + { + check_sequence_range (args[1], start1, end1, Flength (args[1])); + /* Nothing available to replace sequence1's contents. */ + return result; + } + + ending2 -= starting2; + starting2 = 0; + } + + if (overwriting) + { + if (EQ (start1, start2)) + { + return result; + } + + /* Our ranges may overlap. Save the data that might be overwritten. */ + + if (CONSP (sequence2)) + { + Elemcount len = XFIXNUM (Flength (sequence2)); + Lisp_Object *subsequence + = alloca_array (Lisp_Object, min (ending2, len)); + Elemcount ii = 0; + + LIST_LOOP_2 (elt, sequence2) + { + if (counting == ending2) + { + break; + } + + subsequence[ii++] = elt; + counting++; + } + + check_sequence_range (sequence1, start1, end1, + /* The XFIXNUM (start2) is intentional here; we + called #'length after doing (nthcdr + start2 sequence2). */ + make_fixnum (XFIXNUM (start2) + len)); + check_sequence_range (sequence2, start2, end2, + make_fixnum (XFIXNUM (start2) + len)); + + while (starting1 < ending1 + && starting2 < ending2 && !NILP (sequence1)) + { + XSETCAR (sequence1, subsequence[starting2]); + sequence1 = XCDR (sequence1); + starting1++; + starting2++; + } + } + else if (STRINGP (sequence2)) + { + Ibyte *p = XSTRING_DATA (sequence2), + *pend = p + XSTRING_LENGTH (sequence2), *pcursor, + *staging; + Bytecount ii = 0; + + while (ii < starting2 && p < pend) + { + INC_IBYTEPTR (p); + ii++; + } + + pcursor = p; + + while (ii < ending2 && starting1 < ending1 && pcursor < pend) + { + INC_IBYTEPTR (pcursor); + starting1++; + ii++; + } + + if (pcursor == pend) + { + check_sequence_range (sequence1, start1, end1, make_fixnum (ii)); + check_sequence_range (sequence2, start2, end2, make_fixnum (ii)); + } + else + { + assert ((pcursor - p) > 0); + staging = alloca_ibytes (pcursor - p); + memcpy (staging, p, pcursor - p); + replace_string_range (result, start1, + make_fixnum (starting1), + staging, staging + (pcursor - p)); + } + } + else + { + Elemcount seq_len = XFIXNUM (Flength (sequence2)), ii = 0, + subseq_len = min (min (ending1 - starting1, seq_len - starting1), + min (ending2 - starting2, seq_len - starting2)); + Lisp_Object *subsequence = alloca_array (Lisp_Object, subseq_len); + + check_sequence_range (sequence1, start1, end1, make_fixnum (seq_len)); + check_sequence_range (sequence2, start2, end2, make_fixnum (seq_len)); + + while (starting2 < ending2 && ii < seq_len) + { + subsequence[ii] = Faref (sequence2, make_fixnum (starting2)); + ii++, starting2++; + } + + ii = 0; + + while (starting1 < ending1 && ii < seq_len) + { + Faset (sequence1, make_fixnum (starting1), subsequence[ii]); + ii++, starting1++; + } + } + } + else if (sequence1_listp && sequence2_listp) + { + Lisp_Object sequence1_tortoise = sequence1, + sequence2_tortoise = sequence2; + Elemcount shortest_len = 0; + + counting = startcounting = min (ending1, ending2); + + while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2)) + { + XSETCAR (sequence1, + CONSP (sequence2) ? XCAR (sequence2) + : Fcar (sequence2)); + sequence1 = CONSP (sequence1) ? XCDR (sequence1) + : Fcdr (sequence1); + sequence2 = CONSP (sequence2) ? XCDR (sequence2) + : Fcdr (sequence2); + + shortest_len++; + + if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (counting & 1) + { + sequence1_tortoise = XCDR (sequence1_tortoise); + sequence2_tortoise = XCDR (sequence2_tortoise); + } + + if (EQ (sequence1, sequence1_tortoise)) + { + signal_circular_list_error (sequence1); + } + + if (EQ (sequence2, sequence2_tortoise)) + { + signal_circular_list_error (sequence2); + } + } + } + + if (NILP (sequence1)) + { + check_sequence_range (args[0], start1, end1, + make_fixnum (XFIXNUM (start1) + shortest_len)); + } + else if (NILP (sequence2)) + { + check_sequence_range (args[1], start2, end2, + make_fixnum (XFIXNUM (start2) + shortest_len)); + } + } + else if (sequence1_listp) + { + if (STRINGP (sequence2)) + { + Ibyte *s2_data = XSTRING_DATA (sequence2), + *s2_end = s2_data + XSTRING_LENGTH (sequence2); + Elemcount char_count = 0; + Lisp_Object character; + + while (char_count < starting2 && s2_data < s2_end) + { + INC_IBYTEPTR (s2_data); + char_count++; + } + + while (starting1 < ending1 && starting2 < ending2 + && s2_data < s2_end && !NILP (sequence1)) + { + character = make_char (itext_ichar (s2_data)); + CONSP (sequence1) ? + XSETCAR (sequence1, character) + : Fsetcar (sequence1, character); + sequence1 = XCDR (sequence1); + starting1++; + starting2++; + char_count++; + INC_IBYTEPTR (s2_data); + } + + if (NILP (sequence1)) + { + check_sequence_range (sequence1, start1, end1, + make_fixnum (XFIXNUM (start1) + starting1)); + } + + if (s2_data == s2_end) + { + check_sequence_range (sequence2, start2, end2, + make_fixnum (char_count)); + } + } + else + { + Elemcount len2 = XFIXNUM (Flength (sequence2)); + check_sequence_range (sequence2, start2, end2, make_fixnum (len2)); + + ending2 = min (ending2, len2); + while (starting2 < ending2 + && starting1 < ending1 && !NILP (sequence1)) + { + CHECK_CONS (sequence1); + XSETCAR (sequence1, Faref (sequence2, make_fixnum (starting2))); + sequence1 = XCDR (sequence1); + starting1++; + starting2++; + } + + if (NILP (sequence1)) + { + check_sequence_range (args[0], start1, end1, + make_fixnum (XFIXNUM (start1) + starting1)); + } + } + } + else if (sequence2_listp) + { + if (STRINGP (sequence1)) + { + Elemcount ii = 0, count, len = string_char_length (sequence1); + Ibyte *staging, *cursor; + Lisp_Object obj; + + check_sequence_range (sequence1, start1, end1, make_fixnum (len)); + ending1 = min (ending1, len); + count = ending1 - starting1; + staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN); + + while (ii < count && !NILP (sequence2)) + { + obj = CONSP (sequence2) ? XCAR (sequence2) + : Fcar (sequence2); + + CHECK_CHAR_COERCE_INT (obj); + cursor += set_itext_ichar (cursor, XCHAR (obj)); + ii++; + sequence2 = XCDR (sequence2); + } + + if (NILP (sequence2)) + { + check_sequence_range (sequence2, start2, end2, + make_fixnum (XFIXNUM (start2) + ii)); + } + + replace_string_range (result, start1, make_fixnum (XFIXNUM (start1) + ii), + staging, cursor); + } + else + { + Elemcount len = XFIXNUM (Flength (sequence1)); + + check_sequence_range (sequence1, start2, end1, make_fixnum (len)); + ending1 = min (ending2, min (ending1, len)); + + while (starting1 < ending1 && !NILP (sequence2)) + { + Faset (sequence1, make_fixnum (starting1), + CONSP (sequence2) ? XCAR (sequence2) + : Fcar (sequence2)); + sequence2 = XCDR (sequence2); + starting1++; + starting2++; + } + + if (NILP (sequence2)) + { + check_sequence_range (args[1], start2, end2, + make_fixnum (XFIXNUM (start2) + starting2)); + } + } + } + else + { + if (STRINGP (sequence1) && STRINGP (sequence2)) + { + Ibyte *p2 = XSTRING_DATA (sequence2), + *p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor; + Charcount ii = 0, len1 = string_char_length (sequence1); + + check_sequence_range (sequence1, start1, end1, make_fixnum (len1)); + + while (ii < starting2 && p2 < p2end) + { + INC_IBYTEPTR (p2); + ii++; + } + + p2cursor = p2; + ending1 = min (ending1, len1); + + while (ii < ending2 && starting1 < ending1 && p2cursor < p2end) + { + INC_IBYTEPTR (p2cursor); + ii++; + starting1++; + } + + if (p2cursor == p2end) + { + check_sequence_range (sequence2, start2, end2, make_fixnum (ii)); + } + + /* This isn't great; any error message won't necessarily reflect + the END1 that was supplied to #'replace. */ + replace_string_range (result, start1, make_fixnum (starting1), + p2, p2cursor); + } + else if (STRINGP (sequence1)) + { + Ibyte *staging, *cursor; + Elemcount count, len1 = string_char_length (sequence1); + Elemcount len2 = XFIXNUM (Flength (sequence2)), ii = 0; + Lisp_Object obj; + + check_sequence_range (sequence1, start1, end1, make_fixnum (len1)); + check_sequence_range (sequence2, start2, end2, make_fixnum (len2)); + + ending1 = min (ending1, len1); + ending2 = min (ending2, len2); + count = min (ending1 - starting1, ending2 - starting2); + staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN); + + ii = 0; + while (ii < count) + { + obj = Faref (sequence2, make_fixnum (starting2)); + + CHECK_CHAR_COERCE_INT (obj); + cursor += set_itext_ichar (cursor, XCHAR (obj)); + starting2++, ii++; + } + + replace_string_range (result, start1, + make_fixnum (XFIXNUM (start1) + count), + staging, cursor); + } + else if (STRINGP (sequence2)) + { + Ibyte *p2 = XSTRING_DATA (sequence2), + *p2end = p2 + XSTRING_LENGTH (sequence2); + Elemcount len1 = XFIXNUM (Flength (sequence1)), ii = 0; + + check_sequence_range (sequence1, start1, end1, make_fixnum (len1)); + ending1 = min (ending1, len1); + + while (ii < starting2 && p2 < p2end) + { + INC_IBYTEPTR (p2); + ii++; + } + + while (p2 < p2end && starting1 < ending1 && starting2 < ending2) + { + Faset (sequence1, make_fixnum (starting1), + make_char (itext_ichar (p2))); + INC_IBYTEPTR (p2); + starting1++; + starting2++; + ii++; + } + + if (p2 == p2end) + { + check_sequence_range (sequence2, start2, end2, make_fixnum (ii)); + } + } + else + { + Elemcount len1 = XFIXNUM (Flength (sequence1)), + len2 = XFIXNUM (Flength (sequence2)); + + check_sequence_range (sequence1, start1, end1, make_fixnum (len1)); + check_sequence_range (sequence2, start2, end2, make_fixnum (len2)); + + ending1 = min (ending1, len1); + ending2 = min (ending2, len2); + + while (starting1 < ending1 && starting2 < ending2) + { + Faset (sequence1, make_fixnum (starting1), + Faref (sequence2, make_fixnum (starting2))); + starting1++; + starting2++; + } + } + } + + return result; +} + +DEFUN ("nsubstitute", Fnsubstitute, 3, MANY, 0, /* +Substitute NEW for OLD in SEQUENCE. + +This is a destructive function; it reuses the storage of SEQUENCE whenever +possible. See `remove*' for the meaning of the keywords. + +arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) FROM-END COUNT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object new_ = args[0], item = args[1], sequence = args[2]; + Lisp_Object object_, position0; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0; + Elemcount len, ii = 0, counting = MOST_POSITIVE_FIXNUM, presenting = 0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fnsubstitute, nargs, args, 9, + (test, if_, if_not, test_not, key, start, end, count, + from_end), (start = Qzero)); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); + } + + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } +#ifdef HAVE_BIGNUM + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM; + } +#endif + + if (counting <= 0) + { + return sequence; + } + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (CONSP (sequence)) + { + if (!NILP (count) && !NILP (from_end)) + { + Lisp_Object present = count_with_tail (&object_, nargs - 1, args + 1, + Qnsubstitute); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XFIXNUM (present); + presenting = presenting <= counting ? 0 : presenting - counting; + } + + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) + { + if (!(ii < ending)) + { + break; + } + + if (starting <= ii && + check_test (test, key, item, elt) == test_not_unboundp + && (presenting ? encountered++ >= presenting + : encountered++ < counting)) + { + CHECK_LISP_WRITEABLE (tail); + XSETCAR (tail, new_); + } + else if (!presenting && encountered >= counting) + { + break; + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + if ((ii < starting || (ii < ending && !NILP (end))) + && encountered < counting) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + } + else if (STRINGP (sequence)) + { + Ibyte *staging, new_bytes[MAX_ICHAR_LEN], *staging_cursor; + Ibyte *startp = XSTRING_DATA (sequence), *cursor = startp; + Bytecount cursor_offset = 0, byte_len = XSTRING_LENGTH (sequence); + Bytecount new_len; + Lisp_Object character; + + CHECK_CHAR_COERCE_INT (new_); + + new_len = set_itext_ichar (new_bytes, XCHAR (new_)); + + /* Worst case scenario; new char is four octets long, all the old ones + were one octet long, all the old ones match. */ + staging = alloca_ibytes (XSTRING_LENGTH (sequence) * new_len); + staging_cursor = staging; + + if (!NILP (count) && !NILP (from_end)) + { + Lisp_Object present = count_with_tail (&character, nargs - 1, + args + 1, Qnsubstitute); + + if (ZEROP (present)) + { + return sequence; + } + + presenting = XFIXNUM (present); + + /* If there are fewer items in the string than we have + permission to change, we don't need to differentiate + between the :from-end nil and :from-end t + cases. Otherwise, presenting is the number of matching + items we need to ignore before we start to change. */ + presenting = presenting <= counting ? 0 : presenting - counting; + } + + ii = 0; + while (cursor_offset < byte_len && ii < ending) + { + if (ii >= starting) + { + character = make_char (itext_ichar (cursor)); + + if ((check_test (test, key, item, character) + == test_not_unboundp) + && (presenting ? encountered++ >= presenting : + encountered++ < counting)) + { + staging_cursor + += itext_copy_ichar (new_bytes, staging_cursor); + } + else + { + staging_cursor + += itext_copy_ichar (cursor, staging_cursor); + } + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qnsubstitute, sequence); + } + } + else + { + staging_cursor += itext_copy_ichar (cursor, staging_cursor); + } + + INC_IBYTEPTR (cursor); + cursor_offset = cursor - startp; + ii++; + } + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (sequence, start, end, Flength (sequence)); + } + + if (0 != encountered) + { + CHECK_LISP_WRITEABLE (sequence); + replace_string_range (sequence, Qzero, make_fixnum (ii), + staging, staging_cursor); + } + } + else + { + Elemcount positioning; + Lisp_Object object = Qnil; + + len = XFIXNUM (Flength (sequence)); + check_sequence_range (sequence, start, end, make_fixnum (len)); + + position0 = position (&object, item, sequence, check_test, + test_not_unboundp, test, key, start, end, from_end, + Qnil, Qnsubstitute); + + if (NILP (position0)) + { + return sequence; + } + + positioning = XFIXNUM (position0); + ending = min (len, ending); + + Faset (sequence, position0, new_); + encountered = 1; + + if (NILP (from_end)) + { + for (ii = positioning + 1; ii < ending; ii++) + { + object_ = Faref (sequence, make_fixnum (ii)); + + if (check_test (test, key, item, object_) == test_not_unboundp + && encountered++ < counting) + { + Faset (sequence, make_fixnum (ii), new_); + } + else if (encountered == counting) + { + break; + } + } + } + else + { + for (ii = positioning - 1; ii >= starting; ii--) + { + object_ = Faref (sequence, make_fixnum (ii)); + + if (check_test (test, key, item, object_) == test_not_unboundp + && encountered++ < counting) + { + Faset (sequence, make_fixnum (ii), new_); + } + else if (encountered == counting) + { + break; + } + } + } + } + + return sequence; +} + +DEFUN ("substitute", Fsubstitute, 3, MANY, 0, /* +Substitute NEW for OLD in SEQUENCE. + +This is a non-destructive function; it makes a copy of SEQUENCE if necessary +to avoid corrupting the original SEQUENCE. + +See `remove*' for the meaning of the keywords. + +arguments: (NEW OLD SEQUENCE &key (TEST #'eql) (KEY #'identity) (START 0) (END (length SEQUENCE)) COUNT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil; + Lisp_Object result = Qnil, result_tail = Qnil; + Lisp_Object object, position0, matched_count; + Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0; + Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, presenting = 0; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1; + + PARSE_KEYWORDS (Fsubstitute, nargs, args, 9, + (test, if_, if_not, test_not, key, start, end, count, + from_end), (start = Qzero, count = Qunbound)); + + CHECK_SEQUENCE (sequence); + + CHECK_NATNUM (start); + starting = BIGNUMP (start) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); + } + + check_test = get_check_test_function (item, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + if (!UNBOUNDP (count)) + { + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } +#ifdef HAVE_BIGNUM + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM; + } +#endif + + if (counting <= 0) + { + return sequence; + } + } + } + + if (!CONSP (sequence)) + { + position0 = position (&object, item, sequence, check_test, + test_not_unboundp, test, key, start, end, from_end, + Qnil, Qsubstitute); + + if (NILP (position0)) + { + return sequence; + } + else + { + args[2] = Fcopy_sequence (sequence); + return Fnsubstitute (nargs, args); + } + } + + matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute); + + if (ZEROP (matched_count)) + { + return sequence; + } + + if (!NILP (count) && !NILP (from_end)) + { + presenting = XFIXNUM (matched_count); + presenting = presenting <= counting ? 0 : presenting - counting; + } + + GCPRO1 (result); + { + GC_EXTERNAL_LIST_LOOP_3 (elt, sequence, tailing) + { + if (EQ (tail, tailing)) + { + XUNGCPRO (elt); + UNGCPRO; + + if (NILP (result)) + { + return XCDR (tail); + } + + XSETCDR (result_tail, XCDR (tail)); + return result; + } + else if (starting <= ii && ii < ending && + (check_test (test, key, item, elt) == test_not_unboundp) + && (presenting ? encountered++ >= presenting + : encountered++ < counting)) + { + if (NILP (result)) + { + result = result_tail = Fcons (new_, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (new_, Qnil)); + result_tail = XCDR (result_tail); + } + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + + if (ii == ending) + { + break; + } + + ii++; + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + UNGCPRO; + + if (ii < starting || (ii < ending && !NILP (end))) + { + check_sequence_range (args[0], start, end, Flength (args[0])); + } + + return result; +} + +static Lisp_Object +subst (Lisp_Object new_, Lisp_Object old, Lisp_Object tree, int depth) +{ + if (depth + lisp_eval_depth > max_lisp_eval_depth) + { + stack_overflow ("Stack overflow in subst", tree); + } + + if (EQ (tree, old)) + { + return new_; + } + else if (CONSP (tree)) + { + Lisp_Object aa = subst (new_, old, XCAR (tree), depth + 1); + Lisp_Object dd = subst (new_, old, XCDR (tree), depth + 1); + + if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree))) + { + return tree; + } + else + { + return Fcons (aa, dd); + } + } + else + { + return tree; + } +} + +static Lisp_Object +sublis (Lisp_Object alist, Lisp_Object tree, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, int depth) +{ + Lisp_Object keyed = KEY (key, tree), aa, dd; + + if (depth + lisp_eval_depth > max_lisp_eval_depth) + { + stack_overflow ("Stack overflow in sublis", tree); + } + + { + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) + { + XUNGCPRO (elt); + return XCDR (elt); + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + if (!CONSP (tree)) + { + return tree; + } + + aa = sublis (alist, XCAR (tree), check_test, test_not_unboundp, test, key, + depth + 1); + dd = sublis (alist, XCDR (tree), check_test, test_not_unboundp, test, key, + depth + 1); + + if (EQ (aa, XCAR (tree)) && EQ (dd, XCDR (tree))) + { + return tree; + } + + return Fcons (aa, dd); +} + +DEFUN ("sublis", Fsublis, 2, MANY, 0, /* +Perform substitutions indicated by ALIST in TREE (non-destructively). +Return a copy of TREE with all matching elements replaced. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object alist = args[0], tree = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fsublis, nargs, args, 5, (test, if_, test_not, if_not, key), + (key = Qidentity)); + + if (NILP (key)) + { + key = Qidentity; + } + + get_check_match_function (&test, test_not, if_, if_not, + /* sublis() is going to apply the key, don't ask + for a match function that will do it for + us. */ + Qidentity, &test_not_unboundp, &check_test); + + if (CONSP (alist) && NILP (XCDR (alist)) && CONSP (XCAR (alist)) + && EQ (key, Qidentity) && 1 == test_not_unboundp + && (check_eq_nokey == check_test || + (check_eql_nokey == check_test && + !NON_FIXNUM_NUMBER_P (XCAR (XCAR (alist)))))) + { + /* #'subst with #'eq is very cheap indeed; call it. */ + return subst (XCDR (XCAR (alist)), XCAR (XCAR (alist)), tree, 0); + } + + return sublis (alist, tree, check_test, test_not_unboundp, test, key, 0); +} + +static Lisp_Object +nsublis (Lisp_Object alist, Lisp_Object tree, + check_test_func_t check_test, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, int depth) +{ + Lisp_Object tree_saved = tree, tortoise = tree, keyed = Qnil; + struct gcpro gcpro1, gcpro2; + int count = 0; + + if (depth + lisp_eval_depth > max_lisp_eval_depth) + { + stack_overflow ("Stack overflow in nsublis", tree); + } + + GCPRO2 (tree_saved, keyed); + + while (CONSP (tree)) + { + Boolint replaced = 0; + keyed = KEY (key, XCAR (tree)); + + { + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) + { + CHECK_LISP_WRITEABLE (tree); + /* See comment in sublis() on using elt_cdr. */ + XSETCAR (tree, XCDR (elt)); + replaced = 1; + break; + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + if (!replaced) + { + if (CONSP (XCAR (tree))) + { + nsublis (alist, XCAR (tree), check_test, test_not_unboundp, + test, key, depth + 1); + } + } + + keyed = KEY (key, XCDR (tree)); + replaced = 0; + + { + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) + { + CHECK_LISP_WRITEABLE (tree); + XSETCDR (tree, XCDR (elt)); + tree = Qnil; + break; + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + if (!NILP (tree)) + { + tree = XCDR (tree); + } + + if (++count > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (count & 1) + { + tortoise = XCDR (tortoise); + } + + if (EQ (tortoise, tree)) + { + signal_circular_list_error (tree); + } + } + } + + RETURN_UNGCPRO (tree_saved); +} + +DEFUN ("nsublis", Fnsublis, 2, MANY, 0, /* +Perform substitutions indicated by ALIST in TREE (destructively). +Any matching element of TREE is changed via a call to `setcar'. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (ALIST TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object alist = args[0], tree = args[1], tailed = Qnil, keyed = Qnil; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fnsublis, nargs, args, 5, (test, if_, test_not, if_not, key), + (key = Qidentity)); + + if (NILP (key)) + { + key = Qidentity; + } + + get_check_match_function (&test, test_not, if_, if_not, + /* nsublis() is going to apply the key, don't ask + for a match function that will do it for + us. */ + Qidentity, &test_not_unboundp, &check_test); + + GCPRO2 (tailed, keyed); + + keyed = KEY (key, tree); + + { + /* nsublis() won't attempt to replace a cons handed to it, do that + ourselves. */ + GC_EXTERNAL_LIST_LOOP_2 (elt, alist) + { + if (CONSP (elt) && + check_test (test, key, XCAR (elt), keyed) == test_not_unboundp) + { + XUNGCPRO (elt); + return XCDR (elt); + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + UNGCPRO; + + return nsublis (alist, tree, check_test, test_not_unboundp, test, key, 0); +} + +DEFUN ("subst", Fsubst, 3, MANY, 0, /* +Substitute NEW for OLD everywhere in TREE (non-destructively). + +Return a copy of TREE with all elements `eql' to OLD replaced by NEW. + +See `member*' for the meaning of :test, :test-not and :key. + +arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]), + Qnil); + args[1] = alist; + result = Fsublis (nargs - 1, args + 1); + free_cons (XCAR (alist)); + free_cons (alist); + + return result; +} + +DEFUN ("nsubst", Fnsubst, 3, MANY, 0, /* +Substitute NEW for OLD everywhere in TREE (destructively). + +Any element of TREE which is `eql' to OLD is changed to NEW (via a call to +`setcar'). + +See `member*' for the meaning of the keywords. The keyword +:descend-structures, not specified by Common Lisp, allows callers to specify +that non-cons objects (vectors and range tables, among others) should also +undergo substitution. + +arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT DESCEND-STRUCTURES) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object new_ = args[0], old = args[1], tree = args[2], result, alist; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Fnsubst, nargs, args, 6, (test, if_, test_not, if_not, key, + descend_structures), NULL); + if (!NILP (descend_structures)) + { + check_test = get_check_test_function (old, &test, test_not, if_, if_not, + key, &test_not_unboundp); + + return nsubst_structures (new_, old, tree, check_test, test_not_unboundp, + test, key); + + } + + alist = noseeum_cons (noseeum_cons (old, new_), Qnil); + args[1] = alist; + result = Fnsublis (nargs - 1, args + 1); + free_cons (XCAR (alist)); + free_cons (alist); + + return result; +} + +static Boolint +tree_equal (Lisp_Object tree1, Lisp_Object tree2, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, int depth) +{ + Lisp_Object tortoise1 = tree1, tortoise2 = tree2; + struct gcpro gcpro1, gcpro2; + int count = 0; + Boolint result; + + if (depth + lisp_eval_depth > max_lisp_eval_depth) + { + stack_overflow ("Stack overflow in tree-equal", tree1); + } + + GCPRO2 (tree1, tree2); + + while (CONSP (tree1) && CONSP (tree2) + && tree_equal (XCAR (tree1), XCAR (tree2), check_test, + test_not_unboundp, test, key, depth + 1)) + { + tree1 = XCDR (tree1); + tree2 = XCDR (tree2); + + if (++count > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (count & 1) + { + tortoise1 = XCDR (tortoise1); + tortoise2 = XCDR (tortoise2); + } + + if (EQ (tortoise1, tree1)) + { + signal_circular_list_error (tree1); + } + + if (EQ (tortoise2, tree2)) + { + signal_circular_list_error (tree2); + } + } + } + + if (CONSP (tree1) || CONSP (tree2)) + { + UNGCPRO; + return 0; + } + + result = check_test (test, key, tree1, tree2) == test_not_unboundp; + UNGCPRO; + + return result; +} + +DEFUN ("tree-equal", Ftree_equal, 2, MANY, 0, /* +Return t if TREE1 and TREE2 have `eql' leaves. + +Atoms are compared by `eql', unless another test is specified using +:test; cons cells are compared recursively. + +See `union' for the meaning of :test, :test-not and :key. + +arguments: (TREE1 TREE2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object tree1 = args[0], tree2 = args[1]; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + + PARSE_KEYWORDS (Ftree_equal, nargs, args, 3, (test, key, test_not), + (key = Qidentity)); + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + return tree_equal (tree1, tree2, check_test, test_not_unboundp, test, key, + 0) ? Qt : Qnil; +} + +static Lisp_Object +mismatch_from_end (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_sequence1_index)) +{ + Elemcount sequence1_len = XFIXNUM (Flength (sequence1)); + Elemcount sequence2_len = XFIXNUM (Flength (sequence2)), ii = 0; + Elemcount starting1, ending1, starting2, ending2; + Lisp_Object *sequence1_storage = NULL, *sequence2_storage = NULL; + struct gcpro gcpro1, gcpro2; + + check_sequence_range (sequence1, start1, end1, make_fixnum (sequence1_len)); + starting1 = XFIXNUM (start1); + ending1 = FIXNUMP (end1) ? XFIXNUM (end1) : 1 + MOST_POSITIVE_FIXNUM; + ending1 = min (ending1, sequence1_len); + + check_sequence_range (sequence2, start2, end2, make_fixnum (sequence2_len)); + starting2 = XFIXNUM (start2); + ending2 = FIXNUMP (end2) ? XFIXNUM (end2) : 1 + MOST_POSITIVE_FIXNUM; + ending2 = min (ending2, sequence2_len); + + if (LISTP (sequence1)) + { + Lisp_Object *saving; + sequence1_storage = saving + = alloca_array (Lisp_Object, ending1 - starting1); + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence1) + { + if (starting1 <= ii && ii < ending1) + { + *saving++ = elt; + } + else if (ii == ending1) + { + break; + } + + ++ii; + } + } + } + else if (STRINGP (sequence1)) + { + const Ibyte *cursor = string_char_addr (sequence1, starting1); + + STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence1_storage, ii, + ending1 - starting1); + + } + else if (BIT_VECTORP (sequence1)) + { + Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence1); + sequence1_storage = alloca_array (Lisp_Object, ending1 - starting1); + for (ii = starting1; ii < ending1; ++ii) + { + sequence1_storage[ii - starting1] + = make_fixnum (bit_vector_bit (vv, ii)); + } + } + else + { + sequence1_storage = XVECTOR_DATA (sequence1) + starting1; + } + + ii = 0; + + if (LISTP (sequence2)) + { + Lisp_Object *saving; + sequence2_storage = saving + = alloca_array (Lisp_Object, ending2 - starting2); + + { + EXTERNAL_LIST_LOOP_2 (elt, sequence2) + { + if (starting2 <= ii && ii < ending2) + { + *saving++ = elt; + } + else if (ii == ending2) + { + break; + } + + ++ii; + } + } + } + else if (STRINGP (sequence2)) + { + const Ibyte *cursor = string_char_addr (sequence2, starting2); + + STRING_DATA_TO_OBJECT_ARRAY (cursor, sequence2_storage, ii, + ending2 - starting2); + + } + else if (BIT_VECTORP (sequence2)) + { + Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence2); + sequence2_storage = alloca_array (Lisp_Object, ending2 - starting2); + for (ii = starting2; ii < ending2; ++ii) + { + sequence2_storage[ii - starting2] + = make_fixnum (bit_vector_bit (vv, ii)); + } + } + else + { + sequence2_storage = XVECTOR_DATA (sequence2) + starting2; + } + + GCPRO2 (sequence1_storage[0], sequence2_storage[0]); + gcpro1.nvars = ending1 - starting1; + gcpro2.nvars = ending2 - starting2; + + while (ending1 > starting1 && ending2 > starting2) + { + --ending1; + --ending2; + + if (check_match (test, key, sequence1_storage[ending1 - starting1], + sequence2_storage[ending2 - starting2]) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (ending1 + 1); + } + } + + UNGCPRO; + + if (ending1 > starting1 || ending2 > starting2) + { + return make_integer (ending1); + } + + return Qnil; +} + +static Lisp_Object +mismatch_list_list (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_list_index)) +{ + Lisp_Object sequence1_tortoise = sequence1, sequence2_tortoise = sequence2; + Lisp_Object orig_sequence1 = sequence1, orig_sequence2 = sequence2; + Elemcount ending1 = MOST_POSITIVE_FIXNUM, ending2 = MOST_POSITIVE_FIXNUM; + Elemcount starting1, starting2, counting, startcounting; + Elemcount shortest_len = 0; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + starting1 = FIXNUMP (start1) ? XFIXNUM (start1) : 1 + MOST_POSITIVE_FIXNUM; + starting2 = FIXNUMP (start2) ? XFIXNUM (start2) : 1 + MOST_POSITIVE_FIXNUM; + + if (!NILP (end1)) + { + ending1 = FIXNUMP (end1) ? XFIXNUM (end1) : 1 + MOST_POSITIVE_FIXNUM; + } + + if (!NILP (end2)) + { + ending2 = FIXNUMP (end2) ? XFIXNUM (end2) : 1 + MOST_POSITIVE_FIXNUM; + } + + if (!ZEROP (start1)) + { + sequence1 = Fnthcdr (start1, sequence1); + + if (NILP (sequence1)) + { + check_sequence_range (sequence1_tortoise, start1, end1, + Flength (sequence1_tortoise)); + /* Give up early here. */ + return Qnil; + } + + ending1 -= starting1; + starting1 = 0; + sequence1_tortoise = sequence1; + } + + if (!ZEROP (start2)) + { + sequence2 = Fnthcdr (start2, sequence2); + + if (NILP (sequence2)) + { + check_sequence_range (sequence2_tortoise, start2, end2, + Flength (sequence2_tortoise)); + return Qnil; + } + + ending2 -= starting2; + starting2 = 0; + sequence2_tortoise = sequence2; + } + + GCPRO4 (sequence1, sequence2, sequence1_tortoise, sequence2_tortoise); + + counting = startcounting = min (ending1, ending2); + + while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2)) + { + if (check_match (test, key, + CONSP (sequence1) ? XCAR (sequence1) + : Fcar (sequence1), + CONSP (sequence2) ? XCAR (sequence2) + : Fcar (sequence2) ) != test_not_unboundp) + { + UNGCPRO; + return make_integer (XFIXNUM (start1) + shortest_len); + } + + sequence1 = CONSP (sequence1) ? XCDR (sequence1) : Fcdr (sequence1); + sequence2 = CONSP (sequence2) ? XCDR (sequence2) : Fcdr (sequence2); + + shortest_len++; + + if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH) + { + if (counting & 1) + { + sequence1_tortoise = XCDR (sequence1_tortoise); + sequence2_tortoise = XCDR (sequence2_tortoise); + } + + if (EQ (sequence1, sequence1_tortoise)) + { + signal_circular_list_error (sequence1); + } + + if (EQ (sequence2, sequence2_tortoise)) + { + signal_circular_list_error (sequence2); + } + } + } + + UNGCPRO; + + if (NILP (sequence1)) + { + Lisp_Object args[] = { start1, make_fixnum (shortest_len) }; + check_sequence_range (orig_sequence1, start1, end1, + Fplus (countof (args), args)); + } + + if (NILP (sequence2)) + { + Lisp_Object args[] = { start2, make_fixnum (shortest_len) }; + check_sequence_range (orig_sequence2, start2, end2, + Fplus (countof (args), args)); + } + + if ((!NILP (end1) && shortest_len != ending1 - starting1) || + (!NILP (end2) && shortest_len != ending2 - starting2)) + { + return make_integer (XFIXNUM (start1) + shortest_len); + } + + if ((NILP (end1) && CONSP (sequence1)) || (NILP (end2) && CONSP (sequence2))) + { + return make_integer (XFIXNUM (start1) + shortest_len); + } + + return Qnil; +} + +static Lisp_Object +mismatch_list_string (Lisp_Object list, Lisp_Object list_start, + Lisp_Object list_end, + Lisp_Object string, Lisp_Object string_start, + Lisp_Object string_end, + check_test_func_t check_match, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_list_index) +{ + Ibyte *string_data = XSTRING_DATA (string), *startp = string_data; + Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string); + Elemcount char_count = 0, list_starting, list_ending; + Elemcount string_starting, string_ending; + Lisp_Object character, orig_list = list; + struct gcpro gcpro1; + + list_ending = FIXNUMP (list_end) ? XFIXNUM (list_end) : 1 + MOST_POSITIVE_FIXNUM; + list_starting = FIXNUMP (list_start) ? XFIXNUM (list_start) : 1 + MOST_POSITIVE_FIXNUM; + + string_ending = FIXNUMP (string_end) ? XFIXNUM (string_end) : 1 + MOST_POSITIVE_FIXNUM; + string_starting + = FIXNUMP (string_start) ? XFIXNUM (string_start) : 1 + MOST_POSITIVE_FIXNUM; + + while (char_count < string_starting && string_offset < string_len) + { + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + char_count++; + } + + if (!ZEROP (list_start)) + { + list = Fnthcdr (list_start, list); + if (NILP (list)) + { + check_sequence_range (orig_list, list_start, list_end, + Flength (orig_list)); + return Qnil; + } + + list_ending -= list_starting; + list_starting = 0; + } + + GCPRO1 (list); + + while (list_starting < list_ending && string_starting < string_ending + && string_offset < string_len && !NILP (list)) + { + character = make_char (itext_ichar (string_data)); + + if (return_list_index) + { + if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list), + character) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (XFIXNUM (list_start) + char_count); + } + } + else + { + if (check_match (test, key, character, + CONSP (list) ? XCAR (list) : Fcar (list)) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (char_count); + } + } + + list = CONSP (list) ? XCDR (list) : Fcdr (list); + + startp = XSTRING_DATA (string); + string_data = startp + string_offset; + if (string_len != XSTRING_LENGTH (string) + || !valid_ibyteptr_p (string_data)) + { + mapping_interaction_error (Qmismatch, string); + } + + list_starting++; + string_starting++; + char_count++; + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + } + + UNGCPRO; + + if (NILP (list)) + { + Lisp_Object args[] = { list_start, make_fixnum (char_count) }; + check_sequence_range (orig_list, list_start, list_end, + Fplus (countof (args), args)); + } + + if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string)) + { + check_sequence_range (string, string_start, string_end, + make_fixnum (char_count)); + } + + if ((NILP (string_end) ? + string_offset < string_len : string_starting < string_ending) || + (NILP (list_end) ? !NILP (list) : list_starting < list_ending)) + { + return make_integer (return_list_index ? XFIXNUM (list_start) + char_count : + char_count); + } + + return Qnil; +} + +static Lisp_Object +mismatch_list_array (Lisp_Object list, Lisp_Object list_start, + Lisp_Object list_end, + Lisp_Object array, Lisp_Object array_start, + Lisp_Object array_end, + check_test_func_t check_match, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_list_index) +{ + Elemcount ii = 0, list_starting, list_ending; + Elemcount array_starting, array_ending, array_len; + Lisp_Object orig_list = list; + struct gcpro gcpro1; + + list_ending = FIXNUMP (list_end) ? XFIXNUM (list_end) : 1 + MOST_POSITIVE_FIXNUM; + list_starting = FIXNUMP (list_start) ? XFIXNUM (list_start) : 1 + MOST_POSITIVE_FIXNUM; + + array_ending = FIXNUMP (array_end) ? XFIXNUM (array_end) : 1 + MOST_POSITIVE_FIXNUM; + array_starting = FIXNUMP (array_start) ? XFIXNUM (array_start) : 1 + MOST_POSITIVE_FIXNUM; + array_len = XFIXNUM (Flength (array)); + + array_ending = min (array_ending, array_len); + + check_sequence_range (array, array_start, array_end, make_fixnum (array_len)); + + if (!ZEROP (list_start)) + { + list = Fnthcdr (list_start, list); + if (NILP (list)) + { + check_sequence_range (orig_list, list_start, list_end, + Flength (orig_list)); + return Qnil; + } + + list_ending -= list_starting; + list_starting = 0; + } + + GCPRO1 (list); + + while (list_starting < list_ending && array_starting < array_ending + && !NILP (list)) + { + if (return_list_index) + { + if (check_match (test, key, CONSP (list) ? XCAR (list) : Fcar (list), + Faref (array, make_fixnum (array_starting))) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (XFIXNUM (list_start) + ii); + } + } + else + { + if (check_match (test, key, Faref (array, make_fixnum (array_starting)), + CONSP (list) ? XCAR (list) : Fcar (list)) + != test_not_unboundp) + { + UNGCPRO; + return make_integer (array_starting); + } + } + + list = CONSP (list) ? XCDR (list) : Fcdr (list); + list_starting++; + array_starting++; + ii++; + } + + UNGCPRO; + + if (NILP (list)) + { + Lisp_Object args[] = { list_start, make_fixnum (ii) }; + check_sequence_range (orig_list, list_start, list_end, + Fplus (countof (args), args)); + } + + if (array_starting < array_ending || + (NILP (list_end) ? !NILP (list) : list_starting < list_ending)) + { + return make_integer (return_list_index ? XFIXNUM (list_start) + ii : + array_starting); + } + + return Qnil; +} + +static Lisp_Object +mismatch_string_array (Lisp_Object string, Lisp_Object string_start, + Lisp_Object string_end, + Lisp_Object array, Lisp_Object array_start, + Lisp_Object array_end, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_string_index) +{ + Ibyte *string_data = XSTRING_DATA (string), *startp = string_data; + Bytecount string_offset = 0, string_len = XSTRING_LENGTH (string); + Elemcount char_count = 0, array_starting, array_ending, array_length; + Elemcount string_starting, string_ending; + Lisp_Object character; + + array_starting = FIXNUMP (array_start) ? XFIXNUM (array_start) : 1 + MOST_POSITIVE_FIXNUM; + array_ending = FIXNUMP (array_end) ? XFIXNUM (array_end) : 1 + MOST_POSITIVE_FIXNUM; + array_length = XFIXNUM (Flength (array)); + check_sequence_range (array, array_start, array_end, make_fixnum (array_length)); + array_ending = min (array_ending, array_length); + + string_ending = FIXNUMP (string_end) ? XFIXNUM (string_end) : 1 + MOST_POSITIVE_FIXNUM; + string_starting + = FIXNUMP (string_start) ? XFIXNUM (string_start) : 1 + MOST_POSITIVE_FIXNUM; + + while (char_count < string_starting && string_offset < string_len) + { + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + char_count++; + } + + while (array_starting < array_ending && string_starting < string_ending + && string_offset < string_len) + { + character = make_char (itext_ichar (string_data)); + + if (return_string_index) + { + if (check_match (test, key, character, + Faref (array, make_fixnum (array_starting))) + != test_not_unboundp) + { + return make_integer (char_count); + } + } + else + { + if (check_match (test, key, + Faref (array, make_fixnum (array_starting)), + character) + != test_not_unboundp) + { + return make_integer (XFIXNUM (array_start) + char_count); + } + } + + startp = XSTRING_DATA (string); + string_data = startp + string_offset; + if (string_len != XSTRING_LENGTH (string) + || !valid_ibyteptr_p (string_data)) + { + mapping_interaction_error (Qmismatch, string); + } + + array_starting++; + string_starting++; + char_count++; + INC_IBYTEPTR (string_data); + string_offset = string_data - startp; + } + + if (string_data == XSTRING_DATA (string) + XSTRING_LENGTH (string)) + { + check_sequence_range (string, string_start, string_end, + make_fixnum (char_count)); + } + + if ((NILP (string_end) ? + string_offset < string_len : string_starting < string_ending) || + (NILP (array_end) ? !NILP (array) : array_starting < array_ending)) + { + return make_integer (return_string_index ? char_count : + XFIXNUM (array_start) + char_count); + } + + return Qnil; +} + +static Lisp_Object +mismatch_string_string (Lisp_Object string1, + Lisp_Object string1_start, Lisp_Object string1_end, + Lisp_Object string2, Lisp_Object string2_start, + Lisp_Object string2_end, + check_test_func_t check_match, + Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_string1_index)) +{ + Ibyte *string1_data = XSTRING_DATA (string1), *startp1 = string1_data; + Bytecount string1_offset = 0, string1_len = XSTRING_LENGTH (string1); + Ibyte *string2_data = XSTRING_DATA (string2), *startp2 = string2_data; + Bytecount string2_offset = 0, string2_len = XSTRING_LENGTH (string2); + Elemcount char_count1 = 0, string1_starting, string1_ending; + Elemcount char_count2 = 0, string2_starting, string2_ending; + Lisp_Object character1, character2; + + string1_ending = FIXNUMP (string1_end) ? XFIXNUM (string1_end) : 1 + MOST_POSITIVE_FIXNUM; + string1_starting + = FIXNUMP (string1_start) ? XFIXNUM (string1_start) : 1 + MOST_POSITIVE_FIXNUM; + + string2_starting + = FIXNUMP (string2_start) ? XFIXNUM (string2_start) : 1 + MOST_POSITIVE_FIXNUM; + string2_ending = FIXNUMP (string2_end) ? XFIXNUM (string2_end) : 1 + MOST_POSITIVE_FIXNUM; + + while (char_count1 < string1_starting && string1_offset < string1_len) + { + INC_IBYTEPTR (string1_data); + string1_offset = string1_data - startp1; + char_count1++; + } + + while (char_count2 < string2_starting && string2_offset < string2_len) + { + INC_IBYTEPTR (string2_data); + string2_offset = string2_data - startp2; + char_count2++; + } + + while (string2_starting < string2_ending && string1_starting < string1_ending + && string1_offset < string1_len && string2_offset < string2_len) + { + character1 = make_char (itext_ichar (string1_data)); + character2 = make_char (itext_ichar (string2_data)); + + if (check_match (test, key, character1, character2) + != test_not_unboundp) + { + return make_integer (char_count1); + } + + startp1 = XSTRING_DATA (string1); + string1_data = startp1 + string1_offset; + if (string1_len != XSTRING_LENGTH (string1) + || !valid_ibyteptr_p (string1_data)) + { + mapping_interaction_error (Qmismatch, string1); + } + + startp2 = XSTRING_DATA (string2); + string2_data = startp2 + string2_offset; + if (string2_len != XSTRING_LENGTH (string2) + || !valid_ibyteptr_p (string2_data)) + { + mapping_interaction_error (Qmismatch, string2); + } + + string2_starting++; + string1_starting++; + char_count1++; + char_count2++; + INC_IBYTEPTR (string1_data); + string1_offset = string1_data - startp1; + INC_IBYTEPTR (string2_data); + string2_offset = string2_data - startp2; + } + + if (string1_data == XSTRING_DATA (string1) + XSTRING_LENGTH (string1)) + { + check_sequence_range (string1, string1_start, string1_end, + make_fixnum (char_count1)); + } + + if (string2_data == XSTRING_DATA (string2) + XSTRING_LENGTH (string2)) + { + check_sequence_range (string2, string2_start, string2_end, + make_fixnum (char_count2)); + } + + if ((!NILP (string1_end) && string1_starting < string1_ending) || + (!NILP (string2_end) && string2_starting < string2_ending)) + { + return make_integer (char_count1); + } + + if ((NILP (string1_end) && string1_data + < (XSTRING_DATA (string1) + XSTRING_LENGTH (string1))) || + (NILP (string2_end) && string2_data + < (XSTRING_DATA (string2) + XSTRING_LENGTH (string2)))) + { + return make_integer (char_count1); + } + + return Qnil; +} + +static Lisp_Object +mismatch_array_array (Lisp_Object array1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object array2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint UNUSED (return_array1_index)) +{ + Elemcount len1 = XFIXNUM (Flength (array1)), len2 = XFIXNUM (Flength (array2)); + Elemcount ending1 = MOST_POSITIVE_FIXNUM, ending2 = MOST_POSITIVE_FIXNUM; + Elemcount starting1, starting2; + + check_sequence_range (array1, start1, end1, make_fixnum (len1)); + check_sequence_range (array2, start2, end2, make_fixnum (len2)); + + starting1 = FIXNUMP (start1) ? XFIXNUM (start1) : 1 + MOST_POSITIVE_FIXNUM; + starting2 = FIXNUMP (start2) ? XFIXNUM (start2) : 1 + MOST_POSITIVE_FIXNUM; + + if (!NILP (end1)) + { + ending1 = FIXNUMP (end1) ? XFIXNUM (end1) : 1 + MOST_POSITIVE_FIXNUM; + } + + if (!NILP (end2)) + { + ending2 = FIXNUMP (end2) ? XFIXNUM (end2) : 1 + MOST_POSITIVE_FIXNUM; + } + + ending1 = min (ending1, len1); + ending2 = min (ending2, len2); + + while (starting1 < ending1 && starting2 < ending2) + { + if (check_match (test, key, Faref (array1, make_fixnum (starting1)), + Faref (array2, make_fixnum (starting2))) + != test_not_unboundp) + { + return make_integer (starting1); + } + starting1++; + starting2++; + } + + if (starting1 < ending1 || starting2 < ending2) + { + return make_integer (starting1); + } + + return Qnil; +} + +typedef Lisp_Object +(*mismatch_func_t) (Lisp_Object sequence1, Lisp_Object start1, Lisp_Object end1, + Lisp_Object sequence2, Lisp_Object start2, Lisp_Object end2, + check_test_func_t check_match, Boolint test_not_unboundp, + Lisp_Object test, Lisp_Object key, + Boolint return_list_index); + +static mismatch_func_t +get_mismatch_func (Lisp_Object sequence1, Lisp_Object sequence2, + Lisp_Object from_end, Boolint *return_sequence1_index_out) +{ + CHECK_SEQUENCE (sequence1); + CHECK_SEQUENCE (sequence2); + + if (!NILP (from_end)) + { + *return_sequence1_index_out = 1; + return mismatch_from_end; + } + + if (LISTP (sequence1)) + { + if (LISTP (sequence2)) + { + *return_sequence1_index_out = 1; + return mismatch_list_list; + } + + if (STRINGP (sequence2)) + { + *return_sequence1_index_out = 1; + return mismatch_list_string; + } + + *return_sequence1_index_out = 1; + return mismatch_list_array; + } + + if (STRINGP (sequence1)) + { + if (STRINGP (sequence2)) + { + *return_sequence1_index_out = 1; + return mismatch_string_string; + } + + if (LISTP (sequence2)) + { + *return_sequence1_index_out = 0; + return mismatch_list_string; + } + + *return_sequence1_index_out = 1; + return mismatch_string_array; + } + + if (ARRAYP (sequence1)) + { + if (STRINGP (sequence2)) + { + *return_sequence1_index_out = 0; + return mismatch_string_array; + } + + if (LISTP (sequence2)) + { + *return_sequence1_index_out = 0; + return mismatch_list_array; + } + + *return_sequence1_index_out = 1; + return mismatch_array_array; + } + + RETURN_NOT_REACHED (NULL); + return NULL; +} + +DEFUN ("mismatch", Fmismatch, 2, MANY, 0, /* +Compare SEQUENCE1 with SEQUENCE2, return index of first mismatching element. + +Return nil if the sequences match. If one sequence is a prefix of the +other, the return value indicates the end of the shorter sequence. A +non-nil return value always reflects an index into SEQUENCE1. + +See `search' for the meaning of the keywords." + +arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence1 = args[0], sequence2 = args[1]; + Boolint test_not_unboundp = 1, return_first_index = 0; + check_test_func_t check_match = NULL; + mismatch_func_t mismatch = NULL; + + PARSE_KEYWORDS (Fmismatch, nargs, args, 8, + (test, key, from_end, start1, end1, start2, end2, test_not), + (start1 = start2 = Qzero)); + + CHECK_SEQUENCE (sequence1); + CHECK_SEQUENCE (sequence2); + + CHECK_NATNUM (start1); + CHECK_NATNUM (start2); + + if (!NILP (end1)) + { + CHECK_NATNUM (end1); + } + + if (!NILP (end2)) + { + CHECK_NATNUM (end2); + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, NULL); + mismatch = get_mismatch_func (sequence1, sequence2, from_end, + &return_first_index); + + if (return_first_index) + { + return mismatch (sequence1, start1, end1, sequence2, start2, end2, + check_match, test_not_unboundp, test, key, 1); + } + + return mismatch (sequence2, start2, end2, sequence1, start1, end1, + check_match, test_not_unboundp, test, key, 0); +} + +DEFUN ("search", Fsearch, 2, MANY, 0, /* +Search for SEQUENCE1 as a subsequence of SEQUENCE2. + +Return the index of the leftmost element of the first match found; return +nil if there are no matches. + +In this function, :start1 and :end1 specify a subsequence of SEQUENCE1, and +:start2 and :end2 specify a subsequence of SEQUENCE2. See `remove*' for +details of the other keywords. + +arguments: (SEQUENCE1 SEQUENCE2 &key (TEST #'eql) (KEY #'identity) (START1 0) END1 (START2 0) END2 FROM-END TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence1 = args[0], sequence2 = args[1], position0 = Qnil; + Boolint test_not_unboundp = 1, return_first = 0; + check_test_func_t check_test = NULL, check_match = NULL; + mismatch_func_t mismatch = NULL; + Elemcount starting1 = 0, ending1 = 1 + MOST_POSITIVE_FIXNUM, starting2 = 0; + Elemcount ending2 = 1 + MOST_POSITIVE_FIXNUM, ii = 0; + Elemcount length1; + Lisp_Object object = Qnil; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fsearch, nargs, args, 8, + (test, key, from_end, start1, end1, start2, end2, test_not), + (start1 = start2 = Qzero)); + + CHECK_SEQUENCE (sequence1); + CHECK_SEQUENCE (sequence2); + CHECK_KEY_ARGUMENT (key); + + CHECK_NATNUM (start1); + starting1 = FIXNUMP (start1) ? XFIXNUM (start1) : 1 + MOST_POSITIVE_FIXNUM; + CHECK_NATNUM (start2); + starting2 = FIXNUMP (start2) ? XFIXNUM (start2) : 1 + MOST_POSITIVE_FIXNUM; + + if (!NILP (end1)) + { + Lisp_Object len1 = Flength (sequence1); + + CHECK_NATNUM (end1); + check_sequence_range (sequence1, start1, end1, len1); + ending1 = min (XFIXNUM (end1), XFIXNUM (len1)); + } + else + { + end1 = Flength (sequence1); + check_sequence_range (sequence1, start1, end1, end1); + ending1 = XFIXNUM (end1); + } + + length1 = ending1 - starting1; + + if (!NILP (end2)) + { + Lisp_Object len2 = Flength (sequence2); + + CHECK_NATNUM (end2); + check_sequence_range (sequence2, start2, end2, len2); + ending2 = min (XFIXNUM (end2), XFIXNUM (len2)); + } + else + { + end2 = Flength (sequence2); + check_sequence_range (sequence2, start2, end2, end2); + ending2 = XFIXNUM (end2); + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + mismatch = get_mismatch_func (sequence1, sequence2, from_end, &return_first); + + if (bytecode_arithcompare (start1, make_integer (ending1)) >= 0) + { + if (NILP (from_end)) + { + return start2; + } + + if (NILP (end2)) + { + return Flength (sequence2); + } + + return end2; + } + + if (NILP (from_end)) + { + Lisp_Object mismatch_start1 = Fadd1 (start1); + Lisp_Object first = KEY (key, Felt (sequence1, start1)); + GCPRO2 (first, mismatch_start1); + + ii = starting2; + while (ii < ending2) + { + position0 = position (&object, first, sequence2, check_test, + test_not_unboundp, test, key, make_fixnum (ii), + end2, Qnil, Qnil, Qsearch); + if (NILP (position0)) + { + UNGCPRO; + return Qnil; + } + + if (length1 + XFIXNUM (position0) <= ending2 && + (return_first ? + NILP (mismatch (sequence1, mismatch_start1, end1, + sequence2, + make_fixnum (1 + XFIXNUM (position0)), + make_fixnum (length1 + XFIXNUM (position0)), + check_match, test_not_unboundp, test, key, 1)) : + NILP (mismatch (sequence2, + make_fixnum (1 + XFIXNUM (position0)), + make_fixnum (length1 + XFIXNUM (position0)), + sequence1, mismatch_start1, end1, + check_match, test_not_unboundp, test, key, 0)))) + + + { + UNGCPRO; + return position0; + } + + ii = XFIXNUM (position0) + 1; + } + + UNGCPRO; + } + else + { + Lisp_Object mismatch_end1 = make_integer (ending1 - 1); + Lisp_Object last = KEY (key, Felt (sequence1, mismatch_end1)); + GCPRO2 (last, mismatch_end1); + + ii = ending2; + while (ii > starting2) + { + position0 = position (&object, last, sequence2, check_test, + test_not_unboundp, test, key, start2, + make_fixnum (ii), Qt, Qnil, Qsearch); + + if (NILP (position0)) + { + UNGCPRO; + return Qnil; + } + + if (XFIXNUM (position0) - length1 + 1 >= starting2 && + (return_first ? + NILP (mismatch (sequence1, start1, mismatch_end1, + sequence2, + make_fixnum (XFIXNUM (position0) - length1 + 1), + make_fixnum (XFIXNUM (position0)), + check_match, test_not_unboundp, test, key, 1)) : + NILP (mismatch (sequence2, + make_fixnum (XFIXNUM (position0) - length1 + 1), + make_fixnum (XFIXNUM (position0)), + sequence1, start1, mismatch_end1, + check_match, test_not_unboundp, test, key, 0)))) + { + UNGCPRO; + return make_fixnum (XFIXNUM (position0) - length1 + 1); + } + + ii = XFIXNUM (position0); + } + + UNGCPRO; + } + + return Qnil; +} + +/* These two functions do set operations, those that can be visualised with + Venn diagrams. */ +static Lisp_Object +venn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1]; + Lisp_Object result = EQ (caller, Qsubsetp) ? Qt : Qnil, result_tail = Qnil; + Lisp_Object keyed = Qnil, ignore = Qnil; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS_8 (caller, nargs, args, 4, (test, key, test_not, stable), + NULL, 2, 0); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt1) && intersectionp) + { + return Qnil; + } + + if (NILP (liszt2)) + { + return intersectionp ? Qnil : liszt1; + } + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + GCPRO2 (keyed, result); + + { + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil)) + != intersectionp) + { + if (EQ (Qsubsetp, caller)) + { + result = Qnil; + break; + } + else if (NILP (stable)) + { + result = Fcons (elt, result); + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + UNGCPRO; + + return result; +} + +static Lisp_Object +nvenn (Lisp_Object caller, int nargs, Lisp_Object *args, Boolint intersectionp) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1], tortoise_elt, ignore = Qnil; + Lisp_Object elt = Qnil, tail = Qnil, keyed = Qnil, prev_tail = Qnil; + Elemcount count; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + PARSE_KEYWORDS_8 (caller, nargs, args, 3, (test, key, test_not), + NULL, 2, 0); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt1) && intersectionp) + { + return Qnil; + } + + if (NILP (liszt2)) + { + return intersectionp ? Qnil : liszt1; + } + + get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + tortoise_elt = tail = liszt1, count = 0; + + GCPRO4 (tail, keyed, liszt1, tortoise_elt); + + while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : + (signal_malformed_list_error (liszt1), 0)) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil)) + == intersectionp) + { + if (NILP (prev_tail)) + { + liszt1 = XCDR (tail); + } + else + { + XSETCDR (prev_tail, XCDR (tail)); + } + + tail = XCDR (tail); + /* List is definitely not circular now! */ + count = 0; + } + else + { + prev_tail = tail; + tail = XCDR (tail); + } + + if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + { + tortoise_elt = XCDR (tortoise_elt); + } + + if (EQ (elt, tortoise_elt)) + { + signal_circular_list_error (liszt1); + } + } + + UNGCPRO; + + return liszt1; +} + +DEFUN ("intersection", Fintersection, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-intersection operation. + +The result list contains all items that appear in both LIST1 and LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items in the order they appear in LIST1. + +See `union' for the meaning of :test, :test-not and :key." + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE) +*/ + (int nargs, Lisp_Object *args)) +{ + return venn (Qintersection, nargs, args, 1); +} + +DEFUN ("nintersection", Fnintersection, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-intersection operation. + +The result list contains all items that appear in both LIST1 and LIST2. +This is a destructive function; it reuses the storage of LIST1 whenever +possible. + +See `union' for the meaning of :test, :test-not and :key." + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + return nvenn (Qnintersection, nargs, args, 1); +} + +DEFUN ("subsetp", Fsubsetp, 2, MANY, 0, /* +Return non-nil if every element of LIST1 also appears in LIST2. + +See `union' for the meaning of the keyword arguments. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + return venn (Qsubsetp, nargs, args, 0); +} + +DEFUN ("set-difference", Fset_difference, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-difference operation. + +The result list contains all items that appear in LIST1 but not LIST2. This +is a non-destructive function; it makes a copy of the data if necessary to +avoid corrupting the original LIST1 and LIST2. + +See `union' for the meaning of :test, :test-not and :key. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items in the order they appear in LIST1. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE) +*/ + (int nargs, Lisp_Object *args)) +{ + return venn (Qset_difference, nargs, args, 0); +} + +DEFUN ("nset-difference", Fnset_difference, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-difference operation. + +The result list contains all items that appear in LIST1 but not LIST2. This +is a destructive function; it reuses the storage of LIST1 whenever possible. + +See `union' for the meaning of :test, :test-not and :key." + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + return nvenn (Qnset_difference, nargs, args, 0); +} + +DEFUN ("nunion", Fnunion, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-union operation. +The result list contains all items that appear in either LIST1 or LIST2. + +This is a destructive function, it reuses the storage of LIST1 whenever +possible. + +See `union' for the meaning of :test, :test-not and :key. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + args[0] = nvenn (Qnunion, nargs, args, 0); + return bytecode_nconc2 (args); +} + +DEFUN ("union", Funion, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-union operation. +The result list contains all items that appear in either LIST1 or LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. + +The keywords :test and :test-not specify two-argument test and negated-test +predicates, respectively; :test defaults to `eql'. See `member*' for more +information. + +:key specifies a one-argument function that transforms elements of LIST1 +and LIST2 into \"comparison keys\" before the test predicate is applied. +For example, if :key is #'car, then the car of elements from LIST1 is +compared with the car of elements from LIST2. The :key function, however, +does not affect the elements in the returned list, which are taken directly +from the elements in LIST1 and LIST2. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items of LIST1 in order, followed by the remaining items of LIST2 +in the order they occur in LIST2. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1], ignore = Qnil; + Lisp_Object keyed = Qnil, result, result_tail; + Boolint test_not_unboundp = 1; + check_test_func_t check_test = NULL, check_match = NULL; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Funion, nargs, args, 4, (test, key, test_not, stable), NULL); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt1)) + { + return liszt2; + } + + if (NILP (liszt2)) + { + return liszt1; + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + GCPRO2 (keyed, result); + + if (NILP (stable)) + { + result = liszt2; + { + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil))) + { + /* The Lisp version of #'union used to check which list was + longer, and use that as the tail of the constructed + list. That fails when the order of arguments to TEST is + specified, as is the case for these functions. We could + pass the reverse_check argument to + list_position_cons_before, but that means any key argument + is called an awful lot more, so it's a space win but not + a time win. */ + result = Fcons (elt, result); + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + } + else + { + result = result_tail = Qnil; + + /* The standard `union' doesn't produce a "stable" union -- it + iterates over the second list instead of the first one, and returns + the values in backwards order. According to the CLTL2 + documentation, `union' is not required to preserve the ordering of + elements in any fashion; providing the functionality for a stable + union is an XEmacs extension. */ + { + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt2) + { + if (NILP (list_position_cons_before (&ignore, elt, liszt1, + check_match, test_not_unboundp, + test, key, 1, Qzero, Qnil))) + { + if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + result = NILP (result) ? liszt1 : nconc2 (Fcopy_list (liszt1), result); + } + + UNGCPRO; + + return result; +} + +DEFUN ("set-exclusive-or", Fset_exclusive_or, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-exclusive-or operation. + +The result list contains all items that appear in exactly one of LIST1, LIST2. +This is a non-destructive function; it makes a copy of the data if necessary +to avoid corrupting the original LIST1 and LIST2. + +See `union' for the meaning of :test, :test-not and :key. + +A non-nil value for the :stable keyword, not specified by Common Lisp, means +return the items in the order they appear in LIST1, followed by the +remaining items in the order they appear in LIST2. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT STABLE) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1]; + Lisp_Object result = Qnil, result_tail = Qnil, keyed = Qnil, ignore = Qnil; + Boolint test_not_unboundp = 1; + check_test_func_t check_match = NULL, check_test = NULL; + struct gcpro gcpro1, gcpro2; + + PARSE_KEYWORDS (Fset_exclusive_or, nargs, args, 4, + (test, key, test_not, stable), NULL); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt2)) + { + return liszt1; + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + GCPRO2 (keyed, result); + { + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt1) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil))) + { + if (NILP (stable)) + { + result = Fcons (elt, result); + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + { + GC_EXTERNAL_LIST_LOOP_2 (elt, liszt2) + { + if (NILP (list_position_cons_before (&ignore, elt, liszt1, + check_match, test_not_unboundp, + test, key, 1, Qzero, Qnil))) + { + if (NILP (stable)) + { + result = Fcons (elt, result); + } + else if (NILP (result)) + { + result = result_tail = Fcons (elt, Qnil); + } + else + { + XSETCDR (result_tail, Fcons (elt, Qnil)); + result_tail = XCDR (result_tail); + } + } + } + END_GC_EXTERNAL_LIST_LOOP (elt); + } + + UNGCPRO; + + return result; +} + +DEFUN ("nset-exclusive-or", Fnset_exclusive_or, 2, MANY, 0, /* +Combine LIST1 and LIST2 using a set-exclusive-or operation. + +The result list contains all items that appear in exactly one of LIST1 and +LIST2. This is a destructive function; it reuses the storage of LIST1 and +LIST2 whenever possible. + +See `union' for the meaning of :test, :test-not and :key. + +arguments: (LIST1 LIST2 &key (TEST #'eql) (KEY #'identity) TEST-NOT) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object liszt1 = args[0], liszt2 = args[1], elt = Qnil, tail = Qnil; + Lisp_Object result = Qnil, tortoise_elt = Qnil, keyed = Qnil, swap; + Lisp_Object prev_tail = Qnil, ignore = Qnil; + Elemcount count; + Boolint test_not_unboundp = 1; + check_test_func_t check_match = NULL, check_test = NULL; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + PARSE_KEYWORDS (Fnset_exclusive_or, nargs, args, 4, + (test, key, test_not, stable), NULL); + + CHECK_LIST (liszt1); + CHECK_LIST (liszt2); + + CHECK_KEY_ARGUMENT (key); + + if (NILP (liszt2)) + { + return liszt1; + } + + check_match = get_check_match_function (&test, test_not, Qnil, Qnil, key, + &test_not_unboundp, &check_test); + + tortoise_elt = tail = liszt1, count = 0; + + GCPRO4 (tail, keyed, result, tortoise_elt); + + while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : + (signal_malformed_list_error (liszt1), 0)) + { + keyed = KEY (key, elt); + if (NILP (list_position_cons_before (&ignore, keyed, liszt2, + check_test, test_not_unboundp, + test, key, 0, Qzero, Qnil))) + { + swap = XCDR (tail); + + if (NILP (prev_tail)) + { + liszt1 = XCDR (tail); + } + else + { + XSETCDR (prev_tail, swap); + } + + XSETCDR (tail, result); + result = tail; + tail = swap; + + /* List is definitely not circular now! */ + count = 0; + } + else + { + prev_tail = tail; + tail = XCDR (tail); + } + + if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + { + tortoise_elt = XCDR (tortoise_elt); + } + + if (EQ (elt, tortoise_elt)) + { + signal_circular_list_error (liszt1); + } + } + + tortoise_elt = tail = liszt2, count = 0; + + while (CONSP (tail) ? (elt = XCAR (tail), 1) : NILP (tail) ? 0 : + (signal_malformed_list_error (liszt2), 0)) + { + /* Need to leave the key calculation to list_position_cons_before(). */ + if (NILP (list_position_cons_before (&ignore, elt, liszt1, + check_match, test_not_unboundp, + test, key, 1, Qzero, Qnil))) + { + swap = XCDR (tail); + XSETCDR (tail, result); + result = tail; + tail = swap; + count = 0; + } + else + { + tail = XCDR (tail); + } + + if (count++ < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + { + tortoise_elt = XCDR (tortoise_elt); + } + + if (EQ (elt, tortoise_elt)) + { + signal_circular_list_error (liszt1); + } + } + + UNGCPRO; + + return result; +} + +void +syms_of_sequence (void) +{ + DEFSYMBOL (Qstring_lessp); + DEFSYMBOL (Qmerge); + DEFSYMBOL (Qfill); + DEFSYMBOL (Qidentity); + DEFSYMBOL (Qvector); + DEFSYMBOL (Qarray); + DEFSYMBOL (Qstring); + DEFSYMBOL (Qlist); + DEFSYMBOL (Qbit_vector); + defsymbol (&QsortX, "sort*"); + DEFSYMBOL (Qreduce); + DEFSYMBOL (Qreplace); + DEFSYMBOL (Qposition); + DEFSYMBOL (Qfind); + defsymbol (&QdeleteX, "delete*"); + defsymbol (&QremoveX, "remove*"); + + DEFSYMBOL (Qmapconcat); + defsymbol (&QmapcarX, "mapcar*"); + DEFSYMBOL (Qmapvector); + DEFSYMBOL (Qmapcan); + DEFSYMBOL (Qmapc); + DEFSYMBOL (Qmap); + DEFSYMBOL (Qmap_into); + DEFSYMBOL (Qsome); + DEFSYMBOL (Qevery); + DEFSYMBOL (Qnsubstitute); + DEFSYMBOL (Qdelete_duplicates); + DEFSYMBOL (Qsubstitute); + DEFSYMBOL (Qmismatch); + DEFSYMBOL (Qintersection); + DEFSYMBOL (Qnintersection); + DEFSYMBOL (Qsubsetp); + DEFSYMBOL (Qcar_less_than_car); + DEFSYMBOL (Qset_difference); + DEFSYMBOL (Qnset_difference); + DEFSYMBOL (Qnunion); + + DEFKEYWORD (Q_from_end); + DEFKEYWORD (Q_initial_value); + DEFKEYWORD (Q_start1); + DEFKEYWORD (Q_start2); + DEFKEYWORD (Q_end1); + DEFKEYWORD (Q_end2); + defkeyword (&Q_if_, ":if"); + DEFKEYWORD (Q_if_not); + DEFKEYWORD (Q_test_not); + DEFKEYWORD (Q_count); + DEFKEYWORD (Q_stable); + DEFKEYWORD (Q_descend_structures); + + DEFSUBR (Flength); + DEFSUBR (Fcount); + DEFSUBR (Fsubseq); + DEFSUBR (Felt); + DEFSUBR (Fcopy_tree); + DEFSUBR (Fmember); + DEFSUBR (Fmemq); + DEFSUBR (FmemberX); + DEFSUBR (Fadjoin); + DEFSUBR (Fassoc); + DEFSUBR (Fassq); + DEFSUBR (FassocX); + DEFSUBR (Frassoc); + DEFSUBR (Frassq); + DEFSUBR (FrassocX); + DEFSUBR (Fposition); + DEFSUBR (Ffind); + DEFSUBR (FdeleteX); + DEFSUBR (FremoveX); + DEFSUBR (Fdelete_duplicates); + DEFSUBR (Fremove_duplicates); + DEFSUBR (Fnreverse); + DEFSUBR (Freverse); + DEFSUBR (Fmerge); + DEFSUBR (FsortX); + DEFSUBR (Ffill); + DEFSUBR (Fmapconcat); + DEFSUBR (FmapcarX); + DEFSUBR (Fmapvector); + DEFSUBR (Fmapcan); + DEFSUBR (Fmapc); + Ffset (intern ("mapc-internal"), Qmapc); + Ffset (intern ("mapcar"), QmapcarX); + DEFSUBR (Fmap); + DEFSUBR (Fmap_into); + DEFSUBR (Fsome); + DEFSUBR (Fevery); + DEFSUBR (Freduce); + DEFSUBR (Freplace); + DEFSUBR (Fnsubstitute); + DEFSUBR (Fsubstitute); + DEFSUBR (Fsublis); + DEFSUBR (Fnsublis); + DEFSUBR (Fsubst); + DEFSUBR (Fnsubst); + DEFSUBR (Ftree_equal); + DEFSUBR (Fmismatch); + DEFSUBR (Fsearch); + DEFSUBR (Fintersection); + DEFSUBR (Fnintersection); + DEFSUBR (Fsubsetp); + DEFSUBR (Fset_difference); + DEFSUBR (Fnset_difference); + DEFSUBR (Fnunion); + DEFSUBR (Funion); + DEFSUBR (Fset_exclusive_or); + DEFSUBR (Fnset_exclusive_or); +}