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