Mercurial > hg > xemacs-beta
diff src/fns.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 | 10f179710250 |
| children | e2fae7783046 |
line wrap: on
line diff
--- a/src/fns.c Sat Dec 03 15:55:14 2011 +0000 +++ b/src/fns.c Sun Dec 04 18:42:50 2011 +0000 @@ -52,738 +52,12 @@ /* NOTE: This symbol is also used in lread.c */ #define FEATUREP_SYNTAX -Lisp_Object Qstring_lessp, Qmerge, Qfill, Qreplace, QassocX, QrassocX; -Lisp_Object Qposition, Qfind, QdeleteX, QremoveX, Qidentity, Qadjoin; -Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value; -Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into; -Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce, Qsubstitute; -Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable; -Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch; -Lisp_Object Q_descend_structures; - -Lisp_Object Qintersection, Qset_difference, Qnset_difference; -Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qcar_less_than_car; - -Lisp_Object Qbase64_conversion_error; - -Lisp_Object Vpath_separator; - 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); - } -} - -static Lisp_Object -mark_bit_vector (Lisp_Object UNUSED (obj)) -{ - return Qnil; -} - -static void -print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, - int UNUSED (escapeflag)) -{ - Elemcount i; - Lisp_Bit_Vector *v = XBIT_VECTOR (obj); - Elemcount len = bit_vector_length (v); - Elemcount last = len; - - if (FIXNUMP (Vprint_length)) - last = min (len, XFIXNUM (Vprint_length)); - write_ascstring (printcharfun, "#*"); - for (i = 0; i < last; i++) - { - if (bit_vector_bit (v, i)) - write_ascstring (printcharfun, "1"); - else - write_ascstring (printcharfun, "0"); - } - - if (last != len) - write_ascstring (printcharfun, "..."); -} - -static int -bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), - int UNUSED (foldcase)) -{ - Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); - Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); - - return ((bit_vector_length (v1) == bit_vector_length (v2)) && - !memcmp (v1->bits, v2->bits, - BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) * - sizeof (long))); -} - -/* This needs to be algorithmically identical to internal_array_hash in - elhash.c when equalp is one, so arrays and bit vectors with the same - contents hash the same. It would be possible to enforce this by giving - internal_ARRAYLIKE_hash its own file and including it twice, but right - now that doesn't seem worth it. */ -static Hashcode -internal_bit_vector_equalp_hash (Lisp_Bit_Vector *v) -{ - int ii, size = bit_vector_length (v); - Hashcode hash = 0; - - if (size <= 5) - { - for (ii = 0; ii < size; ii++) - { - hash = HASH2 - (hash, - FLOAT_HASHCODE_FROM_DOUBLE ((double) (bit_vector_bit (v, ii)))); - } - return hash; - } - - /* just pick five elements scattered throughout the array. - A slightly better approach would be to offset by some - noise factor from the points chosen below. */ - for (ii = 0; ii < 5; ii++) - hash = HASH2 (hash, - FLOAT_HASHCODE_FROM_DOUBLE - ((double) (bit_vector_bit (v, ii * size / 5)))); - - return hash; -} - -static Hashcode -bit_vector_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) -{ - Lisp_Bit_Vector *v = XBIT_VECTOR (obj); - if (equalp) - { - return HASH2 (bit_vector_length (v), - internal_bit_vector_equalp_hash (v)); - } - - return HASH2 (bit_vector_length (v), - memory_hash (v->bits, - BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) * - sizeof (long))); -} - -static Bytecount -size_bit_vector (Lisp_Object obj) -{ - Lisp_Bit_Vector *v = XBIT_VECTOR (obj); - return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits, - BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))); -} - -static const struct memory_description bit_vector_description[] = { - { XD_END } -}; - - -DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("bit-vector", bit_vector, - mark_bit_vector, - print_bit_vector, 0, - bit_vector_equal, - bit_vector_hash, - bit_vector_description, - size_bit_vector, - Lisp_Bit_Vector); - -/* 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; -} +Lisp_Object Qmapl, Qmapcon, Qmaplist, Qbase64_conversion_error; + +Lisp_Object Vpath_separator; DEFUN ("identity", Fidentity, 1, 1, 0, /* Return the argument unchanged. @@ -847,34 +121,6 @@ function); } -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; - } -} - DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* Return the length of a list, but avoid error or infinite loop. This function never gets an error. If LIST is not really a list, @@ -926,309 +172,6 @@ return EQ (hare, tortoise) && len != 0 ? Qnil : make_fixnum (len); } -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); -} - /*** string functions. ***/ DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* @@ -1836,206 +779,6 @@ return alist; } -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 ("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 ("substring-no-properties", Fsubstring_no_properties, 1, 3, 0, /* Return a substring of STRING, without copying the extents. END may be nil or omitted; then the substring runs to the end of STRING. @@ -2285,44 +1028,6 @@ return Fcar (Fnthcdr (n, list)); } -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 ("last", Flast, 1, 2, 0, /* Return the tail of list LIST, of length N (default 1). LIST may be a dotted list, but not a circular list. @@ -2459,2846 +1164,6 @@ return retval; } -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; -} - -DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* -Return non-nil if VALUE is `old-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 (HACKEQ_UNSAFE (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 Fdelq, 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; -} /************************************************************************/ /* property-list functions */ @@ -6426,6 +2291,20 @@ return Qnil; } +DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* +Return non-nil if VALUE is `old-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 (HACKEQ_UNSAFE (value, elt_cdr)) + return elt; + } + return Qnil; +} + DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. The value is actually the element of ALIST whose cdr equals VALUE. @@ -6502,134 +2381,6 @@ #endif - -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; -} - Lisp_Object nconc2 (Lisp_Object arg1, Lisp_Object arg2) { @@ -6765,607 +2516,6 @@ } -/* 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; -} - /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]), until that #'nthcdr expression gives nil for some element of LISTS. @@ -7528,415 +2678,6 @@ { return maplist (args[0], nargs - 1, args + 1, Qmapcon); } - -/* Extra random functions */ - -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; -} DEFUN ("replace-list", Freplace_list, 2, 2, 0, /* Destructively replace the list OLD with NEW. @@ -7978,3011 +2719,6 @@ return old; } -/* 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; -} - Lisp_Object add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) @@ -11608,77 +3344,19 @@ return result; } -Lisp_Object Qyes_or_no_p; - void syms_of_fns (void) { - INIT_LISP_OBJECT (bit_vector); - - 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 (Qmaplist); DEFSYMBOL (Qmapl); DEFSYMBOL (Qmapcon); - 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); - - DEFSYMBOL (Qyes_or_no_p); + DEFSYMBOL (Qmaplist); DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error); DEFSUBR (Fidentity); DEFSUBR (Frandom); - DEFSUBR (Flength); DEFSUBR (Fsafe_length); DEFSUBR (Flist_length); - DEFSUBR (Fcount); DEFSUBR (Fstring_equal); DEFSUBR (Fcompare_strings); DEFSUBR (Fstring_lessp); @@ -11690,34 +3368,11 @@ DEFSUBR (Fcopy_list); DEFSUBR (Fcopy_sequence); DEFSUBR (Fcopy_alist); - DEFSUBR (Fcopy_tree); - DEFSUBR (Fsubseq); DEFSUBR (Fnthcdr); DEFSUBR (Fnth); - DEFSUBR (Felt); DEFSUBR (Flast); DEFSUBR (Fbutlast); DEFSUBR (Fnbutlast); - DEFSUBR (Fmember); - DEFSUBR (Fmemq); - DEFSUBR (FmemberX); - DEFSUBR (Fadjoin); - DEFSUBR (Fassoc); - DEFSUBR (Fassq); - DEFSUBR (Frassoc); - DEFSUBR (Frassq); - - DEFSUBR (Fposition); - DEFSUBR (Ffind); - - DEFSUBR (FdeleteX); - DEFSUBR (FremoveX); - DEFSUBR (Fdelete_duplicates); - DEFSUBR (Fremove_duplicates); - DEFSUBR (Fnreverse); - DEFSUBR (Freverse); - DEFSUBR (FsortX); - DEFSUBR (Fmerge); DEFSUBR (Fplists_eq); DEFSUBR (Fplists_equal); DEFSUBR (Flax_plists_eq); @@ -11742,61 +3397,26 @@ DEFSUBR (Fobject_setplist); DEFSUBR (Fequal); DEFSUBR (Fequalp); - DEFSUBR (Ffill); #ifdef SUPPORT_CONFOUNDING_FUNCTIONS DEFSUBR (Fold_member); DEFSUBR (Fold_memq); DEFSUBR (Fold_assoc); DEFSUBR (Fold_assq); + DEFSUBR (Fold_rassq); DEFSUBR (Fold_rassoc); - DEFSUBR (Fold_rassq); DEFSUBR (Fold_delete); DEFSUBR (Fold_delq); DEFSUBR (Fold_equal); DEFSUBR (Fold_eq); #endif - DEFSUBR (FassocX); - DEFSUBR (FrassocX); - DEFSUBR (Fnconc); - DEFSUBR (FmapcarX); - DEFSUBR (Fmapvector); - DEFSUBR (Fmapcan); - DEFSUBR (Fmapc); - DEFSUBR (Fmapconcat); - DEFSUBR (Fmap); - DEFSUBR (Fmap_into); - DEFSUBR (Fsome); - DEFSUBR (Fevery); - Ffset (intern ("mapc-internal"), Qmapc); - Ffset (intern ("mapcar"), QmapcarX); DEFSUBR (Fmaplist); DEFSUBR (Fmapl); DEFSUBR (Fmapcon); - DEFSUBR (Freduce); DEFSUBR (Freplace_list); - DEFSUBR (Freplace); - DEFSUBR (Fsubsetp); - DEFSUBR (Fnsubstitute); - DEFSUBR (Fsubstitute); - DEFSUBR (Fsublis); - DEFSUBR (Fnsublis); - DEFSUBR (Fsubst); - DEFSUBR (Fnsubst); - DEFSUBR (Ftree_equal); - DEFSUBR (Fmismatch); - DEFSUBR (Fsearch); - DEFSUBR (Funion); - DEFSUBR (Fnunion); - DEFSUBR (Fintersection); - DEFSUBR (Fnintersection); - DEFSUBR (Fset_difference); - DEFSUBR (Fnset_difference); - DEFSUBR (Fset_exclusive_or); - DEFSUBR (Fnset_exclusive_or); DEFSUBR (Fload_average); DEFSUBR (Ffeaturep);