Mercurial > hg > xemacs-beta
annotate src/fns.c @ 5127:a9c41067dd88 ben-lisp-object
more cleanups, terminology clarification, lots of doc work
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Introduction to Allocation):
* internals/internals.texi (Integers and Characters):
* internals/internals.texi (Allocation from Frob Blocks):
* internals/internals.texi (lrecords):
* internals/internals.texi (Low-level allocation):
Rewrite section on allocation of Lisp objects to reflect the new
reality. Remove references to nonexistent XSETINT and XSETCHAR.
modules/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (allocate_pgconn):
* postgresql/postgresql.c (allocate_pgresult):
* postgresql/postgresql.h (struct Lisp_PGconn):
* postgresql/postgresql.h (struct Lisp_PGresult):
* ldap/eldap.c (allocate_ldap):
* ldap/eldap.h (struct Lisp_LDAP):
Same changes as in src/ dir. See large log there in ChangeLog,
but basically:
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
../hlo/src/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (very_old_free_lcrecord):
* alloc.c (copy_lisp_object):
* alloc.c (zero_sized_lisp_object):
* alloc.c (zero_nonsized_lisp_object):
* alloc.c (lisp_object_storage_size):
* alloc.c (free_normal_lisp_object):
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (Fcons):
* alloc.c (noseeum_cons):
* alloc.c (make_float):
* alloc.c (make_bignum):
* alloc.c (make_bignum_bg):
* alloc.c (make_ratio):
* alloc.c (make_ratio_bg):
* alloc.c (make_ratio_rt):
* alloc.c (make_bigfloat):
* alloc.c (make_bigfloat_bf):
* alloc.c (size_vector):
* alloc.c (make_compiled_function):
* alloc.c (Fmake_symbol):
* alloc.c (allocate_extent):
* alloc.c (allocate_event):
* alloc.c (make_key_data):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (Fmake_marker):
* alloc.c (noseeum_make_marker):
* alloc.c (size_string_direct_data):
* alloc.c (make_uninit_string):
* alloc.c (make_string_nocopy):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* alloc.c (malloced_storage_size):
* buffer.c (allocate_buffer):
* buffer.c (compute_buffer_usage):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* buffer.c (nuke_all_buffer_slots):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.h (struct buffer_text):
* buffer.h (struct buffer):
* bytecode.c:
* bytecode.c (make_compiled_function_args):
* bytecode.c (size_compiled_function_args):
* bytecode.h (struct compiled_function_args):
* casetab.c (allocate_case_table):
* casetab.h (struct Lisp_Case_Table):
* charset.h (struct Lisp_Charset):
* chartab.c (fill_char_table):
* chartab.c (Fmake_char_table):
* chartab.c (make_char_table_entry):
* chartab.c (copy_char_table_entry):
* chartab.c (Fcopy_char_table):
* chartab.c (put_char_table):
* chartab.h (struct Lisp_Char_Table_Entry):
* chartab.h (struct Lisp_Char_Table):
* console-gtk-impl.h (struct gtk_device):
* console-gtk-impl.h (struct gtk_frame):
* console-impl.h (struct console):
* console-msw-impl.h (struct Lisp_Devmode):
* console-msw-impl.h (struct mswindows_device):
* console-msw-impl.h (struct msprinter_device):
* console-msw-impl.h (struct mswindows_frame):
* console-msw-impl.h (struct mswindows_dialog_id):
* console-stream-impl.h (struct stream_console):
* console-stream.c (stream_init_console):
* console-tty-impl.h (struct tty_console):
* console-tty-impl.h (struct tty_device):
* console-tty.c (allocate_tty_console_struct):
* console-x-impl.h (struct x_device):
* console-x-impl.h (struct x_frame):
* console.c (allocate_console):
* console.c (nuke_all_console_slots):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* console.c (common_init_complex_vars_of_console):
* data.c (make_weak_list):
* data.c (make_weak_box):
* data.c (make_ephemeron):
* database.c:
* database.c (struct Lisp_Database):
* database.c (allocate_database):
* database.c (finalize_database):
* device-gtk.c (allocate_gtk_device_struct):
* device-impl.h (struct device):
* device-msw.c:
* device-msw.c (mswindows_init_device):
* device-msw.c (msprinter_init_device):
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device-tty.c (allocate_tty_device_struct):
* device-x.c (allocate_x_device_struct):
* device.c:
* device.c (nuke_all_device_slots):
* device.c (allocate_device):
* dialog-msw.c (handle_question_dialog_box):
* elhash.c:
* elhash.c (struct Lisp_Hash_Table):
* elhash.c (finalize_hash_table):
* elhash.c (make_general_lisp_hash_table):
* elhash.c (Fcopy_hash_table):
* elhash.h (htentry):
* emacs.c (main_1):
* eval.c:
* eval.c (size_multiple_value):
* event-stream.c (finalize_command_builder):
* event-stream.c (allocate_command_builder):
* event-stream.c (free_command_builder):
* event-stream.c (event_stream_generate_wakeup):
* event-stream.c (event_stream_resignal_wakeup):
* event-stream.c (event_stream_disable_wakeup):
* event-stream.c (event_stream_wakeup_pending_p):
* events.h (struct Lisp_Timeout):
* events.h (struct command_builder):
* extents-impl.h:
* extents-impl.h (struct extent_auxiliary):
* extents-impl.h (struct extent_info):
* extents-impl.h (set_extent_no_chase_aux_field):
* extents-impl.h (set_extent_no_chase_normal_field):
* extents.c:
* extents.c (gap_array_marker):
* extents.c (gap_array):
* extents.c (extent_list_marker):
* extents.c (extent_list):
* extents.c (stack_of_extents):
* extents.c (gap_array_make_marker):
* extents.c (extent_list_make_marker):
* extents.c (allocate_extent_list):
* extents.c (SLOT):
* extents.c (mark_extent_auxiliary):
* extents.c (allocate_extent_auxiliary):
* extents.c (attach_extent_auxiliary):
* extents.c (size_gap_array):
* extents.c (finalize_extent_info):
* extents.c (allocate_extent_info):
* extents.c (uninit_buffer_extents):
* extents.c (allocate_soe):
* extents.c (copy_extent):
* extents.c (vars_of_extents):
* extents.h:
* faces.c (allocate_face):
* faces.h (struct Lisp_Face):
* faces.h (struct face_cachel):
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.c (sizeof_coding_system):
* file-coding.c (Fcopy_coding_system):
* file-coding.h (struct Lisp_Coding_System):
* file-coding.h (MARKED_SLOT):
* fns.c (size_bit_vector):
* font-mgr.c:
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (print_fc_pattern):
* font-mgr.c (Ffc_pattern_p):
* font-mgr.c (Ffc_pattern_create):
* font-mgr.c (Ffc_name_parse):
* font-mgr.c (Ffc_name_unparse):
* font-mgr.c (Ffc_pattern_duplicate):
* font-mgr.c (Ffc_pattern_add):
* font-mgr.c (Ffc_pattern_del):
* font-mgr.c (Ffc_pattern_get):
* font-mgr.c (fc_config_create_using):
* font-mgr.c (fc_strlist_to_lisp_using):
* font-mgr.c (fontset_to_list):
* font-mgr.c (Ffc_config_p):
* font-mgr.c (Ffc_config_up_to_date):
* font-mgr.c (Ffc_config_build_fonts):
* font-mgr.c (Ffc_config_get_cache):
* font-mgr.c (Ffc_config_get_fonts):
* font-mgr.c (Ffc_config_set_current):
* font-mgr.c (Ffc_config_get_blanks):
* font-mgr.c (Ffc_config_get_rescan_interval):
* font-mgr.c (Ffc_config_set_rescan_interval):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_app_font_clear):
* font-mgr.c (size):
* font-mgr.c (Ffc_config_substitute):
* font-mgr.c (Ffc_font_render_prepare):
* font-mgr.c (Ffc_font_match):
* font-mgr.c (Ffc_font_sort):
* font-mgr.c (finalize_fc_config):
* font-mgr.c (print_fc_config):
* font-mgr.h:
* font-mgr.h (struct fc_pattern):
* font-mgr.h (XFC_PATTERN):
* font-mgr.h (struct fc_config):
* font-mgr.h (XFC_CONFIG):
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-impl.h (struct frame):
* frame-msw.c (mswindows_init_frame_1):
* frame-x.c (allocate_x_frame_struct):
* frame.c (nuke_all_frame_slots):
* frame.c (allocate_frame_core):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c (finalize_image_instance):
* glyphs.c (allocate_image_instance):
* glyphs.c (Fcolorize_image_instance):
* glyphs.c (allocate_glyph):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* glyphs.c (register_ignored_expose):
* glyphs.h (struct Lisp_Image_Instance):
* glyphs.h (struct Lisp_Glyph):
* glyphs.h (struct glyph_cachel):
* glyphs.h (struct expose_ignore):
* gui.c (allocate_gui_item):
* gui.h (struct Lisp_Gui_Item):
* keymap.c (struct Lisp_Keymap):
* keymap.c (make_keymap):
* lisp.h:
* lisp.h (struct Lisp_String_Direct_Data):
* lisp.h (struct Lisp_String_Indirect_Data):
* lisp.h (struct Lisp_Vector):
* lisp.h (struct Lisp_Bit_Vector):
* lisp.h (DECLARE_INLINE_LISP_BIT_VECTOR):
* lisp.h (struct weak_box):
* lisp.h (struct ephemeron):
* lisp.h (struct weak_list):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (struct lcrecord_list):
* lstream.c (finalize_lstream):
* lstream.c (sizeof_lstream):
* lstream.c (Lstream_new):
* lstream.c (Lstream_delete):
* lstream.h (struct lstream):
* marker.c:
* marker.c (finalize_marker):
* marker.c (compute_buffer_marker_usage):
* mule-charset.c:
* mule-charset.c (make_charset):
* mule-charset.c (compute_charset_usage):
* objects-impl.h (struct Lisp_Color_Instance):
* objects-impl.h (struct Lisp_Font_Instance):
* objects-tty-impl.h (struct tty_color_instance_data):
* objects-tty-impl.h (struct tty_font_instance_data):
* objects-tty.c (tty_initialize_color_instance):
* objects-tty.c (tty_initialize_font_instance):
* objects.c (finalize_color_instance):
* objects.c (Fmake_color_instance):
* objects.c (finalize_font_instance):
* objects.c (Fmake_font_instance):
* objects.c (reinit_vars_of_objects):
* opaque.c:
* opaque.c (sizeof_opaque):
* opaque.c (make_opaque_ptr):
* opaque.c (free_opaque_ptr):
* opaque.h:
* opaque.h (Lisp_Opaque):
* opaque.h (Lisp_Opaque_Ptr):
* print.c (printing_unreadable_lcrecord):
* print.c (external_object_printer):
* print.c (debug_p4):
* process.c (finalize_process):
* process.c (make_process_internal):
* procimpl.h (struct Lisp_Process):
* rangetab.c (Fmake_range_table):
* rangetab.c (Fcopy_range_table):
* rangetab.h (struct Lisp_Range_Table):
* scrollbar.c:
* scrollbar.c (create_scrollbar_instance):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h (struct scrollbar_instance):
* specifier.c (finalize_specifier):
* specifier.c (sizeof_specifier):
* specifier.c (set_specifier_caching):
* specifier.h (struct Lisp_Specifier):
* specifier.h (struct specifier_caching):
* symeval.h:
* symeval.h (SYMBOL_VALUE_MAGIC_P):
* symeval.h (DEFVAR_SYMVAL_FWD):
* symsinit.h:
* syntax.c (init_buffer_syntax_cache):
* syntax.h (struct syntax_cache):
* toolbar.c:
* toolbar.c (allocate_toolbar_button):
* toolbar.c (update_toolbar_button):
* toolbar.h (struct toolbar_button):
* tooltalk.c (struct Lisp_Tooltalk_Message):
* tooltalk.c (make_tooltalk_message):
* tooltalk.c (struct Lisp_Tooltalk_Pattern):
* tooltalk.c (make_tooltalk_pattern):
* ui-gtk.c:
* ui-gtk.c (allocate_ffi_data):
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_object_data):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* ui-gtk.h:
* window-impl.h (struct window):
* window-impl.h (struct window_mirror):
* window.c (finalize_window):
* window.c (allocate_window):
* window.c (new_window_mirror):
* window.c (mark_window_as_deleted):
* window.c (make_dummy_parent):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
Overall point of this change and previous ones in this repository:
(1) Introduce new, clearer terminology: everything other than int
or char is a "record" object, which comes in two types: "normal
objects" and "frob-block objects". Fix up all places that
referred to frob-block objects as "simple", "basic", etc.
(2) Provide an advertised interface for doing operations on Lisp
objects, including creating new types, that is clean and
consistent in its naming, uses the above-referenced terms and
avoids referencing "lrecords", "old lcrecords", etc., which should
hide under the surface.
(3) Make the size_in_bytes and finalizer methods take a
Lisp_Object rather than a void * for consistency with other methods.
(4) Separate finalizer method into finalizer and disksaver, so
that normal finalize methods don't have to worry about disksaving.
Other specifics:
(1) Renaming:
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
implementation->basic_p -> implementation->frob_block_p
ALLOCATE_FIXED_TYPE_AND_SET_IMPL -> ALLOC_FROB_BLOCK_LISP_OBJECT
*FCCONFIG*, wrap_fcconfig -> *FC_CONFIG*, wrap_fc_config
*FCPATTERN*, wrap_fcpattern -> *FC_PATTERN*, wrap_fc_pattern
(the last two changes make the naming of these macros consistent
with the naming of all other macros, since the objects are named
fc-config and fc-pattern with a hyphen)
(2) Lots of documentation fixes in lrecord.h.
(3) Eliminate macros for copying, freeing, zeroing objects, getting
their storage size. Instead, new functions:
zero_sized_lisp_object()
zero_nonsized_lisp_object()
lisp_object_storage_size()
free_normal_lisp_object()
(copy_lisp_object() already exists)
LISP_OBJECT_FROB_BLOCK_P() (actually a macro)
Eliminated:
free_lrecord()
zero_lrecord()
copy_lrecord()
copy_sized_lrecord()
old_copy_lcrecord()
old_copy_sized_lcrecord()
old_zero_lcrecord()
old_zero_sized_lcrecord()
LISP_OBJECT_STORAGE_SIZE()
COPY_SIZED_LISP_OBJECT()
COPY_SIZED_LCRECORD()
COPY_LISP_OBJECT()
ZERO_LISP_OBJECT()
FREE_LISP_OBJECT()
(4) Catch the remaining places where lrecord stuff was used directly
and use the advertised interface, e.g. alloc_sized_lrecord() ->
ALLOC_SIZED_LISP_OBJECT().
(5) Make certain statically-declared pseudo-objects
(buffer_local_flags, console_local_flags) have their lheader
initialized correctly, so things like copy_lisp_object() can work
on them. Make extent_auxiliary_defaults a proper heap object
Vextent_auxiliary_defaults, and make extent auxiliaries dumpable
so that this object can be dumped. allocate_extent_auxiliary()
now just creates the object, and attach_extent_auxiliary()
creates an extent auxiliary and attaches to an extent, like the
old allocate_extent_auxiliary().
(6) Create EXTENT_AUXILIARY_SLOTS macro, similar to the foo-slots.h
files but in a macro instead of a file. The purpose is to avoid
duplication when iterating over all the slots in an extent auxiliary.
Use it.
(7) In lstream.c, don't zero out object after allocation because
allocation routines take care of this.
(8) In marker.c, fix a mistake in computing marker overhead.
(9) In print.c, clean up printing_unreadable_lcrecord(),
external_object_printer() to avoid lots of ifdef NEW_GC's.
(10) Separate toolbar-button allocation into a separate
allocate_toolbar_button() function for use in the example code
in lrecord.h.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Mar 2010 04:08:17 -0600 |
| parents | 2a462149bd6a |
| children | 7be849cb8828 |
| rev | line source |
|---|---|
| 428 | 1 /* Random utility Lisp functions. |
| 2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing. |
| 428 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
| 7 XEmacs is free software; you can redistribute it and/or modify it | |
| 8 under the terms of the GNU General Public License as published by the | |
| 9 Free Software Foundation; either version 2, or (at your option) any | |
| 10 later version. | |
| 11 | |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
| 18 along with XEmacs; see the file COPYING. If not, write to | |
| 19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 20 Boston, MA 02111-1307, USA. */ | |
| 21 | |
| 22 /* Synched up with: Mule 2.0, FSF 19.30. */ | |
| 23 | |
| 24 /* This file has been Mule-ized. */ | |
| 25 | |
| 26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */ | |
| 27 | |
| 28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */ | |
| 29 | |
| 30 #include <config.h> | |
| 31 | |
| 32 /* Note on some machines this defines `vector' as a typedef, | |
| 33 so make sure we don't use that name in this file. */ | |
| 34 #undef vector | |
| 35 #define vector ***** | |
| 36 | |
| 37 #include "lisp.h" | |
| 38 | |
| 442 | 39 #include "sysfile.h" |
| 771 | 40 #include "sysproc.h" /* for qxe_getpid() */ |
| 428 | 41 |
| 42 #include "buffer.h" | |
| 43 #include "bytecode.h" | |
| 44 #include "device.h" | |
| 45 #include "events.h" | |
| 46 #include "extents.h" | |
| 47 #include "frame.h" | |
| 872 | 48 #include "process.h" |
| 428 | 49 #include "systime.h" |
| 50 #include "insdel.h" | |
| 51 #include "lstream.h" | |
| 52 #include "opaque.h" | |
| 53 | |
| 54 /* NOTE: This symbol is also used in lread.c */ | |
| 55 #define FEATUREP_SYNTAX | |
| 56 | |
| 57 Lisp_Object Qstring_lessp; | |
| 58 Lisp_Object Qidentity; | |
|
5002
0cd784a6ec44
fix some compile bugs of Aidan's
Ben Wing <ben@xemacs.org>
parents:
5001
diff
changeset
|
59 Lisp_Object Qvector, Qarray, Qbit_vector; |
| 428 | 60 |
| 563 | 61 Lisp_Object Qbase64_conversion_error; |
| 62 | |
| 771 | 63 Lisp_Object Vpath_separator; |
| 64 | |
| 428 | 65 static int internal_old_equal (Lisp_Object, Lisp_Object, int); |
| 454 | 66 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); |
| 428 | 67 |
| 68 static Lisp_Object | |
| 2286 | 69 mark_bit_vector (Lisp_Object UNUSED (obj)) |
| 428 | 70 { |
| 71 return Qnil; | |
| 72 } | |
| 73 | |
| 74 static void | |
| 2286 | 75 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, |
| 76 int UNUSED (escapeflag)) | |
| 428 | 77 { |
| 665 | 78 Elemcount i; |
| 440 | 79 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
| 665 | 80 Elemcount len = bit_vector_length (v); |
| 81 Elemcount last = len; | |
| 428 | 82 |
| 83 if (INTP (Vprint_length)) | |
| 84 last = min (len, XINT (Vprint_length)); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
85 write_ascstring (printcharfun, "#*"); |
| 428 | 86 for (i = 0; i < last; i++) |
| 87 { | |
| 88 if (bit_vector_bit (v, i)) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
89 write_ascstring (printcharfun, "1"); |
| 428 | 90 else |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
91 write_ascstring (printcharfun, "0"); |
| 428 | 92 } |
| 93 | |
| 94 if (last != len) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
95 write_ascstring (printcharfun, "..."); |
| 428 | 96 } |
| 97 | |
| 98 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
99 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
100 int UNUSED (foldcase)) |
| 428 | 101 { |
| 440 | 102 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); |
| 103 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); | |
| 428 | 104 |
| 105 return ((bit_vector_length (v1) == bit_vector_length (v2)) && | |
| 106 !memcmp (v1->bits, v2->bits, | |
| 107 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) * | |
| 108 sizeof (long))); | |
| 109 } | |
| 110 | |
| 665 | 111 static Hashcode |
| 2286 | 112 bit_vector_hash (Lisp_Object obj, int UNUSED (depth)) |
| 428 | 113 { |
| 440 | 114 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
| 428 | 115 return HASH2 (bit_vector_length (v), |
| 116 memory_hash (v->bits, | |
| 117 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) * | |
| 118 sizeof (long))); | |
| 119 } | |
| 120 | |
| 665 | 121 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
122 size_bit_vector (Lisp_Object obj) |
| 442 | 123 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
124 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
| 456 | 125 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits, |
| 442 | 126 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))); |
| 127 } | |
| 128 | |
| 1204 | 129 static const struct memory_description bit_vector_description[] = { |
| 428 | 130 { XD_END } |
| 131 }; | |
| 132 | |
| 133 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
134 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("bit-vector", bit_vector, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
135 mark_bit_vector, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
136 print_bit_vector, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
137 bit_vector_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
138 bit_vector_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
139 bit_vector_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
140 size_bit_vector, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
141 Lisp_Bit_Vector); |
| 934 | 142 |
| 428 | 143 |
| 144 DEFUN ("identity", Fidentity, 1, 1, 0, /* | |
| 145 Return the argument unchanged. | |
| 146 */ | |
| 147 (arg)) | |
| 148 { | |
| 149 return arg; | |
| 150 } | |
| 151 | |
| 152 DEFUN ("random", Frandom, 0, 1, 0, /* | |
| 153 Return a pseudo-random number. | |
| 1983 | 154 All fixnums are equally likely. On most systems, this is 31 bits' worth. |
| 428 | 155 With positive integer argument N, return random number in interval [0,N). |
| 1983 | 156 N can be a bignum, in which case the range of possible values is extended. |
| 428 | 157 With argument t, set the random number seed from the current time and pid. |
| 158 */ | |
| 159 (limit)) | |
| 160 { | |
| 161 EMACS_INT val; | |
| 162 unsigned long denominator; | |
| 163 | |
| 164 if (EQ (limit, Qt)) | |
| 771 | 165 seed_random (qxe_getpid () + time (NULL)); |
| 428 | 166 if (NATNUMP (limit) && !ZEROP (limit)) |
| 167 { | |
| 168 /* Try to take our random number from the higher bits of VAL, | |
| 169 not the lower, since (says Gentzel) the low bits of `random' | |
| 170 are less random than the higher ones. We do this by using the | |
| 171 quotient rather than the remainder. At the high end of the RNG | |
| 172 it's possible to get a quotient larger than limit; discarding | |
| 173 these values eliminates the bias that would otherwise appear | |
| 174 when using a large limit. */ | |
| 2039 | 175 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit); |
| 428 | 176 do |
| 177 val = get_random () / denominator; | |
| 178 while (val >= XINT (limit)); | |
| 179 } | |
| 1983 | 180 #ifdef HAVE_BIGNUM |
| 181 else if (BIGNUMP (limit)) | |
| 182 { | |
| 183 bignum_random (scratch_bignum, XBIGNUM_DATA (limit)); | |
| 184 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 185 } | |
| 186 #endif | |
| 428 | 187 else |
| 188 val = get_random (); | |
| 189 | |
| 190 return make_int (val); | |
| 191 } | |
| 192 | |
| 193 /* Random data-structure functions */ | |
| 194 | |
| 195 #ifdef LOSING_BYTECODE | |
| 196 | |
| 197 /* #### Delete this shit */ | |
| 198 | |
| 199 /* Charcount is a misnomer here as we might be dealing with the | |
| 200 length of a vector or list, but emphasizes that we're not dealing | |
| 201 with Bytecounts in strings */ | |
| 202 static Charcount | |
| 203 length_with_bytecode_hack (Lisp_Object seq) | |
| 204 { | |
| 205 if (!COMPILED_FUNCTIONP (seq)) | |
| 206 return XINT (Flength (seq)); | |
| 207 else | |
| 208 { | |
| 440 | 209 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); |
| 428 | 210 |
| 211 return (f->flags.interactivep ? COMPILED_INTERACTIVE : | |
| 212 f->flags.domainp ? COMPILED_DOMAIN : | |
| 213 COMPILED_DOC_STRING) | |
| 214 + 1; | |
| 215 } | |
| 216 } | |
| 217 | |
| 218 #endif /* LOSING_BYTECODE */ | |
| 219 | |
| 220 void | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
221 check_losing_bytecode (const Ascbyte *function, Lisp_Object seq) |
| 428 | 222 { |
| 223 if (COMPILED_FUNCTIONP (seq)) | |
| 563 | 224 signal_ferror_with_frob |
| 225 (Qinvalid_argument, seq, | |
| 428 | 226 "As of 20.3, `%s' no longer works with compiled-function objects", |
| 227 function); | |
| 228 } | |
| 229 | |
| 230 DEFUN ("length", Flength, 1, 1, 0, /* | |
| 231 Return the length of vector, bit vector, list or string SEQUENCE. | |
| 232 */ | |
| 233 (sequence)) | |
| 234 { | |
| 235 retry: | |
| 236 if (STRINGP (sequence)) | |
| 826 | 237 return make_int (string_char_length (sequence)); |
| 428 | 238 else if (CONSP (sequence)) |
| 239 { | |
| 665 | 240 Elemcount len; |
| 428 | 241 GET_EXTERNAL_LIST_LENGTH (sequence, len); |
| 242 return make_int (len); | |
| 243 } | |
| 244 else if (VECTORP (sequence)) | |
| 245 return make_int (XVECTOR_LENGTH (sequence)); | |
| 246 else if (NILP (sequence)) | |
| 247 return Qzero; | |
| 248 else if (BIT_VECTORP (sequence)) | |
| 249 return make_int (bit_vector_length (XBIT_VECTOR (sequence))); | |
| 250 else | |
| 251 { | |
| 252 check_losing_bytecode ("length", sequence); | |
| 253 sequence = wrong_type_argument (Qsequencep, sequence); | |
| 254 goto retry; | |
| 255 } | |
| 256 } | |
| 257 | |
| 258 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* | |
| 259 Return the length of a list, but avoid error or infinite loop. | |
| 260 This function never gets an error. If LIST is not really a list, | |
| 261 it returns 0. If LIST is circular, it returns a finite value | |
| 262 which is at least the number of distinct elements. | |
| 263 */ | |
| 264 (list)) | |
| 265 { | |
| 266 Lisp_Object hare, tortoise; | |
| 665 | 267 Elemcount len; |
| 428 | 268 |
| 269 for (hare = tortoise = list, len = 0; | |
| 270 CONSP (hare) && (! EQ (hare, tortoise) || len == 0); | |
| 271 hare = XCDR (hare), len++) | |
| 272 { | |
| 273 if (len & 1) | |
| 274 tortoise = XCDR (tortoise); | |
| 275 } | |
| 276 | |
| 277 return make_int (len); | |
| 278 } | |
| 279 | |
| 280 /*** string functions. ***/ | |
| 281 | |
| 282 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* | |
| 283 Return t if two strings have identical contents. | |
| 284 Case is significant. Text properties are ignored. | |
| 285 \(Under XEmacs, `equal' also ignores text properties and extents in | |
| 286 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20 | |
| 287 `equal' is the same as in XEmacs, in that respect.) | |
| 288 Symbols are also allowed; their print names are used instead. | |
| 289 */ | |
| 444 | 290 (string1, string2)) |
| 428 | 291 { |
| 292 Bytecount len; | |
| 793 | 293 Lisp_Object p1, p2; |
| 428 | 294 |
| 444 | 295 if (SYMBOLP (string1)) |
| 296 p1 = XSYMBOL (string1)->name; | |
| 428 | 297 else |
| 298 { | |
| 444 | 299 CHECK_STRING (string1); |
| 793 | 300 p1 = string1; |
| 428 | 301 } |
| 302 | |
| 444 | 303 if (SYMBOLP (string2)) |
| 304 p2 = XSYMBOL (string2)->name; | |
| 428 | 305 else |
| 306 { | |
| 444 | 307 CHECK_STRING (string2); |
| 793 | 308 p2 = string2; |
| 428 | 309 } |
| 310 | |
| 793 | 311 return (((len = XSTRING_LENGTH (p1)) == XSTRING_LENGTH (p2)) && |
| 312 !memcmp (XSTRING_DATA (p1), XSTRING_DATA (p2), len)) ? Qt : Qnil; | |
| 428 | 313 } |
| 314 | |
| 801 | 315 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /* |
| 316 Compare the contents of two strings, maybe ignoring case. | |
| 317 In string STR1, skip the first START1 characters and stop at END1. | |
| 318 In string STR2, skip the first START2 characters and stop at END2. | |
|
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
319 END1 and END2 default to the full lengths of the respective strings, |
|
4797
a5eca70cf401
Fix typo in last patch.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4796
diff
changeset
|
320 and arguments that are outside the string (negative STARTi or ENDi |
|
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
321 greater than length) are coerced to 0 or string length as appropriate. |
|
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
322 |
|
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
323 Optional IGNORE-CASE non-nil means use case-insensitive comparison. |
|
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
324 Case is significant by default. |
| 801 | 325 |
| 326 The value is t if the strings (or specified portions) match. | |
| 327 If string STR1 is less, the value is a negative number N; | |
| 328 - 1 - N is the number of characters that match at the beginning. | |
| 329 If string STR1 is greater, the value is a positive number N; | |
| 330 N - 1 is the number of characters that match at the beginning. | |
| 331 */ | |
| 332 (str1, start1, end1, str2, start2, end2, ignore_case)) | |
| 333 { | |
| 334 Charcount ccstart1, ccend1, ccstart2, ccend2; | |
| 335 Bytecount bstart1, blen1, bstart2, blen2; | |
| 336 Charcount matching; | |
| 337 int res; | |
| 338 | |
| 339 CHECK_STRING (str1); | |
| 340 CHECK_STRING (str2); | |
| 341 get_string_range_char (str1, start1, end1, &ccstart1, &ccend1, | |
|
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
342 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
| 801 | 343 get_string_range_char (str2, start2, end2, &ccstart2, &ccend2, |
|
4796
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
344 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
| 801 | 345 |
| 346 bstart1 = string_index_char_to_byte (str1, ccstart1); | |
| 347 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1); | |
| 348 bstart2 = string_index_char_to_byte (str2, ccstart2); | |
| 349 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2); | |
| 350 | |
| 351 res = ((NILP (ignore_case) ? qxetextcmp_matching : qxetextcasecmp_matching) | |
| 352 (XSTRING_DATA (str1) + bstart1, blen1, | |
| 353 XSTRING_DATA (str2) + bstart2, blen2, | |
| 354 &matching)); | |
| 355 | |
| 356 if (!res) | |
| 357 return Qt; | |
| 358 else if (res > 0) | |
| 359 return make_int (1 + matching); | |
| 360 else | |
| 361 return make_int (-1 - matching); | |
| 362 } | |
| 363 | |
| 428 | 364 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /* |
| 365 Return t if first arg string is less than second in lexicographic order. | |
| 771 | 366 Comparison is simply done on a character-by-character basis using the |
| 367 numeric value of a character. (Note that this may not produce | |
| 368 particularly meaningful results under Mule if characters from | |
| 369 different charsets are being compared.) | |
| 428 | 370 |
| 371 Symbols are also allowed; their print names are used instead. | |
| 372 | |
| 771 | 373 Currently we don't do proper language-specific collation or handle |
| 374 multiple character sets. This may be changed when Unicode support | |
| 375 is implemented. | |
| 428 | 376 */ |
| 444 | 377 (string1, string2)) |
| 428 | 378 { |
| 793 | 379 Lisp_Object p1, p2; |
| 428 | 380 Charcount end, len2; |
| 381 int i; | |
| 382 | |
| 444 | 383 if (SYMBOLP (string1)) |
| 384 p1 = XSYMBOL (string1)->name; | |
| 793 | 385 else |
| 386 { | |
| 444 | 387 CHECK_STRING (string1); |
| 793 | 388 p1 = string1; |
| 428 | 389 } |
| 390 | |
| 444 | 391 if (SYMBOLP (string2)) |
| 392 p2 = XSYMBOL (string2)->name; | |
| 428 | 393 else |
| 394 { | |
| 444 | 395 CHECK_STRING (string2); |
| 793 | 396 p2 = string2; |
| 428 | 397 } |
| 398 | |
| 826 | 399 end = string_char_length (p1); |
| 400 len2 = string_char_length (p2); | |
| 428 | 401 if (end > len2) |
| 402 end = len2; | |
| 403 | |
| 404 { | |
| 867 | 405 Ibyte *ptr1 = XSTRING_DATA (p1); |
| 406 Ibyte *ptr2 = XSTRING_DATA (p2); | |
| 428 | 407 |
| 408 /* #### It is not really necessary to do this: We could compare | |
| 409 byte-by-byte and still get a reasonable comparison, since this | |
| 410 would compare characters with a charset in the same way. With | |
| 411 a little rearrangement of the leading bytes, we could make most | |
| 412 inter-charset comparisons work out the same, too; even if some | |
| 413 don't, this is not a big deal because inter-charset comparisons | |
| 414 aren't really well-defined anyway. */ | |
| 415 for (i = 0; i < end; i++) | |
| 416 { | |
| 867 | 417 if (itext_ichar (ptr1) != itext_ichar (ptr2)) |
| 418 return itext_ichar (ptr1) < itext_ichar (ptr2) ? Qt : Qnil; | |
| 419 INC_IBYTEPTR (ptr1); | |
| 420 INC_IBYTEPTR (ptr2); | |
| 428 | 421 } |
| 422 } | |
| 423 /* Can't do i < len2 because then comparison between "foo" and "foo^@" | |
| 424 won't work right in I18N2 case */ | |
| 425 return end < len2 ? Qt : Qnil; | |
| 426 } | |
| 427 | |
| 428 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /* | |
| 429 Return STRING's tick counter, incremented for each change to the string. | |
| 430 Each string has a tick counter which is incremented each time the contents | |
| 431 of the string are changed (e.g. with `aset'). It wraps around occasionally. | |
| 432 */ | |
| 433 (string)) | |
| 434 { | |
| 435 CHECK_STRING (string); | |
| 793 | 436 if (CONSP (XSTRING_PLIST (string)) && INTP (XCAR (XSTRING_PLIST (string)))) |
| 437 return XCAR (XSTRING_PLIST (string)); | |
| 428 | 438 else |
| 439 return Qzero; | |
| 440 } | |
| 441 | |
| 442 void | |
| 443 bump_string_modiff (Lisp_Object str) | |
| 444 { | |
| 793 | 445 Lisp_Object *ptr = &XSTRING_PLIST (str); |
| 428 | 446 |
| 447 #ifdef I18N3 | |
| 448 /* #### remove the `string-translatable' property from the string, | |
| 449 if there is one. */ | |
| 450 #endif | |
| 451 /* skip over extent info if it's there */ | |
| 452 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
| 453 ptr = &XCDR (*ptr); | |
| 454 if (CONSP (*ptr) && INTP (XCAR (*ptr))) | |
| 793 | 455 XCAR (*ptr) = make_int (1+XINT (XCAR (*ptr))); |
| 428 | 456 else |
| 457 *ptr = Fcons (make_int (1), *ptr); | |
| 458 } | |
| 459 | |
| 460 | |
| 461 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector }; | |
| 462 static Lisp_Object concat (int nargs, Lisp_Object *args, | |
| 463 enum concat_target_type target_type, | |
| 464 int last_special); | |
| 465 | |
| 466 Lisp_Object | |
| 444 | 467 concat2 (Lisp_Object string1, Lisp_Object string2) |
| 428 | 468 { |
| 469 Lisp_Object args[2]; | |
| 444 | 470 args[0] = string1; |
| 471 args[1] = string2; | |
| 428 | 472 return concat (2, args, c_string, 0); |
| 473 } | |
| 474 | |
| 475 Lisp_Object | |
| 444 | 476 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3) |
| 428 | 477 { |
| 478 Lisp_Object args[3]; | |
| 444 | 479 args[0] = string1; |
| 480 args[1] = string2; | |
| 481 args[2] = string3; | |
| 428 | 482 return concat (3, args, c_string, 0); |
| 483 } | |
| 484 | |
| 485 Lisp_Object | |
| 444 | 486 vconcat2 (Lisp_Object vec1, Lisp_Object vec2) |
| 428 | 487 { |
| 488 Lisp_Object args[2]; | |
| 444 | 489 args[0] = vec1; |
| 490 args[1] = vec2; | |
| 428 | 491 return concat (2, args, c_vector, 0); |
| 492 } | |
| 493 | |
| 494 Lisp_Object | |
| 444 | 495 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3) |
| 428 | 496 { |
| 497 Lisp_Object args[3]; | |
| 444 | 498 args[0] = vec1; |
| 499 args[1] = vec2; | |
| 500 args[2] = vec3; | |
| 428 | 501 return concat (3, args, c_vector, 0); |
| 502 } | |
| 503 | |
| 504 DEFUN ("append", Fappend, 0, MANY, 0, /* | |
| 505 Concatenate all the arguments and make the result a list. | |
| 506 The result is a list whose elements are the elements of all the arguments. | |
| 507 Each argument may be a list, vector, bit vector, or string. | |
| 508 The last argument is not copied, just used as the tail of the new list. | |
| 509 Also see: `nconc'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
510 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
511 arguments: (&rest ARGS) |
| 428 | 512 */ |
| 513 (int nargs, Lisp_Object *args)) | |
| 514 { | |
| 515 return concat (nargs, args, c_cons, 1); | |
| 516 } | |
| 517 | |
| 518 DEFUN ("concat", Fconcat, 0, MANY, 0, /* | |
| 519 Concatenate all the arguments and make the result a string. | |
| 520 The result is a string whose elements are the elements of all the arguments. | |
| 521 Each argument may be a string or a list or vector of characters. | |
| 522 | |
| 523 As of XEmacs 21.0, this function does NOT accept individual integers | |
| 524 as arguments. Old code that relies on, for example, (concat "foo" 50) | |
| 525 returning "foo50" will fail. To fix such code, either apply | |
| 526 `int-to-string' to the integer argument, or use `format'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
527 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
528 arguments: (&rest ARGS) |
| 428 | 529 */ |
| 530 (int nargs, Lisp_Object *args)) | |
| 531 { | |
| 532 return concat (nargs, args, c_string, 0); | |
| 533 } | |
| 534 | |
| 535 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /* | |
| 536 Concatenate all the arguments and make the result a vector. | |
| 537 The result is a vector whose elements are the elements of all the arguments. | |
| 538 Each argument may be a list, vector, bit vector, or string. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
539 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
540 arguments: (&rest ARGS) |
| 428 | 541 */ |
| 542 (int nargs, Lisp_Object *args)) | |
| 543 { | |
| 544 return concat (nargs, args, c_vector, 0); | |
| 545 } | |
| 546 | |
| 547 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /* | |
| 548 Concatenate all the arguments and make the result a bit vector. | |
| 549 The result is a bit vector whose elements are the elements of all the | |
| 550 arguments. Each argument may be a list, vector, bit vector, or string. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
551 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
552 arguments: (&rest ARGS) |
| 428 | 553 */ |
| 554 (int nargs, Lisp_Object *args)) | |
| 555 { | |
| 556 return concat (nargs, args, c_bit_vector, 0); | |
| 557 } | |
| 558 | |
| 559 /* Copy a (possibly dotted) list. LIST must be a cons. | |
| 560 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */ | |
| 561 static Lisp_Object | |
| 562 copy_list (Lisp_Object list) | |
| 563 { | |
| 564 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); | |
| 565 Lisp_Object last = list_copy; | |
| 566 Lisp_Object hare, tortoise; | |
| 665 | 567 Elemcount len; |
| 428 | 568 |
| 569 for (tortoise = hare = XCDR (list), len = 1; | |
| 570 CONSP (hare); | |
| 571 hare = XCDR (hare), len++) | |
| 572 { | |
| 573 XCDR (last) = Fcons (XCAR (hare), XCDR (hare)); | |
| 574 last = XCDR (last); | |
| 575 | |
| 576 if (len < CIRCULAR_LIST_SUSPICION_LENGTH) | |
| 577 continue; | |
| 578 if (len & 1) | |
| 579 tortoise = XCDR (tortoise); | |
| 580 if (EQ (tortoise, hare)) | |
| 581 signal_circular_list_error (list); | |
| 582 } | |
| 583 | |
| 584 return list_copy; | |
| 585 } | |
| 586 | |
| 587 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /* | |
| 588 Return a copy of list LIST, which may be a dotted list. | |
| 589 The elements of LIST are not copied; they are shared | |
| 590 with the original. | |
| 591 */ | |
| 592 (list)) | |
| 593 { | |
| 594 again: | |
| 595 if (NILP (list)) return list; | |
| 596 if (CONSP (list)) return copy_list (list); | |
| 597 | |
| 598 list = wrong_type_argument (Qlistp, list); | |
| 599 goto again; | |
| 600 } | |
| 601 | |
| 602 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* | |
| 603 Return a copy of list, vector, bit vector or string SEQUENCE. | |
| 604 The elements of a list or vector are not copied; they are shared | |
| 605 with the original. SEQUENCE may be a dotted list. | |
| 606 */ | |
| 607 (sequence)) | |
| 608 { | |
| 609 again: | |
| 610 if (NILP (sequence)) return sequence; | |
| 611 if (CONSP (sequence)) return copy_list (sequence); | |
| 612 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0); | |
| 613 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0); | |
| 614 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0); | |
| 615 | |
| 616 check_losing_bytecode ("copy-sequence", sequence); | |
| 617 sequence = wrong_type_argument (Qsequencep, sequence); | |
| 618 goto again; | |
| 619 } | |
| 620 | |
| 621 struct merge_string_extents_struct | |
| 622 { | |
| 623 Lisp_Object string; | |
| 624 Bytecount entry_offset; | |
| 625 Bytecount entry_length; | |
| 626 }; | |
| 627 | |
| 628 static Lisp_Object | |
| 629 concat (int nargs, Lisp_Object *args, | |
| 630 enum concat_target_type target_type, | |
| 631 int last_special) | |
| 632 { | |
| 633 Lisp_Object val; | |
| 634 Lisp_Object tail = Qnil; | |
| 635 int toindex; | |
| 636 int argnum; | |
| 637 Lisp_Object last_tail; | |
| 638 Lisp_Object prev; | |
| 639 struct merge_string_extents_struct *args_mse = 0; | |
| 867 | 640 Ibyte *string_result = 0; |
| 641 Ibyte *string_result_ptr = 0; | |
| 428 | 642 struct gcpro gcpro1; |
| 851 | 643 int sdep = specpdl_depth (); |
| 428 | 644 |
| 645 /* The modus operandi in Emacs is "caller gc-protects args". | |
| 646 However, concat is called many times in Emacs on freshly | |
| 647 created stuff. So we help those callers out by protecting | |
| 648 the args ourselves to save them a lot of temporary-variable | |
| 649 grief. */ | |
| 650 | |
| 651 GCPRO1 (args[0]); | |
| 652 gcpro1.nvars = nargs; | |
| 653 | |
| 654 #ifdef I18N3 | |
| 655 /* #### if the result is a string and any of the strings have a string | |
| 656 for the `string-translatable' property, then concat should also | |
| 657 concat the args but use the `string-translatable' strings, and store | |
| 658 the result in the returned string's `string-translatable' property. */ | |
| 659 #endif | |
| 660 if (target_type == c_string) | |
| 661 args_mse = alloca_array (struct merge_string_extents_struct, nargs); | |
| 662 | |
| 663 /* In append, the last arg isn't treated like the others */ | |
| 664 if (last_special && nargs > 0) | |
| 665 { | |
| 666 nargs--; | |
| 667 last_tail = args[nargs]; | |
| 668 } | |
| 669 else | |
| 670 last_tail = Qnil; | |
| 671 | |
| 672 /* Check and coerce the arguments. */ | |
| 673 for (argnum = 0; argnum < nargs; argnum++) | |
| 674 { | |
| 675 Lisp_Object seq = args[argnum]; | |
| 676 if (LISTP (seq)) | |
| 677 ; | |
| 678 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq)) | |
| 679 ; | |
| 680 #ifdef LOSING_BYTECODE | |
| 681 else if (COMPILED_FUNCTIONP (seq)) | |
| 682 /* Urk! We allow this, for "compatibility"... */ | |
| 683 ; | |
| 684 #endif | |
| 685 #if 0 /* removed for XEmacs 21 */ | |
| 686 else if (INTP (seq)) | |
| 687 /* This is too revolting to think about but maintains | |
| 688 compatibility with FSF (and lots and lots of old code). */ | |
| 689 args[argnum] = Fnumber_to_string (seq); | |
| 690 #endif | |
| 691 else | |
| 692 { | |
| 693 check_losing_bytecode ("concat", seq); | |
| 694 args[argnum] = wrong_type_argument (Qsequencep, seq); | |
| 695 } | |
| 696 | |
| 697 if (args_mse) | |
| 698 { | |
| 699 if (STRINGP (seq)) | |
| 700 args_mse[argnum].string = seq; | |
| 701 else | |
| 702 args_mse[argnum].string = Qnil; | |
| 703 } | |
| 704 } | |
| 705 | |
| 706 { | |
| 707 /* Charcount is a misnomer here as we might be dealing with the | |
| 708 length of a vector or list, but emphasizes that we're not dealing | |
| 709 with Bytecounts in strings */ | |
| 710 Charcount total_length; | |
| 711 | |
| 712 for (argnum = 0, total_length = 0; argnum < nargs; argnum++) | |
| 713 { | |
| 714 #ifdef LOSING_BYTECODE | |
| 715 Charcount thislen = length_with_bytecode_hack (args[argnum]); | |
| 716 #else | |
| 717 Charcount thislen = XINT (Flength (args[argnum])); | |
| 718 #endif | |
| 719 total_length += thislen; | |
| 720 } | |
| 721 | |
| 722 switch (target_type) | |
| 723 { | |
| 724 case c_cons: | |
| 725 if (total_length == 0) | |
| 851 | 726 { |
| 727 unbind_to (sdep); | |
| 728 /* In append, if all but last arg are nil, return last arg */ | |
| 729 RETURN_UNGCPRO (last_tail); | |
| 730 } | |
| 428 | 731 val = Fmake_list (make_int (total_length), Qnil); |
| 732 break; | |
| 733 case c_vector: | |
| 734 val = make_vector (total_length, Qnil); | |
| 735 break; | |
| 736 case c_bit_vector: | |
| 737 val = make_bit_vector (total_length, Qzero); | |
| 738 break; | |
| 739 case c_string: | |
| 740 /* We don't make the string yet because we don't know the | |
| 741 actual number of bytes. This loop was formerly written | |
| 742 to call Fmake_string() here and then call set_string_char() | |
| 743 for each char. This seems logical enough but is waaaaaaaay | |
| 744 slow -- set_string_char() has to scan the whole string up | |
| 745 to the place where the substitution is called for in order | |
| 746 to find the place to change, and may have to do some | |
| 747 realloc()ing in order to make the char fit properly. | |
| 748 O(N^2) yuckage. */ | |
| 749 val = Qnil; | |
| 851 | 750 string_result = |
| 867 | 751 (Ibyte *) MALLOC_OR_ALLOCA (total_length * MAX_ICHAR_LEN); |
| 428 | 752 string_result_ptr = string_result; |
| 753 break; | |
| 754 default: | |
| 442 | 755 val = Qnil; |
| 2500 | 756 ABORT (); |
| 428 | 757 } |
| 758 } | |
| 759 | |
| 760 | |
| 761 if (CONSP (val)) | |
| 762 tail = val, toindex = -1; /* -1 in toindex is flag we are | |
| 763 making a list */ | |
| 764 else | |
| 765 toindex = 0; | |
| 766 | |
| 767 prev = Qnil; | |
| 768 | |
| 769 for (argnum = 0; argnum < nargs; argnum++) | |
| 770 { | |
| 771 Charcount thisleni = 0; | |
| 772 Charcount thisindex = 0; | |
| 773 Lisp_Object seq = args[argnum]; | |
| 867 | 774 Ibyte *string_source_ptr = 0; |
| 775 Ibyte *string_prev_result_ptr = string_result_ptr; | |
| 428 | 776 |
| 777 if (!CONSP (seq)) | |
| 778 { | |
| 779 #ifdef LOSING_BYTECODE | |
| 780 thisleni = length_with_bytecode_hack (seq); | |
| 781 #else | |
| 782 thisleni = XINT (Flength (seq)); | |
| 783 #endif | |
| 784 } | |
| 785 if (STRINGP (seq)) | |
| 786 string_source_ptr = XSTRING_DATA (seq); | |
| 787 | |
| 788 while (1) | |
| 789 { | |
| 790 Lisp_Object elt; | |
| 791 | |
| 792 /* We've come to the end of this arg, so exit. */ | |
| 793 if (NILP (seq)) | |
| 794 break; | |
| 795 | |
| 796 /* Fetch next element of `seq' arg into `elt' */ | |
| 797 if (CONSP (seq)) | |
| 798 { | |
| 799 elt = XCAR (seq); | |
| 800 seq = XCDR (seq); | |
| 801 } | |
| 802 else | |
| 803 { | |
| 804 if (thisindex >= thisleni) | |
| 805 break; | |
| 806 | |
| 807 if (STRINGP (seq)) | |
| 808 { | |
| 867 | 809 elt = make_char (itext_ichar (string_source_ptr)); |
| 810 INC_IBYTEPTR (string_source_ptr); | |
| 428 | 811 } |
| 812 else if (VECTORP (seq)) | |
| 813 elt = XVECTOR_DATA (seq)[thisindex]; | |
| 814 else if (BIT_VECTORP (seq)) | |
| 815 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq), | |
| 816 thisindex)); | |
| 817 else | |
| 818 elt = Felt (seq, make_int (thisindex)); | |
| 819 thisindex++; | |
| 820 } | |
| 821 | |
| 822 /* Store into result */ | |
| 823 if (toindex < 0) | |
| 824 { | |
| 825 /* toindex negative means we are making a list */ | |
| 826 XCAR (tail) = elt; | |
| 827 prev = tail; | |
| 828 tail = XCDR (tail); | |
| 829 } | |
| 830 else if (VECTORP (val)) | |
| 831 XVECTOR_DATA (val)[toindex++] = elt; | |
| 832 else if (BIT_VECTORP (val)) | |
| 833 { | |
| 834 CHECK_BIT (elt); | |
| 835 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt)); | |
| 836 } | |
| 837 else | |
| 838 { | |
| 839 CHECK_CHAR_COERCE_INT (elt); | |
| 867 | 840 string_result_ptr += set_itext_ichar (string_result_ptr, |
| 428 | 841 XCHAR (elt)); |
| 842 } | |
| 843 } | |
| 844 if (args_mse) | |
| 845 { | |
| 846 args_mse[argnum].entry_offset = | |
| 847 string_prev_result_ptr - string_result; | |
| 848 args_mse[argnum].entry_length = | |
| 849 string_result_ptr - string_prev_result_ptr; | |
| 850 } | |
| 851 } | |
| 852 | |
| 853 /* Now we finally make the string. */ | |
| 854 if (target_type == c_string) | |
| 855 { | |
| 856 val = make_string (string_result, string_result_ptr - string_result); | |
| 857 for (argnum = 0; argnum < nargs; argnum++) | |
| 858 { | |
| 859 if (STRINGP (args_mse[argnum].string)) | |
| 860 copy_string_extents (val, args_mse[argnum].string, | |
| 861 args_mse[argnum].entry_offset, 0, | |
| 862 args_mse[argnum].entry_length); | |
| 863 } | |
| 864 } | |
| 865 | |
| 866 if (!NILP (prev)) | |
| 867 XCDR (prev) = last_tail; | |
| 868 | |
| 851 | 869 unbind_to (sdep); |
| 428 | 870 RETURN_UNGCPRO (val); |
| 871 } | |
| 872 | |
| 873 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /* | |
| 874 Return a copy of ALIST. | |
| 875 This is an alist which represents the same mapping from objects to objects, | |
| 876 but does not share the alist structure with ALIST. | |
| 877 The objects mapped (cars and cdrs of elements of the alist) | |
| 878 are shared, however. | |
| 879 Elements of ALIST that are not conses are also shared. | |
| 880 */ | |
| 881 (alist)) | |
| 882 { | |
| 883 Lisp_Object tail; | |
| 884 | |
| 885 if (NILP (alist)) | |
| 886 return alist; | |
| 887 CHECK_CONS (alist); | |
| 888 | |
| 889 alist = concat (1, &alist, c_cons, 0); | |
| 890 for (tail = alist; CONSP (tail); tail = XCDR (tail)) | |
| 891 { | |
| 892 Lisp_Object car = XCAR (tail); | |
| 893 | |
| 894 if (CONSP (car)) | |
| 895 XCAR (tail) = Fcons (XCAR (car), XCDR (car)); | |
| 896 } | |
| 897 return alist; | |
| 898 } | |
| 899 | |
| 900 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /* | |
| 901 Return a copy of a list and substructures. | |
| 902 The argument is copied, and any lists contained within it are copied | |
| 903 recursively. Circularities and shared substructures are not preserved. | |
| 904 Second arg VECP causes vectors to be copied, too. Strings and bit vectors | |
| 905 are not copied. | |
| 906 */ | |
| 907 (arg, vecp)) | |
| 908 { | |
| 454 | 909 return safe_copy_tree (arg, vecp, 0); |
| 910 } | |
| 911 | |
| 912 Lisp_Object | |
| 913 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth) | |
| 914 { | |
| 915 if (depth > 200) | |
| 563 | 916 stack_overflow ("Stack overflow in copy-tree", arg); |
| 454 | 917 |
| 428 | 918 if (CONSP (arg)) |
| 919 { | |
| 920 Lisp_Object rest; | |
| 921 rest = arg = Fcopy_sequence (arg); | |
| 922 while (CONSP (rest)) | |
| 923 { | |
| 924 Lisp_Object elt = XCAR (rest); | |
| 925 QUIT; | |
| 926 if (CONSP (elt) || VECTORP (elt)) | |
| 454 | 927 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1); |
| 428 | 928 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */ |
| 454 | 929 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1); |
| 428 | 930 rest = XCDR (rest); |
| 931 } | |
| 932 } | |
| 933 else if (VECTORP (arg) && ! NILP (vecp)) | |
| 934 { | |
| 935 int i = XVECTOR_LENGTH (arg); | |
| 936 int j; | |
| 937 arg = Fcopy_sequence (arg); | |
| 938 for (j = 0; j < i; j++) | |
| 939 { | |
| 940 Lisp_Object elt = XVECTOR_DATA (arg) [j]; | |
| 941 QUIT; | |
| 942 if (CONSP (elt) || VECTORP (elt)) | |
| 454 | 943 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1); |
| 428 | 944 } |
| 945 } | |
| 946 return arg; | |
| 947 } | |
| 948 | |
| 949 DEFUN ("substring", Fsubstring, 2, 3, 0, /* | |
| 444 | 950 Return the substring of STRING starting at START and ending before END. |
| 951 END may be nil or omitted; then the substring runs to the end of STRING. | |
| 952 If START or END is negative, it counts from the end. | |
| 953 Relevant parts of the string-extent-data are copied to the new string. | |
| 428 | 954 */ |
| 444 | 955 (string, start, end)) |
| 428 | 956 { |
| 444 | 957 Charcount ccstart, ccend; |
| 958 Bytecount bstart, blen; | |
| 428 | 959 Lisp_Object val; |
| 960 | |
| 961 CHECK_STRING (string); | |
| 444 | 962 CHECK_INT (start); |
| 963 get_string_range_char (string, start, end, &ccstart, &ccend, | |
| 428 | 964 GB_HISTORICAL_STRING_BEHAVIOR); |
| 793 | 965 bstart = string_index_char_to_byte (string, ccstart); |
| 966 blen = string_offset_char_to_byte_len (string, bstart, ccend - ccstart); | |
| 444 | 967 val = make_string (XSTRING_DATA (string) + bstart, blen); |
| 968 /* Copy any applicable extent information into the new string. */ | |
| 969 copy_string_extents (val, string, 0, bstart, blen); | |
| 428 | 970 return val; |
| 971 } | |
| 972 | |
| 973 DEFUN ("subseq", Fsubseq, 2, 3, 0, /* | |
| 442 | 974 Return the subsequence of SEQUENCE starting at START and ending before END. |
| 975 END may be omitted; then the subsequence runs to the end of SEQUENCE. | |
| 976 If START or END is negative, it counts from the end. | |
| 977 The returned subsequence is always of the same type as SEQUENCE. | |
| 978 If SEQUENCE is a string, relevant parts of the string-extent-data | |
| 979 are copied to the new string. | |
| 428 | 980 */ |
| 442 | 981 (sequence, start, end)) |
| 428 | 982 { |
| 442 | 983 EMACS_INT len, s, e; |
| 984 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
985 CHECK_SEQUENCE (sequence); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
986 |
| 442 | 987 if (STRINGP (sequence)) |
| 988 return Fsubstring (sequence, start, end); | |
| 989 | |
| 990 len = XINT (Flength (sequence)); | |
| 991 | |
| 992 CHECK_INT (start); | |
| 993 s = XINT (start); | |
| 994 if (s < 0) | |
| 995 s = len + s; | |
| 996 | |
| 997 if (NILP (end)) | |
| 998 e = len; | |
| 428 | 999 else |
| 1000 { | |
| 442 | 1001 CHECK_INT (end); |
| 1002 e = XINT (end); | |
| 1003 if (e < 0) | |
| 1004 e = len + e; | |
| 428 | 1005 } |
| 1006 | |
| 442 | 1007 if (!(0 <= s && s <= e && e <= len)) |
| 1008 args_out_of_range_3 (sequence, make_int (s), make_int (e)); | |
| 1009 | |
| 1010 if (VECTORP (sequence)) | |
| 428 | 1011 { |
| 442 | 1012 Lisp_Object result = make_vector (e - s, Qnil); |
| 428 | 1013 EMACS_INT i; |
| 442 | 1014 Lisp_Object *in_elts = XVECTOR_DATA (sequence); |
| 428 | 1015 Lisp_Object *out_elts = XVECTOR_DATA (result); |
| 1016 | |
| 442 | 1017 for (i = s; i < e; i++) |
| 1018 out_elts[i - s] = in_elts[i]; | |
| 428 | 1019 return result; |
| 1020 } | |
| 442 | 1021 else if (LISTP (sequence)) |
| 428 | 1022 { |
| 1023 Lisp_Object result = Qnil; | |
| 1024 EMACS_INT i; | |
| 1025 | |
| 442 | 1026 sequence = Fnthcdr (make_int (s), sequence); |
| 1027 | |
| 1028 for (i = s; i < e; i++) | |
| 428 | 1029 { |
| 442 | 1030 result = Fcons (Fcar (sequence), result); |
| 1031 sequence = Fcdr (sequence); | |
| 428 | 1032 } |
| 1033 | |
| 1034 return Fnreverse (result); | |
| 1035 } | |
| 442 | 1036 else if (BIT_VECTORP (sequence)) |
| 1037 { | |
| 1038 Lisp_Object result = make_bit_vector (e - s, Qzero); | |
| 1039 EMACS_INT i; | |
| 1040 | |
| 1041 for (i = s; i < e; i++) | |
| 1042 set_bit_vector_bit (XBIT_VECTOR (result), i - s, | |
| 1043 bit_vector_bit (XBIT_VECTOR (sequence), i)); | |
| 1044 return result; | |
| 1045 } | |
| 1046 else | |
| 1047 { | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
1048 ABORT (); /* unreachable, since CHECK_SEQUENCE (sequence) did not |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
1049 error */ |
| 442 | 1050 return Qnil; |
| 1051 } | |
| 428 | 1052 } |
| 1053 | |
| 771 | 1054 /* Split STRING into a list of substrings. The substrings are the |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1055 parts of original STRING separated by SEPCHAR. |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1056 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1057 If UNESCAPE is non-zero, ESCAPECHAR specifies a character that will quote |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1058 SEPCHAR, and cause it not to split STRING. A double ESCAPECHAR is |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1059 necessary for ESCAPECHAR to appear once in a substring. */ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1060 |
| 771 | 1061 static Lisp_Object |
| 867 | 1062 split_string_by_ichar_1 (const Ibyte *string, Bytecount size, |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1063 Ichar sepchar, int unescape, Ichar escapechar) |
| 771 | 1064 { |
| 1065 Lisp_Object result = Qnil; | |
| 867 | 1066 const Ibyte *end = string + size; |
| 771 | 1067 |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1068 if (unescape) |
| 771 | 1069 { |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1070 Ibyte unescape_buffer[64], *unescape_buffer_ptr = unescape_buffer, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1071 escaped[MAX_ICHAR_LEN], *unescape_cursor; |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1072 Bytecount unescape_buffer_size = countof (unescape_buffer), |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1073 escaped_len = set_itext_ichar (escaped, escapechar); |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1074 Boolint deleting_escapes, previous_escaped; |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1075 Ichar pchar; |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1076 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1077 while (1) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1078 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1079 const Ibyte *p = string, *cursor; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1080 deleting_escapes = 0; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1081 previous_escaped = 0; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1082 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1083 while (p < end) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1084 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1085 pchar = itext_ichar (p); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1086 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1087 if (pchar == sepchar) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1088 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1089 if (!previous_escaped) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1090 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1091 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1092 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1093 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1094 else if (pchar == escapechar |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1095 /* Doubled escapes don't escape: */ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1096 && !previous_escaped) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1097 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1098 ++deleting_escapes; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1099 previous_escaped = 1; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1100 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1101 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1102 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1103 previous_escaped = 0; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1104 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1105 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1106 INC_IBYTEPTR (p); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1107 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1108 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1109 if (deleting_escapes) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1110 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1111 if (((p - string) - (escaped_len * deleting_escapes)) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1112 > unescape_buffer_size) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1113 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1114 unescape_buffer_size = |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1115 ((p - string) - (escaped_len * deleting_escapes)) * 1.5; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1116 unescape_buffer_ptr = alloca_ibytes (unescape_buffer_size); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1117 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1118 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1119 cursor = string; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1120 unescape_cursor = unescape_buffer_ptr; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1121 previous_escaped = 0; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1122 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1123 while (cursor < p) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1124 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1125 pchar = itext_ichar (cursor); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1126 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1127 if (pchar != escapechar || previous_escaped) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1128 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1129 memcpy (unescape_cursor, cursor, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1130 itext_ichar_len (cursor)); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1131 INC_IBYTEPTR (unescape_cursor); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1132 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1133 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1134 previous_escaped = !previous_escaped |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1135 && (pchar == escapechar); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1136 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1137 INC_IBYTEPTR (cursor); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1138 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1139 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1140 result = Fcons (make_string (unescape_buffer_ptr, |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1141 unescape_cursor |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1142 - unescape_buffer_ptr), |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1143 result); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1144 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1145 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1146 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1147 result = Fcons (make_string (string, p - string), result); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1148 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1149 if (p < end) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1150 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1151 string = p; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1152 INC_IBYTEPTR (string); /* skip sepchar */ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1153 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1154 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1155 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1156 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1157 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1158 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1159 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1160 while (1) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1161 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1162 const Ibyte *p = string; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1163 while (p < end) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1164 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1165 if (itext_ichar (p) == sepchar) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1166 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1167 INC_IBYTEPTR (p); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1168 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1169 result = Fcons (make_string (string, p - string), result); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1170 if (p < end) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1171 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1172 string = p; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1173 INC_IBYTEPTR (string); /* skip sepchar */ |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1174 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1175 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1176 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1177 } |
| 771 | 1178 } |
| 1179 return Fnreverse (result); | |
| 1180 } | |
| 1181 | |
| 1182 /* The same as the above, except PATH is an external C string (it is | |
| 1183 converted using Qfile_name), and sepchar is hardcoded to SEPCHAR | |
| 1184 (':' or whatever). */ | |
| 1185 Lisp_Object | |
| 1186 split_external_path (const Extbyte *path) | |
| 1187 { | |
| 1188 Bytecount newlen; | |
| 867 | 1189 Ibyte *newpath; |
| 771 | 1190 if (!path) |
| 1191 return Qnil; | |
| 1192 | |
| 1193 TO_INTERNAL_FORMAT (C_STRING, path, ALLOCA, (newpath, newlen), Qfile_name); | |
| 1194 | |
| 1195 /* #### Does this make sense? It certainly does for | |
| 1196 split_env_path(), but it looks dubious here. Does any code | |
| 1197 depend on split_external_path("") returning nil instead of an empty | |
| 1198 string? */ | |
| 1199 if (!newlen) | |
| 1200 return Qnil; | |
| 1201 | |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1202 return split_string_by_ichar_1 (newpath, newlen, SEPCHAR, 0, 0); |
| 771 | 1203 } |
| 1204 | |
| 1205 Lisp_Object | |
| 867 | 1206 split_env_path (const CIbyte *evarname, const Ibyte *default_) |
| 771 | 1207 { |
| 867 | 1208 const Ibyte *path = 0; |
| 771 | 1209 if (evarname) |
| 1210 path = egetenv (evarname); | |
| 1211 if (!path) | |
| 1212 path = default_; | |
| 1213 if (!path) | |
| 1214 return Qnil; | |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1215 return split_string_by_ichar_1 (path, qxestrlen (path), SEPCHAR, 0, 0); |
| 771 | 1216 } |
| 1217 | |
| 1218 /* Ben thinks this function should not exist or be exported to Lisp. | |
| 1219 We use it to define split-path-string in subr.el (not!). */ | |
| 1220 | |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1221 DEFUN ("split-string-by-char", Fsplit_string_by_char, 2, 3, 0, /* |
| 771 | 1222 Split STRING into a list of substrings originally separated by SEPCHAR. |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1223 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1224 With optional ESCAPE-CHAR, any instances of SEPCHAR preceded by that |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1225 character will not split the string, and a double instance of ESCAPE-CHAR |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1226 will be necessary for a single ESCAPE-CHAR to appear in the output string. |
| 771 | 1227 */ |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1228 (string, sepchar, escape_char)) |
| 771 | 1229 { |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1230 Ichar escape_ichar = 0; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1231 |
| 771 | 1232 CHECK_STRING (string); |
| 1233 CHECK_CHAR (sepchar); | |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1234 if (!NILP (escape_char)) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1235 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1236 CHECK_CHAR (escape_char); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1237 escape_ichar = XCHAR (escape_char); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1238 } |
| 867 | 1239 return split_string_by_ichar_1 (XSTRING_DATA (string), |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1240 XSTRING_LENGTH (string), |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1241 XCHAR (sepchar), |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1242 !NILP (escape_char), escape_ichar); |
| 771 | 1243 } |
| 1244 | |
| 1245 /* #### This was supposed to be in subr.el, but is used VERY early in | |
| 1246 the bootstrap process, so it goes here. Damn. */ | |
| 1247 | |
| 1248 DEFUN ("split-path", Fsplit_path, 1, 1, 0, /* | |
| 1249 Explode a search path into a list of strings. | |
| 1250 The path components are separated with the characters specified | |
| 1251 with `path-separator'. | |
| 1252 */ | |
| 1253 (path)) | |
| 1254 { | |
| 1255 CHECK_STRING (path); | |
| 1256 | |
| 1257 while (!STRINGP (Vpath_separator) | |
| 826 | 1258 || (string_char_length (Vpath_separator) != 1)) |
| 771 | 1259 Vpath_separator = signal_continuable_error |
| 1260 (Qinvalid_state, | |
| 1261 "`path-separator' should be set to a single-character string", | |
| 1262 Vpath_separator); | |
| 1263 | |
| 867 | 1264 return (split_string_by_ichar_1 |
| 771 | 1265 (XSTRING_DATA (path), XSTRING_LENGTH (path), |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1266 itext_ichar (XSTRING_DATA (Vpath_separator)), 0, 0)); |
| 771 | 1267 } |
| 1268 | |
| 428 | 1269 |
| 1270 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /* | |
| 1271 Take cdr N times on LIST, and return the result. | |
| 1272 */ | |
| 1273 (n, list)) | |
| 1274 { | |
| 1920 | 1275 /* This function can GC */ |
| 647 | 1276 REGISTER EMACS_INT i; |
| 428 | 1277 REGISTER Lisp_Object tail = list; |
| 1278 CHECK_NATNUM (n); | |
| 1279 for (i = XINT (n); i; i--) | |
| 1280 { | |
| 1281 if (CONSP (tail)) | |
| 1282 tail = XCDR (tail); | |
| 1283 else if (NILP (tail)) | |
| 1284 return Qnil; | |
| 1285 else | |
| 1286 { | |
| 1287 tail = wrong_type_argument (Qlistp, tail); | |
| 1288 i++; | |
| 1289 } | |
| 1290 } | |
| 1291 return tail; | |
| 1292 } | |
| 1293 | |
| 1294 DEFUN ("nth", Fnth, 2, 2, 0, /* | |
| 1295 Return the Nth element of LIST. | |
| 1296 N counts from zero. If LIST is not that long, nil is returned. | |
| 1297 */ | |
| 1298 (n, list)) | |
| 1299 { | |
| 1920 | 1300 /* This function can GC */ |
| 428 | 1301 return Fcar (Fnthcdr (n, list)); |
| 1302 } | |
| 1303 | |
| 1304 DEFUN ("elt", Felt, 2, 2, 0, /* | |
| 1305 Return element of SEQUENCE at index N. | |
| 1306 */ | |
| 1307 (sequence, n)) | |
| 1308 { | |
| 1920 | 1309 /* This function can GC */ |
| 428 | 1310 retry: |
| 1311 CHECK_INT_COERCE_CHAR (n); /* yuck! */ | |
| 1312 if (LISTP (sequence)) | |
| 1313 { | |
| 1314 Lisp_Object tem = Fnthcdr (n, sequence); | |
| 1315 /* #### Utterly, completely, fucking disgusting. | |
| 1316 * #### The whole point of "elt" is that it operates on | |
| 1317 * #### sequences, and does error- (bounds-) checking. | |
| 1318 */ | |
| 1319 if (CONSP (tem)) | |
| 1320 return XCAR (tem); | |
| 1321 else | |
| 1322 #if 1 | |
| 1323 /* This is The Way It Has Always Been. */ | |
| 1324 return Qnil; | |
| 1325 #else | |
| 1326 /* This is The Way Mly and Cltl2 say It Should Be. */ | |
| 1327 args_out_of_range (sequence, n); | |
| 1328 #endif | |
| 1329 } | |
| 1330 else if (STRINGP (sequence) || | |
| 1331 VECTORP (sequence) || | |
| 1332 BIT_VECTORP (sequence)) | |
| 1333 return Faref (sequence, n); | |
| 1334 #ifdef LOSING_BYTECODE | |
| 1335 else if (COMPILED_FUNCTIONP (sequence)) | |
| 1336 { | |
| 1337 EMACS_INT idx = XINT (n); | |
| 1338 if (idx < 0) | |
| 1339 { | |
| 1340 lose: | |
| 1341 args_out_of_range (sequence, n); | |
| 1342 } | |
| 1343 /* Utter perversity */ | |
| 1344 { | |
| 1345 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence); | |
| 1346 switch (idx) | |
| 1347 { | |
| 1348 case COMPILED_ARGLIST: | |
| 1349 return compiled_function_arglist (f); | |
| 1350 case COMPILED_INSTRUCTIONS: | |
| 1351 return compiled_function_instructions (f); | |
| 1352 case COMPILED_CONSTANTS: | |
| 1353 return compiled_function_constants (f); | |
| 1354 case COMPILED_STACK_DEPTH: | |
| 1355 return compiled_function_stack_depth (f); | |
| 1356 case COMPILED_DOC_STRING: | |
| 1357 return compiled_function_documentation (f); | |
| 1358 case COMPILED_DOMAIN: | |
| 1359 return compiled_function_domain (f); | |
| 1360 case COMPILED_INTERACTIVE: | |
| 1361 if (f->flags.interactivep) | |
| 1362 return compiled_function_interactive (f); | |
| 1363 /* if we return nil, can't tell interactive with no args | |
| 1364 from noninteractive. */ | |
| 1365 goto lose; | |
| 1366 default: | |
| 1367 goto lose; | |
| 1368 } | |
| 1369 } | |
| 1370 } | |
| 1371 #endif /* LOSING_BYTECODE */ | |
| 1372 else | |
| 1373 { | |
| 1374 check_losing_bytecode ("elt", sequence); | |
| 1375 sequence = wrong_type_argument (Qsequencep, sequence); | |
| 1376 goto retry; | |
| 1377 } | |
| 1378 } | |
| 1379 | |
| 1380 DEFUN ("last", Flast, 1, 2, 0, /* | |
| 1381 Return the tail of list LIST, of length N (default 1). | |
| 1382 LIST may be a dotted list, but not a circular list. | |
| 1383 Optional argument N must be a non-negative integer. | |
| 1384 If N is zero, then the atom that terminates the list is returned. | |
| 1385 If N is greater than the length of LIST, then LIST itself is returned. | |
| 1386 */ | |
| 1387 (list, n)) | |
| 1388 { | |
| 1389 EMACS_INT int_n, count; | |
| 1390 Lisp_Object retval, tortoise, hare; | |
| 1391 | |
| 1392 CHECK_LIST (list); | |
| 1393 | |
| 1394 if (NILP (n)) | |
| 1395 int_n = 1; | |
| 1396 else | |
| 1397 { | |
| 1398 CHECK_NATNUM (n); | |
| 1399 int_n = XINT (n); | |
| 1400 } | |
| 1401 | |
| 1402 for (retval = tortoise = hare = list, count = 0; | |
| 1403 CONSP (hare); | |
| 1404 hare = XCDR (hare), | |
| 1405 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0), | |
| 1406 count++) | |
| 1407 { | |
| 1408 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 1409 | |
| 1410 if (count & 1) | |
| 1411 tortoise = XCDR (tortoise); | |
| 1412 if (EQ (hare, tortoise)) | |
| 1413 signal_circular_list_error (list); | |
| 1414 } | |
| 1415 | |
| 1416 return retval; | |
| 1417 } | |
| 1418 | |
| 1419 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* | |
| 1420 Modify LIST to remove the last N (default 1) elements. | |
| 1421 If LIST has N or fewer elements, nil is returned and LIST is unmodified. | |
| 1422 */ | |
| 1423 (list, n)) | |
| 1424 { | |
| 1425 EMACS_INT int_n; | |
| 1426 | |
| 1427 CHECK_LIST (list); | |
| 1428 | |
| 1429 if (NILP (n)) | |
| 1430 int_n = 1; | |
| 1431 else | |
| 1432 { | |
| 1433 CHECK_NATNUM (n); | |
| 1434 int_n = XINT (n); | |
| 1435 } | |
| 1436 | |
| 1437 { | |
| 1438 Lisp_Object last_cons = list; | |
| 1439 | |
| 1440 EXTERNAL_LIST_LOOP_1 (list) | |
| 1441 { | |
| 1442 if (int_n-- < 0) | |
| 1443 last_cons = XCDR (last_cons); | |
| 1444 } | |
| 1445 | |
| 1446 if (int_n >= 0) | |
| 1447 return Qnil; | |
| 1448 | |
| 1449 XCDR (last_cons) = Qnil; | |
| 1450 return list; | |
| 1451 } | |
| 1452 } | |
| 1453 | |
| 1454 DEFUN ("butlast", Fbutlast, 1, 2, 0, /* | |
| 1455 Return a copy of LIST with the last N (default 1) elements removed. | |
| 1456 If LIST has N or fewer elements, nil is returned. | |
| 1457 */ | |
| 1458 (list, n)) | |
| 1459 { | |
| 444 | 1460 EMACS_INT int_n; |
| 428 | 1461 |
| 1462 CHECK_LIST (list); | |
| 1463 | |
| 1464 if (NILP (n)) | |
| 1465 int_n = 1; | |
| 1466 else | |
| 1467 { | |
| 1468 CHECK_NATNUM (n); | |
| 1469 int_n = XINT (n); | |
| 1470 } | |
| 1471 | |
| 1472 { | |
| 1473 Lisp_Object retval = Qnil; | |
| 1474 Lisp_Object tail = list; | |
| 1475 | |
| 1476 EXTERNAL_LIST_LOOP_1 (list) | |
| 1477 { | |
| 1478 if (--int_n < 0) | |
| 1479 { | |
| 1480 retval = Fcons (XCAR (tail), retval); | |
| 1481 tail = XCDR (tail); | |
| 1482 } | |
| 1483 } | |
| 1484 | |
| 1485 return Fnreverse (retval); | |
| 1486 } | |
| 1487 } | |
| 1488 | |
| 1489 DEFUN ("member", Fmember, 2, 2, 0, /* | |
| 1490 Return non-nil if ELT is an element of LIST. Comparison done with `equal'. | |
| 1491 The value is actually the tail of LIST whose car is ELT. | |
| 1492 */ | |
| 1493 (elt, list)) | |
| 1494 { | |
| 1495 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1496 { | |
| 1497 if (internal_equal (elt, list_elt, 0)) | |
| 1498 return tail; | |
| 1499 } | |
| 1500 return Qnil; | |
| 1501 } | |
| 1502 | |
| 1503 DEFUN ("old-member", Fold_member, 2, 2, 0, /* | |
| 1504 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'. | |
| 1505 The value is actually the tail of LIST whose car is ELT. | |
| 1506 This function is provided only for byte-code compatibility with v19. | |
| 1507 Do not use it. | |
| 1508 */ | |
| 1509 (elt, list)) | |
| 1510 { | |
| 1511 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1512 { | |
| 1513 if (internal_old_equal (elt, list_elt, 0)) | |
| 1514 return tail; | |
| 1515 } | |
| 1516 return Qnil; | |
| 1517 } | |
| 1518 | |
| 1519 DEFUN ("memq", Fmemq, 2, 2, 0, /* | |
| 1520 Return non-nil if ELT is an element of LIST. Comparison done with `eq'. | |
| 1521 The value is actually the tail of LIST whose car is ELT. | |
| 1522 */ | |
| 1523 (elt, list)) | |
| 1524 { | |
| 1525 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1526 { | |
| 1527 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) | |
| 1528 return tail; | |
| 1529 } | |
| 1530 return Qnil; | |
| 1531 } | |
| 1532 | |
| 1533 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /* | |
| 1534 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'. | |
| 1535 The value is actually the tail of LIST whose car is ELT. | |
| 1536 This function is provided only for byte-code compatibility with v19. | |
| 1537 Do not use it. | |
| 1538 */ | |
| 1539 (elt, list)) | |
| 1540 { | |
| 1541 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1542 { | |
| 1543 if (HACKEQ_UNSAFE (elt, list_elt)) | |
| 1544 return tail; | |
| 1545 } | |
| 1546 return Qnil; | |
| 1547 } | |
| 1548 | |
| 1549 Lisp_Object | |
| 1550 memq_no_quit (Lisp_Object elt, Lisp_Object list) | |
| 1551 { | |
| 1552 LIST_LOOP_3 (list_elt, list, tail) | |
| 1553 { | |
| 1554 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) | |
| 1555 return tail; | |
| 1556 } | |
| 1557 return Qnil; | |
| 1558 } | |
| 1559 | |
| 1560 DEFUN ("assoc", Fassoc, 2, 2, 0, /* | |
| 444 | 1561 Return non-nil if KEY is `equal' to the car of an element of ALIST. |
| 1562 The value is actually the element of ALIST whose car equals KEY. | |
| 428 | 1563 */ |
| 444 | 1564 (key, alist)) |
| 428 | 1565 { |
| 1566 /* This function can GC. */ | |
| 444 | 1567 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1568 { |
| 1569 if (internal_equal (key, elt_car, 0)) | |
| 1570 return elt; | |
| 1571 } | |
| 1572 return Qnil; | |
| 1573 } | |
| 1574 | |
| 1575 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /* | |
| 444 | 1576 Return non-nil if KEY is `old-equal' to the car of an element of ALIST. |
| 1577 The value is actually the element of ALIST whose car equals KEY. | |
| 428 | 1578 */ |
| 444 | 1579 (key, alist)) |
| 428 | 1580 { |
| 1581 /* This function can GC. */ | |
| 444 | 1582 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1583 { |
| 1584 if (internal_old_equal (key, elt_car, 0)) | |
| 1585 return elt; | |
| 1586 } | |
| 1587 return Qnil; | |
| 1588 } | |
| 1589 | |
| 1590 Lisp_Object | |
| 444 | 1591 assoc_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1592 { |
| 1593 int speccount = specpdl_depth (); | |
| 1594 specbind (Qinhibit_quit, Qt); | |
| 771 | 1595 return unbind_to_1 (speccount, Fassoc (key, alist)); |
| 428 | 1596 } |
| 1597 | |
| 1598 DEFUN ("assq", Fassq, 2, 2, 0, /* | |
| 444 | 1599 Return non-nil if KEY is `eq' to the car of an element of ALIST. |
| 1600 The value is actually the element of ALIST whose car is KEY. | |
| 1601 Elements of ALIST that are not conses are ignored. | |
| 428 | 1602 */ |
| 444 | 1603 (key, alist)) |
| 428 | 1604 { |
| 444 | 1605 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1606 { |
| 1607 if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) | |
| 1608 return elt; | |
| 1609 } | |
| 1610 return Qnil; | |
| 1611 } | |
| 1612 | |
| 1613 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /* | |
| 444 | 1614 Return non-nil if KEY is `old-eq' to the car of an element of ALIST. |
| 1615 The value is actually the element of ALIST whose car is KEY. | |
| 1616 Elements of ALIST that are not conses are ignored. | |
| 428 | 1617 This function is provided only for byte-code compatibility with v19. |
| 1618 Do not use it. | |
| 1619 */ | |
| 444 | 1620 (key, alist)) |
| 428 | 1621 { |
| 444 | 1622 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1623 { |
| 1624 if (HACKEQ_UNSAFE (key, elt_car)) | |
| 1625 return elt; | |
| 1626 } | |
| 1627 return Qnil; | |
| 1628 } | |
| 1629 | |
| 1630 /* Like Fassq but never report an error and do not allow quits. | |
| 1631 Use only on lists known never to be circular. */ | |
| 1632 | |
| 1633 Lisp_Object | |
| 444 | 1634 assq_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1635 { |
| 1636 /* This cannot GC. */ | |
| 444 | 1637 LIST_LOOP_2 (elt, alist) |
| 428 | 1638 { |
| 1639 Lisp_Object elt_car = XCAR (elt); | |
| 1640 if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) | |
| 1641 return elt; | |
| 1642 } | |
| 1643 return Qnil; | |
| 1644 } | |
| 1645 | |
| 1646 DEFUN ("rassoc", Frassoc, 2, 2, 0, /* | |
| 444 | 1647 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST. |
| 1648 The value is actually the element of ALIST whose cdr equals VALUE. | |
| 428 | 1649 */ |
| 444 | 1650 (value, alist)) |
| 428 | 1651 { |
| 444 | 1652 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1653 { |
| 444 | 1654 if (internal_equal (value, elt_cdr, 0)) |
| 428 | 1655 return elt; |
| 1656 } | |
| 1657 return Qnil; | |
| 1658 } | |
| 1659 | |
| 1660 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* | |
| 444 | 1661 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. |
| 1662 The value is actually the element of ALIST whose cdr equals VALUE. | |
| 428 | 1663 */ |
| 444 | 1664 (value, alist)) |
| 428 | 1665 { |
| 444 | 1666 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1667 { |
| 444 | 1668 if (internal_old_equal (value, elt_cdr, 0)) |
| 428 | 1669 return elt; |
| 1670 } | |
| 1671 return Qnil; | |
| 1672 } | |
| 1673 | |
| 1674 DEFUN ("rassq", Frassq, 2, 2, 0, /* | |
| 444 | 1675 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST. |
| 1676 The value is actually the element of ALIST whose cdr is VALUE. | |
| 428 | 1677 */ |
| 444 | 1678 (value, alist)) |
| 428 | 1679 { |
| 444 | 1680 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1681 { |
| 444 | 1682 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) |
| 428 | 1683 return elt; |
| 1684 } | |
| 1685 return Qnil; | |
| 1686 } | |
| 1687 | |
| 1688 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* | |
| 444 | 1689 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST. |
| 1690 The value is actually the element of ALIST whose cdr is VALUE. | |
| 428 | 1691 */ |
| 444 | 1692 (value, alist)) |
| 428 | 1693 { |
| 444 | 1694 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1695 { |
| 444 | 1696 if (HACKEQ_UNSAFE (value, elt_cdr)) |
| 428 | 1697 return elt; |
| 1698 } | |
| 1699 return Qnil; | |
| 1700 } | |
| 1701 | |
| 444 | 1702 /* Like Frassq, but caller must ensure that ALIST is properly |
| 428 | 1703 nil-terminated and ebola-free. */ |
| 1704 Lisp_Object | |
| 444 | 1705 rassq_no_quit (Lisp_Object value, Lisp_Object alist) |
| 428 | 1706 { |
| 444 | 1707 LIST_LOOP_2 (elt, alist) |
| 428 | 1708 { |
| 1709 Lisp_Object elt_cdr = XCDR (elt); | |
| 444 | 1710 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) |
| 428 | 1711 return elt; |
| 1712 } | |
| 1713 return Qnil; | |
| 1714 } | |
| 1715 | |
| 1716 | |
| 1717 DEFUN ("delete", Fdelete, 2, 2, 0, /* | |
| 1718 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1719 The modified LIST is returned. Comparison is done with `equal'. | |
| 1720 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1721 effect; therefore, write `(setq foo (delete element foo))' to be sure | |
| 1722 of changing the value of `foo'. | |
| 1723 Also see: `remove'. | |
| 1724 */ | |
| 1725 (elt, list)) | |
| 1726 { | |
| 1727 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1728 (internal_equal (elt, list_elt, 0))); | |
| 1729 return list; | |
| 1730 } | |
| 1731 | |
| 1732 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /* | |
| 1733 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1734 The modified LIST is returned. Comparison is done with `old-equal'. | |
| 1735 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1736 effect; therefore, write `(setq foo (old-delete element foo))' to be sure | |
| 1737 of changing the value of `foo'. | |
| 1738 */ | |
| 1739 (elt, list)) | |
| 1740 { | |
| 1741 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1742 (internal_old_equal (elt, list_elt, 0))); | |
| 1743 return list; | |
| 1744 } | |
| 1745 | |
| 1746 DEFUN ("delq", Fdelq, 2, 2, 0, /* | |
| 1747 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1748 The modified LIST is returned. Comparison is done with `eq'. | |
| 1749 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1750 effect; therefore, write `(setq foo (delq element foo))' to be sure of | |
| 1751 changing the value of `foo'. | |
| 1752 */ | |
| 1753 (elt, list)) | |
| 1754 { | |
| 1755 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1756 (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); | |
| 1757 return list; | |
| 1758 } | |
| 1759 | |
| 1760 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /* | |
| 1761 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1762 The modified LIST is returned. Comparison is done with `old-eq'. | |
| 1763 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1764 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of | |
| 1765 changing the value of `foo'. | |
| 1766 */ | |
| 1767 (elt, list)) | |
| 1768 { | |
| 1769 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1770 (HACKEQ_UNSAFE (elt, list_elt))); | |
| 1771 return list; | |
| 1772 } | |
| 1773 | |
| 1774 /* Like Fdelq, but caller must ensure that LIST is properly | |
| 1775 nil-terminated and ebola-free. */ | |
| 1776 | |
| 1777 Lisp_Object | |
| 1778 delq_no_quit (Lisp_Object elt, Lisp_Object list) | |
| 1779 { | |
| 1780 LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1781 (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); | |
| 1782 return list; | |
| 1783 } | |
| 1784 | |
| 1785 /* Be VERY careful with this. This is like delq_no_quit() but | |
| 1786 also calls free_cons() on the removed conses. You must be SURE | |
| 1787 that no pointers to the freed conses remain around (e.g. | |
| 1788 someone else is pointing to part of the list). This function | |
| 1789 is useful on internal lists that are used frequently and where | |
| 1790 the actual list doesn't escape beyond known code bounds. */ | |
| 1791 | |
| 1792 Lisp_Object | |
| 1793 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) | |
| 1794 { | |
| 1795 REGISTER Lisp_Object tail = list; | |
| 1796 REGISTER Lisp_Object prev = Qnil; | |
| 1797 | |
| 1798 while (!NILP (tail)) | |
| 1799 { | |
| 1800 REGISTER Lisp_Object tem = XCAR (tail); | |
| 1801 if (EQ (elt, tem)) | |
| 1802 { | |
| 1803 Lisp_Object cons_to_free = tail; | |
| 1804 if (NILP (prev)) | |
| 1805 list = XCDR (tail); | |
| 1806 else | |
| 1807 XCDR (prev) = XCDR (tail); | |
| 1808 tail = XCDR (tail); | |
| 853 | 1809 free_cons (cons_to_free); |
| 428 | 1810 } |
| 1811 else | |
| 1812 { | |
| 1813 prev = tail; | |
| 1814 tail = XCDR (tail); | |
| 1815 } | |
| 1816 } | |
| 1817 return list; | |
| 1818 } | |
| 1819 | |
| 1820 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /* | |
| 444 | 1821 Delete by side effect any elements of ALIST whose car is `equal' to KEY. |
| 1822 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1823 that is `equal' to KEY, there is no way to remove it by side effect; |
| 1824 therefore, write `(setq foo (remassoc key foo))' to be sure of changing | |
| 1825 the value of `foo'. | |
| 1826 */ | |
| 444 | 1827 (key, alist)) |
| 428 | 1828 { |
| 444 | 1829 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1830 (CONSP (elt) && |
| 1831 internal_equal (key, XCAR (elt), 0))); | |
| 444 | 1832 return alist; |
| 428 | 1833 } |
| 1834 | |
| 1835 Lisp_Object | |
| 444 | 1836 remassoc_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1837 { |
| 1838 int speccount = specpdl_depth (); | |
| 1839 specbind (Qinhibit_quit, Qt); | |
| 771 | 1840 return unbind_to_1 (speccount, Fremassoc (key, alist)); |
| 428 | 1841 } |
| 1842 | |
| 1843 DEFUN ("remassq", Fremassq, 2, 2, 0, /* | |
| 444 | 1844 Delete by side effect any elements of ALIST whose car is `eq' to KEY. |
| 1845 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1846 that is `eq' to KEY, there is no way to remove it by side effect; |
| 1847 therefore, write `(setq foo (remassq key foo))' to be sure of changing | |
| 1848 the value of `foo'. | |
| 1849 */ | |
| 444 | 1850 (key, alist)) |
| 428 | 1851 { |
| 444 | 1852 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1853 (CONSP (elt) && |
| 1854 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); | |
| 444 | 1855 return alist; |
| 428 | 1856 } |
| 1857 | |
| 1858 /* no quit, no errors; be careful */ | |
| 1859 | |
| 1860 Lisp_Object | |
| 444 | 1861 remassq_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1862 { |
| 444 | 1863 LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1864 (CONSP (elt) && |
| 1865 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); | |
| 444 | 1866 return alist; |
| 428 | 1867 } |
| 1868 | |
| 1869 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /* | |
| 444 | 1870 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE. |
| 1871 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1872 that is `equal' to VALUE, there is no way to remove it by side effect; |
| 1873 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing | |
| 1874 the value of `foo'. | |
| 1875 */ | |
| 444 | 1876 (value, alist)) |
| 428 | 1877 { |
| 444 | 1878 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1879 (CONSP (elt) && |
| 1880 internal_equal (value, XCDR (elt), 0))); | |
| 444 | 1881 return alist; |
| 428 | 1882 } |
| 1883 | |
| 1884 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /* | |
| 444 | 1885 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE. |
| 1886 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1887 that is `eq' to VALUE, there is no way to remove it by side effect; |
| 1888 therefore, write `(setq foo (remrassq value foo))' to be sure of changing | |
| 1889 the value of `foo'. | |
| 1890 */ | |
| 444 | 1891 (value, alist)) |
| 428 | 1892 { |
| 444 | 1893 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1894 (CONSP (elt) && |
| 1895 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); | |
| 444 | 1896 return alist; |
| 428 | 1897 } |
| 1898 | |
| 1899 /* Like Fremrassq, fast and unsafe; be careful */ | |
| 1900 Lisp_Object | |
| 444 | 1901 remrassq_no_quit (Lisp_Object value, Lisp_Object alist) |
| 428 | 1902 { |
| 444 | 1903 LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1904 (CONSP (elt) && |
| 1905 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); | |
| 444 | 1906 return alist; |
| 428 | 1907 } |
| 1908 | |
| 1909 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /* | |
| 1910 Reverse LIST by destructively modifying cdr pointers. | |
| 1911 Return the beginning of the reversed list. | |
| 1912 Also see: `reverse'. | |
| 1913 */ | |
| 1914 (list)) | |
| 1915 { | |
| 1916 struct gcpro gcpro1, gcpro2; | |
| 1849 | 1917 Lisp_Object prev = Qnil; |
| 1918 Lisp_Object tail = list; | |
| 428 | 1919 |
| 1920 /* We gcpro our args; see `nconc' */ | |
| 1921 GCPRO2 (prev, tail); | |
| 1922 while (!NILP (tail)) | |
| 1923 { | |
| 1924 REGISTER Lisp_Object next; | |
| 1925 CONCHECK_CONS (tail); | |
| 1926 next = XCDR (tail); | |
| 1927 XCDR (tail) = prev; | |
| 1928 prev = tail; | |
| 1929 tail = next; | |
| 1930 } | |
| 1931 UNGCPRO; | |
| 1932 return prev; | |
| 1933 } | |
| 1934 | |
| 1935 DEFUN ("reverse", Freverse, 1, 1, 0, /* | |
| 1936 Reverse LIST, copying. Return the beginning of the reversed list. | |
| 1937 See also the function `nreverse', which is used more often. | |
| 1938 */ | |
| 1939 (list)) | |
| 1940 { | |
| 1941 Lisp_Object reversed_list = Qnil; | |
| 1942 EXTERNAL_LIST_LOOP_2 (elt, list) | |
| 1943 { | |
| 1944 reversed_list = Fcons (elt, reversed_list); | |
| 1945 } | |
| 1946 return reversed_list; | |
| 1947 } | |
| 1948 | |
| 1949 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, | |
| 1950 Lisp_Object lisp_arg, | |
| 1951 int (*pred_fn) (Lisp_Object, Lisp_Object, | |
| 1952 Lisp_Object lisp_arg)); | |
| 1953 | |
| 872 | 1954 /* The sort function should return > 0 if OBJ1 < OBJ2, < 0 otherwise. |
| 1955 NOTE: This is backwards from the way qsort() works. */ | |
| 1956 | |
| 428 | 1957 Lisp_Object |
| 1958 list_sort (Lisp_Object list, | |
| 1959 Lisp_Object lisp_arg, | |
| 872 | 1960 int (*pred_fn) (Lisp_Object obj1, Lisp_Object obj2, |
| 428 | 1961 Lisp_Object lisp_arg)) |
| 1962 { | |
| 1963 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 1964 Lisp_Object back, tem; | |
| 1965 Lisp_Object front = list; | |
| 1966 Lisp_Object len = Flength (list); | |
| 444 | 1967 |
| 1968 if (XINT (len) < 2) | |
| 428 | 1969 return list; |
| 1970 | |
| 444 | 1971 len = make_int (XINT (len) / 2 - 1); |
| 428 | 1972 tem = Fnthcdr (len, list); |
| 1973 back = Fcdr (tem); | |
| 1974 Fsetcdr (tem, Qnil); | |
| 1975 | |
| 1976 GCPRO3 (front, back, lisp_arg); | |
| 1977 front = list_sort (front, lisp_arg, pred_fn); | |
| 1978 back = list_sort (back, lisp_arg, pred_fn); | |
| 1979 UNGCPRO; | |
| 1980 return list_merge (front, back, lisp_arg, pred_fn); | |
| 1981 } | |
| 1982 | |
| 1983 | |
| 1984 static int | |
| 1985 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2, | |
| 1986 Lisp_Object pred) | |
| 1987 { | |
| 1988 Lisp_Object tmp; | |
| 1989 | |
| 1990 /* prevents the GC from happening in call2 */ | |
| 853 | 1991 /* Emacs' GC doesn't actually relocate pointers, so this probably |
| 1992 isn't strictly necessary */ | |
| 771 | 1993 int speccount = begin_gc_forbidden (); |
| 428 | 1994 tmp = call2 (pred, obj1, obj2); |
| 771 | 1995 unbind_to (speccount); |
| 428 | 1996 |
| 1997 if (NILP (tmp)) | |
| 1998 return -1; | |
| 1999 else | |
| 2000 return 1; | |
| 2001 } | |
| 2002 | |
| 2003 DEFUN ("sort", Fsort, 2, 2, 0, /* | |
| 2004 Sort LIST, stably, comparing elements using PREDICATE. | |
| 2005 Returns the sorted list. LIST is modified by side effects. | |
| 2006 PREDICATE is called with two elements of LIST, and should return T | |
| 2007 if the first element is "less" than the second. | |
| 2008 */ | |
| 444 | 2009 (list, predicate)) |
| 428 | 2010 { |
| 444 | 2011 return list_sort (list, predicate, merge_pred_function); |
| 428 | 2012 } |
| 2013 | |
| 2014 Lisp_Object | |
| 2015 merge (Lisp_Object org_l1, Lisp_Object org_l2, | |
| 2016 Lisp_Object pred) | |
| 2017 { | |
| 2018 return list_merge (org_l1, org_l2, pred, merge_pred_function); | |
| 2019 } | |
| 2020 | |
| 2021 | |
| 2022 static Lisp_Object | |
| 2023 list_merge (Lisp_Object org_l1, Lisp_Object org_l2, | |
| 2024 Lisp_Object lisp_arg, | |
| 2025 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg)) | |
| 2026 { | |
| 2027 Lisp_Object value; | |
| 2028 Lisp_Object tail; | |
| 2029 Lisp_Object tem; | |
| 2030 Lisp_Object l1, l2; | |
| 2031 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 2032 | |
| 2033 l1 = org_l1; | |
| 2034 l2 = org_l2; | |
| 2035 tail = Qnil; | |
| 2036 value = Qnil; | |
| 2037 | |
| 2038 /* It is sufficient to protect org_l1 and org_l2. | |
| 2039 When l1 and l2 are updated, we copy the new values | |
| 2040 back into the org_ vars. */ | |
| 2041 | |
| 2042 GCPRO4 (org_l1, org_l2, lisp_arg, value); | |
| 2043 | |
| 2044 while (1) | |
| 2045 { | |
| 2046 if (NILP (l1)) | |
| 2047 { | |
| 2048 UNGCPRO; | |
| 2049 if (NILP (tail)) | |
| 2050 return l2; | |
| 2051 Fsetcdr (tail, l2); | |
| 2052 return value; | |
| 2053 } | |
| 2054 if (NILP (l2)) | |
| 2055 { | |
| 2056 UNGCPRO; | |
| 2057 if (NILP (tail)) | |
| 2058 return l1; | |
| 2059 Fsetcdr (tail, l1); | |
| 2060 return value; | |
| 2061 } | |
| 2062 | |
| 2063 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0) | |
| 2064 { | |
| 2065 tem = l1; | |
| 2066 l1 = Fcdr (l1); | |
| 2067 org_l1 = l1; | |
| 2068 } | |
| 2069 else | |
| 2070 { | |
| 2071 tem = l2; | |
| 2072 l2 = Fcdr (l2); | |
| 2073 org_l2 = l2; | |
| 2074 } | |
| 2075 if (NILP (tail)) | |
| 2076 value = tem; | |
| 2077 else | |
| 2078 Fsetcdr (tail, tem); | |
| 2079 tail = tem; | |
| 2080 } | |
| 2081 } | |
| 2082 | |
| 2083 | |
| 2084 /************************************************************************/ | |
| 2085 /* property-list functions */ | |
| 2086 /************************************************************************/ | |
| 2087 | |
| 2088 /* For properties of text, we need to do order-insensitive comparison of | |
| 2089 plists. That is, we need to compare two plists such that they are the | |
| 2090 same if they have the same set of keys, and equivalent values. | |
| 2091 So (a 1 b 2) would be equal to (b 2 a 1). | |
| 2092 | |
| 2093 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc. | |
| 2094 LAXP means use `equal' for comparisons. | |
| 2095 */ | |
| 2096 int | |
| 2097 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2098 int laxp, int depth, int foldcase) |
| 428 | 2099 { |
| 438 | 2100 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ |
| 428 | 2101 int la, lb, m, i, fill; |
| 2102 Lisp_Object *keys, *vals; | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
2103 Boolbyte *flags; |
| 428 | 2104 Lisp_Object rest; |
| 2105 | |
| 2106 if (NILP (a) && NILP (b)) | |
| 2107 return 0; | |
| 2108 | |
| 2109 Fcheck_valid_plist (a); | |
| 2110 Fcheck_valid_plist (b); | |
| 2111 | |
| 2112 la = XINT (Flength (a)); | |
| 2113 lb = XINT (Flength (b)); | |
| 2114 m = (la > lb ? la : lb); | |
| 2115 fill = 0; | |
| 2116 keys = alloca_array (Lisp_Object, m); | |
| 2117 vals = alloca_array (Lisp_Object, m); | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
2118 flags = alloca_array (Boolbyte, m); |
| 428 | 2119 |
| 2120 /* First extract the pairs from A. */ | |
| 2121 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest))) | |
| 2122 { | |
| 2123 Lisp_Object k = XCAR (rest); | |
| 2124 Lisp_Object v = XCAR (XCDR (rest)); | |
| 2125 /* Maybe be Ebolified. */ | |
| 2126 if (nil_means_not_present && NILP (v)) continue; | |
| 2127 keys [fill] = k; | |
| 2128 vals [fill] = v; | |
| 2129 flags[fill] = 0; | |
| 2130 fill++; | |
| 2131 } | |
| 2132 /* Now iterate over B, and stop if we find something that's not in A, | |
| 2133 or that doesn't match. As we match, mark them. */ | |
| 2134 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest))) | |
| 2135 { | |
| 2136 Lisp_Object k = XCAR (rest); | |
| 2137 Lisp_Object v = XCAR (XCDR (rest)); | |
| 2138 /* Maybe be Ebolified. */ | |
| 2139 if (nil_means_not_present && NILP (v)) continue; | |
| 2140 for (i = 0; i < fill; i++) | |
| 2141 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2142 if (!laxp ? EQ (k, keys [i]) : |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2143 internal_equal_0 (k, keys [i], depth, foldcase)) |
| 428 | 2144 { |
| 434 | 2145 if (eqp |
| 2146 /* We narrowly escaped being Ebolified here. */ | |
| 2147 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2148 : !internal_equal_0 (v, vals [i], depth, foldcase)) |
| 428 | 2149 /* a property in B has a different value than in A */ |
| 2150 goto MISMATCH; | |
| 2151 flags [i] = 1; | |
| 2152 break; | |
| 2153 } | |
| 2154 } | |
| 2155 if (i == fill) | |
| 2156 /* there are some properties in B that are not in A */ | |
| 2157 goto MISMATCH; | |
| 2158 } | |
| 2159 /* Now check to see that all the properties in A were also in B */ | |
| 2160 for (i = 0; i < fill; i++) | |
| 2161 if (flags [i] == 0) | |
| 2162 goto MISMATCH; | |
| 2163 | |
| 2164 /* Ok. */ | |
| 2165 return 0; | |
| 2166 | |
| 2167 MISMATCH: | |
| 2168 return 1; | |
| 2169 } | |
| 2170 | |
| 2171 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /* | |
| 2172 Return non-nil if property lists A and B are `eq'. | |
| 2173 A property list is an alternating list of keywords and values. | |
| 2174 This function does order-insensitive comparisons of the property lists: | |
| 2175 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2176 Comparison between values is done using `eq'. See also `plists-equal'. | |
| 2177 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2178 a nil value is ignored. This feature is a virus that has infected | |
| 2179 old Lisp implementations, but should not be used except for backward | |
| 2180 compatibility. | |
| 2181 */ | |
| 2182 (a, b, nil_means_not_present)) | |
| 2183 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2184 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0) |
| 428 | 2185 ? Qnil : Qt); |
| 2186 } | |
| 2187 | |
| 2188 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /* | |
| 2189 Return non-nil if property lists A and B are `equal'. | |
| 2190 A property list is an alternating list of keywords and values. This | |
| 2191 function does order-insensitive comparisons of the property lists: For | |
| 2192 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2193 Comparison between values is done using `equal'. See also `plists-eq'. | |
| 2194 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2195 a nil value is ignored. This feature is a virus that has infected | |
| 2196 old Lisp implementations, but should not be used except for backward | |
| 2197 compatibility. | |
| 2198 */ | |
| 2199 (a, b, nil_means_not_present)) | |
| 2200 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2201 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0) |
| 428 | 2202 ? Qnil : Qt); |
| 2203 } | |
| 2204 | |
| 2205 | |
| 2206 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /* | |
| 2207 Return non-nil if lax property lists A and B are `eq'. | |
| 2208 A property list is an alternating list of keywords and values. | |
| 2209 This function does order-insensitive comparisons of the property lists: | |
| 2210 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2211 Comparison between values is done using `eq'. See also `plists-equal'. | |
| 2212 A lax property list is like a regular one except that comparisons between | |
| 2213 keywords is done using `equal' instead of `eq'. | |
| 2214 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2215 a nil value is ignored. This feature is a virus that has infected | |
| 2216 old Lisp implementations, but should not be used except for backward | |
| 2217 compatibility. | |
| 2218 */ | |
| 2219 (a, b, nil_means_not_present)) | |
| 2220 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2221 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0) |
| 428 | 2222 ? Qnil : Qt); |
| 2223 } | |
| 2224 | |
| 2225 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /* | |
| 2226 Return non-nil if lax property lists A and B are `equal'. | |
| 2227 A property list is an alternating list of keywords and values. This | |
| 2228 function does order-insensitive comparisons of the property lists: For | |
| 2229 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2230 Comparison between values is done using `equal'. See also `plists-eq'. | |
| 2231 A lax property list is like a regular one except that comparisons between | |
| 2232 keywords is done using `equal' instead of `eq'. | |
| 2233 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2234 a nil value is ignored. This feature is a virus that has infected | |
| 2235 old Lisp implementations, but should not be used except for backward | |
| 2236 compatibility. | |
| 2237 */ | |
| 2238 (a, b, nil_means_not_present)) | |
| 2239 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2240 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0) |
| 428 | 2241 ? Qnil : Qt); |
| 2242 } | |
| 2243 | |
| 2244 /* Return the value associated with key PROPERTY in property list PLIST. | |
| 2245 Return nil if key not found. This function is used for internal | |
| 2246 property lists that cannot be directly manipulated by the user. | |
| 2247 */ | |
| 2248 | |
| 2249 Lisp_Object | |
| 2250 internal_plist_get (Lisp_Object plist, Lisp_Object property) | |
| 2251 { | |
| 2252 Lisp_Object tail; | |
| 2253 | |
| 2254 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
| 2255 { | |
| 2256 if (EQ (XCAR (tail), property)) | |
| 2257 return XCAR (XCDR (tail)); | |
| 2258 } | |
| 2259 | |
| 2260 return Qunbound; | |
| 2261 } | |
| 2262 | |
| 2263 /* Set PLIST's value for PROPERTY to VALUE. Analogous to | |
| 2264 internal_plist_get(). */ | |
| 2265 | |
| 2266 void | |
| 2267 internal_plist_put (Lisp_Object *plist, Lisp_Object property, | |
| 2268 Lisp_Object value) | |
| 2269 { | |
| 2270 Lisp_Object tail; | |
| 2271 | |
| 2272 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
| 2273 { | |
| 2274 if (EQ (XCAR (tail), property)) | |
| 2275 { | |
| 2276 XCAR (XCDR (tail)) = value; | |
| 2277 return; | |
| 2278 } | |
| 2279 } | |
| 2280 | |
| 2281 *plist = Fcons (property, Fcons (value, *plist)); | |
| 2282 } | |
| 2283 | |
| 2284 int | |
| 2285 internal_remprop (Lisp_Object *plist, Lisp_Object property) | |
| 2286 { | |
| 2287 Lisp_Object tail, prev; | |
| 2288 | |
| 2289 for (tail = *plist, prev = Qnil; | |
| 2290 !NILP (tail); | |
| 2291 tail = XCDR (XCDR (tail))) | |
| 2292 { | |
| 2293 if (EQ (XCAR (tail), property)) | |
| 2294 { | |
| 2295 if (NILP (prev)) | |
| 2296 *plist = XCDR (XCDR (tail)); | |
| 2297 else | |
| 2298 XCDR (XCDR (prev)) = XCDR (XCDR (tail)); | |
| 2299 return 1; | |
| 2300 } | |
| 2301 else | |
| 2302 prev = tail; | |
| 2303 } | |
| 2304 | |
| 2305 return 0; | |
| 2306 } | |
| 2307 | |
| 2308 /* Called on a malformed property list. BADPLACE should be some | |
| 2309 place where truncating will form a good list -- i.e. we shouldn't | |
| 2310 result in a list with an odd length. */ | |
| 2311 | |
| 2312 static Lisp_Object | |
| 578 | 2313 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
| 428 | 2314 { |
| 2315 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2316 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace)); | |
| 2317 else | |
| 2318 { | |
| 2319 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
| 2320 { | |
| 2321 warn_when_safe_lispobj | |
| 2322 (Qlist, Qwarning, | |
| 771 | 2323 list2 (build_msg_string |
| 428 | 2324 ("Malformed property list -- list has been truncated"), |
| 2325 *plist)); | |
| 793 | 2326 /* #### WARNING: This is more dangerous than it seems; perhaps |
| 2327 not a good idea. It also violates the principle of least | |
| 2328 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
| 2329 ERROR_ME and ERROR_ME_NOT don't. */ | |
| 428 | 2330 *badplace = Qnil; |
| 2331 } | |
| 2332 return Qunbound; | |
| 2333 } | |
| 2334 } | |
| 2335 | |
| 2336 /* Called on a circular property list. BADPLACE should be some place | |
| 2337 where truncating will result in an even-length list, as above. | |
| 2338 If doesn't particularly matter where we truncate -- anywhere we | |
| 2339 truncate along the entire list will break the circularity, because | |
| 2340 it will create a terminus and the list currently doesn't have one. | |
| 2341 */ | |
| 2342 | |
| 2343 static Lisp_Object | |
| 578 | 2344 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
| 428 | 2345 { |
| 2346 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2347 return Fsignal (Qcircular_property_list, list1 (*plist)); | |
| 2348 else | |
| 2349 { | |
| 2350 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
| 2351 { | |
| 2352 warn_when_safe_lispobj | |
| 2353 (Qlist, Qwarning, | |
| 771 | 2354 list2 (build_msg_string |
| 428 | 2355 ("Circular property list -- list has been truncated"), |
| 2356 *plist)); | |
| 793 | 2357 /* #### WARNING: This is more dangerous than it seems; perhaps |
| 2358 not a good idea. It also violates the principle of least | |
| 2359 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
| 2360 ERROR_ME and ERROR_ME_NOT don't. */ | |
| 428 | 2361 *badplace = Qnil; |
| 2362 } | |
| 2363 return Qunbound; | |
| 2364 } | |
| 2365 } | |
| 2366 | |
| 2367 /* Advance the tortoise pointer by two (one iteration of a property-list | |
| 2368 loop) and the hare pointer by four and verify that no malformations | |
| 2369 or circularities exist. If so, return zero and store a value into | |
| 2370 RETVAL that should be returned by the calling function. Otherwise, | |
| 2371 return 1. See external_plist_get(). | |
| 2372 */ | |
| 2373 | |
| 2374 static int | |
| 2375 advance_plist_pointers (Lisp_Object *plist, | |
| 2376 Lisp_Object **tortoise, Lisp_Object **hare, | |
| 578 | 2377 Error_Behavior errb, Lisp_Object *retval) |
| 428 | 2378 { |
| 2379 int i; | |
| 2380 Lisp_Object *tortsave = *tortoise; | |
| 2381 | |
| 2382 /* Note that our "fixing" may be more brutal than necessary, | |
| 2383 but it's the user's own problem, not ours, if they went in and | |
| 2384 manually fucked up a plist. */ | |
| 2385 | |
| 2386 for (i = 0; i < 2; i++) | |
| 2387 { | |
| 2388 /* This is a standard iteration of a defensive-loop-checking | |
| 2389 loop. We just do it twice because we want to advance past | |
| 2390 both the property and its value. | |
| 2391 | |
| 2392 If the pointer indirection is confusing you, remember that | |
| 2393 one level of indirection on the hare and tortoise pointers | |
| 2394 is only due to pass-by-reference for this function. The other | |
| 2395 level is so that the plist can be fixed in place. */ | |
| 2396 | |
| 2397 /* When we reach the end of a well-formed plist, **HARE is | |
| 2398 nil. In that case, we don't do anything at all except | |
| 2399 advance TORTOISE by one. Otherwise, we advance HARE | |
| 2400 by two (making sure it's OK to do so), then advance | |
| 2401 TORTOISE by one (it will always be OK to do so because | |
| 2402 the HARE is always ahead of the TORTOISE and will have | |
| 2403 already verified the path), then make sure TORTOISE and | |
| 2404 HARE don't contain the same non-nil object -- if the | |
| 2405 TORTOISE and the HARE ever meet, then obviously we're | |
| 2406 in a circularity, and if we're in a circularity, then | |
| 2407 the TORTOISE and the HARE can't cross paths without | |
| 2408 meeting, since the HARE only gains one step over the | |
| 2409 TORTOISE per iteration. */ | |
| 2410 | |
| 2411 if (!NILP (**hare)) | |
| 2412 { | |
| 2413 Lisp_Object *haresave = *hare; | |
| 2414 if (!CONSP (**hare)) | |
| 2415 { | |
| 2416 *retval = bad_bad_bunny (plist, haresave, errb); | |
| 2417 return 0; | |
| 2418 } | |
| 2419 *hare = &XCDR (**hare); | |
| 2420 /* In a non-plist, we'd check here for a nil value for | |
| 2421 **HARE, which is OK (it just means the list has an | |
| 2422 odd number of elements). In a plist, it's not OK | |
| 2423 for the list to have an odd number of elements. */ | |
| 2424 if (!CONSP (**hare)) | |
| 2425 { | |
| 2426 *retval = bad_bad_bunny (plist, haresave, errb); | |
| 2427 return 0; | |
| 2428 } | |
| 2429 *hare = &XCDR (**hare); | |
| 2430 } | |
| 2431 | |
| 2432 *tortoise = &XCDR (**tortoise); | |
| 2433 if (!NILP (**hare) && EQ (**tortoise, **hare)) | |
| 2434 { | |
| 2435 *retval = bad_bad_turtle (plist, tortsave, errb); | |
| 2436 return 0; | |
| 2437 } | |
| 2438 } | |
| 2439 | |
| 2440 return 1; | |
| 2441 } | |
| 2442 | |
| 2443 /* Return the value of PROPERTY from PLIST, or Qunbound if | |
| 2444 property is not on the list. | |
| 2445 | |
| 2446 PLIST is a Lisp-accessible property list, meaning that it | |
| 2447 has to be checked for malformations and circularities. | |
| 2448 | |
| 2449 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the | |
| 2450 function will never signal an error; and if ERRB is ERROR_ME_WARN, | |
| 2451 on finding a malformation or a circularity, it issues a warning and | |
| 2452 attempts to silently fix the problem. | |
| 2453 | |
| 2454 A pointer to PLIST is passed in so that PLIST can be successfully | |
| 2455 "fixed" even if the error is at the beginning of the plist. */ | |
| 2456 | |
| 2457 Lisp_Object | |
| 2458 external_plist_get (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 2459 int laxp, Error_Behavior errb) |
| 428 | 2460 { |
| 2461 Lisp_Object *tortoise = plist; | |
| 2462 Lisp_Object *hare = plist; | |
| 2463 | |
| 2464 while (!NILP (*tortoise)) | |
| 2465 { | |
| 2466 Lisp_Object *tortsave = tortoise; | |
| 2467 Lisp_Object retval; | |
| 2468 | |
| 2469 /* We do the standard tortoise/hare march. We isolate the | |
| 2470 grungy stuff to do this in advance_plist_pointers(), though. | |
| 2471 To us, all this function does is advance the tortoise | |
| 2472 pointer by two and the hare pointer by four and make sure | |
| 2473 everything's OK. We first advance the pointers and then | |
| 2474 check if a property matched; this ensures that our | |
| 2475 check for a matching property is safe. */ | |
| 2476 | |
| 2477 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 2478 return retval; | |
| 2479 | |
| 2480 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 2481 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 2482 return XCAR (XCDR (*tortsave)); | |
| 2483 } | |
| 2484 | |
| 2485 return Qunbound; | |
| 2486 } | |
| 2487 | |
| 2488 /* Set PLIST's value for PROPERTY to VALUE, given a possibly | |
| 2489 malformed or circular plist. Analogous to external_plist_get(). */ | |
| 2490 | |
| 2491 void | |
| 2492 external_plist_put (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 2493 Lisp_Object value, int laxp, Error_Behavior errb) |
| 428 | 2494 { |
| 2495 Lisp_Object *tortoise = plist; | |
| 2496 Lisp_Object *hare = plist; | |
| 2497 | |
| 2498 while (!NILP (*tortoise)) | |
| 2499 { | |
| 2500 Lisp_Object *tortsave = tortoise; | |
| 2501 Lisp_Object retval; | |
| 2502 | |
| 2503 /* See above */ | |
| 2504 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 2505 return; | |
| 2506 | |
| 2507 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 2508 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 2509 { | |
| 2510 XCAR (XCDR (*tortsave)) = value; | |
| 2511 return; | |
| 2512 } | |
| 2513 } | |
| 2514 | |
| 2515 *plist = Fcons (property, Fcons (value, *plist)); | |
| 2516 } | |
| 2517 | |
| 2518 int | |
| 2519 external_remprop (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 2520 int laxp, Error_Behavior errb) |
| 428 | 2521 { |
| 2522 Lisp_Object *tortoise = plist; | |
| 2523 Lisp_Object *hare = plist; | |
| 2524 | |
| 2525 while (!NILP (*tortoise)) | |
| 2526 { | |
| 2527 Lisp_Object *tortsave = tortoise; | |
| 2528 Lisp_Object retval; | |
| 2529 | |
| 2530 /* See above */ | |
| 2531 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 2532 return 0; | |
| 2533 | |
| 2534 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 2535 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 2536 { | |
| 2537 /* Now you see why it's so convenient to have that level | |
| 2538 of indirection. */ | |
| 2539 *tortsave = XCDR (XCDR (*tortsave)); | |
| 2540 return 1; | |
| 2541 } | |
| 2542 } | |
| 2543 | |
| 2544 return 0; | |
| 2545 } | |
| 2546 | |
| 2547 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /* | |
| 2548 Extract a value from a property list. | |
| 2549 PLIST is a property list, which is a list of the form | |
| 444 | 2550 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...). |
| 2551 PROPERTY is usually a symbol. | |
| 2552 This function returns the value corresponding to the PROPERTY, | |
| 2553 or DEFAULT if PROPERTY is not one of the properties on the list. | |
| 428 | 2554 */ |
| 444 | 2555 (plist, property, default_)) |
| 428 | 2556 { |
| 444 | 2557 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME); |
| 2558 return UNBOUNDP (value) ? default_ : value; | |
| 428 | 2559 } |
| 2560 | |
| 2561 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* | |
| 444 | 2562 Change value in PLIST of PROPERTY to VALUE. |
| 2563 PLIST is a property list, which is a list of the form | |
| 2564 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
| 2565 PROPERTY is usually a symbol and VALUE is any object. | |
| 2566 If PROPERTY is already a property on the list, its value is set to VALUE, | |
| 2567 otherwise the new PROPERTY VALUE pair is added. | |
| 2568 The new plist is returned; use `(setq x (plist-put x property value))' | |
| 2569 to be sure to use the new value. PLIST is modified by side effect. | |
| 428 | 2570 */ |
| 444 | 2571 (plist, property, value)) |
| 428 | 2572 { |
| 444 | 2573 external_plist_put (&plist, property, value, 0, ERROR_ME); |
| 428 | 2574 return plist; |
| 2575 } | |
| 2576 | |
| 2577 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /* | |
| 444 | 2578 Remove from PLIST the property PROPERTY and its value. |
| 2579 PLIST is a property list, which is a list of the form | |
| 2580 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
| 2581 PROPERTY is usually a symbol. | |
| 2582 The new plist is returned; use `(setq x (plist-remprop x property))' | |
| 2583 to be sure to use the new value. PLIST is modified by side effect. | |
| 428 | 2584 */ |
| 444 | 2585 (plist, property)) |
| 428 | 2586 { |
| 444 | 2587 external_remprop (&plist, property, 0, ERROR_ME); |
| 428 | 2588 return plist; |
| 2589 } | |
| 2590 | |
| 2591 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /* | |
| 444 | 2592 Return t if PROPERTY has a value specified in PLIST. |
| 428 | 2593 */ |
| 444 | 2594 (plist, property)) |
| 428 | 2595 { |
| 444 | 2596 Lisp_Object value = Fplist_get (plist, property, Qunbound); |
| 2597 return UNBOUNDP (value) ? Qnil : Qt; | |
| 428 | 2598 } |
| 2599 | |
| 2600 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* | |
| 2601 Given a plist, signal an error if there is anything wrong with it. | |
| 2602 This means that it's a malformed or circular plist. | |
| 2603 */ | |
| 2604 (plist)) | |
| 2605 { | |
| 2606 Lisp_Object *tortoise; | |
| 2607 Lisp_Object *hare; | |
| 2608 | |
| 2609 start_over: | |
| 2610 tortoise = &plist; | |
| 2611 hare = &plist; | |
| 2612 while (!NILP (*tortoise)) | |
| 2613 { | |
| 2614 Lisp_Object retval; | |
| 2615 | |
| 2616 /* See above */ | |
| 2617 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME, | |
| 2618 &retval)) | |
| 2619 goto start_over; | |
| 2620 } | |
| 2621 | |
| 2622 return Qnil; | |
| 2623 } | |
| 2624 | |
| 2625 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /* | |
| 2626 Given a plist, return non-nil if its format is correct. | |
| 2627 If it returns nil, `check-valid-plist' will signal an error when given | |
| 442 | 2628 the plist; that means it's a malformed or circular plist. |
| 428 | 2629 */ |
| 2630 (plist)) | |
| 2631 { | |
| 2632 Lisp_Object *tortoise; | |
| 2633 Lisp_Object *hare; | |
| 2634 | |
| 2635 tortoise = &plist; | |
| 2636 hare = &plist; | |
| 2637 while (!NILP (*tortoise)) | |
| 2638 { | |
| 2639 Lisp_Object retval; | |
| 2640 | |
| 2641 /* See above */ | |
| 2642 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT, | |
| 2643 &retval)) | |
| 2644 return Qnil; | |
| 2645 } | |
| 2646 | |
| 2647 return Qt; | |
| 2648 } | |
| 2649 | |
| 2650 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /* | |
| 2651 Destructively remove any duplicate entries from a plist. | |
| 2652 In such cases, the first entry applies. | |
| 2653 | |
| 2654 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2655 a nil value is removed. This feature is a virus that has infected | |
| 2656 old Lisp implementations, but should not be used except for backward | |
| 2657 compatibility. | |
| 2658 | |
| 2659 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
| 2660 return value may not be EQ to the passed-in value, so make sure to | |
| 2661 `setq' the value back into where it came from. | |
| 2662 */ | |
| 2663 (plist, nil_means_not_present)) | |
| 2664 { | |
| 2665 Lisp_Object head = plist; | |
| 2666 | |
| 2667 Fcheck_valid_plist (plist); | |
| 2668 | |
| 2669 while (!NILP (plist)) | |
| 2670 { | |
| 2671 Lisp_Object prop = Fcar (plist); | |
| 2672 Lisp_Object next = Fcdr (plist); | |
| 2673 | |
| 2674 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
| 2675 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
| 2676 { | |
| 2677 if (EQ (head, plist)) | |
| 2678 head = Fcdr (next); | |
| 2679 plist = Fcdr (next); | |
| 2680 continue; | |
| 2681 } | |
| 2682 /* external_remprop returns 1 if it removed any property. | |
| 2683 We have to loop till it didn't remove anything, in case | |
| 2684 the property occurs many times. */ | |
| 2685 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)) | |
| 2686 DO_NOTHING; | |
| 2687 plist = Fcdr (next); | |
| 2688 } | |
| 2689 | |
| 2690 return head; | |
| 2691 } | |
| 2692 | |
| 2693 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /* | |
| 2694 Extract a value from a lax property list. | |
| 444 | 2695 LAX-PLIST is a lax property list, which is a list of the form |
| 2696 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2697 properties is done using `equal' instead of `eq'. | |
| 2698 PROPERTY is usually a symbol. | |
| 2699 This function returns the value corresponding to PROPERTY, | |
| 2700 or DEFAULT if PROPERTY is not one of the properties on the list. | |
| 428 | 2701 */ |
| 444 | 2702 (lax_plist, property, default_)) |
| 428 | 2703 { |
| 444 | 2704 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME); |
| 2705 return UNBOUNDP (value) ? default_ : value; | |
| 428 | 2706 } |
| 2707 | |
| 2708 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* | |
| 444 | 2709 Change value in LAX-PLIST of PROPERTY to VALUE. |
| 2710 LAX-PLIST is a lax property list, which is a list of the form | |
| 2711 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2712 properties is done using `equal' instead of `eq'. | |
| 2713 PROPERTY is usually a symbol and VALUE is any object. | |
| 2714 If PROPERTY is already a property on the list, its value is set to | |
| 2715 VALUE, otherwise the new PROPERTY VALUE pair is added. | |
| 2716 The new plist is returned; use `(setq x (lax-plist-put x property value))' | |
| 2717 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
| 428 | 2718 */ |
| 444 | 2719 (lax_plist, property, value)) |
| 428 | 2720 { |
| 444 | 2721 external_plist_put (&lax_plist, property, value, 1, ERROR_ME); |
| 428 | 2722 return lax_plist; |
| 2723 } | |
| 2724 | |
| 2725 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* | |
| 444 | 2726 Remove from LAX-PLIST the property PROPERTY and its value. |
| 2727 LAX-PLIST is a lax property list, which is a list of the form | |
| 2728 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2729 properties is done using `equal' instead of `eq'. | |
| 2730 PROPERTY is usually a symbol. | |
| 2731 The new plist is returned; use `(setq x (lax-plist-remprop x property))' | |
| 2732 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
| 428 | 2733 */ |
| 444 | 2734 (lax_plist, property)) |
| 428 | 2735 { |
| 444 | 2736 external_remprop (&lax_plist, property, 1, ERROR_ME); |
| 428 | 2737 return lax_plist; |
| 2738 } | |
| 2739 | |
| 2740 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* | |
| 444 | 2741 Return t if PROPERTY has a value specified in LAX-PLIST. |
| 2742 LAX-PLIST is a lax property list, which is a list of the form | |
| 2743 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2744 properties is done using `equal' instead of `eq'. | |
| 428 | 2745 */ |
| 444 | 2746 (lax_plist, property)) |
| 428 | 2747 { |
| 444 | 2748 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt; |
| 428 | 2749 } |
| 2750 | |
| 2751 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /* | |
| 2752 Destructively remove any duplicate entries from a lax plist. | |
| 2753 In such cases, the first entry applies. | |
| 2754 | |
| 2755 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2756 a nil value is removed. This feature is a virus that has infected | |
| 2757 old Lisp implementations, but should not be used except for backward | |
| 2758 compatibility. | |
| 2759 | |
| 2760 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
| 2761 return value may not be EQ to the passed-in value, so make sure to | |
| 2762 `setq' the value back into where it came from. | |
| 2763 */ | |
| 2764 (lax_plist, nil_means_not_present)) | |
| 2765 { | |
| 2766 Lisp_Object head = lax_plist; | |
| 2767 | |
| 2768 Fcheck_valid_plist (lax_plist); | |
| 2769 | |
| 2770 while (!NILP (lax_plist)) | |
| 2771 { | |
| 2772 Lisp_Object prop = Fcar (lax_plist); | |
| 2773 Lisp_Object next = Fcdr (lax_plist); | |
| 2774 | |
| 2775 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
| 2776 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
| 2777 { | |
| 2778 if (EQ (head, lax_plist)) | |
| 2779 head = Fcdr (next); | |
| 2780 lax_plist = Fcdr (next); | |
| 2781 continue; | |
| 2782 } | |
| 2783 /* external_remprop returns 1 if it removed any property. | |
| 2784 We have to loop till it didn't remove anything, in case | |
| 2785 the property occurs many times. */ | |
| 2786 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)) | |
| 2787 DO_NOTHING; | |
| 2788 lax_plist = Fcdr (next); | |
| 2789 } | |
| 2790 | |
| 2791 return head; | |
| 2792 } | |
| 2793 | |
| 2794 /* In C because the frame props stuff uses it */ | |
| 2795 | |
| 2796 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /* | |
| 2797 Convert association list ALIST into the equivalent property-list form. | |
| 2798 The plist is returned. This converts from | |
| 2799 | |
| 2800 \((a . 1) (b . 2) (c . 3)) | |
| 2801 | |
| 2802 into | |
| 2803 | |
| 2804 \(a 1 b 2 c 3) | |
| 2805 | |
| 2806 The original alist is destroyed in the process of constructing the plist. | |
| 2807 See also `alist-to-plist'. | |
| 2808 */ | |
| 2809 (alist)) | |
| 2810 { | |
| 2811 Lisp_Object head = alist; | |
| 2812 while (!NILP (alist)) | |
| 2813 { | |
| 2814 /* remember the alist element. */ | |
| 2815 Lisp_Object el = Fcar (alist); | |
| 2816 | |
| 2817 Fsetcar (alist, Fcar (el)); | |
| 2818 Fsetcar (el, Fcdr (el)); | |
| 2819 Fsetcdr (el, Fcdr (alist)); | |
| 2820 Fsetcdr (alist, el); | |
| 2821 alist = Fcdr (Fcdr (alist)); | |
| 2822 } | |
| 2823 | |
| 2824 return head; | |
| 2825 } | |
| 2826 | |
| 2827 DEFUN ("get", Fget, 2, 3, 0, /* | |
| 442 | 2828 Return the value of OBJECT's PROPERTY property. |
| 2829 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. | |
| 428 | 2830 If there is no such property, return optional third arg DEFAULT |
| 442 | 2831 \(which defaults to `nil'). OBJECT can be a symbol, string, extent, |
| 2832 face, or glyph. See also `put', `remprop', and `object-plist'. | |
| 428 | 2833 */ |
| 442 | 2834 (object, property, default_)) |
| 428 | 2835 { |
| 2836 /* Various places in emacs call Fget() and expect it not to quit, | |
| 2837 so don't quit. */ | |
| 442 | 2838 Lisp_Object val; |
| 2839 | |
| 2840 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop) | |
| 2841 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property); | |
| 428 | 2842 else |
| 563 | 2843 invalid_operation ("Object type has no properties", object); |
| 442 | 2844 |
| 2845 return UNBOUNDP (val) ? default_ : val; | |
| 428 | 2846 } |
| 2847 | |
| 2848 DEFUN ("put", Fput, 3, 3, 0, /* | |
| 442 | 2849 Set OBJECT's PROPERTY to VALUE. |
| 2850 It can be subsequently retrieved with `(get OBJECT PROPERTY)'. | |
| 2851 OBJECT can be a symbol, face, extent, or string. | |
| 428 | 2852 For a string, no properties currently have predefined meanings. |
| 2853 For the predefined properties for extents, see `set-extent-property'. | |
| 2854 For the predefined properties for faces, see `set-face-property'. | |
| 2855 See also `get', `remprop', and `object-plist'. | |
| 2856 */ | |
| 442 | 2857 (object, property, value)) |
| 428 | 2858 { |
| 1920 | 2859 /* This function cannot GC */ |
| 428 | 2860 CHECK_LISP_WRITEABLE (object); |
| 2861 | |
| 442 | 2862 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop) |
| 428 | 2863 { |
| 442 | 2864 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop |
| 2865 (object, property, value)) | |
| 563 | 2866 invalid_change ("Can't set property on object", property); |
| 428 | 2867 } |
| 2868 else | |
| 563 | 2869 invalid_change ("Object type has no settable properties", object); |
| 428 | 2870 |
| 2871 return value; | |
| 2872 } | |
| 2873 | |
| 2874 DEFUN ("remprop", Fremprop, 2, 2, 0, /* | |
| 442 | 2875 Remove, from OBJECT's property list, PROPERTY and its corresponding value. |
| 2876 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil | |
| 2877 if the property list was actually modified (i.e. if PROPERTY was present | |
| 2878 in the property list). See also `get', `put', and `object-plist'. | |
| 428 | 2879 */ |
| 442 | 2880 (object, property)) |
| 428 | 2881 { |
| 442 | 2882 int ret = 0; |
| 2883 | |
| 428 | 2884 CHECK_LISP_WRITEABLE (object); |
| 2885 | |
| 442 | 2886 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop) |
| 428 | 2887 { |
| 442 | 2888 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property); |
| 2889 if (ret == -1) | |
| 563 | 2890 invalid_change ("Can't remove property from object", property); |
| 428 | 2891 } |
| 2892 else | |
| 563 | 2893 invalid_change ("Object type has no removable properties", object); |
| 442 | 2894 |
| 2895 return ret ? Qt : Qnil; | |
| 428 | 2896 } |
| 2897 | |
| 2898 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /* | |
| 442 | 2899 Return a property list of OBJECT's properties. |
| 2900 For a symbol, this is equivalent to `symbol-plist'. | |
| 2901 OBJECT can be a symbol, string, extent, face, or glyph. | |
| 2902 Do not modify the returned property list directly; | |
| 2903 this may or may not have the desired effects. Use `put' instead. | |
| 428 | 2904 */ |
| 2905 (object)) | |
| 2906 { | |
| 442 | 2907 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist) |
| 2908 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object); | |
| 428 | 2909 else |
| 563 | 2910 invalid_operation ("Object type has no properties", object); |
| 428 | 2911 |
| 2912 return Qnil; | |
| 2913 } | |
| 2914 | |
| 2915 | |
| 853 | 2916 static Lisp_Object |
| 2917 tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2, | |
| 2918 Lisp_Object depth) | |
| 2919 { | |
| 2920 return make_int (internal_equal (obj1, obj2, XINT (depth))); | |
| 2921 } | |
| 2922 | |
| 2923 int | |
| 2924 internal_equal_trapping_problems (Lisp_Object warning_class, | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
2925 const Ascbyte *warning_string, |
| 853 | 2926 int flags, |
| 2927 struct call_trapping_problems_result *p, | |
| 2928 int retval, | |
| 2929 Lisp_Object obj1, Lisp_Object obj2, | |
| 2930 int depth) | |
| 2931 { | |
| 2932 Lisp_Object glorp = | |
| 2933 va_call_trapping_problems (warning_class, warning_string, | |
| 2934 flags, p, | |
| 2935 (lisp_fn_t) tweaked_internal_equal, | |
| 2936 3, obj1, obj2, make_int (depth)); | |
| 2937 if (UNBOUNDP (glorp)) | |
| 2938 return retval; | |
| 2939 else | |
| 2940 return XINT (glorp); | |
| 2941 } | |
| 2942 | |
| 428 | 2943 int |
| 2944 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2945 { | |
| 2946 if (depth > 200) | |
| 563 | 2947 stack_overflow ("Stack overflow in equal", Qunbound); |
| 428 | 2948 QUIT; |
| 2949 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) | |
| 2950 return 1; | |
| 2951 /* Note that (equal 20 20.0) should be nil */ | |
| 2952 if (XTYPE (obj1) != XTYPE (obj2)) | |
| 2953 return 0; | |
| 2954 if (LRECORDP (obj1)) | |
| 2955 { | |
| 442 | 2956 const struct lrecord_implementation |
| 428 | 2957 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), |
| 2958 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
| 2959 | |
| 2960 return (imp1 == imp2) && | |
| 2961 /* EQ-ness of the objects was noticed above */ | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2962 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0)); |
| 428 | 2963 } |
| 2964 | |
| 2965 return 0; | |
| 2966 } | |
| 2967 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2968 enum array_type |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2969 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2970 ARRAY_NONE = 0, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2971 ARRAY_STRING, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2972 ARRAY_VECTOR, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2973 ARRAY_BIT_VECTOR |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2974 }; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2975 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2976 static enum array_type |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2977 array_type (Lisp_Object obj) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2978 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2979 if (STRINGP (obj)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2980 return ARRAY_STRING; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2981 if (VECTORP (obj)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2982 return ARRAY_VECTOR; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2983 if (BIT_VECTORP (obj)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2984 return ARRAY_BIT_VECTOR; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2985 return ARRAY_NONE; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2986 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2987 |
| 801 | 2988 int |
| 2989 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2990 { | |
| 2991 if (depth > 200) | |
| 2992 stack_overflow ("Stack overflow in equalp", Qunbound); | |
| 2993 QUIT; | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2994 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2995 /* 1. Objects that are `eq' are equal. This will catch the common case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2996 of two equal fixnums or the same object seen twice. */ |
| 801 | 2997 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) |
| 2998 return 1; | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2999 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3000 /* 2. If both numbers, compare with `='. */ |
| 1983 | 3001 if (NUMBERP (obj1) && NUMBERP (obj2)) |
| 3002 { | |
|
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
3003 return (0 == bytecode_arithcompare (obj1, obj2)); |
| 1983 | 3004 } |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3005 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3006 /* 3. If characters, compare case-insensitively. */ |
| 801 | 3007 if (CHARP (obj1) && CHARP (obj2)) |
|
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
3008 return CANONCASE (0, XCHAR (obj1)) == CANONCASE (0, XCHAR (obj2)); |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3009 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3010 /* 4. If arrays of different types, compare their lengths, and |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3011 then compare element-by-element. */ |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3012 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3013 enum array_type artype1, artype2; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3014 artype1 = array_type (obj1); |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3015 artype2 = array_type (obj2); |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3016 if (artype1 != artype2 && artype1 && artype2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3017 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3018 EMACS_INT i; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3019 EMACS_INT l1 = XINT (Flength (obj1)); |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3020 EMACS_INT l2 = XINT (Flength (obj2)); |
|
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
3021 /* Both arrays, but of different lengths */ |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3022 if (l1 != l2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3023 return 0; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3024 for (i = 0; i < l1; i++) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3025 if (!internal_equalp (Faref (obj1, make_int (i)), |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3026 Faref (obj2, make_int (i)), depth + 1)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3027 return 0; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3028 return 1; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3029 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3030 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3031 /* 5. Else, they must be the same type. If so, call the equal() method, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3032 telling it to fold case. For objects that care about case-folding |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3033 their contents, the equal() method will call internal_equal_0(). */ |
| 801 | 3034 if (XTYPE (obj1) != XTYPE (obj2)) |
| 3035 return 0; | |
| 3036 if (LRECORDP (obj1)) | |
| 3037 { | |
| 3038 const struct lrecord_implementation | |
| 3039 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), | |
| 3040 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
| 3041 | |
| 3042 return (imp1 == imp2) && | |
| 3043 /* EQ-ness of the objects was noticed above */ | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3044 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1)); |
| 801 | 3045 } |
| 3046 | |
| 3047 return 0; | |
| 3048 } | |
| 3049 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3050 int |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3051 internal_equal_0 (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3052 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3053 if (foldcase) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3054 return internal_equalp (obj1, obj2, depth); |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3055 else |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3056 return internal_equal (obj1, obj2, depth); |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3057 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3058 |
| 428 | 3059 /* Note that we may be calling sub-objects that will use |
| 3060 internal_equal() (instead of internal_old_equal()). Oh well. | |
| 3061 We will get an Ebola note if there's any possibility of confusion, | |
| 3062 but that seems unlikely. */ | |
| 3063 | |
| 3064 static int | |
| 3065 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 3066 { | |
| 3067 if (depth > 200) | |
| 563 | 3068 stack_overflow ("Stack overflow in equal", Qunbound); |
| 428 | 3069 QUIT; |
| 3070 if (HACKEQ_UNSAFE (obj1, obj2)) | |
| 3071 return 1; | |
| 3072 /* Note that (equal 20 20.0) should be nil */ | |
| 3073 if (XTYPE (obj1) != XTYPE (obj2)) | |
| 3074 return 0; | |
| 3075 | |
| 3076 return internal_equal (obj1, obj2, depth); | |
| 3077 } | |
| 3078 | |
| 3079 DEFUN ("equal", Fequal, 2, 2, 0, /* | |
| 3080 Return t if two Lisp objects have similar structure and contents. | |
| 3081 They must have the same data type. | |
| 3082 Conses are compared by comparing the cars and the cdrs. | |
| 3083 Vectors and strings are compared element by element. | |
| 3084 Numbers are compared by value. Symbols must match exactly. | |
| 3085 */ | |
| 444 | 3086 (object1, object2)) |
| 428 | 3087 { |
| 444 | 3088 return internal_equal (object1, object2, 0) ? Qt : Qnil; |
| 428 | 3089 } |
| 3090 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3091 DEFUN ("equalp", Fequalp, 2, 2, 0, /* |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3092 Return t if two Lisp objects have similar structure and contents. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3093 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3094 This is like `equal', except that it accepts numerically equal |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3095 numbers of different types (float, integer, bignum, bigfloat), and also |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3096 compares strings and characters case-insensitively. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3097 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3098 Type objects that are arrays (that is, strings, bit-vectors, and vectors) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3099 of the same length and with contents that are `equalp' are themselves |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3100 `equalp', regardless of whether the two objects have the same type. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3101 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3102 Other objects whose primary purpose is as containers of other objects are |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3103 `equalp' if they would otherwise be equal (same length, type, etc.) and |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3104 their contents are `equalp'. This goes for conses, weak lists, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3105 weak boxes, ephemerons, specifiers, hash tables, char tables and range |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3106 tables. However, objects that happen to contain other objects but are not |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3107 primarily designed for this purpose (e.g. compiled functions, events or |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3108 display-related objects such as glyphs, faces or extents) are currently |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3109 compared using `equalp' the same way as using `equal'. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3110 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3111 More specifically, two hash tables are `equalp' if they have the same test |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3112 (see `hash-table-test'), the same number of entries, and the same value for |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3113 `hash-table-weakness', and if, for each entry in one hash table, its key is |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3114 equivalent to a key in the other hash table using the hash table test, and |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3115 its value is `equalp' to the other hash table's value for that key. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3116 */ |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3117 (object1, object2)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3118 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3119 return internal_equalp (object1, object2, 0) ? Qt : Qnil; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3120 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3121 |
| 428 | 3122 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* |
| 3123 Return t if two Lisp objects have similar structure and contents. | |
| 3124 They must have the same data type. | |
| 3125 \(Note, however, that an exception is made for characters and integers; | |
| 3126 this is known as the "char-int confoundance disease." See `eq' and | |
| 3127 `old-eq'.) | |
| 3128 This function is provided only for byte-code compatibility with v19. | |
| 3129 Do not use it. | |
| 3130 */ | |
| 444 | 3131 (object1, object2)) |
| 428 | 3132 { |
| 444 | 3133 return internal_old_equal (object1, object2, 0) ? Qt : Qnil; |
| 428 | 3134 } |
| 3135 | |
| 3136 | |
| 3137 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* | |
| 434 | 3138 Destructively modify ARRAY by replacing each element with ITEM. |
| 428 | 3139 ARRAY is a vector, bit vector, or string. |
| 3140 */ | |
| 3141 (array, item)) | |
| 3142 { | |
| 3143 retry: | |
| 3144 if (STRINGP (array)) | |
| 3145 { | |
| 793 | 3146 Bytecount old_bytecount = XSTRING_LENGTH (array); |
| 434 | 3147 Bytecount new_bytecount; |
| 3148 Bytecount item_bytecount; | |
| 867 | 3149 Ibyte item_buf[MAX_ICHAR_LEN]; |
| 3150 Ibyte *p; | |
| 3151 Ibyte *end; | |
| 434 | 3152 |
| 428 | 3153 CHECK_CHAR_COERCE_INT (item); |
| 2720 | 3154 |
| 428 | 3155 CHECK_LISP_WRITEABLE (array); |
| 771 | 3156 sledgehammer_check_ascii_begin (array); |
| 867 | 3157 item_bytecount = set_itext_ichar (item_buf, XCHAR (item)); |
| 826 | 3158 new_bytecount = item_bytecount * (Bytecount) string_char_length (array); |
| 793 | 3159 |
| 3160 resize_string (array, -1, new_bytecount - old_bytecount); | |
| 3161 | |
| 3162 for (p = XSTRING_DATA (array), end = p + new_bytecount; | |
| 434 | 3163 p < end; |
| 3164 p += item_bytecount) | |
| 3165 memcpy (p, item_buf, item_bytecount); | |
| 3166 *p = '\0'; | |
| 3167 | |
| 793 | 3168 XSET_STRING_ASCII_BEGIN (array, |
| 3169 item_bytecount == 1 ? | |
| 3170 min (new_bytecount, MAX_STRING_ASCII_BEGIN) : | |
| 3171 0); | |
| 428 | 3172 bump_string_modiff (array); |
| 771 | 3173 sledgehammer_check_ascii_begin (array); |
| 428 | 3174 } |
| 3175 else if (VECTORP (array)) | |
| 3176 { | |
| 3177 Lisp_Object *p = XVECTOR_DATA (array); | |
| 665 | 3178 Elemcount len = XVECTOR_LENGTH (array); |
| 428 | 3179 CHECK_LISP_WRITEABLE (array); |
| 3180 while (len--) | |
| 3181 *p++ = item; | |
| 3182 } | |
| 3183 else if (BIT_VECTORP (array)) | |
| 3184 { | |
| 440 | 3185 Lisp_Bit_Vector *v = XBIT_VECTOR (array); |
| 665 | 3186 Elemcount len = bit_vector_length (v); |
| 428 | 3187 int bit; |
| 3188 CHECK_BIT (item); | |
| 444 | 3189 bit = XINT (item); |
| 428 | 3190 CHECK_LISP_WRITEABLE (array); |
| 3191 while (len--) | |
| 3192 set_bit_vector_bit (v, len, bit); | |
| 3193 } | |
| 3194 else | |
| 3195 { | |
| 3196 array = wrong_type_argument (Qarrayp, array); | |
| 3197 goto retry; | |
| 3198 } | |
| 3199 return array; | |
| 3200 } | |
| 3201 | |
| 3202 Lisp_Object | |
| 3203 nconc2 (Lisp_Object arg1, Lisp_Object arg2) | |
| 3204 { | |
| 3205 Lisp_Object args[2]; | |
| 3206 struct gcpro gcpro1; | |
| 3207 args[0] = arg1; | |
| 3208 args[1] = arg2; | |
| 3209 | |
| 3210 GCPRO1 (args[0]); | |
| 3211 gcpro1.nvars = 2; | |
| 3212 | |
| 3213 RETURN_UNGCPRO (bytecode_nconc2 (args)); | |
| 3214 } | |
| 3215 | |
| 3216 Lisp_Object | |
| 3217 bytecode_nconc2 (Lisp_Object *args) | |
| 3218 { | |
| 3219 retry: | |
| 3220 | |
| 3221 if (CONSP (args[0])) | |
| 3222 { | |
| 3223 /* (setcdr (last args[0]) args[1]) */ | |
| 3224 Lisp_Object tortoise, hare; | |
| 665 | 3225 Elemcount count; |
| 428 | 3226 |
| 3227 for (hare = tortoise = args[0], count = 0; | |
| 3228 CONSP (XCDR (hare)); | |
| 3229 hare = XCDR (hare), count++) | |
| 3230 { | |
| 3231 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 3232 | |
| 3233 if (count & 1) | |
| 3234 tortoise = XCDR (tortoise); | |
| 3235 if (EQ (hare, tortoise)) | |
| 3236 signal_circular_list_error (args[0]); | |
| 3237 } | |
| 3238 XCDR (hare) = args[1]; | |
| 3239 return args[0]; | |
| 3240 } | |
| 3241 else if (NILP (args[0])) | |
| 3242 { | |
| 3243 return args[1]; | |
| 3244 } | |
| 3245 else | |
| 3246 { | |
| 3247 args[0] = wrong_type_argument (args[0], Qlistp); | |
| 3248 goto retry; | |
| 3249 } | |
| 3250 } | |
| 3251 | |
| 3252 DEFUN ("nconc", Fnconc, 0, MANY, 0, /* | |
| 3253 Concatenate any number of lists by altering them. | |
| 3254 Only the last argument is not altered, and need not be a list. | |
| 3255 Also see: `append'. | |
| 3256 If the first argument is nil, there is no way to modify it by side | |
| 3257 effect; therefore, write `(setq foo (nconc foo list))' to be sure of | |
| 3258 changing the value of `foo'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
3259 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
3260 arguments: (&rest ARGS) |
| 428 | 3261 */ |
| 3262 (int nargs, Lisp_Object *args)) | |
| 3263 { | |
| 3264 int argnum = 0; | |
| 3265 struct gcpro gcpro1; | |
| 3266 | |
| 3267 /* The modus operandi in Emacs is "caller gc-protects args". | |
| 3268 However, nconc (particularly nconc2 ()) is called many times | |
| 3269 in Emacs on freshly created stuff (e.g. you see the idiom | |
| 3270 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those | |
| 3271 callers out by protecting the args ourselves to save them | |
| 3272 a lot of temporary-variable grief. */ | |
| 3273 | |
| 3274 GCPRO1 (args[0]); | |
| 3275 gcpro1.nvars = nargs; | |
| 3276 | |
| 3277 while (argnum < nargs) | |
| 3278 { | |
| 3279 Lisp_Object val; | |
| 3280 retry: | |
| 3281 val = args[argnum]; | |
| 3282 if (CONSP (val)) | |
| 3283 { | |
| 3284 /* `val' is the first cons, which will be our return value. */ | |
| 3285 /* `last_cons' will be the cons cell to mutate. */ | |
| 3286 Lisp_Object last_cons = val; | |
| 3287 Lisp_Object tortoise = val; | |
| 3288 | |
| 3289 for (argnum++; argnum < nargs; argnum++) | |
| 3290 { | |
| 3291 Lisp_Object next = args[argnum]; | |
| 3292 retry_next: | |
| 3293 if (CONSP (next) || argnum == nargs -1) | |
| 3294 { | |
| 3295 /* (setcdr (last val) next) */ | |
| 665 | 3296 Elemcount count; |
| 428 | 3297 |
| 3298 for (count = 0; | |
| 3299 CONSP (XCDR (last_cons)); | |
| 3300 last_cons = XCDR (last_cons), count++) | |
| 3301 { | |
| 3302 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 3303 | |
| 3304 if (count & 1) | |
| 3305 tortoise = XCDR (tortoise); | |
| 3306 if (EQ (last_cons, tortoise)) | |
| 3307 signal_circular_list_error (args[argnum-1]); | |
| 3308 } | |
| 3309 XCDR (last_cons) = next; | |
| 3310 } | |
| 3311 else if (NILP (next)) | |
| 3312 { | |
| 3313 continue; | |
| 3314 } | |
| 3315 else | |
| 3316 { | |
| 3317 next = wrong_type_argument (Qlistp, next); | |
| 3318 goto retry_next; | |
| 3319 } | |
| 3320 } | |
| 3321 RETURN_UNGCPRO (val); | |
| 3322 } | |
| 3323 else if (NILP (val)) | |
| 3324 argnum++; | |
| 3325 else if (argnum == nargs - 1) /* last arg? */ | |
| 3326 RETURN_UNGCPRO (val); | |
| 3327 else | |
| 3328 { | |
| 3329 args[argnum] = wrong_type_argument (Qlistp, val); | |
| 3330 goto retry; | |
| 3331 } | |
| 3332 } | |
| 3333 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ | |
| 3334 } | |
| 3335 | |
| 3336 | |
| 434 | 3337 /* This is the guts of several mapping functions. |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3338 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3339 Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time, |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3340 taking the elements from SEQUENCES. If VALS is non-NULL, store the |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3341 results into VALS, a C array of Lisp_Objects; else, if LISP_VALS is |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3342 non-nil, store the results into LISP_VALS, a sequence with sufficient |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3343 room for CALL_COUNT results (but see the documentation of SOME_OR_EVERY.) |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3344 Else, do not accumulate any result. |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3345 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3346 If VALS is non-NULL, NSEQUENCES is one, and SEQUENCES[0] is a cons, |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3347 mapcarX will store the elements of SEQUENCES[0] in stack and GCPRO them, |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3348 so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3349 mapcarX. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3350 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3351 Otherwise, mapcarX signals a wrong-type-error if it encounters a |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3352 non-cons, non-array when traversing SEQUENCES. Common Lisp specifies in |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3353 MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3354 destructively modifies SEQUENCES in a way that might affect the ongoing |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3355 traversal operation. |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3356 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3357 If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3358 values given by FUNCTION the first time it is non-nil, and abandon the |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3359 iterations. LISP_VALS must be a cons, and the return value will be |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3360 stored in its car. If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3361 in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it |
|
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3362 alone. */ |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3363 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3364 #define SOME_OR_EVERY_NEITHER 0 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3365 #define SOME_OR_EVERY_SOME 1 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3366 #define SOME_OR_EVERY_EVERY 2 |
| 428 | 3367 |
| 3368 static void | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3369 mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals, |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3370 Lisp_Object function, int nsequences, Lisp_Object *sequences, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3371 int some_or_every) |
| 428 | 3372 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3373 Lisp_Object called, *args; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3374 struct gcpro gcpro1, gcpro2; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3375 int i, j; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3376 enum lrecord_type lisp_vals_type; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3377 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3378 assert (LRECORDP (lisp_vals)); |
| 4999 | 3379 lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3380 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3381 args = alloca_array (Lisp_Object, nsequences + 1); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3382 args[0] = function; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3383 for (i = 1; i <= nsequences; ++i) |
| 428 | 3384 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3385 args[i] = Qnil; |
| 428 | 3386 } |
| 3387 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3388 if (vals != NULL) |
| 428 | 3389 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3390 GCPRO2 (args[0], vals[0]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3391 gcpro1.nvars = nsequences + 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3392 gcpro2.nvars = 0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3393 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3394 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3395 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3396 GCPRO1 (args[0]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3397 gcpro1.nvars = nsequences + 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3398 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3399 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3400 /* Be extra nice in the event that we've been handed one list and one |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3401 only; make it possible for FUNCTION to set cdrs not yet processed to |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3402 non-cons, non-nil objects without ill-effect, if we have been handed |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3403 the stack space to do that. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3404 if (vals != NULL && 1 == nsequences && CONSP (sequences[0])) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3405 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3406 Lisp_Object lst = sequences[0]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3407 Lisp_Object *val = vals; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3408 for (i = 0; i < call_count; ++i) |
| 434 | 3409 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3410 *val++ = XCAR (lst); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3411 lst = XCDR (lst); |
| 428 | 3412 } |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3413 gcpro2.nvars = call_count; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3414 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3415 for (i = 0; i < call_count; ++i) |
| 428 | 3416 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3417 args[1] = vals[i]; |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3418 vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args)); |
| 428 | 3419 } |
| 3420 } | |
| 3421 else | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3422 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3423 Binbyte *sequence_types = alloca_array (Binbyte, nsequences); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3424 for (j = 0; j < nsequences; ++j) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3425 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3426 sequence_types[j] = XRECORD_LHEADER (sequences[j])->type; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3427 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3428 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3429 for (i = 0; i < call_count; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3430 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3431 for (j = 0; j < nsequences; ++j) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3432 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3433 switch (sequence_types[j]) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3434 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3435 case lrecord_type_cons: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3436 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3437 if (!CONSP (sequences[j])) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3438 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3439 /* This means FUNCTION has probably messed |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3440 around with a cons in one of the sequences, |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3441 since we checked the type |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3442 (CHECK_SEQUENCE()) and the length and |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3443 structure (with Flength()) correctly in our |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3444 callers. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3445 dead_wrong_type_argument (Qconsp, sequences[j]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3446 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3447 args[j + 1] = XCAR (sequences[j]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3448 sequences[j] = XCDR (sequences[j]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3449 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3450 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3451 case lrecord_type_vector: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3452 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3453 args[j + 1] = XVECTOR_DATA (sequences[j])[i]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3454 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3455 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3456 case lrecord_type_string: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3457 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3458 args[j + 1] = make_char (string_ichar (sequences[j], i)); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3459 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3460 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3461 case lrecord_type_bit_vector: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3462 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3463 args[j + 1] |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3464 = make_int (bit_vector_bit (XBIT_VECTOR (sequences[j]), |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3465 i)); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3466 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3467 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3468 default: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3469 ABORT(); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3470 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3471 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3472 called = Ffuncall (nsequences + 1, args); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3473 if (vals != NULL) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3474 { |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3475 vals[i] = IGNORE_MULTIPLE_VALUES (called); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3476 gcpro2.nvars += 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3477 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3478 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3479 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3480 switch (lisp_vals_type) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3481 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3482 case lrecord_type_symbol: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3483 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3484 case lrecord_type_cons: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3485 { |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3486 if (SOME_OR_EVERY_NEITHER == some_or_every) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3487 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3488 called = IGNORE_MULTIPLE_VALUES (called); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3489 if (!CONSP (lisp_vals)) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3490 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3491 /* If FUNCTION has inserted a non-cons non-nil |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3492 cdr into the list before we've processed the |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3493 relevant part, error. */ |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3494 dead_wrong_type_argument (Qconsp, lisp_vals); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3495 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3496 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3497 XSETCAR (lisp_vals, called); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3498 lisp_vals = XCDR (lisp_vals); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3499 break; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3500 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3501 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3502 if (SOME_OR_EVERY_SOME == some_or_every) |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3503 { |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3504 if (!NILP (IGNORE_MULTIPLE_VALUES (called))) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3505 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3506 XCAR (lisp_vals) = called; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3507 UNGCPRO; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3508 return; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3509 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3510 break; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3511 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3512 |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3513 if (SOME_OR_EVERY_EVERY == some_or_every) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3514 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3515 called = IGNORE_MULTIPLE_VALUES (called); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3516 if (NILP (called)) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3517 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3518 XCAR (lisp_vals) = Qnil; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3519 UNGCPRO; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3520 return; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3521 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3522 break; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3523 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3524 |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3525 goto bad_some_or_every_flag; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3526 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3527 case lrecord_type_vector: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3528 { |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3529 called = IGNORE_MULTIPLE_VALUES (called); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3530 i < XVECTOR_LENGTH (lisp_vals) ? |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3531 (XVECTOR_DATA (lisp_vals)[i] = called) : |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3532 /* Let #'aset error. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3533 Faset (lisp_vals, make_int (i), called); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3534 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3535 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3536 case lrecord_type_string: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3537 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3538 /* If this ever becomes a code hotspot, we can keep |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3539 around pointers into the data of the string, checking |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3540 each time that it hasn't been relocated. */ |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3541 called = IGNORE_MULTIPLE_VALUES (called); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3542 Faset (lisp_vals, make_int (i), called); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3543 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3544 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3545 case lrecord_type_bit_vector: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3546 { |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3547 called = IGNORE_MULTIPLE_VALUES (called); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3548 (BITP (called) && |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3549 i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ? |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3550 set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i, |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3551 XINT (called)) : |
|
5002
0cd784a6ec44
fix some compile bugs of Aidan's
Ben Wing <ben@xemacs.org>
parents:
5001
diff
changeset
|
3552 (void) Faset (lisp_vals, make_int (i), called); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3553 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3554 } |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5002
diff
changeset
|
3555 bad_some_or_every_flag: |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3556 default: |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3557 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3558 ABORT(); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3559 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3560 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3561 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3562 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3563 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3564 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3565 UNGCPRO; |
| 428 | 3566 } |
| 3567 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3568 DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3569 Call FUNCTION on each element of SEQUENCE, and concat results to a string. |
| 751 | 3570 Between each pair of results, insert SEPARATOR. |
| 3571 | |
| 3572 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR | |
| 3573 results in spaces between the values returned by FUNCTION. SEQUENCE itself | |
| 3574 may be a list, a vector, a bit vector, or a string. | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3575 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3576 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3577 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3578 from each sequence will be used each time FUNCTION is called, and |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3579 `mapconcat' will give up once the shortest sequence is exhausted. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3580 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3581 arguments: (FUNCTION SEQUENCE SEPARATOR &rest SEQUENCES) |
| 428 | 3582 */ |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3583 (int nargs, Lisp_Object *args)) |
| 428 | 3584 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3585 Lisp_Object function = args[0]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3586 Lisp_Object sequence = args[1]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3587 Lisp_Object separator = args[2]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3588 Elemcount len = EMACS_INT_MAX; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3589 Lisp_Object *args0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3590 EMACS_INT i, nargs0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3591 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3592 args[2] = sequence; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3593 args[1] = separator; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3594 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3595 for (i = 2; i < nargs; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3596 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3597 CHECK_SEQUENCE (args[i]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3598 len = min (len, XINT (Flength (args[i]))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3599 } |
| 428 | 3600 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3601 if (len == 0) return build_ascstring (""); |
| 428 | 3602 |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3603 nargs0 = len + len - 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3604 args0 = alloca_array (Lisp_Object, nargs0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3605 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3606 /* Special-case this, it's very common and doesn't require any |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3607 funcalls. Upside of doing it here, instead of cl-macs.el: no consing, |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3608 apart from the final string, we allocate everything on the stack. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3609 if (EQ (function, Qidentity) && 3 == nargs && CONSP (sequence)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3610 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3611 for (i = 0; i < len; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3612 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3613 args0[i] = XCAR (sequence); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3614 sequence = XCDR (sequence); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3615 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3616 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3617 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3618 { |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3619 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3620 SOME_OR_EVERY_NEITHER); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3621 } |
| 428 | 3622 |
| 3623 for (i = len - 1; i >= 0; i--) | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3624 args0[i + i] = args0[i]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3625 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3626 for (i = 1; i < nargs0; i += 2) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3627 args0[i] = separator; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3628 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3629 return Fconcat (nargs0, args0); |
| 428 | 3630 } |
| 3631 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3632 DEFUN ("mapcar*", FmapcarX, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3633 Call FUNCTION on each element of SEQUENCE; return a list of the results. |
| 434 | 3634 The result is a list of the same length as SEQUENCE. |
| 428 | 3635 SEQUENCE may be a list, a vector, a bit vector, or a string. |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3636 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3637 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3638 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3639 from each sequence will be used each time FUNCTION is called, and `mapcar' |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3640 stops calling FUNCTION once the shortest sequence is exhausted. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3641 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3642 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
| 428 | 3643 */ |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3644 (int nargs, Lisp_Object *args)) |
| 428 | 3645 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3646 Lisp_Object function = args[0]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3647 Elemcount len = EMACS_INT_MAX; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3648 Lisp_Object *args0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3649 int i; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3650 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3651 for (i = 1; i < nargs; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3652 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3653 CHECK_SEQUENCE (args[i]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3654 len = min (len, XINT (Flength (args[i]))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3655 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3656 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3657 args0 = alloca_array (Lisp_Object, len); |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3658 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3659 SOME_OR_EVERY_NEITHER); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3660 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3661 return Flist ((int) len, args0); |
| 428 | 3662 } |
| 3663 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3664 DEFUN ("mapvector", Fmapvector, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3665 Call FUNCTION on each element of SEQUENCE; return a vector of the results. |
| 428 | 3666 The result is a vector of the same length as SEQUENCE. |
| 434 | 3667 SEQUENCE may be a list, a vector, a bit vector, or a string. |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3668 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3669 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3670 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3671 from each sequence will be used each time FUNCTION is called, and |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3672 `mapvector' stops calling FUNCTION once the shortest sequence is exhausted. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3673 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3674 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
| 428 | 3675 */ |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3676 (int nargs, Lisp_Object *args)) |
| 428 | 3677 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3678 Lisp_Object function = args[0]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3679 Elemcount len = EMACS_INT_MAX; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3680 Lisp_Object result; |
| 428 | 3681 struct gcpro gcpro1; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3682 int i; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3683 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3684 for (i = 1; i < nargs; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3685 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3686 CHECK_SEQUENCE (args[i]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3687 len = min (len, XINT (Flength (args[i]))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3688 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3689 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3690 result = make_vector (len, Qnil); |
| 428 | 3691 GCPRO1 (result); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3692 /* Don't pass result as the lisp_object argument, we want mapcarX to protect |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3693 a single list argument's elements from being garbage-collected. */ |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3694 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3695 SOME_OR_EVERY_NEITHER); |
| 428 | 3696 UNGCPRO; |
| 3697 | |
| 3698 return result; | |
| 3699 } | |
| 3700 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3701 DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3702 Call FUNCTION on each element of SEQUENCE; chain the results together. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3703 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3704 FUNCTION must normally return a list; the results will be concatenated |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3705 together using `nconc'. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3706 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3707 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3708 there are SEQUENCES, plus one for the element from SEQUENCE. One element |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3709 from each sequence will be used each time FUNCTION is called, and |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3710 `mapcan' stops calling FUNCTION once the shortest sequence is exhausted. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3711 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3712 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3713 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3714 (int nargs, Lisp_Object *args)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3715 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3716 Lisp_Object function = args[0], nconcing; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3717 Elemcount len = EMACS_INT_MAX; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3718 Lisp_Object *args0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3719 struct gcpro gcpro1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3720 int i; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3721 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3722 for (i = 1; i < nargs; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3723 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3724 CHECK_SEQUENCE (args[i]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3725 len = min (len, XINT (Flength (args[i]))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3726 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3727 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3728 args0 = alloca_array (Lisp_Object, len + 1); |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3729 mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3730 SOME_OR_EVERY_NEITHER); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3731 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3732 if (len < 2) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3733 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3734 return len ? args0[1] : Qnil; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3735 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3736 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3737 /* bytecode_nconc2 can signal and return, we need to GCPRO the args, since |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3738 mapcarX is no longer doing this for us. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3739 args0[0] = Fcons (Qnil, Qnil); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3740 GCPRO1 (args0[0]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3741 gcpro1.nvars = len + 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3742 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3743 for (i = 0; i < len; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3744 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3745 nconcing = bytecode_nconc2 (args0 + i); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3746 args0[i + 1] = nconcing; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3747 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3748 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3749 RETURN_UNGCPRO (XCDR (nconcing)); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3750 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3751 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3752 DEFUN ("mapc", Fmapc, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3753 Call FUNCTION on each element of SEQUENCE. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3754 |
| 428 | 3755 SEQUENCE may be a list, a vector, a bit vector, or a string. |
| 3756 This function is like `mapcar' but does not accumulate the results, | |
| 3757 which is more efficient if you do not use the results. | |
| 3758 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3759 With optional SEQUENCES, call FUNCTION each time with as many arguments as |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3760 there are SEQUENCES, plus one for the elements from SEQUENCE. One element |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3761 from each sequence will be used each time FUNCTION is called, and |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3762 `mapc' stops calling FUNCTION once the shortest sequence is exhausted. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3763 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3764 Return SEQUENCE. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3765 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3766 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3767 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3768 (int nargs, Lisp_Object *args)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3769 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3770 Elemcount len = EMACS_INT_MAX; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3771 Lisp_Object sequence = args[1]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3772 struct gcpro gcpro1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3773 int i; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3774 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3775 for (i = 1; i < nargs; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3776 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3777 CHECK_SEQUENCE (args[i]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3778 len = min (len, XINT (Flength (args[i]))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3779 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3780 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3781 /* We need to GCPRO sequence, because mapcarX will modify the |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3782 elements of the args array handed to it, and this may involve |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3783 elements of sequence getting garbage collected. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3784 GCPRO1 (sequence); |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3785 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3786 SOME_OR_EVERY_NEITHER); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3787 RETURN_UNGCPRO (sequence); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3788 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3789 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3790 DEFUN ("map", Fmap, 3, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3791 Map FUNCTION across one or more sequences, returning a sequence. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3792 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3793 TYPE is the sequence type to return, FUNCTION is the function, SEQUENCE is |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3794 the first argument sequence, SEQUENCES are the other argument sequences. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3795 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3796 FUNCTION will be called with (1+ (length SEQUENCES)) arguments, and must be |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3797 capable of accepting this number of arguments. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3798 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3799 Certain TYPEs are recognised internally by `map', but others are not, and |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3800 `coerce' may throw an error on an attempt to convert to a TYPE it does not |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3801 understand. A null TYPE means do not accumulate any values. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3802 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3803 arguments: (TYPE FUNCTION SEQUENCE &rest SEQUENCES) |
| 428 | 3804 */ |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3805 (int nargs, Lisp_Object *args)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3806 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3807 Lisp_Object type = args[0]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3808 Lisp_Object function = args[1]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3809 Lisp_Object result = Qnil; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3810 Lisp_Object *args0 = NULL; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3811 Elemcount len = EMACS_INT_MAX; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3812 int i; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3813 struct gcpro gcpro1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3814 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3815 for (i = 2; i < nargs; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3816 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3817 CHECK_SEQUENCE (args[i]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3818 len = min (len, XINT (Flength (args[i]))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3819 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3820 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3821 if (!NILP (type)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3822 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3823 args0 = alloca_array (Lisp_Object, len); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3824 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3825 |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3826 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3827 SOME_OR_EVERY_NEITHER); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3828 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3829 if (EQ (type, Qnil)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3830 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3831 return result; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3832 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3833 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3834 if (EQ (type, Qvector) || EQ (type, Qarray)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3835 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3836 result = Fvector (len, args0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3837 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3838 else if (EQ (type, Qstring)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3839 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3840 result = Fstring (len, args0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3841 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3842 else if (EQ (type, Qlist)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3843 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3844 result = Flist (len, args0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3845 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3846 else if (EQ (type, Qbit_vector)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3847 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3848 result = Fbit_vector (len, args0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3849 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3850 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3851 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3852 result = Flist (len, args0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3853 GCPRO1 (result); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3854 result = call2 (Qcoerce, result, type); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3855 UNGCPRO; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3856 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3857 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3858 return result; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3859 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3860 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3861 DEFUN ("map-into", Fmap_into, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3862 Modify RESULT-SEQUENCE using the return values of FUNCTION on SEQUENCES. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3863 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3864 RESULT-SEQUENCE and SEQUENCES can be lists or arrays. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3865 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3866 FUNCTION must accept at least as many arguments as there are SEQUENCES |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3867 \(possibly zero). If RESULT-SEQUENCE and the elements of SEQUENCES are not |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3868 the same length, stop when the shortest is exhausted; any elements of |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3869 RESULT-SEQUENCE beyond that are unmodified. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3870 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3871 Return RESULT-SEQUENCE. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3872 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3873 arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3874 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3875 (int nargs, Lisp_Object *args)) |
| 428 | 3876 { |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3877 Elemcount len = EMACS_INT_MAX; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3878 Lisp_Object result_sequence = args[0]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3879 Lisp_Object function = args[1]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3880 int i; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3881 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3882 args[0] = function; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3883 args[1] = result_sequence; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3884 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3885 for (i = 1; i < nargs; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3886 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3887 CHECK_SEQUENCE (args[i]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3888 len = min (len, XINT (Flength (args[i]))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3889 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3890 |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3891 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3892 SOME_OR_EVERY_NEITHER); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3893 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3894 return result_sequence; |
| 428 | 3895 } |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3896 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3897 DEFUN ("some", Fsome, 2, MANY, 0, /* |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3898 Return true if PREDICATE gives non-nil for an element of SEQUENCE. |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3899 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3900 If so, return the value (possibly multiple) given by PREDICATE. |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3901 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3902 With optional SEQUENCES, call PREDICATE each time with as many arguments as |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3903 there are SEQUENCES (plus one for the element from SEQUENCE). |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3904 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3905 arguments: (PREDICATE SEQUENCE &rest SEQUENCES) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3906 */ |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3907 (int nargs, Lisp_Object *args)) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3908 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3909 Lisp_Object result_box = Fcons (Qnil, Qnil); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3910 struct gcpro gcpro1; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3911 Elemcount len = EMACS_INT_MAX; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3912 int i; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3913 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3914 GCPRO1 (result_box); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3915 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3916 for (i = 1; i < nargs; ++i) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3917 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3918 CHECK_SEQUENCE (args[i]); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3919 len = min (len, XINT (Flength (args[i]))); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3920 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3921 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3922 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3923 SOME_OR_EVERY_SOME); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3924 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3925 RETURN_UNGCPRO (XCAR (result_box)); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3926 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3927 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3928 DEFUN ("every", Fevery, 2, MANY, 0, /* |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3929 Return true if PREDICATE is true of every element of SEQUENCE. |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3930 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3931 With optional SEQUENCES, call PREDICATE each time with as many arguments as |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3932 there are SEQUENCES (plus one for the element from SEQUENCE). |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3933 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3934 In contrast to `some', `every' never returns multiple values. |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3935 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3936 arguments: (PREDICATE SEQUENCE &rest SEQUENCES) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3937 */ |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3938 (int nargs, Lisp_Object *args)) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3939 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3940 Lisp_Object result_box = Fcons (Qt, Qnil); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3941 struct gcpro gcpro1; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3942 Elemcount len = EMACS_INT_MAX; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3943 int i; |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3944 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3945 GCPRO1 (result_box); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3946 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3947 for (i = 1; i < nargs; ++i) |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3948 { |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3949 CHECK_SEQUENCE (args[i]); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3950 len = min (len, XINT (Flength (args[i]))); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3951 } |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3952 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3953 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1, |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3954 SOME_OR_EVERY_EVERY); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3955 |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3956 RETURN_UNGCPRO (XCAR (result_box)); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
3957 } |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3958 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3959 /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3960 corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]), |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3961 until that #'nthcdr expression gives nil for some element of LISTS. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3962 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3963 If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3964 values from FUNCTION; if NCONCP is non-zero, nconc them together. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3965 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3966 In contrast to mapcarX, we don't require our callers to check LISTS for |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3967 well-formedness, we signal wrong-type-argument if it's not a list, or |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3968 circular-list if it's circular. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3969 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3970 static Lisp_Object |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3971 maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp, |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3972 int nconcp) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3973 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3974 Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3975 Lisp_Object nconcing[2], accum = result, *args; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3976 struct gcpro gcpro1, gcpro2, gcpro3; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3977 int i, j, continuing = (nlists > 0), called_count = 0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3978 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3979 args = alloca_array (Lisp_Object, nlists + 1); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3980 args[0] = function; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3981 for (i = 1; i <= nlists; ++i) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3982 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3983 args[i] = Qnil; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3984 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3985 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3986 if (nconcp) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3987 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3988 nconcing[0] = result; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3989 nconcing[1] = Qnil; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3990 GCPRO3 (args[0], nconcing[0], result); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3991 gcpro1.nvars = 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3992 gcpro2.nvars = 2; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3993 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3994 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3995 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3996 GCPRO2 (args[0], result); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3997 gcpro1.nvars = 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3998 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3999 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4000 while (continuing) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4001 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4002 for (j = 0; j < nlists; ++j) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4003 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4004 if (CONSP (lists[j])) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4005 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4006 args[j + 1] = lists[j]; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4007 lists[j] = XCDR (lists[j]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4008 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4009 else if (NILP (lists[j])) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4010 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4011 continuing = 0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4012 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4013 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4014 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4015 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4016 dead_wrong_type_argument (Qlistp, lists[j]); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4017 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4018 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4019 if (!continuing) break; |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
4020 funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args)); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4021 if (!maplp) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4022 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4023 if (nconcp) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4024 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4025 /* This order of calls means we check that each list is |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4026 well-formed once and once only. The last result does |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4027 not have to be a list. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4028 nconcing[1] = funcalled; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4029 nconcing[0] = bytecode_nconc2 (nconcing); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4030 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4031 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4032 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4033 /* Add to the end, avoiding the need to call nreverse |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4034 once we're done: */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4035 XSETCDR (accum, Fcons (funcalled, Qnil)); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4036 accum = XCDR (accum); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4037 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4038 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4039 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4040 if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4041 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4042 for (j = 0; j < nlists; ++j) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4043 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4044 EXTERNAL_LIST_LOOP_1 (lists[j]) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4045 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4046 /* Just check the lists aren't circular, using the |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4047 EXTERNAL_LIST_LOOP_1 macro. */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4048 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4049 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4050 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4051 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4052 if (!maplp) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4053 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4054 result = XCDR (result); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4055 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4056 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4057 RETURN_UNGCPRO (result); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4058 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4059 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4060 DEFUN ("maplist", Fmaplist, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4061 Call FUNCTION on each sublist of LIST and LISTS. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4062 Like `mapcar', except applies to lists and their cdr's rather than to |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4063 the elements themselves." |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4064 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4065 arguments: (FUNCTION LIST &rest LISTS) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4066 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4067 (int nargs, Lisp_Object *args)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4068 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4069 return maplist (args[0], nargs - 1, args + 1, 0, 0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4070 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4071 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4072 DEFUN ("mapl", Fmapl, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4073 Like `maplist', but do not accumulate values returned by the function. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4074 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4075 arguments: (FUNCTION LIST &rest LISTS) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4076 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4077 (int nargs, Lisp_Object *args)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4078 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4079 return maplist (args[0], nargs - 1, args + 1, 1, 0); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4080 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4081 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4082 DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /* |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4083 Like `maplist', but chains together the values returned by FUNCTION. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4084 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4085 FUNCTION must return a list (unless it happens to be the last |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4086 iteration); the results will be concatenated together using `nconc'. |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4087 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4088 arguments: (FUNCTION LIST &rest LISTS) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4089 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4090 (int nargs, Lisp_Object *args)) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4091 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4092 return maplist (args[0], nargs - 1, args + 1, 0, 1); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4093 } |
| 428 | 4094 |
| 771 | 4095 /* Extra random functions */ |
| 442 | 4096 |
| 4097 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /* | |
| 4098 Destructively replace the list OLD with NEW. | |
| 4099 This is like (copy-sequence NEW) except that it reuses the | |
| 4100 conses in OLD as much as possible. If OLD and NEW are the same | |
| 4101 length, no consing will take place. | |
| 4102 */ | |
| 3025 | 4103 (old, new_)) |
| 442 | 4104 { |
| 2367 | 4105 Lisp_Object oldtail = old, prevoldtail = Qnil; |
| 4106 | |
| 3025 | 4107 EXTERNAL_LIST_LOOP_2 (elt, new_) |
| 442 | 4108 { |
| 4109 if (!NILP (oldtail)) | |
| 4110 { | |
| 4111 CHECK_CONS (oldtail); | |
| 2367 | 4112 XCAR (oldtail) = elt; |
| 442 | 4113 } |
| 4114 else if (!NILP (prevoldtail)) | |
| 4115 { | |
| 2367 | 4116 XCDR (prevoldtail) = Fcons (elt, Qnil); |
| 442 | 4117 prevoldtail = XCDR (prevoldtail); |
| 4118 } | |
| 4119 else | |
| 2367 | 4120 old = oldtail = Fcons (elt, Qnil); |
| 442 | 4121 |
| 4122 if (!NILP (oldtail)) | |
| 4123 { | |
| 4124 prevoldtail = oldtail; | |
| 4125 oldtail = XCDR (oldtail); | |
| 4126 } | |
| 4127 } | |
| 4128 | |
| 4129 if (!NILP (prevoldtail)) | |
| 4130 XCDR (prevoldtail) = Qnil; | |
| 4131 else | |
| 4132 old = Qnil; | |
| 4133 | |
| 4134 return old; | |
| 4135 } | |
| 4136 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4137 |
| 771 | 4138 Lisp_Object |
| 2367 | 4139 add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) |
| 771 | 4140 { |
| 4141 return Fintern (concat2 (Fsymbol_name (symbol), | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
4142 build_ascstring (ascii_string)), |
| 771 | 4143 Qnil); |
| 4144 } | |
| 4145 | |
| 4146 Lisp_Object | |
| 2367 | 4147 add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol) |
| 771 | 4148 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
4149 return Fintern (concat2 (build_ascstring (ascii_string), |
| 771 | 4150 Fsymbol_name (symbol)), |
| 4151 Qnil); | |
| 4152 } | |
| 4153 | |
| 442 | 4154 |
| 428 | 4155 /* #### this function doesn't belong in this file! */ |
| 4156 | |
| 442 | 4157 #ifdef HAVE_GETLOADAVG |
| 4158 #ifdef HAVE_SYS_LOADAVG_H | |
| 4159 #include <sys/loadavg.h> | |
| 4160 #endif | |
| 4161 #else | |
| 4162 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */ | |
| 4163 #endif | |
| 4164 | |
| 428 | 4165 DEFUN ("load-average", Fload_average, 0, 1, 0, /* |
| 4166 Return list of 1 minute, 5 minute and 15 minute load averages. | |
| 4167 Each of the three load averages is multiplied by 100, | |
| 4168 then converted to integer. | |
| 4169 | |
| 4170 When USE-FLOATS is non-nil, floats will be used instead of integers. | |
| 4171 These floats are not multiplied by 100. | |
| 4172 | |
| 4173 If the 5-minute or 15-minute load averages are not available, return a | |
| 4174 shortened list, containing only those averages which are available. | |
| 4175 | |
| 4176 On some systems, this won't work due to permissions on /dev/kmem, | |
| 4177 in which case you can't use this. | |
| 4178 */ | |
| 4179 (use_floats)) | |
| 4180 { | |
| 4181 double load_ave[3]; | |
| 4182 int loads = getloadavg (load_ave, countof (load_ave)); | |
| 4183 Lisp_Object ret = Qnil; | |
| 4184 | |
| 4185 if (loads == -2) | |
| 563 | 4186 signal_error (Qunimplemented, |
| 4187 "load-average not implemented for this operating system", | |
| 4188 Qunbound); | |
| 428 | 4189 else if (loads < 0) |
| 563 | 4190 invalid_operation ("Could not get load-average", lisp_strerror (errno)); |
| 428 | 4191 |
| 4192 while (loads-- > 0) | |
| 4193 { | |
| 4194 Lisp_Object load = (NILP (use_floats) ? | |
| 4195 make_int ((int) (100.0 * load_ave[loads])) | |
| 4196 : make_float (load_ave[loads])); | |
| 4197 ret = Fcons (load, ret); | |
| 4198 } | |
| 4199 return ret; | |
| 4200 } | |
| 4201 | |
| 4202 | |
| 4203 Lisp_Object Vfeatures; | |
| 4204 | |
| 4205 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /* | |
| 4206 Return non-nil if feature FEXP is present in this Emacs. | |
| 4207 Use this to conditionalize execution of lisp code based on the | |
| 4208 presence or absence of emacs or environment extensions. | |
| 4209 FEXP can be a symbol, a number, or a list. | |
| 4210 If it is a symbol, that symbol is looked up in the `features' variable, | |
| 4211 and non-nil will be returned if found. | |
| 4212 If it is a number, the function will return non-nil if this Emacs | |
| 4213 has an equal or greater version number than FEXP. | |
| 4214 If it is a list whose car is the symbol `and', it will return | |
| 4215 non-nil if all the features in its cdr are non-nil. | |
| 4216 If it is a list whose car is the symbol `or', it will return non-nil | |
| 4217 if any of the features in its cdr are non-nil. | |
| 4218 If it is a list whose car is the symbol `not', it will return | |
| 4219 non-nil if the feature is not present. | |
| 4220 | |
| 4221 Examples: | |
| 4222 | |
| 4223 (featurep 'xemacs) | |
| 4224 => ; Non-nil on XEmacs. | |
| 4225 | |
| 4226 (featurep '(and xemacs gnus)) | |
| 4227 => ; Non-nil on XEmacs with Gnus loaded. | |
| 4228 | |
| 4229 (featurep '(or tty-frames (and emacs 19.30))) | |
| 4230 => ; Non-nil if this Emacs supports TTY frames. | |
| 4231 | |
| 4232 (featurep '(or (and xemacs 19.15) (and emacs 19.34))) | |
| 4233 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later. | |
| 4234 | |
| 442 | 4235 (featurep '(and xemacs 21.02)) |
| 4236 => ; Non-nil on XEmacs 21.2 and later. | |
| 4237 | |
| 428 | 4238 NOTE: The advanced arguments of this function (anything other than a |
| 4239 symbol) are not yet supported by FSF Emacs. If you feel they are useful | |
| 4240 for supporting multiple Emacs variants, lobby Richard Stallman at | |
| 442 | 4241 <bug-gnu-emacs@gnu.org>. |
| 428 | 4242 */ |
| 4243 (fexp)) | |
| 4244 { | |
| 4245 #ifndef FEATUREP_SYNTAX | |
| 4246 CHECK_SYMBOL (fexp); | |
| 4247 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
| 4248 #else /* FEATUREP_SYNTAX */ | |
| 4249 static double featurep_emacs_version; | |
| 4250 | |
| 4251 /* Brute force translation from Erik Naggum's lisp function. */ | |
| 4252 if (SYMBOLP (fexp)) | |
| 4253 { | |
| 4254 /* Original definition */ | |
| 4255 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
| 4256 } | |
| 4257 else if (INTP (fexp) || FLOATP (fexp)) | |
| 4258 { | |
| 4259 double d = extract_float (fexp); | |
| 4260 | |
| 4261 if (featurep_emacs_version == 0.0) | |
| 4262 { | |
| 4263 featurep_emacs_version = XINT (Vemacs_major_version) + | |
| 4264 (XINT (Vemacs_minor_version) / 100.0); | |
| 4265 } | |
| 4266 return featurep_emacs_version >= d ? Qt : Qnil; | |
| 4267 } | |
| 4268 else if (CONSP (fexp)) | |
| 4269 { | |
| 4270 Lisp_Object tem = XCAR (fexp); | |
| 4271 if (EQ (tem, Qnot)) | |
| 4272 { | |
| 4273 Lisp_Object negate; | |
| 4274 | |
| 4275 tem = XCDR (fexp); | |
| 4276 negate = Fcar (tem); | |
| 4277 if (!NILP (tem)) | |
| 4278 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil; | |
| 4279 else | |
| 4280 return Fsignal (Qinvalid_read_syntax, list1 (tem)); | |
| 4281 } | |
| 4282 else if (EQ (tem, Qand)) | |
| 4283 { | |
| 4284 tem = XCDR (fexp); | |
| 4285 /* Use Fcar/Fcdr for error-checking. */ | |
| 4286 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem)))) | |
| 4287 { | |
| 4288 tem = Fcdr (tem); | |
| 4289 } | |
| 4290 return NILP (tem) ? Qt : Qnil; | |
| 4291 } | |
| 4292 else if (EQ (tem, Qor)) | |
| 4293 { | |
| 4294 tem = XCDR (fexp); | |
| 4295 /* Use Fcar/Fcdr for error-checking. */ | |
| 4296 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem)))) | |
| 4297 { | |
| 4298 tem = Fcdr (tem); | |
| 4299 } | |
| 4300 return NILP (tem) ? Qnil : Qt; | |
| 4301 } | |
| 4302 else | |
| 4303 { | |
| 4304 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp))); | |
| 4305 } | |
| 4306 } | |
| 4307 else | |
| 4308 { | |
| 4309 return Fsignal (Qinvalid_read_syntax, list1 (fexp)); | |
| 4310 } | |
| 4311 } | |
| 4312 #endif /* FEATUREP_SYNTAX */ | |
| 4313 | |
| 4314 DEFUN ("provide", Fprovide, 1, 1, 0, /* | |
| 4315 Announce that FEATURE is a feature of the current Emacs. | |
| 4316 This function updates the value of the variable `features'. | |
| 4317 */ | |
| 4318 (feature)) | |
| 4319 { | |
| 4320 Lisp_Object tem; | |
| 4321 CHECK_SYMBOL (feature); | |
| 4322 if (!NILP (Vautoload_queue)) | |
| 4323 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue); | |
| 4324 tem = Fmemq (feature, Vfeatures); | |
| 4325 if (NILP (tem)) | |
| 4326 Vfeatures = Fcons (feature, Vfeatures); | |
| 4327 LOADHIST_ATTACH (Fcons (Qprovide, feature)); | |
| 4328 return feature; | |
| 4329 } | |
| 4330 | |
| 1067 | 4331 DEFUN ("require", Frequire, 1, 3, 0, /* |
| 3842 | 4332 Ensure that FEATURE is present in the Lisp environment. |
| 4333 FEATURE is a symbol naming a collection of resources (functions, etc). | |
| 4334 Optional FILENAME is a library from which to load resources; it defaults to | |
| 4335 the print name of FEATURE. | |
| 4336 Optional NOERROR, if non-nil, causes require to return nil rather than signal | |
| 4337 `file-error' if loading the library fails. | |
| 4338 | |
| 4339 If feature FEATURE is present in `features', update `load-history' to reflect | |
| 4340 the require and return FEATURE. Otherwise, try to load it from a library. | |
| 4341 The normal messages at start and end of loading are suppressed. | |
| 4342 If the library is successfully loaded and it calls `(provide FEATURE)', add | |
| 4343 FEATURE to `features', update `load-history' and return FEATURE. | |
| 4344 If the load succeeds but FEATURE is not provided by the library, signal | |
| 4345 `invalid-state'. | |
| 4346 | |
| 4347 The byte-compiler treats top-level calls to `require' specially, by evaluating | |
| 4348 them at compile time (and then compiling them normally). Thus a library may | |
| 4349 request that definitions that should be inlined such as macros and defsubsts | |
| 4350 be loaded into its compilation environment. Achieving this in other contexts | |
| 4351 requires an explicit \(eval-and-compile ...\) block. | |
| 428 | 4352 */ |
| 1067 | 4353 (feature, filename, noerror)) |
| 428 | 4354 { |
| 4355 Lisp_Object tem; | |
| 4356 CHECK_SYMBOL (feature); | |
| 4357 tem = Fmemq (feature, Vfeatures); | |
| 4358 LOADHIST_ATTACH (Fcons (Qrequire, feature)); | |
| 4359 if (!NILP (tem)) | |
| 4360 return feature; | |
| 4361 else | |
| 4362 { | |
| 4363 int speccount = specpdl_depth (); | |
| 4364 | |
| 4365 /* Value saved here is to be restored into Vautoload_queue */ | |
| 4366 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 4367 Vautoload_queue = Qt; | |
| 4368 | |
| 1067 | 4369 tem = call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename, |
| 1261 | 4370 noerror, Qrequire, Qnil); |
| 1067 | 4371 /* If load failed entirely, return nil. */ |
| 4372 if (NILP (tem)) | |
| 4373 return unbind_to_1 (speccount, Qnil); | |
| 428 | 4374 |
| 4375 tem = Fmemq (feature, Vfeatures); | |
| 4376 if (NILP (tem)) | |
| 563 | 4377 invalid_state ("Required feature was not provided", feature); |
| 428 | 4378 |
| 4379 /* Once loading finishes, don't undo it. */ | |
| 4380 Vautoload_queue = Qt; | |
| 771 | 4381 return unbind_to_1 (speccount, feature); |
| 428 | 4382 } |
| 4383 } | |
| 4384 | |
| 4385 /* base64 encode/decode functions. | |
| 4386 | |
| 4387 Originally based on code from GNU recode. Ported to FSF Emacs by | |
| 4388 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and | |
| 4389 subsequently heavily hacked by Hrvoje Niksic. */ | |
| 4390 | |
| 4391 #define MIME_LINE_LENGTH 72 | |
| 4392 | |
| 4393 #define IS_ASCII(Character) \ | |
| 4394 ((Character) < 128) | |
| 4395 #define IS_BASE64(Character) \ | |
| 4396 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0) | |
| 4397 | |
| 4398 /* Table of characters coding the 64 values. */ | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4399 static Ascbyte base64_value_to_char[64] = |
| 428 | 4400 { |
| 4401 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */ | |
| 4402 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */ | |
| 4403 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */ | |
| 4404 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */ | |
| 4405 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */ | |
| 4406 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */ | |
| 4407 '8', '9', '+', '/' /* 60-63 */ | |
| 4408 }; | |
| 4409 | |
| 4410 /* Table of base64 values for first 128 characters. */ | |
| 4411 static short base64_char_to_value[128] = | |
| 4412 { | |
| 4413 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */ | |
| 4414 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */ | |
| 4415 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */ | |
| 4416 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */ | |
| 4417 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */ | |
| 4418 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */ | |
| 4419 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */ | |
| 4420 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */ | |
| 4421 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */ | |
| 4422 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */ | |
| 4423 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */ | |
| 4424 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */ | |
| 4425 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */ | |
| 4426 }; | |
| 4427 | |
| 4428 /* The following diagram shows the logical steps by which three octets | |
| 4429 get transformed into four base64 characters. | |
| 4430 | |
| 4431 .--------. .--------. .--------. | |
| 4432 |aaaaaabb| |bbbbcccc| |ccdddddd| | |
| 4433 `--------' `--------' `--------' | |
| 4434 6 2 4 4 2 6 | |
| 4435 .--------+--------+--------+--------. | |
| 4436 |00aaaaaa|00bbbbbb|00cccccc|00dddddd| | |
| 4437 `--------+--------+--------+--------' | |
| 4438 | |
| 4439 .--------+--------+--------+--------. | |
| 4440 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD| | |
| 4441 `--------+--------+--------+--------' | |
| 4442 | |
| 4443 The octets are divided into 6 bit chunks, which are then encoded into | |
| 4444 base64 characters. */ | |
| 4445 | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4446 static DECLARE_DOESNT_RETURN (base64_conversion_error (const Ascbyte *, |
| 2268 | 4447 Lisp_Object)); |
| 4448 | |
| 575 | 4449 static DOESNT_RETURN |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4450 base64_conversion_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 4451 { |
| 4452 signal_error (Qbase64_conversion_error, reason, frob); | |
| 4453 } | |
| 4454 | |
| 4455 #define ADVANCE_INPUT(c, stream) \ | |
| 867 | 4456 ((ec = Lstream_get_ichar (stream)) == -1 ? 0 : \ |
| 563 | 4457 ((ec > 255) ? \ |
| 4458 (base64_conversion_error ("Non-ascii character in base64 input", \ | |
| 4459 make_char (ec)), 0) \ | |
| 867 | 4460 : (c = (Ibyte)ec), 1)) |
| 665 | 4461 |
| 4462 static Bytebpos | |
| 867 | 4463 base64_encode_1 (Lstream *istream, Ibyte *to, int line_break) |
| 428 | 4464 { |
| 4465 EMACS_INT counter = 0; | |
| 867 | 4466 Ibyte *e = to; |
| 4467 Ichar ec; | |
| 428 | 4468 unsigned int value; |
| 4469 | |
| 4470 while (1) | |
| 4471 { | |
| 1204 | 4472 Ibyte c = 0; |
| 428 | 4473 if (!ADVANCE_INPUT (c, istream)) |
| 4474 break; | |
| 4475 | |
| 4476 /* Wrap line every 76 characters. */ | |
| 4477 if (line_break) | |
| 4478 { | |
| 4479 if (counter < MIME_LINE_LENGTH / 4) | |
| 4480 counter++; | |
| 4481 else | |
| 4482 { | |
| 4483 *e++ = '\n'; | |
| 4484 counter = 1; | |
| 4485 } | |
| 4486 } | |
| 4487 | |
| 4488 /* Process first byte of a triplet. */ | |
| 4489 *e++ = base64_value_to_char[0x3f & c >> 2]; | |
| 4490 value = (0x03 & c) << 4; | |
| 4491 | |
| 4492 /* Process second byte of a triplet. */ | |
| 4493 if (!ADVANCE_INPUT (c, istream)) | |
| 4494 { | |
| 4495 *e++ = base64_value_to_char[value]; | |
| 4496 *e++ = '='; | |
| 4497 *e++ = '='; | |
| 4498 break; | |
| 4499 } | |
| 4500 | |
| 4501 *e++ = base64_value_to_char[value | (0x0f & c >> 4)]; | |
| 4502 value = (0x0f & c) << 2; | |
| 4503 | |
| 4504 /* Process third byte of a triplet. */ | |
| 4505 if (!ADVANCE_INPUT (c, istream)) | |
| 4506 { | |
| 4507 *e++ = base64_value_to_char[value]; | |
| 4508 *e++ = '='; | |
| 4509 break; | |
| 4510 } | |
| 4511 | |
| 4512 *e++ = base64_value_to_char[value | (0x03 & c >> 6)]; | |
| 4513 *e++ = base64_value_to_char[0x3f & c]; | |
| 4514 } | |
| 4515 | |
| 4516 return e - to; | |
| 4517 } | |
| 4518 #undef ADVANCE_INPUT | |
| 4519 | |
| 4520 /* Get next character from the stream, except that non-base64 | |
| 4521 characters are ignored. This is in accordance with rfc2045. EC | |
| 867 | 4522 should be an Ichar, so that it can hold -1 as the value for EOF. */ |
| 428 | 4523 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \ |
| 867 | 4524 ec = Lstream_get_ichar (stream); \ |
| 428 | 4525 ++streampos; \ |
| 4526 /* IS_BASE64 may not be called with negative arguments so check for \ | |
| 4527 EOF first. */ \ | |
| 4528 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ | |
| 4529 break; \ | |
| 4530 } while (1) | |
| 4531 | |
| 4532 #define STORE_BYTE(pos, val, ccnt) do { \ | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4533 pos += set_itext_ichar (pos, (Ichar)((Binbyte)(val))); \ |
| 428 | 4534 ++ccnt; \ |
| 4535 } while (0) | |
| 4536 | |
| 665 | 4537 static Bytebpos |
| 867 | 4538 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr) |
| 428 | 4539 { |
| 4540 Charcount ccnt = 0; | |
| 867 | 4541 Ibyte *e = to; |
| 428 | 4542 EMACS_INT streampos = 0; |
| 4543 | |
| 4544 while (1) | |
| 4545 { | |
| 867 | 4546 Ichar ec; |
| 428 | 4547 unsigned long value; |
| 4548 | |
| 4549 /* Process first byte of a quadruplet. */ | |
| 4550 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 4551 if (ec < 0) | |
| 4552 break; | |
| 4553 if (ec == '=') | |
| 563 | 4554 base64_conversion_error ("Illegal `=' character while decoding base64", |
| 4555 make_int (streampos)); | |
| 428 | 4556 value = base64_char_to_value[ec] << 18; |
| 4557 | |
| 4558 /* Process second byte of a quadruplet. */ | |
| 4559 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 4560 if (ec < 0) | |
| 563 | 4561 base64_conversion_error ("Premature EOF while decoding base64", |
| 4562 Qunbound); | |
| 428 | 4563 if (ec == '=') |
| 563 | 4564 base64_conversion_error ("Illegal `=' character while decoding base64", |
| 4565 make_int (streampos)); | |
| 428 | 4566 value |= base64_char_to_value[ec] << 12; |
| 4567 STORE_BYTE (e, value >> 16, ccnt); | |
| 4568 | |
| 4569 /* Process third byte of a quadruplet. */ | |
| 4570 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 4571 if (ec < 0) | |
| 563 | 4572 base64_conversion_error ("Premature EOF while decoding base64", |
| 4573 Qunbound); | |
| 428 | 4574 |
| 4575 if (ec == '=') | |
| 4576 { | |
| 4577 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 4578 if (ec < 0) | |
| 563 | 4579 base64_conversion_error ("Premature EOF while decoding base64", |
| 4580 Qunbound); | |
| 428 | 4581 if (ec != '=') |
| 563 | 4582 base64_conversion_error |
| 4583 ("Padding `=' expected but not found while decoding base64", | |
| 4584 make_int (streampos)); | |
| 428 | 4585 continue; |
| 4586 } | |
| 4587 | |
| 4588 value |= base64_char_to_value[ec] << 6; | |
| 4589 STORE_BYTE (e, 0xff & value >> 8, ccnt); | |
| 4590 | |
| 4591 /* Process fourth byte of a quadruplet. */ | |
| 4592 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 4593 if (ec < 0) | |
| 563 | 4594 base64_conversion_error ("Premature EOF while decoding base64", |
| 4595 Qunbound); | |
| 428 | 4596 if (ec == '=') |
| 4597 continue; | |
| 4598 | |
| 4599 value |= base64_char_to_value[ec]; | |
| 4600 STORE_BYTE (e, 0xff & value, ccnt); | |
| 4601 } | |
| 4602 | |
| 4603 *ccptr = ccnt; | |
| 4604 return e - to; | |
| 4605 } | |
| 4606 #undef ADVANCE_INPUT | |
| 4607 #undef ADVANCE_INPUT_IGNORE_NONBASE64 | |
| 4608 #undef STORE_BYTE | |
| 4609 | |
| 4610 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* | |
| 444 | 4611 Base64-encode the region between START and END. |
| 428 | 4612 Return the length of the encoded text. |
| 4613 Optional third argument NO-LINE-BREAK means do not break long lines | |
| 4614 into shorter lines. | |
| 4615 */ | |
| 444 | 4616 (start, end, no_line_break)) |
| 428 | 4617 { |
| 867 | 4618 Ibyte *encoded; |
| 665 | 4619 Bytebpos encoded_length; |
| 428 | 4620 Charcount allength, length; |
| 4621 struct buffer *buf = current_buffer; | |
| 665 | 4622 Charbpos begv, zv, old_pt = BUF_PT (buf); |
| 428 | 4623 Lisp_Object input; |
| 851 | 4624 int speccount = specpdl_depth (); |
| 428 | 4625 |
| 444 | 4626 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
| 428 | 4627 barf_if_buffer_read_only (buf, begv, zv); |
| 4628 | |
| 4629 /* We need to allocate enough room for encoding the text. | |
| 4630 We need 33 1/3% more space, plus a newline every 76 | |
| 4631 characters, and then we round up. */ | |
| 4632 length = zv - begv; | |
| 4633 allength = length + length/3 + 1; | |
| 4634 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
| 4635 | |
| 4636 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
| 867 | 4637 /* We needn't multiply allength with MAX_ICHAR_LEN because all the |
| 428 | 4638 base64 characters will be single-byte. */ |
| 867 | 4639 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
| 428 | 4640 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
| 4641 NILP (no_line_break)); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4642 assert (encoded_length <= allength); |
| 428 | 4643 Lstream_delete (XLSTREAM (input)); |
| 4644 | |
| 4645 /* Now we have encoded the region, so we insert the new contents | |
| 4646 and delete the old. (Insert first in order to preserve markers.) */ | |
| 4647 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); | |
| 851 | 4648 unbind_to (speccount); |
| 428 | 4649 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); |
| 4650 | |
| 4651 /* Simulate FSF Emacs implementation of this function: if point was | |
| 4652 in the region, place it at the beginning. */ | |
| 4653 if (old_pt >= begv && old_pt < zv) | |
| 4654 BUF_SET_PT (buf, begv); | |
| 4655 | |
| 4656 /* We return the length of the encoded text. */ | |
| 4657 return make_int (encoded_length); | |
| 4658 } | |
| 4659 | |
| 4660 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /* | |
| 4661 Base64 encode STRING and return the result. | |
| 444 | 4662 Optional argument NO-LINE-BREAK means do not break long lines |
| 4663 into shorter lines. | |
| 428 | 4664 */ |
| 4665 (string, no_line_break)) | |
| 4666 { | |
| 4667 Charcount allength, length; | |
| 665 | 4668 Bytebpos encoded_length; |
| 867 | 4669 Ibyte *encoded; |
| 428 | 4670 Lisp_Object input, result; |
| 4671 int speccount = specpdl_depth(); | |
| 4672 | |
| 4673 CHECK_STRING (string); | |
| 4674 | |
| 826 | 4675 length = string_char_length (string); |
| 428 | 4676 allength = length + length/3 + 1; |
| 4677 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
| 4678 | |
| 4679 input = make_lisp_string_input_stream (string, 0, -1); | |
| 867 | 4680 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
| 428 | 4681 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
| 4682 NILP (no_line_break)); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4683 assert (encoded_length <= allength); |
| 428 | 4684 Lstream_delete (XLSTREAM (input)); |
| 4685 result = make_string (encoded, encoded_length); | |
| 851 | 4686 unbind_to (speccount); |
| 428 | 4687 return result; |
| 4688 } | |
| 4689 | |
| 4690 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* | |
| 444 | 4691 Base64-decode the region between START and END. |
| 428 | 4692 Return the length of the decoded text. |
| 4693 If the region can't be decoded, return nil and don't modify the buffer. | |
| 4694 Characters out of the base64 alphabet are ignored. | |
| 4695 */ | |
| 444 | 4696 (start, end)) |
| 428 | 4697 { |
| 4698 struct buffer *buf = current_buffer; | |
| 665 | 4699 Charbpos begv, zv, old_pt = BUF_PT (buf); |
| 867 | 4700 Ibyte *decoded; |
| 665 | 4701 Bytebpos decoded_length; |
| 428 | 4702 Charcount length, cc_decoded_length; |
| 4703 Lisp_Object input; | |
| 4704 int speccount = specpdl_depth(); | |
| 4705 | |
| 444 | 4706 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
| 428 | 4707 barf_if_buffer_read_only (buf, begv, zv); |
| 4708 | |
| 4709 length = zv - begv; | |
| 4710 | |
| 4711 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
| 4712 /* We need to allocate enough room for decoding the text. */ | |
| 867 | 4713 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
| 428 | 4714 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4715 assert (decoded_length <= length * MAX_ICHAR_LEN); |
| 428 | 4716 Lstream_delete (XLSTREAM (input)); |
| 4717 | |
| 4718 /* Now we have decoded the region, so we insert the new contents | |
| 4719 and delete the old. (Insert first in order to preserve markers.) */ | |
| 4720 BUF_SET_PT (buf, begv); | |
| 4721 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); | |
| 851 | 4722 unbind_to (speccount); |
| 428 | 4723 buffer_delete_range (buf, begv + cc_decoded_length, |
| 4724 zv + cc_decoded_length, 0); | |
| 4725 | |
| 4726 /* Simulate FSF Emacs implementation of this function: if point was | |
| 4727 in the region, place it at the beginning. */ | |
| 4728 if (old_pt >= begv && old_pt < zv) | |
| 4729 BUF_SET_PT (buf, begv); | |
| 4730 | |
| 4731 return make_int (cc_decoded_length); | |
| 4732 } | |
| 4733 | |
| 4734 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* | |
| 4735 Base64-decode STRING and return the result. | |
| 4736 Characters out of the base64 alphabet are ignored. | |
| 4737 */ | |
| 4738 (string)) | |
| 4739 { | |
| 867 | 4740 Ibyte *decoded; |
| 665 | 4741 Bytebpos decoded_length; |
| 428 | 4742 Charcount length, cc_decoded_length; |
| 4743 Lisp_Object input, result; | |
| 4744 int speccount = specpdl_depth(); | |
| 4745 | |
| 4746 CHECK_STRING (string); | |
| 4747 | |
| 826 | 4748 length = string_char_length (string); |
| 428 | 4749 /* We need to allocate enough room for decoding the text. */ |
| 867 | 4750 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
| 428 | 4751 |
| 4752 input = make_lisp_string_input_stream (string, 0, -1); | |
| 4753 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, | |
| 4754 &cc_decoded_length); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
4755 assert (decoded_length <= length * MAX_ICHAR_LEN); |
| 428 | 4756 Lstream_delete (XLSTREAM (input)); |
| 4757 | |
| 4758 result = make_string (decoded, decoded_length); | |
| 851 | 4759 unbind_to (speccount); |
| 428 | 4760 return result; |
| 4761 } | |
| 4762 | |
| 4763 Lisp_Object Qyes_or_no_p; | |
| 4764 | |
| 4765 void | |
| 4766 syms_of_fns (void) | |
| 4767 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
4768 INIT_LISP_OBJECT (bit_vector); |
| 442 | 4769 |
| 563 | 4770 DEFSYMBOL (Qstring_lessp); |
| 4771 DEFSYMBOL (Qidentity); | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4772 DEFSYMBOL (Qvector); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4773 DEFSYMBOL (Qarray); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4774 DEFSYMBOL (Qstring); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4775 DEFSYMBOL (Qlist); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4776 DEFSYMBOL (Qbit_vector); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4777 |
| 563 | 4778 DEFSYMBOL (Qyes_or_no_p); |
| 4779 | |
| 4780 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error); | |
| 428 | 4781 |
| 4782 DEFSUBR (Fidentity); | |
| 4783 DEFSUBR (Frandom); | |
| 4784 DEFSUBR (Flength); | |
| 4785 DEFSUBR (Fsafe_length); | |
| 4786 DEFSUBR (Fstring_equal); | |
| 801 | 4787 DEFSUBR (Fcompare_strings); |
| 428 | 4788 DEFSUBR (Fstring_lessp); |
| 4789 DEFSUBR (Fstring_modified_tick); | |
| 4790 DEFSUBR (Fappend); | |
| 4791 DEFSUBR (Fconcat); | |
| 4792 DEFSUBR (Fvconcat); | |
| 4793 DEFSUBR (Fbvconcat); | |
| 4794 DEFSUBR (Fcopy_list); | |
| 4795 DEFSUBR (Fcopy_sequence); | |
| 4796 DEFSUBR (Fcopy_alist); | |
| 4797 DEFSUBR (Fcopy_tree); | |
| 4798 DEFSUBR (Fsubstring); | |
| 4799 DEFSUBR (Fsubseq); | |
| 4800 DEFSUBR (Fnthcdr); | |
| 4801 DEFSUBR (Fnth); | |
| 4802 DEFSUBR (Felt); | |
| 4803 DEFSUBR (Flast); | |
| 4804 DEFSUBR (Fbutlast); | |
| 4805 DEFSUBR (Fnbutlast); | |
| 4806 DEFSUBR (Fmember); | |
| 4807 DEFSUBR (Fold_member); | |
| 4808 DEFSUBR (Fmemq); | |
| 4809 DEFSUBR (Fold_memq); | |
| 4810 DEFSUBR (Fassoc); | |
| 4811 DEFSUBR (Fold_assoc); | |
| 4812 DEFSUBR (Fassq); | |
| 4813 DEFSUBR (Fold_assq); | |
| 4814 DEFSUBR (Frassoc); | |
| 4815 DEFSUBR (Fold_rassoc); | |
| 4816 DEFSUBR (Frassq); | |
| 4817 DEFSUBR (Fold_rassq); | |
| 4818 DEFSUBR (Fdelete); | |
| 4819 DEFSUBR (Fold_delete); | |
| 4820 DEFSUBR (Fdelq); | |
| 4821 DEFSUBR (Fold_delq); | |
| 4822 DEFSUBR (Fremassoc); | |
| 4823 DEFSUBR (Fremassq); | |
| 4824 DEFSUBR (Fremrassoc); | |
| 4825 DEFSUBR (Fremrassq); | |
| 4826 DEFSUBR (Fnreverse); | |
| 4827 DEFSUBR (Freverse); | |
| 4828 DEFSUBR (Fsort); | |
| 4829 DEFSUBR (Fplists_eq); | |
| 4830 DEFSUBR (Fplists_equal); | |
| 4831 DEFSUBR (Flax_plists_eq); | |
| 4832 DEFSUBR (Flax_plists_equal); | |
| 4833 DEFSUBR (Fplist_get); | |
| 4834 DEFSUBR (Fplist_put); | |
| 4835 DEFSUBR (Fplist_remprop); | |
| 4836 DEFSUBR (Fplist_member); | |
| 4837 DEFSUBR (Fcheck_valid_plist); | |
| 4838 DEFSUBR (Fvalid_plist_p); | |
| 4839 DEFSUBR (Fcanonicalize_plist); | |
| 4840 DEFSUBR (Flax_plist_get); | |
| 4841 DEFSUBR (Flax_plist_put); | |
| 4842 DEFSUBR (Flax_plist_remprop); | |
| 4843 DEFSUBR (Flax_plist_member); | |
| 4844 DEFSUBR (Fcanonicalize_lax_plist); | |
| 4845 DEFSUBR (Fdestructive_alist_to_plist); | |
| 4846 DEFSUBR (Fget); | |
| 4847 DEFSUBR (Fput); | |
| 4848 DEFSUBR (Fremprop); | |
| 4849 DEFSUBR (Fobject_plist); | |
| 4850 DEFSUBR (Fequal); | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
4851 DEFSUBR (Fequalp); |
| 428 | 4852 DEFSUBR (Fold_equal); |
| 4853 DEFSUBR (Ffillarray); | |
| 4854 DEFSUBR (Fnconc); | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4855 DEFSUBR (FmapcarX); |
| 428 | 4856 DEFSUBR (Fmapvector); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4857 DEFSUBR (Fmapcan); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4858 DEFSUBR (Fmapc); |
| 428 | 4859 DEFSUBR (Fmapconcat); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4860 DEFSUBR (Fmap); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4861 DEFSUBR (Fmap_into); |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
4862 DEFSUBR (Fsome); |
|
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
4863 DEFSUBR (Fevery); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4864 Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc"))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4865 Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*"))); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4866 DEFSUBR (Fmaplist); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4867 DEFSUBR (Fmapl); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4868 DEFSUBR (Fmapcon); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
4869 |
| 442 | 4870 DEFSUBR (Freplace_list); |
| 428 | 4871 DEFSUBR (Fload_average); |
| 4872 DEFSUBR (Ffeaturep); | |
| 4873 DEFSUBR (Frequire); | |
| 4874 DEFSUBR (Fprovide); | |
| 4875 DEFSUBR (Fbase64_encode_region); | |
| 4876 DEFSUBR (Fbase64_encode_string); | |
| 4877 DEFSUBR (Fbase64_decode_region); | |
| 4878 DEFSUBR (Fbase64_decode_string); | |
| 771 | 4879 |
| 4880 DEFSUBR (Fsplit_string_by_char); | |
| 4881 DEFSUBR (Fsplit_path); /* #### */ | |
| 4882 } | |
| 4883 | |
| 4884 void | |
| 4885 vars_of_fns (void) | |
| 4886 { | |
| 4887 DEFVAR_LISP ("path-separator", &Vpath_separator /* | |
| 4888 The directory separator in search paths, as a string. | |
| 4889 */ ); | |
| 4890 { | |
|
5000
44d7bde26046
fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents:
4966
diff
changeset
|
4891 Ascbyte c = SEPCHAR; |
| 867 | 4892 Vpath_separator = make_string ((Ibyte *) &c, 1); |
| 771 | 4893 } |
| 428 | 4894 } |
| 4895 | |
| 4896 void | |
| 4897 init_provide_once (void) | |
| 4898 { | |
| 4899 DEFVAR_LISP ("features", &Vfeatures /* | |
| 4900 A list of symbols which are the features of the executing emacs. | |
| 4901 Used by `featurep' and `require', and altered by `provide'. | |
| 4902 */ ); | |
| 4903 Vfeatures = Qnil; | |
| 4904 | |
| 4905 Fprovide (intern ("base64")); | |
| 4906 } |