Mercurial > hg > xemacs-beta
annotate src/fns.c @ 4952:19a72041c5ed
Mule-izing, various fixes related to char * arguments
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (print_pgresult):
* postgresql/postgresql.c (Fpq_conn_defaults):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_result_status):
* postgresql/postgresql.c (Fpq_res_status):
Mule-ize large parts of it.
2010-01-26 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
* ldap/eldap.c (allocate_ldap):
Use write_ascstring().
src/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (build_ascstring):
* alloc.c (build_msg_cistring):
* alloc.c (staticpro_1):
* alloc.c (staticpro_name):
* alloc.c (staticpro_nodump_1):
* alloc.c (staticpro_nodump_name):
* alloc.c (unstaticpro_nodump_1):
* alloc.c (mcpro_1):
* alloc.c (mcpro_name):
* alloc.c (object_memory_usage_stats):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* buffer.c (print_buffer):
* buffer.c (vars_of_buffer):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.c (init_initial_directory):
* bytecode.c (invalid_byte_code):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* chartab.c (print_table_entry):
* chartab.c (print_char_table):
* config.h.in:
* console-gtk.c:
* console-gtk.c (gtk_device_to_console_connection):
* console-gtk.c (gtk_semi_canonicalize_console_connection):
* console-gtk.c (gtk_canonicalize_console_connection):
* console-gtk.c (gtk_semi_canonicalize_device_connection):
* console-gtk.c (gtk_canonicalize_device_connection):
* console-stream.c (stream_init_frame_1):
* console-stream.c (vars_of_console_stream):
* console-stream.c (init_console_stream):
* console-x.c (x_semi_canonicalize_console_connection):
* console-x.c (x_semi_canonicalize_device_connection):
* console-x.c (x_canonicalize_device_connection):
* console-x.h:
* data.c (eq_with_ebola_notice):
* data.c (Fsubr_interactive):
* data.c (Fnumber_to_string):
* data.c (digit_to_number):
* device-gtk.c (gtk_init_device):
* device-msw.c (print_devmode):
* device-x.c (x_event_name):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-msw.c (vars_of_dialog_mswindows):
* doc.c (weird_doc):
* doc.c (Fsnarf_documentation):
* doc.c (vars_of_doc):
* dumper.c (pdump):
* dynarr.c:
* dynarr.c (Dynarr_realloc):
* editfns.c (Fuser_real_login_name):
* editfns.c (get_home_directory):
* elhash.c (print_hash_table_data):
* elhash.c (print_hash_table):
* emacs.c (main_1):
* emacs.c (vars_of_emacs):
* emodules.c:
* emodules.c (_emodules_list):
* emodules.c (Fload_module):
* emodules.c (Funload_module):
* emodules.c (Flist_modules):
* emodules.c (find_make_module):
* emodules.c (attempt_module_delete):
* emodules.c (emodules_load):
* emodules.c (emodules_doc_subr):
* emodules.c (emodules_doc_sym):
* emodules.c (syms_of_module):
* emodules.c (vars_of_module):
* emodules.h:
* eval.c (print_subr):
* eval.c (signal_call_debugger):
* eval.c (build_error_data):
* eval.c (signal_error):
* eval.c (maybe_signal_error):
* eval.c (signal_continuable_error):
* eval.c (maybe_signal_continuable_error):
* eval.c (signal_error_2):
* eval.c (maybe_signal_error_2):
* eval.c (signal_continuable_error_2):
* eval.c (maybe_signal_continuable_error_2):
* eval.c (signal_ferror):
* eval.c (maybe_signal_ferror):
* eval.c (signal_continuable_ferror):
* eval.c (maybe_signal_continuable_ferror):
* eval.c (signal_ferror_with_frob):
* eval.c (maybe_signal_ferror_with_frob):
* eval.c (signal_continuable_ferror_with_frob):
* eval.c (maybe_signal_continuable_ferror_with_frob):
* eval.c (syntax_error):
* eval.c (syntax_error_2):
* eval.c (maybe_syntax_error):
* eval.c (sferror):
* eval.c (sferror_2):
* eval.c (maybe_sferror):
* eval.c (invalid_argument):
* eval.c (invalid_argument_2):
* eval.c (maybe_invalid_argument):
* eval.c (invalid_constant):
* eval.c (invalid_constant_2):
* eval.c (maybe_invalid_constant):
* eval.c (invalid_operation):
* eval.c (invalid_operation_2):
* eval.c (maybe_invalid_operation):
* eval.c (invalid_change):
* eval.c (invalid_change_2):
* eval.c (maybe_invalid_change):
* eval.c (invalid_state):
* eval.c (invalid_state_2):
* eval.c (maybe_invalid_state):
* eval.c (wtaerror):
* eval.c (stack_overflow):
* eval.c (out_of_memory):
* eval.c (print_multiple_value):
* eval.c (issue_call_trapping_problems_warning):
* eval.c (backtrace_specials):
* eval.c (backtrace_unevalled_args):
* eval.c (Fbacktrace):
* eval.c (warn_when_safe):
* event-Xt.c (modwarn):
* event-Xt.c (modbarf):
* event-Xt.c (check_modifier):
* event-Xt.c (store_modifier):
* event-Xt.c (emacs_Xt_format_magic_event):
* event-Xt.c (describe_event):
* event-gtk.c (dragndrop_data_received):
* event-gtk.c (store_modifier):
* event-gtk.c (gtk_reset_modifier_mapping):
* event-msw.c (dde_eval_string):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (FROB):
* event-msw.c (emacs_mswindows_format_magic_event):
* event-stream.c (external_debugging_print_event):
* event-stream.c (execute_help_form):
* event-stream.c (vars_of_event_stream):
* events.c (print_event_1):
* events.c (print_event):
* events.c (event_equal):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* faces.c (print_face):
* faces.c (complex_vars_of_faces):
* file-coding.c:
* file-coding.c (print_coding_system):
* file-coding.c (print_coding_system_in_print_method):
* file-coding.c (default_query_method):
* file-coding.c (find_coding_system):
* file-coding.c (make_coding_system_1):
* file-coding.c (chain_print):
* file-coding.c (undecided_print):
* file-coding.c (gzip_print):
* file-coding.c (vars_of_file_coding):
* file-coding.c (complex_vars_of_file_coding):
* fileio.c:
* fileio.c (report_file_type_error):
* fileio.c (report_error_with_errno):
* fileio.c (report_file_error):
* fileio.c (barf_or_query_if_file_exists):
* fileio.c (vars_of_fileio):
* floatfns.c (matherr):
* fns.c (print_bit_vector):
* fns.c (Fmapconcat):
* fns.c (add_suffix_to_symbol):
* fns.c (add_prefix_to_symbol):
* frame-gtk.c:
* frame-gtk.c (Fgtk_window_id):
* frame-x.c (def):
* frame-x.c (x_cde_transfer_callback):
* frame.c:
* frame.c (Fmake_frame):
* gc.c (show_gc_cursor_and_message):
* gc.c (vars_of_gc):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (gtk_print_image_instance):
* glyphs-msw.c (mswindows_print_image_instance):
* glyphs-x.c (x_print_image_instance):
* glyphs-x.c (update_widget_face):
* glyphs.c (make_string_from_file):
* glyphs.c (print_image_instance):
* glyphs.c (signal_image_error):
* glyphs.c (signal_image_error_2):
* glyphs.c (signal_double_image_error):
* glyphs.c (signal_double_image_error_2):
* glyphs.c (xbm_mask_file_munging):
* glyphs.c (pixmap_to_lisp_data):
* glyphs.h:
* gui.c (gui_item_display_flush_left):
* hpplay.c (player_error_internal):
* hpplay.c (myHandler):
* intl-win32.c:
* intl-win32.c (langcode_to_lang):
* intl-win32.c (sublangcode_to_lang):
* intl-win32.c (Fmswindows_get_locale_info):
* intl-win32.c (lcid_to_locale_mule_or_no):
* intl-win32.c (mswindows_multibyte_to_unicode_print):
* intl-win32.c (complex_vars_of_intl_win32):
* keymap.c:
* keymap.c (print_keymap):
* keymap.c (ensure_meta_prefix_char_keymapp):
* keymap.c (Fkey_description):
* keymap.c (Ftext_char_description):
* lisp.h:
* lisp.h (struct):
* lisp.h (DECLARE_INLINE_HEADER):
* lread.c (Fload_internal):
* lread.c (locate_file):
* lread.c (read_escape):
* lread.c (read_raw_string):
* lread.c (read1):
* lread.c (read_list):
* lread.c (read_compiled_function):
* lread.c (init_lread):
* lrecord.h:
* marker.c (print_marker):
* marker.c (marker_equal):
* menubar-msw.c (displayable_menu_item):
* menubar-x.c (command_builder_operate_menu_accelerator):
* menubar.c (vars_of_menubar):
* minibuf.c (reinit_complex_vars_of_minibuf):
* minibuf.c (complex_vars_of_minibuf):
* mule-charset.c (Fmake_charset):
* mule-charset.c (complex_vars_of_mule_charset):
* mule-coding.c (iso2022_print):
* mule-coding.c (fixed_width_query):
* number.c (bignum_print):
* number.c (ratio_print):
* number.c (bigfloat_print):
* number.c (bigfloat_finalize):
* objects-msw.c:
* objects-msw.c (mswindows_color_to_string):
* objects-msw.c (mswindows_color_list):
* objects-tty.c:
* objects-tty.c (tty_font_list):
* objects-tty.c (tty_find_charset_font):
* objects-xlike-inc.c (xft_find_charset_font):
* objects-xlike-inc.c (endif):
* print.c:
* print.c (write_istring):
* print.c (write_ascstring):
* print.c (Fterpri):
* print.c (Fprint):
* print.c (print_error_message):
* print.c (print_vector_internal):
* print.c (print_cons):
* print.c (print_string):
* print.c (printing_unreadable_object):
* print.c (print_internal):
* print.c (print_float):
* print.c (print_symbol):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_canonicalize_host_name):
* process-unix.c (unix_canonicalize_host_name):
* process.c (print_process):
* process.c (report_process_error):
* process.c (report_network_error):
* process.c (make_process_internal):
* process.c (Fstart_process_internal):
* process.c (status_message):
* process.c (putenv_internal):
* process.c (vars_of_process):
* process.h:
* profile.c (vars_of_profile):
* rangetab.c (print_range_table):
* realpath.c (vars_of_realpath):
* redisplay.c (vars_of_redisplay):
* search.c (wordify):
* search.c (Freplace_match):
* sheap.c (sheap_adjust_h):
* sound.c (report_sound_error):
* sound.c (Fplay_sound_file):
* specifier.c (print_specifier):
* symbols.c (Fsubr_name):
* symbols.c (do_symval_forwarding):
* symbols.c (set_default_buffer_slot_variable):
* symbols.c (set_default_console_slot_variable):
* symbols.c (store_symval_forwarding):
* symbols.c (default_value):
* symbols.c (defsymbol_massage_name_1):
* symbols.c (defsymbol_massage_name_nodump):
* symbols.c (defsymbol_massage_name):
* symbols.c (defsymbol_massage_multiword_predicate_nodump):
* symbols.c (defsymbol_massage_multiword_predicate):
* symbols.c (defsymbol_nodump):
* symbols.c (defsymbol):
* symbols.c (defkeyword):
* symbols.c (defkeyword_massage_name):
* symbols.c (check_module_subr):
* symbols.c (deferror_1):
* symbols.c (deferror):
* symbols.c (deferror_massage_name):
* symbols.c (deferror_massage_name_and_message):
* symbols.c (defvar_magic):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* sysdep.c:
* sysdep.c (init_system_name):
* sysdll.c:
* sysdll.c (MAYBE_PREPEND_UNDERSCORE):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (dll_error):
* sysdll.c (dll_open):
* sysdll.c (dll_close):
* sysdll.c (image_for_address):
* sysdll.c (my_find_image):
* sysdll.c (search_linked_libs):
* sysdll.h:
* sysfile.h:
* sysfile.h (DEFAULT_DIRECTORY_FALLBACK):
* syswindows.h:
* tests.c (DFC_CHECK_LENGTH):
* tests.c (DFC_CHECK_CONTENT):
* tests.c (Ftest_hash_tables):
* text.c (vars_of_text):
* text.h:
* tooltalk.c (tt_opnum_string):
* tooltalk.c (tt_message_arg_ival_string):
* tooltalk.c (Ftooltalk_default_procid):
* tooltalk.c (Ftooltalk_default_session):
* tooltalk.c (init_tooltalk):
* tooltalk.c (vars_of_tooltalk):
* ui-gtk.c (Fdll_load):
* ui-gtk.c (type_to_marshaller_type):
* ui-gtk.c (Fgtk_import_function_internal):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* unicode.c (unicode_to_ichar):
* unicode.c (unicode_print):
* unicode.c (unicode_query):
* unicode.c (vars_of_unicode):
* unicode.c (complex_vars_of_unicode):
* win32.c:
* win32.c (mswindows_report_process_error):
* window.c (print_window):
* xemacs.def.in.in:
BASIC IDEA: Further fixing up uses of char * and CIbyte *
to reflect their actual semantics; Mule-izing some code;
redoing of the not-yet-working code to handle message translation.
Clean up code to handle message-translation (not yet working).
Create separate versions of build_msg_string() for working with
Ibyte *, CIbyte *, and Ascbyte * arguments. Assert that Ascbyte *
arguments are pure-ASCII. Make build_msg_string() be the same
as build_msg_ascstring(). Create same three versions of GETTEXT()
and DEFER_GETTEXT(). Also create build_defer_string() and
variants for the equivalent of DEFER_GETTEXT() when building a
string. Remove old CGETTEXT(). Clean up code where GETTEXT(),
DEFER_GETTEXT(), build_msg_string(), etc. was being called and
introduce some new calls to build_msg_string(), etc. Remove
GETTEXT() from calls to weird_doc() -- we assume that the
message snarfer knows about weird_doc(). Remove uses of
DEFER_GETTEXT() from error messages in sysdep.c and instead use
special comments /* @@@begin-snarf@@@ */ and /* @@@end-snarf@@@ */
that the message snarfer presumably knows about.
Create build_ascstring() and use it in many instances in place
of build_string(). The purpose of having Ascbyte * variants is
to make the code more self-documenting in terms of what sort of
semantics is expected for char * strings. In fact in the process
of looking for uses of build_string(), much improperly Mule-ized
was discovered.
Mule-ize a lot of code as described in previous paragraph,
e.g. in sysdep.c.
Make the error functions take Ascbyte * strings and fix up a
couple of places where non-pure-ASCII strings were being passed in
(file-coding.c, mule-coding.c, unicode.c). (It's debatable whether
we really need to make the error functions work this way. It
helps catch places where code is written in a way that message
translation won't work, but we may well never implement message
translation.)
Make staticpro() and friends take Ascbyte * strings instead of
raw char * strings. Create a const_Ascbyte_ptr dynarr type
to describe what's held by staticpro_names[] and friends,
create pdump descriptions for const_Ascbyte_ptr dynarrs, and
use them in place of specially-crafted staticpro descriptions.
Mule-ize certain other functions (e.g. x_event_name) by correcting
raw use of char * to Ascbyte *, Rawbyte * or another such type,
and raw use of char[] buffers to another type (usually Ascbyte[]).
Change many uses of write_c_string() to write_msg_string(),
write_ascstring(), etc.
Mule-ize emodules.c, emodules.h, sysdll.h.
Fix some un-Mule-ized code in intl-win32.c.
A comment in event-Xt.c and the limitations of the message
snarfer (make-msgfile or whatever) is presumably incorrect --
it should be smart enough to handle function calls spread over
more than one line. Clean up code in event-Xt.c that was
written awkwardly for this reason.
In config.h.in, instead of NEED_ERROR_CHECK_TYPES_INLINES,
create a more general XEMACS_DEFS_NEEDS_INLINE_DECLS to
indicate when inlined functions need to be declared in
xemacs.defs.in.in, and make use of it in xemacs.defs.in.in.
We need to do this because postgresql.c now calls qxestrdup(),
which is an inline function.
Make nconc2() and other such functions MODULE_API and put
them in xemacs.defs.in.in since postgresql.c now uses them.
Clean up indentation in lread.c and a few other places.
In text.h, document ASSERT_ASCTEXT_ASCII() and
ASSERT_ASCTEXT_ASCII_LEN(), group together the stand-in
encodings and add some more for DLL symbols, function and
variable names, etc.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Tue, 26 Jan 2010 23:22:30 -0600 |
| parents | a5eca70cf401 |
| children | e813cf16c015 |
| rev | line source |
|---|---|
| 428 | 1 /* Random utility Lisp functions. |
| 2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. | |
| 1261 | 3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003 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; | |
| 59 | |
| 563 | 60 Lisp_Object Qbase64_conversion_error; |
| 61 | |
| 771 | 62 Lisp_Object Vpath_separator; |
| 63 | |
| 428 | 64 static int internal_old_equal (Lisp_Object, Lisp_Object, int); |
| 454 | 65 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); |
| 428 | 66 |
| 67 static Lisp_Object | |
| 2286 | 68 mark_bit_vector (Lisp_Object UNUSED (obj)) |
| 428 | 69 { |
| 70 return Qnil; | |
| 71 } | |
| 72 | |
| 73 static void | |
| 2286 | 74 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, |
| 75 int UNUSED (escapeflag)) | |
| 428 | 76 { |
| 665 | 77 Elemcount i; |
| 440 | 78 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
| 665 | 79 Elemcount len = bit_vector_length (v); |
| 80 Elemcount last = len; | |
| 428 | 81 |
| 82 if (INTP (Vprint_length)) | |
| 83 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
|
84 write_ascstring (printcharfun, "#*"); |
| 428 | 85 for (i = 0; i < last; i++) |
| 86 { | |
| 87 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
|
88 write_ascstring (printcharfun, "1"); |
| 428 | 89 else |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
90 write_ascstring (printcharfun, "0"); |
| 428 | 91 } |
| 92 | |
| 93 if (last != len) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
94 write_ascstring (printcharfun, "..."); |
| 428 | 95 } |
| 96 | |
| 97 static int | |
| 2286 | 98 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) |
| 428 | 99 { |
| 440 | 100 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); |
| 101 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); | |
| 428 | 102 |
| 103 return ((bit_vector_length (v1) == bit_vector_length (v2)) && | |
| 104 !memcmp (v1->bits, v2->bits, | |
| 105 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) * | |
| 106 sizeof (long))); | |
| 107 } | |
| 108 | |
| 665 | 109 static Hashcode |
| 2286 | 110 bit_vector_hash (Lisp_Object obj, int UNUSED (depth)) |
| 428 | 111 { |
| 440 | 112 Lisp_Bit_Vector *v = XBIT_VECTOR (obj); |
| 428 | 113 return HASH2 (bit_vector_length (v), |
| 114 memory_hash (v->bits, | |
| 115 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) * | |
| 116 sizeof (long))); | |
| 117 } | |
| 118 | |
| 665 | 119 static Bytecount |
| 442 | 120 size_bit_vector (const void *lheader) |
| 121 { | |
| 122 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader; | |
| 456 | 123 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits, |
| 442 | 124 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))); |
| 125 } | |
| 126 | |
| 1204 | 127 static const struct memory_description bit_vector_description[] = { |
| 428 | 128 { XD_END } |
| 129 }; | |
| 130 | |
| 131 | |
| 1204 | 132 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector, |
| 133 1, /*dumpable-flag*/ | |
| 134 mark_bit_vector, | |
| 135 print_bit_vector, 0, | |
| 136 bit_vector_equal, | |
| 137 bit_vector_hash, | |
| 138 bit_vector_description, | |
| 139 size_bit_vector, | |
| 140 Lisp_Bit_Vector); | |
| 934 | 141 |
| 428 | 142 |
| 143 DEFUN ("identity", Fidentity, 1, 1, 0, /* | |
| 144 Return the argument unchanged. | |
| 145 */ | |
| 146 (arg)) | |
| 147 { | |
| 148 return arg; | |
| 149 } | |
| 150 | |
| 151 DEFUN ("random", Frandom, 0, 1, 0, /* | |
| 152 Return a pseudo-random number. | |
| 1983 | 153 All fixnums are equally likely. On most systems, this is 31 bits' worth. |
| 428 | 154 With positive integer argument N, return random number in interval [0,N). |
| 1983 | 155 N can be a bignum, in which case the range of possible values is extended. |
| 428 | 156 With argument t, set the random number seed from the current time and pid. |
| 157 */ | |
| 158 (limit)) | |
| 159 { | |
| 160 EMACS_INT val; | |
| 161 unsigned long denominator; | |
| 162 | |
| 163 if (EQ (limit, Qt)) | |
| 771 | 164 seed_random (qxe_getpid () + time (NULL)); |
| 428 | 165 if (NATNUMP (limit) && !ZEROP (limit)) |
| 166 { | |
| 167 /* Try to take our random number from the higher bits of VAL, | |
| 168 not the lower, since (says Gentzel) the low bits of `random' | |
| 169 are less random than the higher ones. We do this by using the | |
| 170 quotient rather than the remainder. At the high end of the RNG | |
| 171 it's possible to get a quotient larger than limit; discarding | |
| 172 these values eliminates the bias that would otherwise appear | |
| 173 when using a large limit. */ | |
| 2039 | 174 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit); |
| 428 | 175 do |
| 176 val = get_random () / denominator; | |
| 177 while (val >= XINT (limit)); | |
| 178 } | |
| 1983 | 179 #ifdef HAVE_BIGNUM |
| 180 else if (BIGNUMP (limit)) | |
| 181 { | |
| 182 bignum_random (scratch_bignum, XBIGNUM_DATA (limit)); | |
| 183 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 184 } | |
| 185 #endif | |
| 428 | 186 else |
| 187 val = get_random (); | |
| 188 | |
| 189 return make_int (val); | |
| 190 } | |
| 191 | |
| 192 /* Random data-structure functions */ | |
| 193 | |
| 194 #ifdef LOSING_BYTECODE | |
| 195 | |
| 196 /* #### Delete this shit */ | |
| 197 | |
| 198 /* Charcount is a misnomer here as we might be dealing with the | |
| 199 length of a vector or list, but emphasizes that we're not dealing | |
| 200 with Bytecounts in strings */ | |
| 201 static Charcount | |
| 202 length_with_bytecode_hack (Lisp_Object seq) | |
| 203 { | |
| 204 if (!COMPILED_FUNCTIONP (seq)) | |
| 205 return XINT (Flength (seq)); | |
| 206 else | |
| 207 { | |
| 440 | 208 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); |
| 428 | 209 |
| 210 return (f->flags.interactivep ? COMPILED_INTERACTIVE : | |
| 211 f->flags.domainp ? COMPILED_DOMAIN : | |
| 212 COMPILED_DOC_STRING) | |
| 213 + 1; | |
| 214 } | |
| 215 } | |
| 216 | |
| 217 #endif /* LOSING_BYTECODE */ | |
| 218 | |
| 219 void | |
| 442 | 220 check_losing_bytecode (const char *function, Lisp_Object seq) |
| 428 | 221 { |
| 222 if (COMPILED_FUNCTIONP (seq)) | |
| 563 | 223 signal_ferror_with_frob |
| 224 (Qinvalid_argument, seq, | |
| 428 | 225 "As of 20.3, `%s' no longer works with compiled-function objects", |
| 226 function); | |
| 227 } | |
| 228 | |
| 229 DEFUN ("length", Flength, 1, 1, 0, /* | |
| 230 Return the length of vector, bit vector, list or string SEQUENCE. | |
| 231 */ | |
| 232 (sequence)) | |
| 233 { | |
| 234 retry: | |
| 235 if (STRINGP (sequence)) | |
| 826 | 236 return make_int (string_char_length (sequence)); |
| 428 | 237 else if (CONSP (sequence)) |
| 238 { | |
| 665 | 239 Elemcount len; |
| 428 | 240 GET_EXTERNAL_LIST_LENGTH (sequence, len); |
| 241 return make_int (len); | |
| 242 } | |
| 243 else if (VECTORP (sequence)) | |
| 244 return make_int (XVECTOR_LENGTH (sequence)); | |
| 245 else if (NILP (sequence)) | |
| 246 return Qzero; | |
| 247 else if (BIT_VECTORP (sequence)) | |
| 248 return make_int (bit_vector_length (XBIT_VECTOR (sequence))); | |
| 249 else | |
| 250 { | |
| 251 check_losing_bytecode ("length", sequence); | |
| 252 sequence = wrong_type_argument (Qsequencep, sequence); | |
| 253 goto retry; | |
| 254 } | |
| 255 } | |
| 256 | |
| 257 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* | |
| 258 Return the length of a list, but avoid error or infinite loop. | |
| 259 This function never gets an error. If LIST is not really a list, | |
| 260 it returns 0. If LIST is circular, it returns a finite value | |
| 261 which is at least the number of distinct elements. | |
| 262 */ | |
| 263 (list)) | |
| 264 { | |
| 265 Lisp_Object hare, tortoise; | |
| 665 | 266 Elemcount len; |
| 428 | 267 |
| 268 for (hare = tortoise = list, len = 0; | |
| 269 CONSP (hare) && (! EQ (hare, tortoise) || len == 0); | |
| 270 hare = XCDR (hare), len++) | |
| 271 { | |
| 272 if (len & 1) | |
| 273 tortoise = XCDR (tortoise); | |
| 274 } | |
| 275 | |
| 276 return make_int (len); | |
| 277 } | |
| 278 | |
| 279 /*** string functions. ***/ | |
| 280 | |
| 281 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* | |
| 282 Return t if two strings have identical contents. | |
| 283 Case is significant. Text properties are ignored. | |
| 284 \(Under XEmacs, `equal' also ignores text properties and extents in | |
| 285 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20 | |
| 286 `equal' is the same as in XEmacs, in that respect.) | |
| 287 Symbols are also allowed; their print names are used instead. | |
| 288 */ | |
| 444 | 289 (string1, string2)) |
| 428 | 290 { |
| 291 Bytecount len; | |
| 793 | 292 Lisp_Object p1, p2; |
| 428 | 293 |
| 444 | 294 if (SYMBOLP (string1)) |
| 295 p1 = XSYMBOL (string1)->name; | |
| 428 | 296 else |
| 297 { | |
| 444 | 298 CHECK_STRING (string1); |
| 793 | 299 p1 = string1; |
| 428 | 300 } |
| 301 | |
| 444 | 302 if (SYMBOLP (string2)) |
| 303 p2 = XSYMBOL (string2)->name; | |
| 428 | 304 else |
| 305 { | |
| 444 | 306 CHECK_STRING (string2); |
| 793 | 307 p2 = string2; |
| 428 | 308 } |
| 309 | |
| 793 | 310 return (((len = XSTRING_LENGTH (p1)) == XSTRING_LENGTH (p2)) && |
| 311 !memcmp (XSTRING_DATA (p1), XSTRING_DATA (p2), len)) ? Qt : Qnil; | |
| 428 | 312 } |
| 313 | |
| 801 | 314 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /* |
| 315 Compare the contents of two strings, maybe ignoring case. | |
| 316 In string STR1, skip the first START1 characters and stop at END1. | |
| 317 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
|
318 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
|
319 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
|
320 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
|
321 |
|
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
322 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
|
323 Case is significant by default. |
| 801 | 324 |
| 325 The value is t if the strings (or specified portions) match. | |
| 326 If string STR1 is less, the value is a negative number N; | |
| 327 - 1 - N is the number of characters that match at the beginning. | |
| 328 If string STR1 is greater, the value is a positive number N; | |
| 329 N - 1 is the number of characters that match at the beginning. | |
| 330 */ | |
| 331 (str1, start1, end1, str2, start2, end2, ignore_case)) | |
| 332 { | |
| 333 Charcount ccstart1, ccend1, ccstart2, ccend2; | |
| 334 Bytecount bstart1, blen1, bstart2, blen2; | |
| 335 Charcount matching; | |
| 336 int res; | |
| 337 | |
| 338 CHECK_STRING (str1); | |
| 339 CHECK_STRING (str2); | |
| 340 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
|
341 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
| 801 | 342 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
|
343 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
| 801 | 344 |
| 345 bstart1 = string_index_char_to_byte (str1, ccstart1); | |
| 346 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1); | |
| 347 bstart2 = string_index_char_to_byte (str2, ccstart2); | |
| 348 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2); | |
| 349 | |
| 350 res = ((NILP (ignore_case) ? qxetextcmp_matching : qxetextcasecmp_matching) | |
| 351 (XSTRING_DATA (str1) + bstart1, blen1, | |
| 352 XSTRING_DATA (str2) + bstart2, blen2, | |
| 353 &matching)); | |
| 354 | |
| 355 if (!res) | |
| 356 return Qt; | |
| 357 else if (res > 0) | |
| 358 return make_int (1 + matching); | |
| 359 else | |
| 360 return make_int (-1 - matching); | |
| 361 } | |
| 362 | |
| 428 | 363 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /* |
| 364 Return t if first arg string is less than second in lexicographic order. | |
| 771 | 365 Comparison is simply done on a character-by-character basis using the |
| 366 numeric value of a character. (Note that this may not produce | |
| 367 particularly meaningful results under Mule if characters from | |
| 368 different charsets are being compared.) | |
| 428 | 369 |
| 370 Symbols are also allowed; their print names are used instead. | |
| 371 | |
| 771 | 372 Currently we don't do proper language-specific collation or handle |
| 373 multiple character sets. This may be changed when Unicode support | |
| 374 is implemented. | |
| 428 | 375 */ |
| 444 | 376 (string1, string2)) |
| 428 | 377 { |
| 793 | 378 Lisp_Object p1, p2; |
| 428 | 379 Charcount end, len2; |
| 380 int i; | |
| 381 | |
| 444 | 382 if (SYMBOLP (string1)) |
| 383 p1 = XSYMBOL (string1)->name; | |
| 793 | 384 else |
| 385 { | |
| 444 | 386 CHECK_STRING (string1); |
| 793 | 387 p1 = string1; |
| 428 | 388 } |
| 389 | |
| 444 | 390 if (SYMBOLP (string2)) |
| 391 p2 = XSYMBOL (string2)->name; | |
| 428 | 392 else |
| 393 { | |
| 444 | 394 CHECK_STRING (string2); |
| 793 | 395 p2 = string2; |
| 428 | 396 } |
| 397 | |
| 826 | 398 end = string_char_length (p1); |
| 399 len2 = string_char_length (p2); | |
| 428 | 400 if (end > len2) |
| 401 end = len2; | |
| 402 | |
| 403 { | |
| 867 | 404 Ibyte *ptr1 = XSTRING_DATA (p1); |
| 405 Ibyte *ptr2 = XSTRING_DATA (p2); | |
| 428 | 406 |
| 407 /* #### It is not really necessary to do this: We could compare | |
| 408 byte-by-byte and still get a reasonable comparison, since this | |
| 409 would compare characters with a charset in the same way. With | |
| 410 a little rearrangement of the leading bytes, we could make most | |
| 411 inter-charset comparisons work out the same, too; even if some | |
| 412 don't, this is not a big deal because inter-charset comparisons | |
| 413 aren't really well-defined anyway. */ | |
| 414 for (i = 0; i < end; i++) | |
| 415 { | |
| 867 | 416 if (itext_ichar (ptr1) != itext_ichar (ptr2)) |
| 417 return itext_ichar (ptr1) < itext_ichar (ptr2) ? Qt : Qnil; | |
| 418 INC_IBYTEPTR (ptr1); | |
| 419 INC_IBYTEPTR (ptr2); | |
| 428 | 420 } |
| 421 } | |
| 422 /* Can't do i < len2 because then comparison between "foo" and "foo^@" | |
| 423 won't work right in I18N2 case */ | |
| 424 return end < len2 ? Qt : Qnil; | |
| 425 } | |
| 426 | |
| 427 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /* | |
| 428 Return STRING's tick counter, incremented for each change to the string. | |
| 429 Each string has a tick counter which is incremented each time the contents | |
| 430 of the string are changed (e.g. with `aset'). It wraps around occasionally. | |
| 431 */ | |
| 432 (string)) | |
| 433 { | |
| 434 CHECK_STRING (string); | |
| 793 | 435 if (CONSP (XSTRING_PLIST (string)) && INTP (XCAR (XSTRING_PLIST (string)))) |
| 436 return XCAR (XSTRING_PLIST (string)); | |
| 428 | 437 else |
| 438 return Qzero; | |
| 439 } | |
| 440 | |
| 441 void | |
| 442 bump_string_modiff (Lisp_Object str) | |
| 443 { | |
| 793 | 444 Lisp_Object *ptr = &XSTRING_PLIST (str); |
| 428 | 445 |
| 446 #ifdef I18N3 | |
| 447 /* #### remove the `string-translatable' property from the string, | |
| 448 if there is one. */ | |
| 449 #endif | |
| 450 /* skip over extent info if it's there */ | |
| 451 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
| 452 ptr = &XCDR (*ptr); | |
| 453 if (CONSP (*ptr) && INTP (XCAR (*ptr))) | |
| 793 | 454 XCAR (*ptr) = make_int (1+XINT (XCAR (*ptr))); |
| 428 | 455 else |
| 456 *ptr = Fcons (make_int (1), *ptr); | |
| 457 } | |
| 458 | |
| 459 | |
| 460 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector }; | |
| 461 static Lisp_Object concat (int nargs, Lisp_Object *args, | |
| 462 enum concat_target_type target_type, | |
| 463 int last_special); | |
| 464 | |
| 465 Lisp_Object | |
| 444 | 466 concat2 (Lisp_Object string1, Lisp_Object string2) |
| 428 | 467 { |
| 468 Lisp_Object args[2]; | |
| 444 | 469 args[0] = string1; |
| 470 args[1] = string2; | |
| 428 | 471 return concat (2, args, c_string, 0); |
| 472 } | |
| 473 | |
| 474 Lisp_Object | |
| 444 | 475 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3) |
| 428 | 476 { |
| 477 Lisp_Object args[3]; | |
| 444 | 478 args[0] = string1; |
| 479 args[1] = string2; | |
| 480 args[2] = string3; | |
| 428 | 481 return concat (3, args, c_string, 0); |
| 482 } | |
| 483 | |
| 484 Lisp_Object | |
| 444 | 485 vconcat2 (Lisp_Object vec1, Lisp_Object vec2) |
| 428 | 486 { |
| 487 Lisp_Object args[2]; | |
| 444 | 488 args[0] = vec1; |
| 489 args[1] = vec2; | |
| 428 | 490 return concat (2, args, c_vector, 0); |
| 491 } | |
| 492 | |
| 493 Lisp_Object | |
| 444 | 494 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3) |
| 428 | 495 { |
| 496 Lisp_Object args[3]; | |
| 444 | 497 args[0] = vec1; |
| 498 args[1] = vec2; | |
| 499 args[2] = vec3; | |
| 428 | 500 return concat (3, args, c_vector, 0); |
| 501 } | |
| 502 | |
| 503 DEFUN ("append", Fappend, 0, MANY, 0, /* | |
| 504 Concatenate all the arguments and make the result a list. | |
| 505 The result is a list whose elements are the elements of all the arguments. | |
| 506 Each argument may be a list, vector, bit vector, or string. | |
| 507 The last argument is not copied, just used as the tail of the new list. | |
| 508 Also see: `nconc'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
509 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
510 arguments: (&rest ARGS) |
| 428 | 511 */ |
| 512 (int nargs, Lisp_Object *args)) | |
| 513 { | |
| 514 return concat (nargs, args, c_cons, 1); | |
| 515 } | |
| 516 | |
| 517 DEFUN ("concat", Fconcat, 0, MANY, 0, /* | |
| 518 Concatenate all the arguments and make the result a string. | |
| 519 The result is a string whose elements are the elements of all the arguments. | |
| 520 Each argument may be a string or a list or vector of characters. | |
| 521 | |
| 522 As of XEmacs 21.0, this function does NOT accept individual integers | |
| 523 as arguments. Old code that relies on, for example, (concat "foo" 50) | |
| 524 returning "foo50" will fail. To fix such code, either apply | |
| 525 `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
|
526 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
527 arguments: (&rest ARGS) |
| 428 | 528 */ |
| 529 (int nargs, Lisp_Object *args)) | |
| 530 { | |
| 531 return concat (nargs, args, c_string, 0); | |
| 532 } | |
| 533 | |
| 534 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /* | |
| 535 Concatenate all the arguments and make the result a vector. | |
| 536 The result is a vector whose elements are the elements of all the arguments. | |
| 537 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
|
538 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
539 arguments: (&rest ARGS) |
| 428 | 540 */ |
| 541 (int nargs, Lisp_Object *args)) | |
| 542 { | |
| 543 return concat (nargs, args, c_vector, 0); | |
| 544 } | |
| 545 | |
| 546 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /* | |
| 547 Concatenate all the arguments and make the result a bit vector. | |
| 548 The result is a bit vector whose elements are the elements of all the | |
| 549 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
|
550 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
551 arguments: (&rest ARGS) |
| 428 | 552 */ |
| 553 (int nargs, Lisp_Object *args)) | |
| 554 { | |
| 555 return concat (nargs, args, c_bit_vector, 0); | |
| 556 } | |
| 557 | |
| 558 /* Copy a (possibly dotted) list. LIST must be a cons. | |
| 559 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */ | |
| 560 static Lisp_Object | |
| 561 copy_list (Lisp_Object list) | |
| 562 { | |
| 563 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); | |
| 564 Lisp_Object last = list_copy; | |
| 565 Lisp_Object hare, tortoise; | |
| 665 | 566 Elemcount len; |
| 428 | 567 |
| 568 for (tortoise = hare = XCDR (list), len = 1; | |
| 569 CONSP (hare); | |
| 570 hare = XCDR (hare), len++) | |
| 571 { | |
| 572 XCDR (last) = Fcons (XCAR (hare), XCDR (hare)); | |
| 573 last = XCDR (last); | |
| 574 | |
| 575 if (len < CIRCULAR_LIST_SUSPICION_LENGTH) | |
| 576 continue; | |
| 577 if (len & 1) | |
| 578 tortoise = XCDR (tortoise); | |
| 579 if (EQ (tortoise, hare)) | |
| 580 signal_circular_list_error (list); | |
| 581 } | |
| 582 | |
| 583 return list_copy; | |
| 584 } | |
| 585 | |
| 586 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /* | |
| 587 Return a copy of list LIST, which may be a dotted list. | |
| 588 The elements of LIST are not copied; they are shared | |
| 589 with the original. | |
| 590 */ | |
| 591 (list)) | |
| 592 { | |
| 593 again: | |
| 594 if (NILP (list)) return list; | |
| 595 if (CONSP (list)) return copy_list (list); | |
| 596 | |
| 597 list = wrong_type_argument (Qlistp, list); | |
| 598 goto again; | |
| 599 } | |
| 600 | |
| 601 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* | |
| 602 Return a copy of list, vector, bit vector or string SEQUENCE. | |
| 603 The elements of a list or vector are not copied; they are shared | |
| 604 with the original. SEQUENCE may be a dotted list. | |
| 605 */ | |
| 606 (sequence)) | |
| 607 { | |
| 608 again: | |
| 609 if (NILP (sequence)) return sequence; | |
| 610 if (CONSP (sequence)) return copy_list (sequence); | |
| 611 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0); | |
| 612 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0); | |
| 613 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0); | |
| 614 | |
| 615 check_losing_bytecode ("copy-sequence", sequence); | |
| 616 sequence = wrong_type_argument (Qsequencep, sequence); | |
| 617 goto again; | |
| 618 } | |
| 619 | |
| 620 struct merge_string_extents_struct | |
| 621 { | |
| 622 Lisp_Object string; | |
| 623 Bytecount entry_offset; | |
| 624 Bytecount entry_length; | |
| 625 }; | |
| 626 | |
| 627 static Lisp_Object | |
| 628 concat (int nargs, Lisp_Object *args, | |
| 629 enum concat_target_type target_type, | |
| 630 int last_special) | |
| 631 { | |
| 632 Lisp_Object val; | |
| 633 Lisp_Object tail = Qnil; | |
| 634 int toindex; | |
| 635 int argnum; | |
| 636 Lisp_Object last_tail; | |
| 637 Lisp_Object prev; | |
| 638 struct merge_string_extents_struct *args_mse = 0; | |
| 867 | 639 Ibyte *string_result = 0; |
| 640 Ibyte *string_result_ptr = 0; | |
| 428 | 641 struct gcpro gcpro1; |
| 851 | 642 int sdep = specpdl_depth (); |
| 428 | 643 |
| 644 /* The modus operandi in Emacs is "caller gc-protects args". | |
| 645 However, concat is called many times in Emacs on freshly | |
| 646 created stuff. So we help those callers out by protecting | |
| 647 the args ourselves to save them a lot of temporary-variable | |
| 648 grief. */ | |
| 649 | |
| 650 GCPRO1 (args[0]); | |
| 651 gcpro1.nvars = nargs; | |
| 652 | |
| 653 #ifdef I18N3 | |
| 654 /* #### if the result is a string and any of the strings have a string | |
| 655 for the `string-translatable' property, then concat should also | |
| 656 concat the args but use the `string-translatable' strings, and store | |
| 657 the result in the returned string's `string-translatable' property. */ | |
| 658 #endif | |
| 659 if (target_type == c_string) | |
| 660 args_mse = alloca_array (struct merge_string_extents_struct, nargs); | |
| 661 | |
| 662 /* In append, the last arg isn't treated like the others */ | |
| 663 if (last_special && nargs > 0) | |
| 664 { | |
| 665 nargs--; | |
| 666 last_tail = args[nargs]; | |
| 667 } | |
| 668 else | |
| 669 last_tail = Qnil; | |
| 670 | |
| 671 /* Check and coerce the arguments. */ | |
| 672 for (argnum = 0; argnum < nargs; argnum++) | |
| 673 { | |
| 674 Lisp_Object seq = args[argnum]; | |
| 675 if (LISTP (seq)) | |
| 676 ; | |
| 677 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq)) | |
| 678 ; | |
| 679 #ifdef LOSING_BYTECODE | |
| 680 else if (COMPILED_FUNCTIONP (seq)) | |
| 681 /* Urk! We allow this, for "compatibility"... */ | |
| 682 ; | |
| 683 #endif | |
| 684 #if 0 /* removed for XEmacs 21 */ | |
| 685 else if (INTP (seq)) | |
| 686 /* This is too revolting to think about but maintains | |
| 687 compatibility with FSF (and lots and lots of old code). */ | |
| 688 args[argnum] = Fnumber_to_string (seq); | |
| 689 #endif | |
| 690 else | |
| 691 { | |
| 692 check_losing_bytecode ("concat", seq); | |
| 693 args[argnum] = wrong_type_argument (Qsequencep, seq); | |
| 694 } | |
| 695 | |
| 696 if (args_mse) | |
| 697 { | |
| 698 if (STRINGP (seq)) | |
| 699 args_mse[argnum].string = seq; | |
| 700 else | |
| 701 args_mse[argnum].string = Qnil; | |
| 702 } | |
| 703 } | |
| 704 | |
| 705 { | |
| 706 /* Charcount is a misnomer here as we might be dealing with the | |
| 707 length of a vector or list, but emphasizes that we're not dealing | |
| 708 with Bytecounts in strings */ | |
| 709 Charcount total_length; | |
| 710 | |
| 711 for (argnum = 0, total_length = 0; argnum < nargs; argnum++) | |
| 712 { | |
| 713 #ifdef LOSING_BYTECODE | |
| 714 Charcount thislen = length_with_bytecode_hack (args[argnum]); | |
| 715 #else | |
| 716 Charcount thislen = XINT (Flength (args[argnum])); | |
| 717 #endif | |
| 718 total_length += thislen; | |
| 719 } | |
| 720 | |
| 721 switch (target_type) | |
| 722 { | |
| 723 case c_cons: | |
| 724 if (total_length == 0) | |
| 851 | 725 { |
| 726 unbind_to (sdep); | |
| 727 /* In append, if all but last arg are nil, return last arg */ | |
| 728 RETURN_UNGCPRO (last_tail); | |
| 729 } | |
| 428 | 730 val = Fmake_list (make_int (total_length), Qnil); |
| 731 break; | |
| 732 case c_vector: | |
| 733 val = make_vector (total_length, Qnil); | |
| 734 break; | |
| 735 case c_bit_vector: | |
| 736 val = make_bit_vector (total_length, Qzero); | |
| 737 break; | |
| 738 case c_string: | |
| 739 /* We don't make the string yet because we don't know the | |
| 740 actual number of bytes. This loop was formerly written | |
| 741 to call Fmake_string() here and then call set_string_char() | |
| 742 for each char. This seems logical enough but is waaaaaaaay | |
| 743 slow -- set_string_char() has to scan the whole string up | |
| 744 to the place where the substitution is called for in order | |
| 745 to find the place to change, and may have to do some | |
| 746 realloc()ing in order to make the char fit properly. | |
| 747 O(N^2) yuckage. */ | |
| 748 val = Qnil; | |
| 851 | 749 string_result = |
| 867 | 750 (Ibyte *) MALLOC_OR_ALLOCA (total_length * MAX_ICHAR_LEN); |
| 428 | 751 string_result_ptr = string_result; |
| 752 break; | |
| 753 default: | |
| 442 | 754 val = Qnil; |
| 2500 | 755 ABORT (); |
| 428 | 756 } |
| 757 } | |
| 758 | |
| 759 | |
| 760 if (CONSP (val)) | |
| 761 tail = val, toindex = -1; /* -1 in toindex is flag we are | |
| 762 making a list */ | |
| 763 else | |
| 764 toindex = 0; | |
| 765 | |
| 766 prev = Qnil; | |
| 767 | |
| 768 for (argnum = 0; argnum < nargs; argnum++) | |
| 769 { | |
| 770 Charcount thisleni = 0; | |
| 771 Charcount thisindex = 0; | |
| 772 Lisp_Object seq = args[argnum]; | |
| 867 | 773 Ibyte *string_source_ptr = 0; |
| 774 Ibyte *string_prev_result_ptr = string_result_ptr; | |
| 428 | 775 |
| 776 if (!CONSP (seq)) | |
| 777 { | |
| 778 #ifdef LOSING_BYTECODE | |
| 779 thisleni = length_with_bytecode_hack (seq); | |
| 780 #else | |
| 781 thisleni = XINT (Flength (seq)); | |
| 782 #endif | |
| 783 } | |
| 784 if (STRINGP (seq)) | |
| 785 string_source_ptr = XSTRING_DATA (seq); | |
| 786 | |
| 787 while (1) | |
| 788 { | |
| 789 Lisp_Object elt; | |
| 790 | |
| 791 /* We've come to the end of this arg, so exit. */ | |
| 792 if (NILP (seq)) | |
| 793 break; | |
| 794 | |
| 795 /* Fetch next element of `seq' arg into `elt' */ | |
| 796 if (CONSP (seq)) | |
| 797 { | |
| 798 elt = XCAR (seq); | |
| 799 seq = XCDR (seq); | |
| 800 } | |
| 801 else | |
| 802 { | |
| 803 if (thisindex >= thisleni) | |
| 804 break; | |
| 805 | |
| 806 if (STRINGP (seq)) | |
| 807 { | |
| 867 | 808 elt = make_char (itext_ichar (string_source_ptr)); |
| 809 INC_IBYTEPTR (string_source_ptr); | |
| 428 | 810 } |
| 811 else if (VECTORP (seq)) | |
| 812 elt = XVECTOR_DATA (seq)[thisindex]; | |
| 813 else if (BIT_VECTORP (seq)) | |
| 814 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq), | |
| 815 thisindex)); | |
| 816 else | |
| 817 elt = Felt (seq, make_int (thisindex)); | |
| 818 thisindex++; | |
| 819 } | |
| 820 | |
| 821 /* Store into result */ | |
| 822 if (toindex < 0) | |
| 823 { | |
| 824 /* toindex negative means we are making a list */ | |
| 825 XCAR (tail) = elt; | |
| 826 prev = tail; | |
| 827 tail = XCDR (tail); | |
| 828 } | |
| 829 else if (VECTORP (val)) | |
| 830 XVECTOR_DATA (val)[toindex++] = elt; | |
| 831 else if (BIT_VECTORP (val)) | |
| 832 { | |
| 833 CHECK_BIT (elt); | |
| 834 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt)); | |
| 835 } | |
| 836 else | |
| 837 { | |
| 838 CHECK_CHAR_COERCE_INT (elt); | |
| 867 | 839 string_result_ptr += set_itext_ichar (string_result_ptr, |
| 428 | 840 XCHAR (elt)); |
| 841 } | |
| 842 } | |
| 843 if (args_mse) | |
| 844 { | |
| 845 args_mse[argnum].entry_offset = | |
| 846 string_prev_result_ptr - string_result; | |
| 847 args_mse[argnum].entry_length = | |
| 848 string_result_ptr - string_prev_result_ptr; | |
| 849 } | |
| 850 } | |
| 851 | |
| 852 /* Now we finally make the string. */ | |
| 853 if (target_type == c_string) | |
| 854 { | |
| 855 val = make_string (string_result, string_result_ptr - string_result); | |
| 856 for (argnum = 0; argnum < nargs; argnum++) | |
| 857 { | |
| 858 if (STRINGP (args_mse[argnum].string)) | |
| 859 copy_string_extents (val, args_mse[argnum].string, | |
| 860 args_mse[argnum].entry_offset, 0, | |
| 861 args_mse[argnum].entry_length); | |
| 862 } | |
| 863 } | |
| 864 | |
| 865 if (!NILP (prev)) | |
| 866 XCDR (prev) = last_tail; | |
| 867 | |
| 851 | 868 unbind_to (sdep); |
| 428 | 869 RETURN_UNGCPRO (val); |
| 870 } | |
| 871 | |
| 872 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /* | |
| 873 Return a copy of ALIST. | |
| 874 This is an alist which represents the same mapping from objects to objects, | |
| 875 but does not share the alist structure with ALIST. | |
| 876 The objects mapped (cars and cdrs of elements of the alist) | |
| 877 are shared, however. | |
| 878 Elements of ALIST that are not conses are also shared. | |
| 879 */ | |
| 880 (alist)) | |
| 881 { | |
| 882 Lisp_Object tail; | |
| 883 | |
| 884 if (NILP (alist)) | |
| 885 return alist; | |
| 886 CHECK_CONS (alist); | |
| 887 | |
| 888 alist = concat (1, &alist, c_cons, 0); | |
| 889 for (tail = alist; CONSP (tail); tail = XCDR (tail)) | |
| 890 { | |
| 891 Lisp_Object car = XCAR (tail); | |
| 892 | |
| 893 if (CONSP (car)) | |
| 894 XCAR (tail) = Fcons (XCAR (car), XCDR (car)); | |
| 895 } | |
| 896 return alist; | |
| 897 } | |
| 898 | |
| 899 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /* | |
| 900 Return a copy of a list and substructures. | |
| 901 The argument is copied, and any lists contained within it are copied | |
| 902 recursively. Circularities and shared substructures are not preserved. | |
| 903 Second arg VECP causes vectors to be copied, too. Strings and bit vectors | |
| 904 are not copied. | |
| 905 */ | |
| 906 (arg, vecp)) | |
| 907 { | |
| 454 | 908 return safe_copy_tree (arg, vecp, 0); |
| 909 } | |
| 910 | |
| 911 Lisp_Object | |
| 912 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth) | |
| 913 { | |
| 914 if (depth > 200) | |
| 563 | 915 stack_overflow ("Stack overflow in copy-tree", arg); |
| 454 | 916 |
| 428 | 917 if (CONSP (arg)) |
| 918 { | |
| 919 Lisp_Object rest; | |
| 920 rest = arg = Fcopy_sequence (arg); | |
| 921 while (CONSP (rest)) | |
| 922 { | |
| 923 Lisp_Object elt = XCAR (rest); | |
| 924 QUIT; | |
| 925 if (CONSP (elt) || VECTORP (elt)) | |
| 454 | 926 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1); |
| 428 | 927 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */ |
| 454 | 928 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1); |
| 428 | 929 rest = XCDR (rest); |
| 930 } | |
| 931 } | |
| 932 else if (VECTORP (arg) && ! NILP (vecp)) | |
| 933 { | |
| 934 int i = XVECTOR_LENGTH (arg); | |
| 935 int j; | |
| 936 arg = Fcopy_sequence (arg); | |
| 937 for (j = 0; j < i; j++) | |
| 938 { | |
| 939 Lisp_Object elt = XVECTOR_DATA (arg) [j]; | |
| 940 QUIT; | |
| 941 if (CONSP (elt) || VECTORP (elt)) | |
| 454 | 942 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1); |
| 428 | 943 } |
| 944 } | |
| 945 return arg; | |
| 946 } | |
| 947 | |
| 948 DEFUN ("substring", Fsubstring, 2, 3, 0, /* | |
| 444 | 949 Return the substring of STRING starting at START and ending before END. |
| 950 END may be nil or omitted; then the substring runs to the end of STRING. | |
| 951 If START or END is negative, it counts from the end. | |
| 952 Relevant parts of the string-extent-data are copied to the new string. | |
| 428 | 953 */ |
| 444 | 954 (string, start, end)) |
| 428 | 955 { |
| 444 | 956 Charcount ccstart, ccend; |
| 957 Bytecount bstart, blen; | |
| 428 | 958 Lisp_Object val; |
| 959 | |
| 960 CHECK_STRING (string); | |
| 444 | 961 CHECK_INT (start); |
| 962 get_string_range_char (string, start, end, &ccstart, &ccend, | |
| 428 | 963 GB_HISTORICAL_STRING_BEHAVIOR); |
| 793 | 964 bstart = string_index_char_to_byte (string, ccstart); |
| 965 blen = string_offset_char_to_byte_len (string, bstart, ccend - ccstart); | |
| 444 | 966 val = make_string (XSTRING_DATA (string) + bstart, blen); |
| 967 /* Copy any applicable extent information into the new string. */ | |
| 968 copy_string_extents (val, string, 0, bstart, blen); | |
| 428 | 969 return val; |
| 970 } | |
| 971 | |
| 972 DEFUN ("subseq", Fsubseq, 2, 3, 0, /* | |
| 442 | 973 Return the subsequence of SEQUENCE starting at START and ending before END. |
| 974 END may be omitted; then the subsequence runs to the end of SEQUENCE. | |
| 975 If START or END is negative, it counts from the end. | |
| 976 The returned subsequence is always of the same type as SEQUENCE. | |
| 977 If SEQUENCE is a string, relevant parts of the string-extent-data | |
| 978 are copied to the new string. | |
| 428 | 979 */ |
| 442 | 980 (sequence, start, end)) |
| 428 | 981 { |
| 442 | 982 EMACS_INT len, s, e; |
| 983 | |
| 984 if (STRINGP (sequence)) | |
| 985 return Fsubstring (sequence, start, end); | |
| 986 | |
| 987 len = XINT (Flength (sequence)); | |
| 988 | |
| 989 CHECK_INT (start); | |
| 990 s = XINT (start); | |
| 991 if (s < 0) | |
| 992 s = len + s; | |
| 993 | |
| 994 if (NILP (end)) | |
| 995 e = len; | |
| 428 | 996 else |
| 997 { | |
| 442 | 998 CHECK_INT (end); |
| 999 e = XINT (end); | |
| 1000 if (e < 0) | |
| 1001 e = len + e; | |
| 428 | 1002 } |
| 1003 | |
| 442 | 1004 if (!(0 <= s && s <= e && e <= len)) |
| 1005 args_out_of_range_3 (sequence, make_int (s), make_int (e)); | |
| 1006 | |
| 1007 if (VECTORP (sequence)) | |
| 428 | 1008 { |
| 442 | 1009 Lisp_Object result = make_vector (e - s, Qnil); |
| 428 | 1010 EMACS_INT i; |
| 442 | 1011 Lisp_Object *in_elts = XVECTOR_DATA (sequence); |
| 428 | 1012 Lisp_Object *out_elts = XVECTOR_DATA (result); |
| 1013 | |
| 442 | 1014 for (i = s; i < e; i++) |
| 1015 out_elts[i - s] = in_elts[i]; | |
| 428 | 1016 return result; |
| 1017 } | |
| 442 | 1018 else if (LISTP (sequence)) |
| 428 | 1019 { |
| 1020 Lisp_Object result = Qnil; | |
| 1021 EMACS_INT i; | |
| 1022 | |
| 442 | 1023 sequence = Fnthcdr (make_int (s), sequence); |
| 1024 | |
| 1025 for (i = s; i < e; i++) | |
| 428 | 1026 { |
| 442 | 1027 result = Fcons (Fcar (sequence), result); |
| 1028 sequence = Fcdr (sequence); | |
| 428 | 1029 } |
| 1030 | |
| 1031 return Fnreverse (result); | |
| 1032 } | |
| 442 | 1033 else if (BIT_VECTORP (sequence)) |
| 1034 { | |
| 1035 Lisp_Object result = make_bit_vector (e - s, Qzero); | |
| 1036 EMACS_INT i; | |
| 1037 | |
| 1038 for (i = s; i < e; i++) | |
| 1039 set_bit_vector_bit (XBIT_VECTOR (result), i - s, | |
| 1040 bit_vector_bit (XBIT_VECTOR (sequence), i)); | |
| 1041 return result; | |
| 1042 } | |
| 1043 else | |
| 1044 { | |
| 2500 | 1045 ABORT (); /* unreachable, since Flength (sequence) did not get |
| 442 | 1046 an error */ |
| 1047 return Qnil; | |
| 1048 } | |
| 428 | 1049 } |
| 1050 | |
| 771 | 1051 /* Split STRING into a list of substrings. The substrings are the |
| 1052 parts of original STRING separated by SEPCHAR. */ | |
| 1053 static Lisp_Object | |
| 867 | 1054 split_string_by_ichar_1 (const Ibyte *string, Bytecount size, |
| 1055 Ichar sepchar) | |
| 771 | 1056 { |
| 1057 Lisp_Object result = Qnil; | |
| 867 | 1058 const Ibyte *end = string + size; |
| 771 | 1059 |
| 1060 while (1) | |
| 1061 { | |
| 867 | 1062 const Ibyte *p = string; |
| 771 | 1063 while (p < end) |
| 1064 { | |
| 867 | 1065 if (itext_ichar (p) == sepchar) |
| 771 | 1066 break; |
| 867 | 1067 INC_IBYTEPTR (p); |
| 771 | 1068 } |
| 1069 result = Fcons (make_string (string, p - string), result); | |
| 1070 if (p < end) | |
| 1071 { | |
| 1072 string = p; | |
| 867 | 1073 INC_IBYTEPTR (string); /* skip sepchar */ |
| 771 | 1074 } |
| 1075 else | |
| 1076 break; | |
| 1077 } | |
| 1078 return Fnreverse (result); | |
| 1079 } | |
| 1080 | |
| 1081 /* The same as the above, except PATH is an external C string (it is | |
| 1082 converted using Qfile_name), and sepchar is hardcoded to SEPCHAR | |
| 1083 (':' or whatever). */ | |
| 1084 Lisp_Object | |
| 1085 split_external_path (const Extbyte *path) | |
| 1086 { | |
| 1087 Bytecount newlen; | |
| 867 | 1088 Ibyte *newpath; |
| 771 | 1089 if (!path) |
| 1090 return Qnil; | |
| 1091 | |
| 1092 TO_INTERNAL_FORMAT (C_STRING, path, ALLOCA, (newpath, newlen), Qfile_name); | |
| 1093 | |
| 1094 /* #### Does this make sense? It certainly does for | |
| 1095 split_env_path(), but it looks dubious here. Does any code | |
| 1096 depend on split_external_path("") returning nil instead of an empty | |
| 1097 string? */ | |
| 1098 if (!newlen) | |
| 1099 return Qnil; | |
| 1100 | |
| 867 | 1101 return split_string_by_ichar_1 (newpath, newlen, SEPCHAR); |
| 771 | 1102 } |
| 1103 | |
| 1104 Lisp_Object | |
| 867 | 1105 split_env_path (const CIbyte *evarname, const Ibyte *default_) |
| 771 | 1106 { |
| 867 | 1107 const Ibyte *path = 0; |
| 771 | 1108 if (evarname) |
| 1109 path = egetenv (evarname); | |
| 1110 if (!path) | |
| 1111 path = default_; | |
| 1112 if (!path) | |
| 1113 return Qnil; | |
| 867 | 1114 return split_string_by_ichar_1 (path, qxestrlen (path), SEPCHAR); |
| 771 | 1115 } |
| 1116 | |
| 1117 /* Ben thinks this function should not exist or be exported to Lisp. | |
| 1118 We use it to define split-path-string in subr.el (not!). */ | |
| 1119 | |
| 949 | 1120 DEFUN ("split-string-by-char", Fsplit_string_by_char, 2, 2, 0, /* |
| 771 | 1121 Split STRING into a list of substrings originally separated by SEPCHAR. |
| 1122 */ | |
| 1123 (string, sepchar)) | |
| 1124 { | |
| 1125 CHECK_STRING (string); | |
| 1126 CHECK_CHAR (sepchar); | |
| 867 | 1127 return split_string_by_ichar_1 (XSTRING_DATA (string), |
| 771 | 1128 XSTRING_LENGTH (string), |
| 1129 XCHAR (sepchar)); | |
| 1130 } | |
| 1131 | |
| 1132 /* #### This was supposed to be in subr.el, but is used VERY early in | |
| 1133 the bootstrap process, so it goes here. Damn. */ | |
| 1134 | |
| 1135 DEFUN ("split-path", Fsplit_path, 1, 1, 0, /* | |
| 1136 Explode a search path into a list of strings. | |
| 1137 The path components are separated with the characters specified | |
| 1138 with `path-separator'. | |
| 1139 */ | |
| 1140 (path)) | |
| 1141 { | |
| 1142 CHECK_STRING (path); | |
| 1143 | |
| 1144 while (!STRINGP (Vpath_separator) | |
| 826 | 1145 || (string_char_length (Vpath_separator) != 1)) |
| 771 | 1146 Vpath_separator = signal_continuable_error |
| 1147 (Qinvalid_state, | |
| 1148 "`path-separator' should be set to a single-character string", | |
| 1149 Vpath_separator); | |
| 1150 | |
| 867 | 1151 return (split_string_by_ichar_1 |
| 771 | 1152 (XSTRING_DATA (path), XSTRING_LENGTH (path), |
| 867 | 1153 itext_ichar (XSTRING_DATA (Vpath_separator)))); |
| 771 | 1154 } |
| 1155 | |
| 428 | 1156 |
| 1157 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /* | |
| 1158 Take cdr N times on LIST, and return the result. | |
| 1159 */ | |
| 1160 (n, list)) | |
| 1161 { | |
| 1920 | 1162 /* This function can GC */ |
| 647 | 1163 REGISTER EMACS_INT i; |
| 428 | 1164 REGISTER Lisp_Object tail = list; |
| 1165 CHECK_NATNUM (n); | |
| 1166 for (i = XINT (n); i; i--) | |
| 1167 { | |
| 1168 if (CONSP (tail)) | |
| 1169 tail = XCDR (tail); | |
| 1170 else if (NILP (tail)) | |
| 1171 return Qnil; | |
| 1172 else | |
| 1173 { | |
| 1174 tail = wrong_type_argument (Qlistp, tail); | |
| 1175 i++; | |
| 1176 } | |
| 1177 } | |
| 1178 return tail; | |
| 1179 } | |
| 1180 | |
| 1181 DEFUN ("nth", Fnth, 2, 2, 0, /* | |
| 1182 Return the Nth element of LIST. | |
| 1183 N counts from zero. If LIST is not that long, nil is returned. | |
| 1184 */ | |
| 1185 (n, list)) | |
| 1186 { | |
| 1920 | 1187 /* This function can GC */ |
| 428 | 1188 return Fcar (Fnthcdr (n, list)); |
| 1189 } | |
| 1190 | |
| 1191 DEFUN ("elt", Felt, 2, 2, 0, /* | |
| 1192 Return element of SEQUENCE at index N. | |
| 1193 */ | |
| 1194 (sequence, n)) | |
| 1195 { | |
| 1920 | 1196 /* This function can GC */ |
| 428 | 1197 retry: |
| 1198 CHECK_INT_COERCE_CHAR (n); /* yuck! */ | |
| 1199 if (LISTP (sequence)) | |
| 1200 { | |
| 1201 Lisp_Object tem = Fnthcdr (n, sequence); | |
| 1202 /* #### Utterly, completely, fucking disgusting. | |
| 1203 * #### The whole point of "elt" is that it operates on | |
| 1204 * #### sequences, and does error- (bounds-) checking. | |
| 1205 */ | |
| 1206 if (CONSP (tem)) | |
| 1207 return XCAR (tem); | |
| 1208 else | |
| 1209 #if 1 | |
| 1210 /* This is The Way It Has Always Been. */ | |
| 1211 return Qnil; | |
| 1212 #else | |
| 1213 /* This is The Way Mly and Cltl2 say It Should Be. */ | |
| 1214 args_out_of_range (sequence, n); | |
| 1215 #endif | |
| 1216 } | |
| 1217 else if (STRINGP (sequence) || | |
| 1218 VECTORP (sequence) || | |
| 1219 BIT_VECTORP (sequence)) | |
| 1220 return Faref (sequence, n); | |
| 1221 #ifdef LOSING_BYTECODE | |
| 1222 else if (COMPILED_FUNCTIONP (sequence)) | |
| 1223 { | |
| 1224 EMACS_INT idx = XINT (n); | |
| 1225 if (idx < 0) | |
| 1226 { | |
| 1227 lose: | |
| 1228 args_out_of_range (sequence, n); | |
| 1229 } | |
| 1230 /* Utter perversity */ | |
| 1231 { | |
| 1232 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence); | |
| 1233 switch (idx) | |
| 1234 { | |
| 1235 case COMPILED_ARGLIST: | |
| 1236 return compiled_function_arglist (f); | |
| 1237 case COMPILED_INSTRUCTIONS: | |
| 1238 return compiled_function_instructions (f); | |
| 1239 case COMPILED_CONSTANTS: | |
| 1240 return compiled_function_constants (f); | |
| 1241 case COMPILED_STACK_DEPTH: | |
| 1242 return compiled_function_stack_depth (f); | |
| 1243 case COMPILED_DOC_STRING: | |
| 1244 return compiled_function_documentation (f); | |
| 1245 case COMPILED_DOMAIN: | |
| 1246 return compiled_function_domain (f); | |
| 1247 case COMPILED_INTERACTIVE: | |
| 1248 if (f->flags.interactivep) | |
| 1249 return compiled_function_interactive (f); | |
| 1250 /* if we return nil, can't tell interactive with no args | |
| 1251 from noninteractive. */ | |
| 1252 goto lose; | |
| 1253 default: | |
| 1254 goto lose; | |
| 1255 } | |
| 1256 } | |
| 1257 } | |
| 1258 #endif /* LOSING_BYTECODE */ | |
| 1259 else | |
| 1260 { | |
| 1261 check_losing_bytecode ("elt", sequence); | |
| 1262 sequence = wrong_type_argument (Qsequencep, sequence); | |
| 1263 goto retry; | |
| 1264 } | |
| 1265 } | |
| 1266 | |
| 1267 DEFUN ("last", Flast, 1, 2, 0, /* | |
| 1268 Return the tail of list LIST, of length N (default 1). | |
| 1269 LIST may be a dotted list, but not a circular list. | |
| 1270 Optional argument N must be a non-negative integer. | |
| 1271 If N is zero, then the atom that terminates the list is returned. | |
| 1272 If N is greater than the length of LIST, then LIST itself is returned. | |
| 1273 */ | |
| 1274 (list, n)) | |
| 1275 { | |
| 1276 EMACS_INT int_n, count; | |
| 1277 Lisp_Object retval, tortoise, hare; | |
| 1278 | |
| 1279 CHECK_LIST (list); | |
| 1280 | |
| 1281 if (NILP (n)) | |
| 1282 int_n = 1; | |
| 1283 else | |
| 1284 { | |
| 1285 CHECK_NATNUM (n); | |
| 1286 int_n = XINT (n); | |
| 1287 } | |
| 1288 | |
| 1289 for (retval = tortoise = hare = list, count = 0; | |
| 1290 CONSP (hare); | |
| 1291 hare = XCDR (hare), | |
| 1292 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0), | |
| 1293 count++) | |
| 1294 { | |
| 1295 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 1296 | |
| 1297 if (count & 1) | |
| 1298 tortoise = XCDR (tortoise); | |
| 1299 if (EQ (hare, tortoise)) | |
| 1300 signal_circular_list_error (list); | |
| 1301 } | |
| 1302 | |
| 1303 return retval; | |
| 1304 } | |
| 1305 | |
| 1306 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* | |
| 1307 Modify LIST to remove the last N (default 1) elements. | |
| 1308 If LIST has N or fewer elements, nil is returned and LIST is unmodified. | |
| 1309 */ | |
| 1310 (list, n)) | |
| 1311 { | |
| 1312 EMACS_INT int_n; | |
| 1313 | |
| 1314 CHECK_LIST (list); | |
| 1315 | |
| 1316 if (NILP (n)) | |
| 1317 int_n = 1; | |
| 1318 else | |
| 1319 { | |
| 1320 CHECK_NATNUM (n); | |
| 1321 int_n = XINT (n); | |
| 1322 } | |
| 1323 | |
| 1324 { | |
| 1325 Lisp_Object last_cons = list; | |
| 1326 | |
| 1327 EXTERNAL_LIST_LOOP_1 (list) | |
| 1328 { | |
| 1329 if (int_n-- < 0) | |
| 1330 last_cons = XCDR (last_cons); | |
| 1331 } | |
| 1332 | |
| 1333 if (int_n >= 0) | |
| 1334 return Qnil; | |
| 1335 | |
| 1336 XCDR (last_cons) = Qnil; | |
| 1337 return list; | |
| 1338 } | |
| 1339 } | |
| 1340 | |
| 1341 DEFUN ("butlast", Fbutlast, 1, 2, 0, /* | |
| 1342 Return a copy of LIST with the last N (default 1) elements removed. | |
| 1343 If LIST has N or fewer elements, nil is returned. | |
| 1344 */ | |
| 1345 (list, n)) | |
| 1346 { | |
| 444 | 1347 EMACS_INT int_n; |
| 428 | 1348 |
| 1349 CHECK_LIST (list); | |
| 1350 | |
| 1351 if (NILP (n)) | |
| 1352 int_n = 1; | |
| 1353 else | |
| 1354 { | |
| 1355 CHECK_NATNUM (n); | |
| 1356 int_n = XINT (n); | |
| 1357 } | |
| 1358 | |
| 1359 { | |
| 1360 Lisp_Object retval = Qnil; | |
| 1361 Lisp_Object tail = list; | |
| 1362 | |
| 1363 EXTERNAL_LIST_LOOP_1 (list) | |
| 1364 { | |
| 1365 if (--int_n < 0) | |
| 1366 { | |
| 1367 retval = Fcons (XCAR (tail), retval); | |
| 1368 tail = XCDR (tail); | |
| 1369 } | |
| 1370 } | |
| 1371 | |
| 1372 return Fnreverse (retval); | |
| 1373 } | |
| 1374 } | |
| 1375 | |
| 1376 DEFUN ("member", Fmember, 2, 2, 0, /* | |
| 1377 Return non-nil if ELT is an element of LIST. Comparison done with `equal'. | |
| 1378 The value is actually the tail of LIST whose car is ELT. | |
| 1379 */ | |
| 1380 (elt, list)) | |
| 1381 { | |
| 1382 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1383 { | |
| 1384 if (internal_equal (elt, list_elt, 0)) | |
| 1385 return tail; | |
| 1386 } | |
| 1387 return Qnil; | |
| 1388 } | |
| 1389 | |
| 1390 DEFUN ("old-member", Fold_member, 2, 2, 0, /* | |
| 1391 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'. | |
| 1392 The value is actually the tail of LIST whose car is ELT. | |
| 1393 This function is provided only for byte-code compatibility with v19. | |
| 1394 Do not use it. | |
| 1395 */ | |
| 1396 (elt, list)) | |
| 1397 { | |
| 1398 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1399 { | |
| 1400 if (internal_old_equal (elt, list_elt, 0)) | |
| 1401 return tail; | |
| 1402 } | |
| 1403 return Qnil; | |
| 1404 } | |
| 1405 | |
| 1406 DEFUN ("memq", Fmemq, 2, 2, 0, /* | |
| 1407 Return non-nil if ELT is an element of LIST. Comparison done with `eq'. | |
| 1408 The value is actually the tail of LIST whose car is ELT. | |
| 1409 */ | |
| 1410 (elt, list)) | |
| 1411 { | |
| 1412 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1413 { | |
| 1414 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) | |
| 1415 return tail; | |
| 1416 } | |
| 1417 return Qnil; | |
| 1418 } | |
| 1419 | |
| 1420 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /* | |
| 1421 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'. | |
| 1422 The value is actually the tail of LIST whose car is ELT. | |
| 1423 This function is provided only for byte-code compatibility with v19. | |
| 1424 Do not use it. | |
| 1425 */ | |
| 1426 (elt, list)) | |
| 1427 { | |
| 1428 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) | |
| 1429 { | |
| 1430 if (HACKEQ_UNSAFE (elt, list_elt)) | |
| 1431 return tail; | |
| 1432 } | |
| 1433 return Qnil; | |
| 1434 } | |
| 1435 | |
| 1436 Lisp_Object | |
| 1437 memq_no_quit (Lisp_Object elt, Lisp_Object list) | |
| 1438 { | |
| 1439 LIST_LOOP_3 (list_elt, list, tail) | |
| 1440 { | |
| 1441 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) | |
| 1442 return tail; | |
| 1443 } | |
| 1444 return Qnil; | |
| 1445 } | |
| 1446 | |
| 1447 DEFUN ("assoc", Fassoc, 2, 2, 0, /* | |
| 444 | 1448 Return non-nil if KEY is `equal' to the car of an element of ALIST. |
| 1449 The value is actually the element of ALIST whose car equals KEY. | |
| 428 | 1450 */ |
| 444 | 1451 (key, alist)) |
| 428 | 1452 { |
| 1453 /* This function can GC. */ | |
| 444 | 1454 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1455 { |
| 1456 if (internal_equal (key, elt_car, 0)) | |
| 1457 return elt; | |
| 1458 } | |
| 1459 return Qnil; | |
| 1460 } | |
| 1461 | |
| 1462 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /* | |
| 444 | 1463 Return non-nil if KEY is `old-equal' to the car of an element of ALIST. |
| 1464 The value is actually the element of ALIST whose car equals KEY. | |
| 428 | 1465 */ |
| 444 | 1466 (key, alist)) |
| 428 | 1467 { |
| 1468 /* This function can GC. */ | |
| 444 | 1469 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1470 { |
| 1471 if (internal_old_equal (key, elt_car, 0)) | |
| 1472 return elt; | |
| 1473 } | |
| 1474 return Qnil; | |
| 1475 } | |
| 1476 | |
| 1477 Lisp_Object | |
| 444 | 1478 assoc_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1479 { |
| 1480 int speccount = specpdl_depth (); | |
| 1481 specbind (Qinhibit_quit, Qt); | |
| 771 | 1482 return unbind_to_1 (speccount, Fassoc (key, alist)); |
| 428 | 1483 } |
| 1484 | |
| 1485 DEFUN ("assq", Fassq, 2, 2, 0, /* | |
| 444 | 1486 Return non-nil if KEY is `eq' to the car of an element of ALIST. |
| 1487 The value is actually the element of ALIST whose car is KEY. | |
| 1488 Elements of ALIST that are not conses are ignored. | |
| 428 | 1489 */ |
| 444 | 1490 (key, alist)) |
| 428 | 1491 { |
| 444 | 1492 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1493 { |
| 1494 if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) | |
| 1495 return elt; | |
| 1496 } | |
| 1497 return Qnil; | |
| 1498 } | |
| 1499 | |
| 1500 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /* | |
| 444 | 1501 Return non-nil if KEY is `old-eq' to the car of an element of ALIST. |
| 1502 The value is actually the element of ALIST whose car is KEY. | |
| 1503 Elements of ALIST that are not conses are ignored. | |
| 428 | 1504 This function is provided only for byte-code compatibility with v19. |
| 1505 Do not use it. | |
| 1506 */ | |
| 444 | 1507 (key, alist)) |
| 428 | 1508 { |
| 444 | 1509 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1510 { |
| 1511 if (HACKEQ_UNSAFE (key, elt_car)) | |
| 1512 return elt; | |
| 1513 } | |
| 1514 return Qnil; | |
| 1515 } | |
| 1516 | |
| 1517 /* Like Fassq but never report an error and do not allow quits. | |
| 1518 Use only on lists known never to be circular. */ | |
| 1519 | |
| 1520 Lisp_Object | |
| 444 | 1521 assq_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1522 { |
| 1523 /* This cannot GC. */ | |
| 444 | 1524 LIST_LOOP_2 (elt, alist) |
| 428 | 1525 { |
| 1526 Lisp_Object elt_car = XCAR (elt); | |
| 1527 if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) | |
| 1528 return elt; | |
| 1529 } | |
| 1530 return Qnil; | |
| 1531 } | |
| 1532 | |
| 1533 DEFUN ("rassoc", Frassoc, 2, 2, 0, /* | |
| 444 | 1534 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST. |
| 1535 The value is actually the element of ALIST whose cdr equals VALUE. | |
| 428 | 1536 */ |
| 444 | 1537 (value, alist)) |
| 428 | 1538 { |
| 444 | 1539 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1540 { |
| 444 | 1541 if (internal_equal (value, elt_cdr, 0)) |
| 428 | 1542 return elt; |
| 1543 } | |
| 1544 return Qnil; | |
| 1545 } | |
| 1546 | |
| 1547 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* | |
| 444 | 1548 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. |
| 1549 The value is actually the element of ALIST whose cdr equals VALUE. | |
| 428 | 1550 */ |
| 444 | 1551 (value, alist)) |
| 428 | 1552 { |
| 444 | 1553 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1554 { |
| 444 | 1555 if (internal_old_equal (value, elt_cdr, 0)) |
| 428 | 1556 return elt; |
| 1557 } | |
| 1558 return Qnil; | |
| 1559 } | |
| 1560 | |
| 1561 DEFUN ("rassq", Frassq, 2, 2, 0, /* | |
| 444 | 1562 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST. |
| 1563 The value is actually the element of ALIST whose cdr is VALUE. | |
| 428 | 1564 */ |
| 444 | 1565 (value, alist)) |
| 428 | 1566 { |
| 444 | 1567 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1568 { |
| 444 | 1569 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) |
| 428 | 1570 return elt; |
| 1571 } | |
| 1572 return Qnil; | |
| 1573 } | |
| 1574 | |
| 1575 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* | |
| 444 | 1576 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST. |
| 1577 The value is actually the element of ALIST whose cdr is VALUE. | |
| 428 | 1578 */ |
| 444 | 1579 (value, alist)) |
| 428 | 1580 { |
| 444 | 1581 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
| 428 | 1582 { |
| 444 | 1583 if (HACKEQ_UNSAFE (value, elt_cdr)) |
| 428 | 1584 return elt; |
| 1585 } | |
| 1586 return Qnil; | |
| 1587 } | |
| 1588 | |
| 444 | 1589 /* Like Frassq, but caller must ensure that ALIST is properly |
| 428 | 1590 nil-terminated and ebola-free. */ |
| 1591 Lisp_Object | |
| 444 | 1592 rassq_no_quit (Lisp_Object value, Lisp_Object alist) |
| 428 | 1593 { |
| 444 | 1594 LIST_LOOP_2 (elt, alist) |
| 428 | 1595 { |
| 1596 Lisp_Object elt_cdr = XCDR (elt); | |
| 444 | 1597 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) |
| 428 | 1598 return elt; |
| 1599 } | |
| 1600 return Qnil; | |
| 1601 } | |
| 1602 | |
| 1603 | |
| 1604 DEFUN ("delete", Fdelete, 2, 2, 0, /* | |
| 1605 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1606 The modified LIST is returned. Comparison is done with `equal'. | |
| 1607 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1608 effect; therefore, write `(setq foo (delete element foo))' to be sure | |
| 1609 of changing the value of `foo'. | |
| 1610 Also see: `remove'. | |
| 1611 */ | |
| 1612 (elt, list)) | |
| 1613 { | |
| 1614 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1615 (internal_equal (elt, list_elt, 0))); | |
| 1616 return list; | |
| 1617 } | |
| 1618 | |
| 1619 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /* | |
| 1620 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1621 The modified LIST is returned. Comparison is done with `old-equal'. | |
| 1622 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1623 effect; therefore, write `(setq foo (old-delete element foo))' to be sure | |
| 1624 of changing the value of `foo'. | |
| 1625 */ | |
| 1626 (elt, list)) | |
| 1627 { | |
| 1628 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1629 (internal_old_equal (elt, list_elt, 0))); | |
| 1630 return list; | |
| 1631 } | |
| 1632 | |
| 1633 DEFUN ("delq", Fdelq, 2, 2, 0, /* | |
| 1634 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1635 The modified LIST is returned. Comparison is done with `eq'. | |
| 1636 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1637 effect; therefore, write `(setq foo (delq element foo))' to be sure of | |
| 1638 changing the value of `foo'. | |
| 1639 */ | |
| 1640 (elt, list)) | |
| 1641 { | |
| 1642 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1643 (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); | |
| 1644 return list; | |
| 1645 } | |
| 1646 | |
| 1647 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /* | |
| 1648 Delete by side effect any occurrences of ELT as a member of LIST. | |
| 1649 The modified LIST is returned. Comparison is done with `old-eq'. | |
| 1650 If the first member of LIST is ELT, there is no way to remove it by side | |
| 1651 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of | |
| 1652 changing the value of `foo'. | |
| 1653 */ | |
| 1654 (elt, list)) | |
| 1655 { | |
| 1656 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1657 (HACKEQ_UNSAFE (elt, list_elt))); | |
| 1658 return list; | |
| 1659 } | |
| 1660 | |
| 1661 /* Like Fdelq, but caller must ensure that LIST is properly | |
| 1662 nil-terminated and ebola-free. */ | |
| 1663 | |
| 1664 Lisp_Object | |
| 1665 delq_no_quit (Lisp_Object elt, Lisp_Object list) | |
| 1666 { | |
| 1667 LIST_LOOP_DELETE_IF (list_elt, list, | |
| 1668 (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); | |
| 1669 return list; | |
| 1670 } | |
| 1671 | |
| 1672 /* Be VERY careful with this. This is like delq_no_quit() but | |
| 1673 also calls free_cons() on the removed conses. You must be SURE | |
| 1674 that no pointers to the freed conses remain around (e.g. | |
| 1675 someone else is pointing to part of the list). This function | |
| 1676 is useful on internal lists that are used frequently and where | |
| 1677 the actual list doesn't escape beyond known code bounds. */ | |
| 1678 | |
| 1679 Lisp_Object | |
| 1680 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) | |
| 1681 { | |
| 1682 REGISTER Lisp_Object tail = list; | |
| 1683 REGISTER Lisp_Object prev = Qnil; | |
| 1684 | |
| 1685 while (!NILP (tail)) | |
| 1686 { | |
| 1687 REGISTER Lisp_Object tem = XCAR (tail); | |
| 1688 if (EQ (elt, tem)) | |
| 1689 { | |
| 1690 Lisp_Object cons_to_free = tail; | |
| 1691 if (NILP (prev)) | |
| 1692 list = XCDR (tail); | |
| 1693 else | |
| 1694 XCDR (prev) = XCDR (tail); | |
| 1695 tail = XCDR (tail); | |
| 853 | 1696 free_cons (cons_to_free); |
| 428 | 1697 } |
| 1698 else | |
| 1699 { | |
| 1700 prev = tail; | |
| 1701 tail = XCDR (tail); | |
| 1702 } | |
| 1703 } | |
| 1704 return list; | |
| 1705 } | |
| 1706 | |
| 1707 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /* | |
| 444 | 1708 Delete by side effect any elements of ALIST whose car is `equal' to KEY. |
| 1709 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1710 that is `equal' to KEY, there is no way to remove it by side effect; |
| 1711 therefore, write `(setq foo (remassoc key foo))' to be sure of changing | |
| 1712 the value of `foo'. | |
| 1713 */ | |
| 444 | 1714 (key, alist)) |
| 428 | 1715 { |
| 444 | 1716 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1717 (CONSP (elt) && |
| 1718 internal_equal (key, XCAR (elt), 0))); | |
| 444 | 1719 return alist; |
| 428 | 1720 } |
| 1721 | |
| 1722 Lisp_Object | |
| 444 | 1723 remassoc_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1724 { |
| 1725 int speccount = specpdl_depth (); | |
| 1726 specbind (Qinhibit_quit, Qt); | |
| 771 | 1727 return unbind_to_1 (speccount, Fremassoc (key, alist)); |
| 428 | 1728 } |
| 1729 | |
| 1730 DEFUN ("remassq", Fremassq, 2, 2, 0, /* | |
| 444 | 1731 Delete by side effect any elements of ALIST whose car is `eq' to KEY. |
| 1732 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1733 that is `eq' to KEY, there is no way to remove it by side effect; |
| 1734 therefore, write `(setq foo (remassq key foo))' to be sure of changing | |
| 1735 the value of `foo'. | |
| 1736 */ | |
| 444 | 1737 (key, alist)) |
| 428 | 1738 { |
| 444 | 1739 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1740 (CONSP (elt) && |
| 1741 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); | |
| 444 | 1742 return alist; |
| 428 | 1743 } |
| 1744 | |
| 1745 /* no quit, no errors; be careful */ | |
| 1746 | |
| 1747 Lisp_Object | |
| 444 | 1748 remassq_no_quit (Lisp_Object key, Lisp_Object alist) |
| 428 | 1749 { |
| 444 | 1750 LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1751 (CONSP (elt) && |
| 1752 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); | |
| 444 | 1753 return alist; |
| 428 | 1754 } |
| 1755 | |
| 1756 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /* | |
| 444 | 1757 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE. |
| 1758 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1759 that is `equal' to VALUE, there is no way to remove it by side effect; |
| 1760 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing | |
| 1761 the value of `foo'. | |
| 1762 */ | |
| 444 | 1763 (value, alist)) |
| 428 | 1764 { |
| 444 | 1765 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1766 (CONSP (elt) && |
| 1767 internal_equal (value, XCDR (elt), 0))); | |
| 444 | 1768 return alist; |
| 428 | 1769 } |
| 1770 | |
| 1771 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /* | |
| 444 | 1772 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE. |
| 1773 The modified ALIST is returned. If the first member of ALIST has a car | |
| 428 | 1774 that is `eq' to VALUE, there is no way to remove it by side effect; |
| 1775 therefore, write `(setq foo (remrassq value foo))' to be sure of changing | |
| 1776 the value of `foo'. | |
| 1777 */ | |
| 444 | 1778 (value, alist)) |
| 428 | 1779 { |
| 444 | 1780 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1781 (CONSP (elt) && |
| 1782 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); | |
| 444 | 1783 return alist; |
| 428 | 1784 } |
| 1785 | |
| 1786 /* Like Fremrassq, fast and unsafe; be careful */ | |
| 1787 Lisp_Object | |
| 444 | 1788 remrassq_no_quit (Lisp_Object value, Lisp_Object alist) |
| 428 | 1789 { |
| 444 | 1790 LIST_LOOP_DELETE_IF (elt, alist, |
| 428 | 1791 (CONSP (elt) && |
| 1792 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); | |
| 444 | 1793 return alist; |
| 428 | 1794 } |
| 1795 | |
| 1796 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /* | |
| 1797 Reverse LIST by destructively modifying cdr pointers. | |
| 1798 Return the beginning of the reversed list. | |
| 1799 Also see: `reverse'. | |
| 1800 */ | |
| 1801 (list)) | |
| 1802 { | |
| 1803 struct gcpro gcpro1, gcpro2; | |
| 1849 | 1804 Lisp_Object prev = Qnil; |
| 1805 Lisp_Object tail = list; | |
| 428 | 1806 |
| 1807 /* We gcpro our args; see `nconc' */ | |
| 1808 GCPRO2 (prev, tail); | |
| 1809 while (!NILP (tail)) | |
| 1810 { | |
| 1811 REGISTER Lisp_Object next; | |
| 1812 CONCHECK_CONS (tail); | |
| 1813 next = XCDR (tail); | |
| 1814 XCDR (tail) = prev; | |
| 1815 prev = tail; | |
| 1816 tail = next; | |
| 1817 } | |
| 1818 UNGCPRO; | |
| 1819 return prev; | |
| 1820 } | |
| 1821 | |
| 1822 DEFUN ("reverse", Freverse, 1, 1, 0, /* | |
| 1823 Reverse LIST, copying. Return the beginning of the reversed list. | |
| 1824 See also the function `nreverse', which is used more often. | |
| 1825 */ | |
| 1826 (list)) | |
| 1827 { | |
| 1828 Lisp_Object reversed_list = Qnil; | |
| 1829 EXTERNAL_LIST_LOOP_2 (elt, list) | |
| 1830 { | |
| 1831 reversed_list = Fcons (elt, reversed_list); | |
| 1832 } | |
| 1833 return reversed_list; | |
| 1834 } | |
| 1835 | |
| 1836 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, | |
| 1837 Lisp_Object lisp_arg, | |
| 1838 int (*pred_fn) (Lisp_Object, Lisp_Object, | |
| 1839 Lisp_Object lisp_arg)); | |
| 1840 | |
| 872 | 1841 /* The sort function should return > 0 if OBJ1 < OBJ2, < 0 otherwise. |
| 1842 NOTE: This is backwards from the way qsort() works. */ | |
| 1843 | |
| 428 | 1844 Lisp_Object |
| 1845 list_sort (Lisp_Object list, | |
| 1846 Lisp_Object lisp_arg, | |
| 872 | 1847 int (*pred_fn) (Lisp_Object obj1, Lisp_Object obj2, |
| 428 | 1848 Lisp_Object lisp_arg)) |
| 1849 { | |
| 1850 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 1851 Lisp_Object back, tem; | |
| 1852 Lisp_Object front = list; | |
| 1853 Lisp_Object len = Flength (list); | |
| 444 | 1854 |
| 1855 if (XINT (len) < 2) | |
| 428 | 1856 return list; |
| 1857 | |
| 444 | 1858 len = make_int (XINT (len) / 2 - 1); |
| 428 | 1859 tem = Fnthcdr (len, list); |
| 1860 back = Fcdr (tem); | |
| 1861 Fsetcdr (tem, Qnil); | |
| 1862 | |
| 1863 GCPRO3 (front, back, lisp_arg); | |
| 1864 front = list_sort (front, lisp_arg, pred_fn); | |
| 1865 back = list_sort (back, lisp_arg, pred_fn); | |
| 1866 UNGCPRO; | |
| 1867 return list_merge (front, back, lisp_arg, pred_fn); | |
| 1868 } | |
| 1869 | |
| 1870 | |
| 1871 static int | |
| 1872 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2, | |
| 1873 Lisp_Object pred) | |
| 1874 { | |
| 1875 Lisp_Object tmp; | |
| 1876 | |
| 1877 /* prevents the GC from happening in call2 */ | |
| 853 | 1878 /* Emacs' GC doesn't actually relocate pointers, so this probably |
| 1879 isn't strictly necessary */ | |
| 771 | 1880 int speccount = begin_gc_forbidden (); |
| 428 | 1881 tmp = call2 (pred, obj1, obj2); |
| 771 | 1882 unbind_to (speccount); |
| 428 | 1883 |
| 1884 if (NILP (tmp)) | |
| 1885 return -1; | |
| 1886 else | |
| 1887 return 1; | |
| 1888 } | |
| 1889 | |
| 1890 DEFUN ("sort", Fsort, 2, 2, 0, /* | |
| 1891 Sort LIST, stably, comparing elements using PREDICATE. | |
| 1892 Returns the sorted list. LIST is modified by side effects. | |
| 1893 PREDICATE is called with two elements of LIST, and should return T | |
| 1894 if the first element is "less" than the second. | |
| 1895 */ | |
| 444 | 1896 (list, predicate)) |
| 428 | 1897 { |
| 444 | 1898 return list_sort (list, predicate, merge_pred_function); |
| 428 | 1899 } |
| 1900 | |
| 1901 Lisp_Object | |
| 1902 merge (Lisp_Object org_l1, Lisp_Object org_l2, | |
| 1903 Lisp_Object pred) | |
| 1904 { | |
| 1905 return list_merge (org_l1, org_l2, pred, merge_pred_function); | |
| 1906 } | |
| 1907 | |
| 1908 | |
| 1909 static Lisp_Object | |
| 1910 list_merge (Lisp_Object org_l1, Lisp_Object org_l2, | |
| 1911 Lisp_Object lisp_arg, | |
| 1912 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg)) | |
| 1913 { | |
| 1914 Lisp_Object value; | |
| 1915 Lisp_Object tail; | |
| 1916 Lisp_Object tem; | |
| 1917 Lisp_Object l1, l2; | |
| 1918 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1919 | |
| 1920 l1 = org_l1; | |
| 1921 l2 = org_l2; | |
| 1922 tail = Qnil; | |
| 1923 value = Qnil; | |
| 1924 | |
| 1925 /* It is sufficient to protect org_l1 and org_l2. | |
| 1926 When l1 and l2 are updated, we copy the new values | |
| 1927 back into the org_ vars. */ | |
| 1928 | |
| 1929 GCPRO4 (org_l1, org_l2, lisp_arg, value); | |
| 1930 | |
| 1931 while (1) | |
| 1932 { | |
| 1933 if (NILP (l1)) | |
| 1934 { | |
| 1935 UNGCPRO; | |
| 1936 if (NILP (tail)) | |
| 1937 return l2; | |
| 1938 Fsetcdr (tail, l2); | |
| 1939 return value; | |
| 1940 } | |
| 1941 if (NILP (l2)) | |
| 1942 { | |
| 1943 UNGCPRO; | |
| 1944 if (NILP (tail)) | |
| 1945 return l1; | |
| 1946 Fsetcdr (tail, l1); | |
| 1947 return value; | |
| 1948 } | |
| 1949 | |
| 1950 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0) | |
| 1951 { | |
| 1952 tem = l1; | |
| 1953 l1 = Fcdr (l1); | |
| 1954 org_l1 = l1; | |
| 1955 } | |
| 1956 else | |
| 1957 { | |
| 1958 tem = l2; | |
| 1959 l2 = Fcdr (l2); | |
| 1960 org_l2 = l2; | |
| 1961 } | |
| 1962 if (NILP (tail)) | |
| 1963 value = tem; | |
| 1964 else | |
| 1965 Fsetcdr (tail, tem); | |
| 1966 tail = tem; | |
| 1967 } | |
| 1968 } | |
| 1969 | |
| 1970 | |
| 1971 /************************************************************************/ | |
| 1972 /* property-list functions */ | |
| 1973 /************************************************************************/ | |
| 1974 | |
| 1975 /* For properties of text, we need to do order-insensitive comparison of | |
| 1976 plists. That is, we need to compare two plists such that they are the | |
| 1977 same if they have the same set of keys, and equivalent values. | |
| 1978 So (a 1 b 2) would be equal to (b 2 a 1). | |
| 1979 | |
| 1980 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc. | |
| 1981 LAXP means use `equal' for comparisons. | |
| 1982 */ | |
| 1983 int | |
| 1984 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, | |
| 1985 int laxp, int depth) | |
| 1986 { | |
| 438 | 1987 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ |
| 428 | 1988 int la, lb, m, i, fill; |
| 1989 Lisp_Object *keys, *vals; | |
| 1990 char *flags; | |
| 1991 Lisp_Object rest; | |
| 1992 | |
| 1993 if (NILP (a) && NILP (b)) | |
| 1994 return 0; | |
| 1995 | |
| 1996 Fcheck_valid_plist (a); | |
| 1997 Fcheck_valid_plist (b); | |
| 1998 | |
| 1999 la = XINT (Flength (a)); | |
| 2000 lb = XINT (Flength (b)); | |
| 2001 m = (la > lb ? la : lb); | |
| 2002 fill = 0; | |
| 2003 keys = alloca_array (Lisp_Object, m); | |
| 2004 vals = alloca_array (Lisp_Object, m); | |
| 2005 flags = alloca_array (char, m); | |
| 2006 | |
| 2007 /* First extract the pairs from A. */ | |
| 2008 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest))) | |
| 2009 { | |
| 2010 Lisp_Object k = XCAR (rest); | |
| 2011 Lisp_Object v = XCAR (XCDR (rest)); | |
| 2012 /* Maybe be Ebolified. */ | |
| 2013 if (nil_means_not_present && NILP (v)) continue; | |
| 2014 keys [fill] = k; | |
| 2015 vals [fill] = v; | |
| 2016 flags[fill] = 0; | |
| 2017 fill++; | |
| 2018 } | |
| 2019 /* Now iterate over B, and stop if we find something that's not in A, | |
| 2020 or that doesn't match. As we match, mark them. */ | |
| 2021 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest))) | |
| 2022 { | |
| 2023 Lisp_Object k = XCAR (rest); | |
| 2024 Lisp_Object v = XCAR (XCDR (rest)); | |
| 2025 /* Maybe be Ebolified. */ | |
| 2026 if (nil_means_not_present && NILP (v)) continue; | |
| 2027 for (i = 0; i < fill; i++) | |
| 2028 { | |
| 2029 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) | |
| 2030 { | |
| 434 | 2031 if (eqp |
| 2032 /* We narrowly escaped being Ebolified here. */ | |
| 2033 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) | |
| 2034 : !internal_equal (v, vals [i], depth)) | |
| 428 | 2035 /* a property in B has a different value than in A */ |
| 2036 goto MISMATCH; | |
| 2037 flags [i] = 1; | |
| 2038 break; | |
| 2039 } | |
| 2040 } | |
| 2041 if (i == fill) | |
| 2042 /* there are some properties in B that are not in A */ | |
| 2043 goto MISMATCH; | |
| 2044 } | |
| 2045 /* Now check to see that all the properties in A were also in B */ | |
| 2046 for (i = 0; i < fill; i++) | |
| 2047 if (flags [i] == 0) | |
| 2048 goto MISMATCH; | |
| 2049 | |
| 2050 /* Ok. */ | |
| 2051 return 0; | |
| 2052 | |
| 2053 MISMATCH: | |
| 2054 return 1; | |
| 2055 } | |
| 2056 | |
| 2057 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /* | |
| 2058 Return non-nil if property lists A and B are `eq'. | |
| 2059 A property list is an alternating list of keywords and values. | |
| 2060 This function does order-insensitive comparisons of the property lists: | |
| 2061 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2062 Comparison between values is done using `eq'. See also `plists-equal'. | |
| 2063 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2064 a nil value is ignored. This feature is a virus that has infected | |
| 2065 old Lisp implementations, but should not be used except for backward | |
| 2066 compatibility. | |
| 2067 */ | |
| 2068 (a, b, nil_means_not_present)) | |
| 2069 { | |
| 2070 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1) | |
| 2071 ? Qnil : Qt); | |
| 2072 } | |
| 2073 | |
| 2074 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /* | |
| 2075 Return non-nil if property lists A and B are `equal'. | |
| 2076 A property list is an alternating list of keywords and values. This | |
| 2077 function does order-insensitive comparisons of the property lists: For | |
| 2078 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2079 Comparison between values is done using `equal'. See also `plists-eq'. | |
| 2080 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2081 a nil value is ignored. This feature is a virus that has infected | |
| 2082 old Lisp implementations, but should not be used except for backward | |
| 2083 compatibility. | |
| 2084 */ | |
| 2085 (a, b, nil_means_not_present)) | |
| 2086 { | |
| 2087 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1) | |
| 2088 ? Qnil : Qt); | |
| 2089 } | |
| 2090 | |
| 2091 | |
| 2092 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /* | |
| 2093 Return non-nil if lax property lists A and B are `eq'. | |
| 2094 A property list is an alternating list of keywords and values. | |
| 2095 This function does order-insensitive comparisons of the property lists: | |
| 2096 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2097 Comparison between values is done using `eq'. See also `plists-equal'. | |
| 2098 A lax property list is like a regular one except that comparisons between | |
| 2099 keywords is done using `equal' instead of `eq'. | |
| 2100 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2101 a nil value is ignored. This feature is a virus that has infected | |
| 2102 old Lisp implementations, but should not be used except for backward | |
| 2103 compatibility. | |
| 2104 */ | |
| 2105 (a, b, nil_means_not_present)) | |
| 2106 { | |
| 2107 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1) | |
| 2108 ? Qnil : Qt); | |
| 2109 } | |
| 2110 | |
| 2111 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /* | |
| 2112 Return non-nil if lax property lists A and B are `equal'. | |
| 2113 A property list is an alternating list of keywords and values. This | |
| 2114 function does order-insensitive comparisons of the property lists: For | |
| 2115 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 2116 Comparison between values is done using `equal'. See also `plists-eq'. | |
| 2117 A lax property list is like a regular one except that comparisons between | |
| 2118 keywords is done using `equal' instead of `eq'. | |
| 2119 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2120 a nil value is ignored. This feature is a virus that has infected | |
| 2121 old Lisp implementations, but should not be used except for backward | |
| 2122 compatibility. | |
| 2123 */ | |
| 2124 (a, b, nil_means_not_present)) | |
| 2125 { | |
| 2126 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1) | |
| 2127 ? Qnil : Qt); | |
| 2128 } | |
| 2129 | |
| 2130 /* Return the value associated with key PROPERTY in property list PLIST. | |
| 2131 Return nil if key not found. This function is used for internal | |
| 2132 property lists that cannot be directly manipulated by the user. | |
| 2133 */ | |
| 2134 | |
| 2135 Lisp_Object | |
| 2136 internal_plist_get (Lisp_Object plist, Lisp_Object property) | |
| 2137 { | |
| 2138 Lisp_Object tail; | |
| 2139 | |
| 2140 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
| 2141 { | |
| 2142 if (EQ (XCAR (tail), property)) | |
| 2143 return XCAR (XCDR (tail)); | |
| 2144 } | |
| 2145 | |
| 2146 return Qunbound; | |
| 2147 } | |
| 2148 | |
| 2149 /* Set PLIST's value for PROPERTY to VALUE. Analogous to | |
| 2150 internal_plist_get(). */ | |
| 2151 | |
| 2152 void | |
| 2153 internal_plist_put (Lisp_Object *plist, Lisp_Object property, | |
| 2154 Lisp_Object value) | |
| 2155 { | |
| 2156 Lisp_Object tail; | |
| 2157 | |
| 2158 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
| 2159 { | |
| 2160 if (EQ (XCAR (tail), property)) | |
| 2161 { | |
| 2162 XCAR (XCDR (tail)) = value; | |
| 2163 return; | |
| 2164 } | |
| 2165 } | |
| 2166 | |
| 2167 *plist = Fcons (property, Fcons (value, *plist)); | |
| 2168 } | |
| 2169 | |
| 2170 int | |
| 2171 internal_remprop (Lisp_Object *plist, Lisp_Object property) | |
| 2172 { | |
| 2173 Lisp_Object tail, prev; | |
| 2174 | |
| 2175 for (tail = *plist, prev = Qnil; | |
| 2176 !NILP (tail); | |
| 2177 tail = XCDR (XCDR (tail))) | |
| 2178 { | |
| 2179 if (EQ (XCAR (tail), property)) | |
| 2180 { | |
| 2181 if (NILP (prev)) | |
| 2182 *plist = XCDR (XCDR (tail)); | |
| 2183 else | |
| 2184 XCDR (XCDR (prev)) = XCDR (XCDR (tail)); | |
| 2185 return 1; | |
| 2186 } | |
| 2187 else | |
| 2188 prev = tail; | |
| 2189 } | |
| 2190 | |
| 2191 return 0; | |
| 2192 } | |
| 2193 | |
| 2194 /* Called on a malformed property list. BADPLACE should be some | |
| 2195 place where truncating will form a good list -- i.e. we shouldn't | |
| 2196 result in a list with an odd length. */ | |
| 2197 | |
| 2198 static Lisp_Object | |
| 578 | 2199 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
| 428 | 2200 { |
| 2201 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2202 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace)); | |
| 2203 else | |
| 2204 { | |
| 2205 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
| 2206 { | |
| 2207 warn_when_safe_lispobj | |
| 2208 (Qlist, Qwarning, | |
| 771 | 2209 list2 (build_msg_string |
| 428 | 2210 ("Malformed property list -- list has been truncated"), |
| 2211 *plist)); | |
| 793 | 2212 /* #### WARNING: This is more dangerous than it seems; perhaps |
| 2213 not a good idea. It also violates the principle of least | |
| 2214 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
| 2215 ERROR_ME and ERROR_ME_NOT don't. */ | |
| 428 | 2216 *badplace = Qnil; |
| 2217 } | |
| 2218 return Qunbound; | |
| 2219 } | |
| 2220 } | |
| 2221 | |
| 2222 /* Called on a circular property list. BADPLACE should be some place | |
| 2223 where truncating will result in an even-length list, as above. | |
| 2224 If doesn't particularly matter where we truncate -- anywhere we | |
| 2225 truncate along the entire list will break the circularity, because | |
| 2226 it will create a terminus and the list currently doesn't have one. | |
| 2227 */ | |
| 2228 | |
| 2229 static Lisp_Object | |
| 578 | 2230 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
| 428 | 2231 { |
| 2232 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2233 return Fsignal (Qcircular_property_list, list1 (*plist)); | |
| 2234 else | |
| 2235 { | |
| 2236 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
| 2237 { | |
| 2238 warn_when_safe_lispobj | |
| 2239 (Qlist, Qwarning, | |
| 771 | 2240 list2 (build_msg_string |
| 428 | 2241 ("Circular property list -- list has been truncated"), |
| 2242 *plist)); | |
| 793 | 2243 /* #### WARNING: This is more dangerous than it seems; perhaps |
| 2244 not a good idea. It also violates the principle of least | |
| 2245 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
| 2246 ERROR_ME and ERROR_ME_NOT don't. */ | |
| 428 | 2247 *badplace = Qnil; |
| 2248 } | |
| 2249 return Qunbound; | |
| 2250 } | |
| 2251 } | |
| 2252 | |
| 2253 /* Advance the tortoise pointer by two (one iteration of a property-list | |
| 2254 loop) and the hare pointer by four and verify that no malformations | |
| 2255 or circularities exist. If so, return zero and store a value into | |
| 2256 RETVAL that should be returned by the calling function. Otherwise, | |
| 2257 return 1. See external_plist_get(). | |
| 2258 */ | |
| 2259 | |
| 2260 static int | |
| 2261 advance_plist_pointers (Lisp_Object *plist, | |
| 2262 Lisp_Object **tortoise, Lisp_Object **hare, | |
| 578 | 2263 Error_Behavior errb, Lisp_Object *retval) |
| 428 | 2264 { |
| 2265 int i; | |
| 2266 Lisp_Object *tortsave = *tortoise; | |
| 2267 | |
| 2268 /* Note that our "fixing" may be more brutal than necessary, | |
| 2269 but it's the user's own problem, not ours, if they went in and | |
| 2270 manually fucked up a plist. */ | |
| 2271 | |
| 2272 for (i = 0; i < 2; i++) | |
| 2273 { | |
| 2274 /* This is a standard iteration of a defensive-loop-checking | |
| 2275 loop. We just do it twice because we want to advance past | |
| 2276 both the property and its value. | |
| 2277 | |
| 2278 If the pointer indirection is confusing you, remember that | |
| 2279 one level of indirection on the hare and tortoise pointers | |
| 2280 is only due to pass-by-reference for this function. The other | |
| 2281 level is so that the plist can be fixed in place. */ | |
| 2282 | |
| 2283 /* When we reach the end of a well-formed plist, **HARE is | |
| 2284 nil. In that case, we don't do anything at all except | |
| 2285 advance TORTOISE by one. Otherwise, we advance HARE | |
| 2286 by two (making sure it's OK to do so), then advance | |
| 2287 TORTOISE by one (it will always be OK to do so because | |
| 2288 the HARE is always ahead of the TORTOISE and will have | |
| 2289 already verified the path), then make sure TORTOISE and | |
| 2290 HARE don't contain the same non-nil object -- if the | |
| 2291 TORTOISE and the HARE ever meet, then obviously we're | |
| 2292 in a circularity, and if we're in a circularity, then | |
| 2293 the TORTOISE and the HARE can't cross paths without | |
| 2294 meeting, since the HARE only gains one step over the | |
| 2295 TORTOISE per iteration. */ | |
| 2296 | |
| 2297 if (!NILP (**hare)) | |
| 2298 { | |
| 2299 Lisp_Object *haresave = *hare; | |
| 2300 if (!CONSP (**hare)) | |
| 2301 { | |
| 2302 *retval = bad_bad_bunny (plist, haresave, errb); | |
| 2303 return 0; | |
| 2304 } | |
| 2305 *hare = &XCDR (**hare); | |
| 2306 /* In a non-plist, we'd check here for a nil value for | |
| 2307 **HARE, which is OK (it just means the list has an | |
| 2308 odd number of elements). In a plist, it's not OK | |
| 2309 for the list to have an odd number of elements. */ | |
| 2310 if (!CONSP (**hare)) | |
| 2311 { | |
| 2312 *retval = bad_bad_bunny (plist, haresave, errb); | |
| 2313 return 0; | |
| 2314 } | |
| 2315 *hare = &XCDR (**hare); | |
| 2316 } | |
| 2317 | |
| 2318 *tortoise = &XCDR (**tortoise); | |
| 2319 if (!NILP (**hare) && EQ (**tortoise, **hare)) | |
| 2320 { | |
| 2321 *retval = bad_bad_turtle (plist, tortsave, errb); | |
| 2322 return 0; | |
| 2323 } | |
| 2324 } | |
| 2325 | |
| 2326 return 1; | |
| 2327 } | |
| 2328 | |
| 2329 /* Return the value of PROPERTY from PLIST, or Qunbound if | |
| 2330 property is not on the list. | |
| 2331 | |
| 2332 PLIST is a Lisp-accessible property list, meaning that it | |
| 2333 has to be checked for malformations and circularities. | |
| 2334 | |
| 2335 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the | |
| 2336 function will never signal an error; and if ERRB is ERROR_ME_WARN, | |
| 2337 on finding a malformation or a circularity, it issues a warning and | |
| 2338 attempts to silently fix the problem. | |
| 2339 | |
| 2340 A pointer to PLIST is passed in so that PLIST can be successfully | |
| 2341 "fixed" even if the error is at the beginning of the plist. */ | |
| 2342 | |
| 2343 Lisp_Object | |
| 2344 external_plist_get (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 2345 int laxp, Error_Behavior errb) |
| 428 | 2346 { |
| 2347 Lisp_Object *tortoise = plist; | |
| 2348 Lisp_Object *hare = plist; | |
| 2349 | |
| 2350 while (!NILP (*tortoise)) | |
| 2351 { | |
| 2352 Lisp_Object *tortsave = tortoise; | |
| 2353 Lisp_Object retval; | |
| 2354 | |
| 2355 /* We do the standard tortoise/hare march. We isolate the | |
| 2356 grungy stuff to do this in advance_plist_pointers(), though. | |
| 2357 To us, all this function does is advance the tortoise | |
| 2358 pointer by two and the hare pointer by four and make sure | |
| 2359 everything's OK. We first advance the pointers and then | |
| 2360 check if a property matched; this ensures that our | |
| 2361 check for a matching property is safe. */ | |
| 2362 | |
| 2363 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 2364 return retval; | |
| 2365 | |
| 2366 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 2367 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 2368 return XCAR (XCDR (*tortsave)); | |
| 2369 } | |
| 2370 | |
| 2371 return Qunbound; | |
| 2372 } | |
| 2373 | |
| 2374 /* Set PLIST's value for PROPERTY to VALUE, given a possibly | |
| 2375 malformed or circular plist. Analogous to external_plist_get(). */ | |
| 2376 | |
| 2377 void | |
| 2378 external_plist_put (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 2379 Lisp_Object value, int laxp, Error_Behavior errb) |
| 428 | 2380 { |
| 2381 Lisp_Object *tortoise = plist; | |
| 2382 Lisp_Object *hare = plist; | |
| 2383 | |
| 2384 while (!NILP (*tortoise)) | |
| 2385 { | |
| 2386 Lisp_Object *tortsave = tortoise; | |
| 2387 Lisp_Object retval; | |
| 2388 | |
| 2389 /* See above */ | |
| 2390 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 2391 return; | |
| 2392 | |
| 2393 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 2394 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 2395 { | |
| 2396 XCAR (XCDR (*tortsave)) = value; | |
| 2397 return; | |
| 2398 } | |
| 2399 } | |
| 2400 | |
| 2401 *plist = Fcons (property, Fcons (value, *plist)); | |
| 2402 } | |
| 2403 | |
| 2404 int | |
| 2405 external_remprop (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 2406 int laxp, Error_Behavior errb) |
| 428 | 2407 { |
| 2408 Lisp_Object *tortoise = plist; | |
| 2409 Lisp_Object *hare = plist; | |
| 2410 | |
| 2411 while (!NILP (*tortoise)) | |
| 2412 { | |
| 2413 Lisp_Object *tortsave = tortoise; | |
| 2414 Lisp_Object retval; | |
| 2415 | |
| 2416 /* See above */ | |
| 2417 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 2418 return 0; | |
| 2419 | |
| 2420 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 2421 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 2422 { | |
| 2423 /* Now you see why it's so convenient to have that level | |
| 2424 of indirection. */ | |
| 2425 *tortsave = XCDR (XCDR (*tortsave)); | |
| 2426 return 1; | |
| 2427 } | |
| 2428 } | |
| 2429 | |
| 2430 return 0; | |
| 2431 } | |
| 2432 | |
| 2433 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /* | |
| 2434 Extract a value from a property list. | |
| 2435 PLIST is a property list, which is a list of the form | |
| 444 | 2436 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...). |
| 2437 PROPERTY is usually a symbol. | |
| 2438 This function returns the value corresponding to the PROPERTY, | |
| 2439 or DEFAULT if PROPERTY is not one of the properties on the list. | |
| 428 | 2440 */ |
| 444 | 2441 (plist, property, default_)) |
| 428 | 2442 { |
| 444 | 2443 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME); |
| 2444 return UNBOUNDP (value) ? default_ : value; | |
| 428 | 2445 } |
| 2446 | |
| 2447 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* | |
| 444 | 2448 Change value in PLIST of PROPERTY to VALUE. |
| 2449 PLIST is a property list, which is a list of the form | |
| 2450 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
| 2451 PROPERTY is usually a symbol and VALUE is any object. | |
| 2452 If PROPERTY is already a property on the list, its value is set to VALUE, | |
| 2453 otherwise the new PROPERTY VALUE pair is added. | |
| 2454 The new plist is returned; use `(setq x (plist-put x property value))' | |
| 2455 to be sure to use the new value. PLIST is modified by side effect. | |
| 428 | 2456 */ |
| 444 | 2457 (plist, property, value)) |
| 428 | 2458 { |
| 444 | 2459 external_plist_put (&plist, property, value, 0, ERROR_ME); |
| 428 | 2460 return plist; |
| 2461 } | |
| 2462 | |
| 2463 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /* | |
| 444 | 2464 Remove from PLIST the property PROPERTY and its value. |
| 2465 PLIST is a property list, which is a list of the form | |
| 2466 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
| 2467 PROPERTY is usually a symbol. | |
| 2468 The new plist is returned; use `(setq x (plist-remprop x property))' | |
| 2469 to be sure to use the new value. PLIST is modified by side effect. | |
| 428 | 2470 */ |
| 444 | 2471 (plist, property)) |
| 428 | 2472 { |
| 444 | 2473 external_remprop (&plist, property, 0, ERROR_ME); |
| 428 | 2474 return plist; |
| 2475 } | |
| 2476 | |
| 2477 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /* | |
| 444 | 2478 Return t if PROPERTY has a value specified in PLIST. |
| 428 | 2479 */ |
| 444 | 2480 (plist, property)) |
| 428 | 2481 { |
| 444 | 2482 Lisp_Object value = Fplist_get (plist, property, Qunbound); |
| 2483 return UNBOUNDP (value) ? Qnil : Qt; | |
| 428 | 2484 } |
| 2485 | |
| 2486 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* | |
| 2487 Given a plist, signal an error if there is anything wrong with it. | |
| 2488 This means that it's a malformed or circular plist. | |
| 2489 */ | |
| 2490 (plist)) | |
| 2491 { | |
| 2492 Lisp_Object *tortoise; | |
| 2493 Lisp_Object *hare; | |
| 2494 | |
| 2495 start_over: | |
| 2496 tortoise = &plist; | |
| 2497 hare = &plist; | |
| 2498 while (!NILP (*tortoise)) | |
| 2499 { | |
| 2500 Lisp_Object retval; | |
| 2501 | |
| 2502 /* See above */ | |
| 2503 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME, | |
| 2504 &retval)) | |
| 2505 goto start_over; | |
| 2506 } | |
| 2507 | |
| 2508 return Qnil; | |
| 2509 } | |
| 2510 | |
| 2511 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /* | |
| 2512 Given a plist, return non-nil if its format is correct. | |
| 2513 If it returns nil, `check-valid-plist' will signal an error when given | |
| 442 | 2514 the plist; that means it's a malformed or circular plist. |
| 428 | 2515 */ |
| 2516 (plist)) | |
| 2517 { | |
| 2518 Lisp_Object *tortoise; | |
| 2519 Lisp_Object *hare; | |
| 2520 | |
| 2521 tortoise = &plist; | |
| 2522 hare = &plist; | |
| 2523 while (!NILP (*tortoise)) | |
| 2524 { | |
| 2525 Lisp_Object retval; | |
| 2526 | |
| 2527 /* See above */ | |
| 2528 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT, | |
| 2529 &retval)) | |
| 2530 return Qnil; | |
| 2531 } | |
| 2532 | |
| 2533 return Qt; | |
| 2534 } | |
| 2535 | |
| 2536 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /* | |
| 2537 Destructively remove any duplicate entries from a plist. | |
| 2538 In such cases, the first entry applies. | |
| 2539 | |
| 2540 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2541 a nil value is removed. This feature is a virus that has infected | |
| 2542 old Lisp implementations, but should not be used except for backward | |
| 2543 compatibility. | |
| 2544 | |
| 2545 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
| 2546 return value may not be EQ to the passed-in value, so make sure to | |
| 2547 `setq' the value back into where it came from. | |
| 2548 */ | |
| 2549 (plist, nil_means_not_present)) | |
| 2550 { | |
| 2551 Lisp_Object head = plist; | |
| 2552 | |
| 2553 Fcheck_valid_plist (plist); | |
| 2554 | |
| 2555 while (!NILP (plist)) | |
| 2556 { | |
| 2557 Lisp_Object prop = Fcar (plist); | |
| 2558 Lisp_Object next = Fcdr (plist); | |
| 2559 | |
| 2560 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
| 2561 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
| 2562 { | |
| 2563 if (EQ (head, plist)) | |
| 2564 head = Fcdr (next); | |
| 2565 plist = Fcdr (next); | |
| 2566 continue; | |
| 2567 } | |
| 2568 /* external_remprop returns 1 if it removed any property. | |
| 2569 We have to loop till it didn't remove anything, in case | |
| 2570 the property occurs many times. */ | |
| 2571 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)) | |
| 2572 DO_NOTHING; | |
| 2573 plist = Fcdr (next); | |
| 2574 } | |
| 2575 | |
| 2576 return head; | |
| 2577 } | |
| 2578 | |
| 2579 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /* | |
| 2580 Extract a value from a lax property list. | |
| 444 | 2581 LAX-PLIST is a lax property list, which is a list of the form |
| 2582 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2583 properties is done using `equal' instead of `eq'. | |
| 2584 PROPERTY is usually a symbol. | |
| 2585 This function returns the value corresponding to PROPERTY, | |
| 2586 or DEFAULT if PROPERTY is not one of the properties on the list. | |
| 428 | 2587 */ |
| 444 | 2588 (lax_plist, property, default_)) |
| 428 | 2589 { |
| 444 | 2590 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME); |
| 2591 return UNBOUNDP (value) ? default_ : value; | |
| 428 | 2592 } |
| 2593 | |
| 2594 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* | |
| 444 | 2595 Change value in LAX-PLIST of PROPERTY to VALUE. |
| 2596 LAX-PLIST is a lax property list, which is a list of the form | |
| 2597 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2598 properties is done using `equal' instead of `eq'. | |
| 2599 PROPERTY is usually a symbol and VALUE is any object. | |
| 2600 If PROPERTY is already a property on the list, its value is set to | |
| 2601 VALUE, otherwise the new PROPERTY VALUE pair is added. | |
| 2602 The new plist is returned; use `(setq x (lax-plist-put x property value))' | |
| 2603 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
| 428 | 2604 */ |
| 444 | 2605 (lax_plist, property, value)) |
| 428 | 2606 { |
| 444 | 2607 external_plist_put (&lax_plist, property, value, 1, ERROR_ME); |
| 428 | 2608 return lax_plist; |
| 2609 } | |
| 2610 | |
| 2611 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* | |
| 444 | 2612 Remove from LAX-PLIST the property PROPERTY and its value. |
| 2613 LAX-PLIST is a lax property list, which is a list of the form | |
| 2614 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2615 properties is done using `equal' instead of `eq'. | |
| 2616 PROPERTY is usually a symbol. | |
| 2617 The new plist is returned; use `(setq x (lax-plist-remprop x property))' | |
| 2618 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
| 428 | 2619 */ |
| 444 | 2620 (lax_plist, property)) |
| 428 | 2621 { |
| 444 | 2622 external_remprop (&lax_plist, property, 1, ERROR_ME); |
| 428 | 2623 return lax_plist; |
| 2624 } | |
| 2625 | |
| 2626 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* | |
| 444 | 2627 Return t if PROPERTY has a value specified in LAX-PLIST. |
| 2628 LAX-PLIST is a lax property list, which is a list of the form | |
| 2629 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 2630 properties is done using `equal' instead of `eq'. | |
| 428 | 2631 */ |
| 444 | 2632 (lax_plist, property)) |
| 428 | 2633 { |
| 444 | 2634 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt; |
| 428 | 2635 } |
| 2636 | |
| 2637 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /* | |
| 2638 Destructively remove any duplicate entries from a lax plist. | |
| 2639 In such cases, the first entry applies. | |
| 2640 | |
| 2641 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 2642 a nil value is removed. This feature is a virus that has infected | |
| 2643 old Lisp implementations, but should not be used except for backward | |
| 2644 compatibility. | |
| 2645 | |
| 2646 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
| 2647 return value may not be EQ to the passed-in value, so make sure to | |
| 2648 `setq' the value back into where it came from. | |
| 2649 */ | |
| 2650 (lax_plist, nil_means_not_present)) | |
| 2651 { | |
| 2652 Lisp_Object head = lax_plist; | |
| 2653 | |
| 2654 Fcheck_valid_plist (lax_plist); | |
| 2655 | |
| 2656 while (!NILP (lax_plist)) | |
| 2657 { | |
| 2658 Lisp_Object prop = Fcar (lax_plist); | |
| 2659 Lisp_Object next = Fcdr (lax_plist); | |
| 2660 | |
| 2661 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
| 2662 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
| 2663 { | |
| 2664 if (EQ (head, lax_plist)) | |
| 2665 head = Fcdr (next); | |
| 2666 lax_plist = Fcdr (next); | |
| 2667 continue; | |
| 2668 } | |
| 2669 /* external_remprop returns 1 if it removed any property. | |
| 2670 We have to loop till it didn't remove anything, in case | |
| 2671 the property occurs many times. */ | |
| 2672 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)) | |
| 2673 DO_NOTHING; | |
| 2674 lax_plist = Fcdr (next); | |
| 2675 } | |
| 2676 | |
| 2677 return head; | |
| 2678 } | |
| 2679 | |
| 2680 /* In C because the frame props stuff uses it */ | |
| 2681 | |
| 2682 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /* | |
| 2683 Convert association list ALIST into the equivalent property-list form. | |
| 2684 The plist is returned. This converts from | |
| 2685 | |
| 2686 \((a . 1) (b . 2) (c . 3)) | |
| 2687 | |
| 2688 into | |
| 2689 | |
| 2690 \(a 1 b 2 c 3) | |
| 2691 | |
| 2692 The original alist is destroyed in the process of constructing the plist. | |
| 2693 See also `alist-to-plist'. | |
| 2694 */ | |
| 2695 (alist)) | |
| 2696 { | |
| 2697 Lisp_Object head = alist; | |
| 2698 while (!NILP (alist)) | |
| 2699 { | |
| 2700 /* remember the alist element. */ | |
| 2701 Lisp_Object el = Fcar (alist); | |
| 2702 | |
| 2703 Fsetcar (alist, Fcar (el)); | |
| 2704 Fsetcar (el, Fcdr (el)); | |
| 2705 Fsetcdr (el, Fcdr (alist)); | |
| 2706 Fsetcdr (alist, el); | |
| 2707 alist = Fcdr (Fcdr (alist)); | |
| 2708 } | |
| 2709 | |
| 2710 return head; | |
| 2711 } | |
| 2712 | |
| 2713 DEFUN ("get", Fget, 2, 3, 0, /* | |
| 442 | 2714 Return the value of OBJECT's PROPERTY property. |
| 2715 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. | |
| 428 | 2716 If there is no such property, return optional third arg DEFAULT |
| 442 | 2717 \(which defaults to `nil'). OBJECT can be a symbol, string, extent, |
| 2718 face, or glyph. See also `put', `remprop', and `object-plist'. | |
| 428 | 2719 */ |
| 442 | 2720 (object, property, default_)) |
| 428 | 2721 { |
| 2722 /* Various places in emacs call Fget() and expect it not to quit, | |
| 2723 so don't quit. */ | |
| 442 | 2724 Lisp_Object val; |
| 2725 | |
| 2726 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop) | |
| 2727 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property); | |
| 428 | 2728 else |
| 563 | 2729 invalid_operation ("Object type has no properties", object); |
| 442 | 2730 |
| 2731 return UNBOUNDP (val) ? default_ : val; | |
| 428 | 2732 } |
| 2733 | |
| 2734 DEFUN ("put", Fput, 3, 3, 0, /* | |
| 442 | 2735 Set OBJECT's PROPERTY to VALUE. |
| 2736 It can be subsequently retrieved with `(get OBJECT PROPERTY)'. | |
| 2737 OBJECT can be a symbol, face, extent, or string. | |
| 428 | 2738 For a string, no properties currently have predefined meanings. |
| 2739 For the predefined properties for extents, see `set-extent-property'. | |
| 2740 For the predefined properties for faces, see `set-face-property'. | |
| 2741 See also `get', `remprop', and `object-plist'. | |
| 2742 */ | |
| 442 | 2743 (object, property, value)) |
| 428 | 2744 { |
| 1920 | 2745 /* This function cannot GC */ |
| 428 | 2746 CHECK_LISP_WRITEABLE (object); |
| 2747 | |
| 442 | 2748 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop) |
| 428 | 2749 { |
| 442 | 2750 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop |
| 2751 (object, property, value)) | |
| 563 | 2752 invalid_change ("Can't set property on object", property); |
| 428 | 2753 } |
| 2754 else | |
| 563 | 2755 invalid_change ("Object type has no settable properties", object); |
| 428 | 2756 |
| 2757 return value; | |
| 2758 } | |
| 2759 | |
| 2760 DEFUN ("remprop", Fremprop, 2, 2, 0, /* | |
| 442 | 2761 Remove, from OBJECT's property list, PROPERTY and its corresponding value. |
| 2762 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil | |
| 2763 if the property list was actually modified (i.e. if PROPERTY was present | |
| 2764 in the property list). See also `get', `put', and `object-plist'. | |
| 428 | 2765 */ |
| 442 | 2766 (object, property)) |
| 428 | 2767 { |
| 442 | 2768 int ret = 0; |
| 2769 | |
| 428 | 2770 CHECK_LISP_WRITEABLE (object); |
| 2771 | |
| 442 | 2772 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop) |
| 428 | 2773 { |
| 442 | 2774 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property); |
| 2775 if (ret == -1) | |
| 563 | 2776 invalid_change ("Can't remove property from object", property); |
| 428 | 2777 } |
| 2778 else | |
| 563 | 2779 invalid_change ("Object type has no removable properties", object); |
| 442 | 2780 |
| 2781 return ret ? Qt : Qnil; | |
| 428 | 2782 } |
| 2783 | |
| 2784 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /* | |
| 442 | 2785 Return a property list of OBJECT's properties. |
| 2786 For a symbol, this is equivalent to `symbol-plist'. | |
| 2787 OBJECT can be a symbol, string, extent, face, or glyph. | |
| 2788 Do not modify the returned property list directly; | |
| 2789 this may or may not have the desired effects. Use `put' instead. | |
| 428 | 2790 */ |
| 2791 (object)) | |
| 2792 { | |
| 442 | 2793 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist) |
| 2794 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object); | |
| 428 | 2795 else |
| 563 | 2796 invalid_operation ("Object type has no properties", object); |
| 428 | 2797 |
| 2798 return Qnil; | |
| 2799 } | |
| 2800 | |
| 2801 | |
| 853 | 2802 static Lisp_Object |
| 2803 tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2, | |
| 2804 Lisp_Object depth) | |
| 2805 { | |
| 2806 return make_int (internal_equal (obj1, obj2, XINT (depth))); | |
| 2807 } | |
| 2808 | |
| 2809 int | |
| 2810 internal_equal_trapping_problems (Lisp_Object warning_class, | |
| 2811 const char *warning_string, | |
| 2812 int flags, | |
| 2813 struct call_trapping_problems_result *p, | |
| 2814 int retval, | |
| 2815 Lisp_Object obj1, Lisp_Object obj2, | |
| 2816 int depth) | |
| 2817 { | |
| 2818 Lisp_Object glorp = | |
| 2819 va_call_trapping_problems (warning_class, warning_string, | |
| 2820 flags, p, | |
| 2821 (lisp_fn_t) tweaked_internal_equal, | |
| 2822 3, obj1, obj2, make_int (depth)); | |
| 2823 if (UNBOUNDP (glorp)) | |
| 2824 return retval; | |
| 2825 else | |
| 2826 return XINT (glorp); | |
| 2827 } | |
| 2828 | |
| 428 | 2829 int |
| 2830 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2831 { | |
| 2832 if (depth > 200) | |
| 563 | 2833 stack_overflow ("Stack overflow in equal", Qunbound); |
| 428 | 2834 QUIT; |
| 2835 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) | |
| 2836 return 1; | |
| 2837 /* Note that (equal 20 20.0) should be nil */ | |
| 2838 if (XTYPE (obj1) != XTYPE (obj2)) | |
| 2839 return 0; | |
| 2840 if (LRECORDP (obj1)) | |
| 2841 { | |
| 442 | 2842 const struct lrecord_implementation |
| 428 | 2843 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), |
| 2844 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
| 2845 | |
| 2846 return (imp1 == imp2) && | |
| 2847 /* EQ-ness of the objects was noticed above */ | |
| 2848 (imp1->equal && (imp1->equal) (obj1, obj2, depth)); | |
| 2849 } | |
| 2850 | |
| 2851 return 0; | |
| 2852 } | |
| 2853 | |
| 801 | 2854 int |
| 2855 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2856 { | |
| 2857 if (depth > 200) | |
| 2858 stack_overflow ("Stack overflow in equalp", Qunbound); | |
| 2859 QUIT; | |
| 2860 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) | |
| 2861 return 1; | |
| 1983 | 2862 #ifdef WITH_NUMBER_TYPES |
| 2863 if (NUMBERP (obj1) && NUMBERP (obj2)) | |
| 2864 { | |
| 2865 switch (promote_args (&obj1, &obj2)) | |
| 2866 { | |
| 2867 case FIXNUM_T: | |
| 2868 return XREALINT (obj1) == XREALINT (obj2); | |
| 2869 #ifdef HAVE_BIGNUM | |
| 2870 case BIGNUM_T: | |
| 2871 return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); | |
| 2872 #endif | |
| 2873 #ifdef HAVE_RATIO | |
| 2874 case RATIO_T: | |
| 2875 return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 2876 #endif | |
| 2877 case FLOAT_T: | |
| 2878 return XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2); | |
| 2879 #ifdef HAVE_BIGFLOAT | |
| 2880 case BIGFLOAT_T: | |
| 2881 return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); | |
| 2882 #endif | |
| 2883 } | |
| 2884 } | |
| 2885 #else | |
| 801 | 2886 if ((INTP (obj1) && FLOATP (obj2)) || (FLOATP (obj1) && INTP (obj2))) |
| 2887 return extract_float (obj1) == extract_float (obj2); | |
| 1983 | 2888 #endif |
| 801 | 2889 if (CHARP (obj1) && CHARP (obj2)) |
| 2890 return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2)); | |
| 2891 if (XTYPE (obj1) != XTYPE (obj2)) | |
| 2892 return 0; | |
| 2893 if (LRECORDP (obj1)) | |
| 2894 { | |
| 2895 const struct lrecord_implementation | |
| 2896 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), | |
| 2897 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
| 2898 | |
| 2899 /* #### not yet implemented properly, needs another flag to specify | |
| 2900 equalp-ness */ | |
| 2901 return (imp1 == imp2) && | |
| 2902 /* EQ-ness of the objects was noticed above */ | |
| 2903 (imp1->equal && (imp1->equal) (obj1, obj2, depth)); | |
| 2904 } | |
| 2905 | |
| 2906 return 0; | |
| 2907 } | |
| 2908 | |
| 428 | 2909 /* Note that we may be calling sub-objects that will use |
| 2910 internal_equal() (instead of internal_old_equal()). Oh well. | |
| 2911 We will get an Ebola note if there's any possibility of confusion, | |
| 2912 but that seems unlikely. */ | |
| 2913 | |
| 2914 static int | |
| 2915 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2916 { | |
| 2917 if (depth > 200) | |
| 563 | 2918 stack_overflow ("Stack overflow in equal", Qunbound); |
| 428 | 2919 QUIT; |
| 2920 if (HACKEQ_UNSAFE (obj1, obj2)) | |
| 2921 return 1; | |
| 2922 /* Note that (equal 20 20.0) should be nil */ | |
| 2923 if (XTYPE (obj1) != XTYPE (obj2)) | |
| 2924 return 0; | |
| 2925 | |
| 2926 return internal_equal (obj1, obj2, depth); | |
| 2927 } | |
| 2928 | |
| 2929 DEFUN ("equal", Fequal, 2, 2, 0, /* | |
| 2930 Return t if two Lisp objects have similar structure and contents. | |
| 2931 They must have the same data type. | |
| 2932 Conses are compared by comparing the cars and the cdrs. | |
| 2933 Vectors and strings are compared element by element. | |
| 2934 Numbers are compared by value. Symbols must match exactly. | |
| 2935 */ | |
| 444 | 2936 (object1, object2)) |
| 428 | 2937 { |
| 444 | 2938 return internal_equal (object1, object2, 0) ? Qt : Qnil; |
| 428 | 2939 } |
| 2940 | |
| 2941 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* | |
| 2942 Return t if two Lisp objects have similar structure and contents. | |
| 2943 They must have the same data type. | |
| 2944 \(Note, however, that an exception is made for characters and integers; | |
| 2945 this is known as the "char-int confoundance disease." See `eq' and | |
| 2946 `old-eq'.) | |
| 2947 This function is provided only for byte-code compatibility with v19. | |
| 2948 Do not use it. | |
| 2949 */ | |
| 444 | 2950 (object1, object2)) |
| 428 | 2951 { |
| 444 | 2952 return internal_old_equal (object1, object2, 0) ? Qt : Qnil; |
| 428 | 2953 } |
| 2954 | |
| 2955 | |
| 2956 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* | |
| 434 | 2957 Destructively modify ARRAY by replacing each element with ITEM. |
| 428 | 2958 ARRAY is a vector, bit vector, or string. |
| 2959 */ | |
| 2960 (array, item)) | |
| 2961 { | |
| 2962 retry: | |
| 2963 if (STRINGP (array)) | |
| 2964 { | |
| 793 | 2965 Bytecount old_bytecount = XSTRING_LENGTH (array); |
| 434 | 2966 Bytecount new_bytecount; |
| 2967 Bytecount item_bytecount; | |
| 867 | 2968 Ibyte item_buf[MAX_ICHAR_LEN]; |
| 2969 Ibyte *p; | |
| 2970 Ibyte *end; | |
| 434 | 2971 |
| 428 | 2972 CHECK_CHAR_COERCE_INT (item); |
| 2720 | 2973 |
| 428 | 2974 CHECK_LISP_WRITEABLE (array); |
| 771 | 2975 sledgehammer_check_ascii_begin (array); |
| 867 | 2976 item_bytecount = set_itext_ichar (item_buf, XCHAR (item)); |
| 826 | 2977 new_bytecount = item_bytecount * (Bytecount) string_char_length (array); |
| 793 | 2978 |
| 2979 resize_string (array, -1, new_bytecount - old_bytecount); | |
| 2980 | |
| 2981 for (p = XSTRING_DATA (array), end = p + new_bytecount; | |
| 434 | 2982 p < end; |
| 2983 p += item_bytecount) | |
| 2984 memcpy (p, item_buf, item_bytecount); | |
| 2985 *p = '\0'; | |
| 2986 | |
| 793 | 2987 XSET_STRING_ASCII_BEGIN (array, |
| 2988 item_bytecount == 1 ? | |
| 2989 min (new_bytecount, MAX_STRING_ASCII_BEGIN) : | |
| 2990 0); | |
| 428 | 2991 bump_string_modiff (array); |
| 771 | 2992 sledgehammer_check_ascii_begin (array); |
| 428 | 2993 } |
| 2994 else if (VECTORP (array)) | |
| 2995 { | |
| 2996 Lisp_Object *p = XVECTOR_DATA (array); | |
| 665 | 2997 Elemcount len = XVECTOR_LENGTH (array); |
| 428 | 2998 CHECK_LISP_WRITEABLE (array); |
| 2999 while (len--) | |
| 3000 *p++ = item; | |
| 3001 } | |
| 3002 else if (BIT_VECTORP (array)) | |
| 3003 { | |
| 440 | 3004 Lisp_Bit_Vector *v = XBIT_VECTOR (array); |
| 665 | 3005 Elemcount len = bit_vector_length (v); |
| 428 | 3006 int bit; |
| 3007 CHECK_BIT (item); | |
| 444 | 3008 bit = XINT (item); |
| 428 | 3009 CHECK_LISP_WRITEABLE (array); |
| 3010 while (len--) | |
| 3011 set_bit_vector_bit (v, len, bit); | |
| 3012 } | |
| 3013 else | |
| 3014 { | |
| 3015 array = wrong_type_argument (Qarrayp, array); | |
| 3016 goto retry; | |
| 3017 } | |
| 3018 return array; | |
| 3019 } | |
| 3020 | |
| 3021 Lisp_Object | |
| 3022 nconc2 (Lisp_Object arg1, Lisp_Object arg2) | |
| 3023 { | |
| 3024 Lisp_Object args[2]; | |
| 3025 struct gcpro gcpro1; | |
| 3026 args[0] = arg1; | |
| 3027 args[1] = arg2; | |
| 3028 | |
| 3029 GCPRO1 (args[0]); | |
| 3030 gcpro1.nvars = 2; | |
| 3031 | |
| 3032 RETURN_UNGCPRO (bytecode_nconc2 (args)); | |
| 3033 } | |
| 3034 | |
| 3035 Lisp_Object | |
| 3036 bytecode_nconc2 (Lisp_Object *args) | |
| 3037 { | |
| 3038 retry: | |
| 3039 | |
| 3040 if (CONSP (args[0])) | |
| 3041 { | |
| 3042 /* (setcdr (last args[0]) args[1]) */ | |
| 3043 Lisp_Object tortoise, hare; | |
| 665 | 3044 Elemcount count; |
| 428 | 3045 |
| 3046 for (hare = tortoise = args[0], count = 0; | |
| 3047 CONSP (XCDR (hare)); | |
| 3048 hare = XCDR (hare), count++) | |
| 3049 { | |
| 3050 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 3051 | |
| 3052 if (count & 1) | |
| 3053 tortoise = XCDR (tortoise); | |
| 3054 if (EQ (hare, tortoise)) | |
| 3055 signal_circular_list_error (args[0]); | |
| 3056 } | |
| 3057 XCDR (hare) = args[1]; | |
| 3058 return args[0]; | |
| 3059 } | |
| 3060 else if (NILP (args[0])) | |
| 3061 { | |
| 3062 return args[1]; | |
| 3063 } | |
| 3064 else | |
| 3065 { | |
| 3066 args[0] = wrong_type_argument (args[0], Qlistp); | |
| 3067 goto retry; | |
| 3068 } | |
| 3069 } | |
| 3070 | |
| 3071 DEFUN ("nconc", Fnconc, 0, MANY, 0, /* | |
| 3072 Concatenate any number of lists by altering them. | |
| 3073 Only the last argument is not altered, and need not be a list. | |
| 3074 Also see: `append'. | |
| 3075 If the first argument is nil, there is no way to modify it by side | |
| 3076 effect; therefore, write `(setq foo (nconc foo list))' to be sure of | |
| 3077 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
|
3078 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
3079 arguments: (&rest ARGS) |
| 428 | 3080 */ |
| 3081 (int nargs, Lisp_Object *args)) | |
| 3082 { | |
| 3083 int argnum = 0; | |
| 3084 struct gcpro gcpro1; | |
| 3085 | |
| 3086 /* The modus operandi in Emacs is "caller gc-protects args". | |
| 3087 However, nconc (particularly nconc2 ()) is called many times | |
| 3088 in Emacs on freshly created stuff (e.g. you see the idiom | |
| 3089 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those | |
| 3090 callers out by protecting the args ourselves to save them | |
| 3091 a lot of temporary-variable grief. */ | |
| 3092 | |
| 3093 GCPRO1 (args[0]); | |
| 3094 gcpro1.nvars = nargs; | |
| 3095 | |
| 3096 while (argnum < nargs) | |
| 3097 { | |
| 3098 Lisp_Object val; | |
| 3099 retry: | |
| 3100 val = args[argnum]; | |
| 3101 if (CONSP (val)) | |
| 3102 { | |
| 3103 /* `val' is the first cons, which will be our return value. */ | |
| 3104 /* `last_cons' will be the cons cell to mutate. */ | |
| 3105 Lisp_Object last_cons = val; | |
| 3106 Lisp_Object tortoise = val; | |
| 3107 | |
| 3108 for (argnum++; argnum < nargs; argnum++) | |
| 3109 { | |
| 3110 Lisp_Object next = args[argnum]; | |
| 3111 retry_next: | |
| 3112 if (CONSP (next) || argnum == nargs -1) | |
| 3113 { | |
| 3114 /* (setcdr (last val) next) */ | |
| 665 | 3115 Elemcount count; |
| 428 | 3116 |
| 3117 for (count = 0; | |
| 3118 CONSP (XCDR (last_cons)); | |
| 3119 last_cons = XCDR (last_cons), count++) | |
| 3120 { | |
| 3121 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 3122 | |
| 3123 if (count & 1) | |
| 3124 tortoise = XCDR (tortoise); | |
| 3125 if (EQ (last_cons, tortoise)) | |
| 3126 signal_circular_list_error (args[argnum-1]); | |
| 3127 } | |
| 3128 XCDR (last_cons) = next; | |
| 3129 } | |
| 3130 else if (NILP (next)) | |
| 3131 { | |
| 3132 continue; | |
| 3133 } | |
| 3134 else | |
| 3135 { | |
| 3136 next = wrong_type_argument (Qlistp, next); | |
| 3137 goto retry_next; | |
| 3138 } | |
| 3139 } | |
| 3140 RETURN_UNGCPRO (val); | |
| 3141 } | |
| 3142 else if (NILP (val)) | |
| 3143 argnum++; | |
| 3144 else if (argnum == nargs - 1) /* last arg? */ | |
| 3145 RETURN_UNGCPRO (val); | |
| 3146 else | |
| 3147 { | |
| 3148 args[argnum] = wrong_type_argument (Qlistp, val); | |
| 3149 goto retry; | |
| 3150 } | |
| 3151 } | |
| 3152 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ | |
| 3153 } | |
| 3154 | |
| 3155 | |
| 434 | 3156 /* This is the guts of several mapping functions. |
| 3157 Apply FUNCTION to each element of SEQUENCE, one by one, | |
| 3158 storing the results into elements of VALS, a C vector of Lisp_Objects. | |
| 3159 LENI is the length of VALS, which should also be the length of SEQUENCE. | |
| 428 | 3160 |
| 3161 If VALS is a null pointer, do not accumulate the results. */ | |
| 3162 | |
| 3163 static void | |
| 665 | 3164 mapcar1 (Elemcount leni, Lisp_Object *vals, |
| 434 | 3165 Lisp_Object function, Lisp_Object sequence) |
| 428 | 3166 { |
| 3167 Lisp_Object result; | |
| 3168 Lisp_Object args[2]; | |
| 3169 struct gcpro gcpro1; | |
| 3170 | |
| 3171 if (vals) | |
| 3172 { | |
| 3173 GCPRO1 (vals[0]); | |
| 3174 gcpro1.nvars = 0; | |
| 3175 } | |
| 3176 | |
| 434 | 3177 args[0] = function; |
| 3178 | |
| 3179 if (LISTP (sequence)) | |
| 428 | 3180 { |
| 434 | 3181 /* A devious `function' could either: |
| 3182 - insert garbage into the list in front of us, causing XCDR to crash | |
| 3183 - amputate the list behind us using (setcdr), causing the remaining | |
| 3184 elts to lose their GCPRO status. | |
| 3185 | |
| 3186 if (vals != 0) we avoid this by copying the elts into the | |
| 3187 `vals' array. By a stroke of luck, `vals' is exactly large | |
| 3188 enough to hold the elts left to be traversed as well as the | |
| 3189 results computed so far. | |
| 3190 | |
| 3191 if (vals == 0) we don't have any free space available and | |
| 851 | 3192 don't want to eat up any more stack with ALLOCA (). |
| 442 | 3193 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */ |
| 434 | 3194 |
| 3195 if (vals) | |
| 428 | 3196 { |
| 434 | 3197 Lisp_Object *val = vals; |
| 665 | 3198 Elemcount i; |
| 434 | 3199 |
| 3200 LIST_LOOP_2 (elt, sequence) | |
| 3201 *val++ = elt; | |
| 3202 | |
| 3203 gcpro1.nvars = leni; | |
| 3204 | |
| 3205 for (i = 0; i < leni; i++) | |
| 3206 { | |
| 3207 args[1] = vals[i]; | |
| 3208 vals[i] = Ffuncall (2, args); | |
| 3209 } | |
| 3210 } | |
| 3211 else | |
| 3212 { | |
| 3213 Lisp_Object elt, tail; | |
| 442 | 3214 EMACS_INT len_unused; |
| 434 | 3215 struct gcpro ngcpro1; |
| 3216 | |
| 3217 NGCPRO1 (tail); | |
| 3218 | |
| 3219 { | |
| 442 | 3220 EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused) |
| 434 | 3221 { |
| 3222 args[1] = elt; | |
| 3223 Ffuncall (2, args); | |
| 3224 } | |
| 3225 } | |
| 3226 | |
| 3227 NUNGCPRO; | |
| 428 | 3228 } |
| 3229 } | |
| 434 | 3230 else if (VECTORP (sequence)) |
| 428 | 3231 { |
| 434 | 3232 Lisp_Object *objs = XVECTOR_DATA (sequence); |
| 665 | 3233 Elemcount i; |
| 428 | 3234 for (i = 0; i < leni; i++) |
| 3235 { | |
| 3236 args[1] = *objs++; | |
| 3237 result = Ffuncall (2, args); | |
| 3238 if (vals) vals[gcpro1.nvars++] = result; | |
| 3239 } | |
| 3240 } | |
| 434 | 3241 else if (STRINGP (sequence)) |
| 428 | 3242 { |
| 434 | 3243 /* The string data of `sequence' might be relocated during GC. */ |
| 3244 Bytecount slen = XSTRING_LENGTH (sequence); | |
| 2367 | 3245 Ibyte *p = alloca_ibytes (slen); |
| 867 | 3246 Ibyte *end = p + slen; |
| 434 | 3247 |
| 3248 memcpy (p, XSTRING_DATA (sequence), slen); | |
| 3249 | |
| 3250 while (p < end) | |
| 428 | 3251 { |
| 867 | 3252 args[1] = make_char (itext_ichar (p)); |
| 3253 INC_IBYTEPTR (p); | |
| 428 | 3254 result = Ffuncall (2, args); |
| 3255 if (vals) vals[gcpro1.nvars++] = result; | |
| 3256 } | |
| 3257 } | |
| 434 | 3258 else if (BIT_VECTORP (sequence)) |
| 428 | 3259 { |
| 440 | 3260 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); |
| 665 | 3261 Elemcount i; |
| 428 | 3262 for (i = 0; i < leni; i++) |
| 3263 { | |
| 3264 args[1] = make_int (bit_vector_bit (v, i)); | |
| 3265 result = Ffuncall (2, args); | |
| 3266 if (vals) vals[gcpro1.nvars++] = result; | |
| 3267 } | |
| 3268 } | |
| 3269 else | |
| 2500 | 3270 ABORT (); /* unreachable, since Flength (sequence) did not get an error */ |
| 428 | 3271 |
| 3272 if (vals) | |
| 3273 UNGCPRO; | |
| 3274 } | |
| 3275 | |
| 3276 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* | |
| 751 | 3277 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string. |
| 3278 Between each pair of results, insert SEPARATOR. | |
| 3279 | |
| 3280 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR | |
| 3281 results in spaces between the values returned by FUNCTION. SEQUENCE itself | |
| 3282 may be a list, a vector, a bit vector, or a string. | |
| 428 | 3283 */ |
| 434 | 3284 (function, sequence, separator)) |
| 428 | 3285 { |
| 444 | 3286 EMACS_INT len = XINT (Flength (sequence)); |
| 428 | 3287 Lisp_Object *args; |
| 444 | 3288 EMACS_INT i; |
| 3289 EMACS_INT nargs = len + len - 1; | |
| 428 | 3290 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3291 if (len == 0) return build_ascstring (""); |
| 428 | 3292 |
| 3293 args = alloca_array (Lisp_Object, nargs); | |
| 3294 | |
| 434 | 3295 mapcar1 (len, args, function, sequence); |
| 428 | 3296 |
| 3297 for (i = len - 1; i >= 0; i--) | |
| 3298 args[i + i] = args[i]; | |
| 3299 | |
| 3300 for (i = 1; i < nargs; i += 2) | |
| 434 | 3301 args[i] = separator; |
| 428 | 3302 |
| 3303 return Fconcat (nargs, args); | |
| 3304 } | |
| 3305 | |
| 3306 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /* | |
| 434 | 3307 Apply FUNCTION to each element of SEQUENCE; return a list of the results. |
| 3308 The result is a list of the same length as SEQUENCE. | |
| 428 | 3309 SEQUENCE may be a list, a vector, a bit vector, or a string. |
| 3310 */ | |
| 434 | 3311 (function, sequence)) |
| 428 | 3312 { |
| 665 | 3313 Elemcount len = XINT (Flength (sequence)); |
| 428 | 3314 Lisp_Object *args = alloca_array (Lisp_Object, len); |
| 3315 | |
| 434 | 3316 mapcar1 (len, args, function, sequence); |
| 428 | 3317 |
| 647 | 3318 return Flist ((int) len, args); |
| 428 | 3319 } |
| 3320 | |
| 3321 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /* | |
| 434 | 3322 Apply FUNCTION to each element of SEQUENCE; return a vector of the results. |
| 428 | 3323 The result is a vector of the same length as SEQUENCE. |
| 434 | 3324 SEQUENCE may be a list, a vector, a bit vector, or a string. |
| 428 | 3325 */ |
| 434 | 3326 (function, sequence)) |
| 428 | 3327 { |
| 665 | 3328 Elemcount len = XINT (Flength (sequence)); |
| 428 | 3329 Lisp_Object result = make_vector (len, Qnil); |
| 3330 struct gcpro gcpro1; | |
| 3331 | |
| 3332 GCPRO1 (result); | |
| 434 | 3333 mapcar1 (len, XVECTOR_DATA (result), function, sequence); |
| 428 | 3334 UNGCPRO; |
| 3335 | |
| 3336 return result; | |
| 3337 } | |
| 3338 | |
| 3339 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /* | |
| 3340 Apply FUNCTION to each element of SEQUENCE. | |
| 3341 SEQUENCE may be a list, a vector, a bit vector, or a string. | |
| 3342 This function is like `mapcar' but does not accumulate the results, | |
| 3343 which is more efficient if you do not use the results. | |
| 3344 | |
| 3345 The difference between this and `mapc' is that `mapc' supports all | |
| 3346 the spiffy Common Lisp arguments. You should normally use `mapc'. | |
| 3347 */ | |
| 434 | 3348 (function, sequence)) |
| 428 | 3349 { |
| 434 | 3350 mapcar1 (XINT (Flength (sequence)), 0, function, sequence); |
| 3351 | |
| 3352 return sequence; | |
| 428 | 3353 } |
| 3354 | |
| 3355 | |
| 771 | 3356 /* Extra random functions */ |
| 442 | 3357 |
| 3358 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /* | |
| 3359 Destructively replace the list OLD with NEW. | |
| 3360 This is like (copy-sequence NEW) except that it reuses the | |
| 3361 conses in OLD as much as possible. If OLD and NEW are the same | |
| 3362 length, no consing will take place. | |
| 3363 */ | |
| 3025 | 3364 (old, new_)) |
| 442 | 3365 { |
| 2367 | 3366 Lisp_Object oldtail = old, prevoldtail = Qnil; |
| 3367 | |
| 3025 | 3368 EXTERNAL_LIST_LOOP_2 (elt, new_) |
| 442 | 3369 { |
| 3370 if (!NILP (oldtail)) | |
| 3371 { | |
| 3372 CHECK_CONS (oldtail); | |
| 2367 | 3373 XCAR (oldtail) = elt; |
| 442 | 3374 } |
| 3375 else if (!NILP (prevoldtail)) | |
| 3376 { | |
| 2367 | 3377 XCDR (prevoldtail) = Fcons (elt, Qnil); |
| 442 | 3378 prevoldtail = XCDR (prevoldtail); |
| 3379 } | |
| 3380 else | |
| 2367 | 3381 old = oldtail = Fcons (elt, Qnil); |
| 442 | 3382 |
| 3383 if (!NILP (oldtail)) | |
| 3384 { | |
| 3385 prevoldtail = oldtail; | |
| 3386 oldtail = XCDR (oldtail); | |
| 3387 } | |
| 3388 } | |
| 3389 | |
| 3390 if (!NILP (prevoldtail)) | |
| 3391 XCDR (prevoldtail) = Qnil; | |
| 3392 else | |
| 3393 old = Qnil; | |
| 3394 | |
| 3395 return old; | |
| 3396 } | |
| 3397 | |
| 771 | 3398 Lisp_Object |
| 2367 | 3399 add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) |
| 771 | 3400 { |
| 3401 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
|
3402 build_ascstring (ascii_string)), |
| 771 | 3403 Qnil); |
| 3404 } | |
| 3405 | |
| 3406 Lisp_Object | |
| 2367 | 3407 add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol) |
| 771 | 3408 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
3409 return Fintern (concat2 (build_ascstring (ascii_string), |
| 771 | 3410 Fsymbol_name (symbol)), |
| 3411 Qnil); | |
| 3412 } | |
| 3413 | |
| 442 | 3414 |
| 428 | 3415 /* #### this function doesn't belong in this file! */ |
| 3416 | |
| 442 | 3417 #ifdef HAVE_GETLOADAVG |
| 3418 #ifdef HAVE_SYS_LOADAVG_H | |
| 3419 #include <sys/loadavg.h> | |
| 3420 #endif | |
| 3421 #else | |
| 3422 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */ | |
| 3423 #endif | |
| 3424 | |
| 428 | 3425 DEFUN ("load-average", Fload_average, 0, 1, 0, /* |
| 3426 Return list of 1 minute, 5 minute and 15 minute load averages. | |
| 3427 Each of the three load averages is multiplied by 100, | |
| 3428 then converted to integer. | |
| 3429 | |
| 3430 When USE-FLOATS is non-nil, floats will be used instead of integers. | |
| 3431 These floats are not multiplied by 100. | |
| 3432 | |
| 3433 If the 5-minute or 15-minute load averages are not available, return a | |
| 3434 shortened list, containing only those averages which are available. | |
| 3435 | |
| 3436 On some systems, this won't work due to permissions on /dev/kmem, | |
| 3437 in which case you can't use this. | |
| 3438 */ | |
| 3439 (use_floats)) | |
| 3440 { | |
| 3441 double load_ave[3]; | |
| 3442 int loads = getloadavg (load_ave, countof (load_ave)); | |
| 3443 Lisp_Object ret = Qnil; | |
| 3444 | |
| 3445 if (loads == -2) | |
| 563 | 3446 signal_error (Qunimplemented, |
| 3447 "load-average not implemented for this operating system", | |
| 3448 Qunbound); | |
| 428 | 3449 else if (loads < 0) |
| 563 | 3450 invalid_operation ("Could not get load-average", lisp_strerror (errno)); |
| 428 | 3451 |
| 3452 while (loads-- > 0) | |
| 3453 { | |
| 3454 Lisp_Object load = (NILP (use_floats) ? | |
| 3455 make_int ((int) (100.0 * load_ave[loads])) | |
| 3456 : make_float (load_ave[loads])); | |
| 3457 ret = Fcons (load, ret); | |
| 3458 } | |
| 3459 return ret; | |
| 3460 } | |
| 3461 | |
| 3462 | |
| 3463 Lisp_Object Vfeatures; | |
| 3464 | |
| 3465 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /* | |
| 3466 Return non-nil if feature FEXP is present in this Emacs. | |
| 3467 Use this to conditionalize execution of lisp code based on the | |
| 3468 presence or absence of emacs or environment extensions. | |
| 3469 FEXP can be a symbol, a number, or a list. | |
| 3470 If it is a symbol, that symbol is looked up in the `features' variable, | |
| 3471 and non-nil will be returned if found. | |
| 3472 If it is a number, the function will return non-nil if this Emacs | |
| 3473 has an equal or greater version number than FEXP. | |
| 3474 If it is a list whose car is the symbol `and', it will return | |
| 3475 non-nil if all the features in its cdr are non-nil. | |
| 3476 If it is a list whose car is the symbol `or', it will return non-nil | |
| 3477 if any of the features in its cdr are non-nil. | |
| 3478 If it is a list whose car is the symbol `not', it will return | |
| 3479 non-nil if the feature is not present. | |
| 3480 | |
| 3481 Examples: | |
| 3482 | |
| 3483 (featurep 'xemacs) | |
| 3484 => ; Non-nil on XEmacs. | |
| 3485 | |
| 3486 (featurep '(and xemacs gnus)) | |
| 3487 => ; Non-nil on XEmacs with Gnus loaded. | |
| 3488 | |
| 3489 (featurep '(or tty-frames (and emacs 19.30))) | |
| 3490 => ; Non-nil if this Emacs supports TTY frames. | |
| 3491 | |
| 3492 (featurep '(or (and xemacs 19.15) (and emacs 19.34))) | |
| 3493 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later. | |
| 3494 | |
| 442 | 3495 (featurep '(and xemacs 21.02)) |
| 3496 => ; Non-nil on XEmacs 21.2 and later. | |
| 3497 | |
| 428 | 3498 NOTE: The advanced arguments of this function (anything other than a |
| 3499 symbol) are not yet supported by FSF Emacs. If you feel they are useful | |
| 3500 for supporting multiple Emacs variants, lobby Richard Stallman at | |
| 442 | 3501 <bug-gnu-emacs@gnu.org>. |
| 428 | 3502 */ |
| 3503 (fexp)) | |
| 3504 { | |
| 3505 #ifndef FEATUREP_SYNTAX | |
| 3506 CHECK_SYMBOL (fexp); | |
| 3507 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
| 3508 #else /* FEATUREP_SYNTAX */ | |
| 3509 static double featurep_emacs_version; | |
| 3510 | |
| 3511 /* Brute force translation from Erik Naggum's lisp function. */ | |
| 3512 if (SYMBOLP (fexp)) | |
| 3513 { | |
| 3514 /* Original definition */ | |
| 3515 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
| 3516 } | |
| 3517 else if (INTP (fexp) || FLOATP (fexp)) | |
| 3518 { | |
| 3519 double d = extract_float (fexp); | |
| 3520 | |
| 3521 if (featurep_emacs_version == 0.0) | |
| 3522 { | |
| 3523 featurep_emacs_version = XINT (Vemacs_major_version) + | |
| 3524 (XINT (Vemacs_minor_version) / 100.0); | |
| 3525 } | |
| 3526 return featurep_emacs_version >= d ? Qt : Qnil; | |
| 3527 } | |
| 3528 else if (CONSP (fexp)) | |
| 3529 { | |
| 3530 Lisp_Object tem = XCAR (fexp); | |
| 3531 if (EQ (tem, Qnot)) | |
| 3532 { | |
| 3533 Lisp_Object negate; | |
| 3534 | |
| 3535 tem = XCDR (fexp); | |
| 3536 negate = Fcar (tem); | |
| 3537 if (!NILP (tem)) | |
| 3538 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil; | |
| 3539 else | |
| 3540 return Fsignal (Qinvalid_read_syntax, list1 (tem)); | |
| 3541 } | |
| 3542 else if (EQ (tem, Qand)) | |
| 3543 { | |
| 3544 tem = XCDR (fexp); | |
| 3545 /* Use Fcar/Fcdr for error-checking. */ | |
| 3546 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem)))) | |
| 3547 { | |
| 3548 tem = Fcdr (tem); | |
| 3549 } | |
| 3550 return NILP (tem) ? Qt : Qnil; | |
| 3551 } | |
| 3552 else if (EQ (tem, Qor)) | |
| 3553 { | |
| 3554 tem = XCDR (fexp); | |
| 3555 /* Use Fcar/Fcdr for error-checking. */ | |
| 3556 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem)))) | |
| 3557 { | |
| 3558 tem = Fcdr (tem); | |
| 3559 } | |
| 3560 return NILP (tem) ? Qnil : Qt; | |
| 3561 } | |
| 3562 else | |
| 3563 { | |
| 3564 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp))); | |
| 3565 } | |
| 3566 } | |
| 3567 else | |
| 3568 { | |
| 3569 return Fsignal (Qinvalid_read_syntax, list1 (fexp)); | |
| 3570 } | |
| 3571 } | |
| 3572 #endif /* FEATUREP_SYNTAX */ | |
| 3573 | |
| 3574 DEFUN ("provide", Fprovide, 1, 1, 0, /* | |
| 3575 Announce that FEATURE is a feature of the current Emacs. | |
| 3576 This function updates the value of the variable `features'. | |
| 3577 */ | |
| 3578 (feature)) | |
| 3579 { | |
| 3580 Lisp_Object tem; | |
| 3581 CHECK_SYMBOL (feature); | |
| 3582 if (!NILP (Vautoload_queue)) | |
| 3583 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue); | |
| 3584 tem = Fmemq (feature, Vfeatures); | |
| 3585 if (NILP (tem)) | |
| 3586 Vfeatures = Fcons (feature, Vfeatures); | |
| 3587 LOADHIST_ATTACH (Fcons (Qprovide, feature)); | |
| 3588 return feature; | |
| 3589 } | |
| 3590 | |
| 1067 | 3591 DEFUN ("require", Frequire, 1, 3, 0, /* |
| 3842 | 3592 Ensure that FEATURE is present in the Lisp environment. |
| 3593 FEATURE is a symbol naming a collection of resources (functions, etc). | |
| 3594 Optional FILENAME is a library from which to load resources; it defaults to | |
| 3595 the print name of FEATURE. | |
| 3596 Optional NOERROR, if non-nil, causes require to return nil rather than signal | |
| 3597 `file-error' if loading the library fails. | |
| 3598 | |
| 3599 If feature FEATURE is present in `features', update `load-history' to reflect | |
| 3600 the require and return FEATURE. Otherwise, try to load it from a library. | |
| 3601 The normal messages at start and end of loading are suppressed. | |
| 3602 If the library is successfully loaded and it calls `(provide FEATURE)', add | |
| 3603 FEATURE to `features', update `load-history' and return FEATURE. | |
| 3604 If the load succeeds but FEATURE is not provided by the library, signal | |
| 3605 `invalid-state'. | |
| 3606 | |
| 3607 The byte-compiler treats top-level calls to `require' specially, by evaluating | |
| 3608 them at compile time (and then compiling them normally). Thus a library may | |
| 3609 request that definitions that should be inlined such as macros and defsubsts | |
| 3610 be loaded into its compilation environment. Achieving this in other contexts | |
| 3611 requires an explicit \(eval-and-compile ...\) block. | |
| 428 | 3612 */ |
| 1067 | 3613 (feature, filename, noerror)) |
| 428 | 3614 { |
| 3615 Lisp_Object tem; | |
| 3616 CHECK_SYMBOL (feature); | |
| 3617 tem = Fmemq (feature, Vfeatures); | |
| 3618 LOADHIST_ATTACH (Fcons (Qrequire, feature)); | |
| 3619 if (!NILP (tem)) | |
| 3620 return feature; | |
| 3621 else | |
| 3622 { | |
| 3623 int speccount = specpdl_depth (); | |
| 3624 | |
| 3625 /* Value saved here is to be restored into Vautoload_queue */ | |
| 3626 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 3627 Vautoload_queue = Qt; | |
| 3628 | |
| 1067 | 3629 tem = call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename, |
| 1261 | 3630 noerror, Qrequire, Qnil); |
| 1067 | 3631 /* If load failed entirely, return nil. */ |
| 3632 if (NILP (tem)) | |
| 3633 return unbind_to_1 (speccount, Qnil); | |
| 428 | 3634 |
| 3635 tem = Fmemq (feature, Vfeatures); | |
| 3636 if (NILP (tem)) | |
| 563 | 3637 invalid_state ("Required feature was not provided", feature); |
| 428 | 3638 |
| 3639 /* Once loading finishes, don't undo it. */ | |
| 3640 Vautoload_queue = Qt; | |
| 771 | 3641 return unbind_to_1 (speccount, feature); |
| 428 | 3642 } |
| 3643 } | |
| 3644 | |
| 3645 /* base64 encode/decode functions. | |
| 3646 | |
| 3647 Originally based on code from GNU recode. Ported to FSF Emacs by | |
| 3648 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and | |
| 3649 subsequently heavily hacked by Hrvoje Niksic. */ | |
| 3650 | |
| 3651 #define MIME_LINE_LENGTH 72 | |
| 3652 | |
| 3653 #define IS_ASCII(Character) \ | |
| 3654 ((Character) < 128) | |
| 3655 #define IS_BASE64(Character) \ | |
| 3656 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0) | |
| 3657 | |
| 3658 /* Table of characters coding the 64 values. */ | |
| 3659 static char base64_value_to_char[64] = | |
| 3660 { | |
| 3661 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */ | |
| 3662 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */ | |
| 3663 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */ | |
| 3664 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */ | |
| 3665 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */ | |
| 3666 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */ | |
| 3667 '8', '9', '+', '/' /* 60-63 */ | |
| 3668 }; | |
| 3669 | |
| 3670 /* Table of base64 values for first 128 characters. */ | |
| 3671 static short base64_char_to_value[128] = | |
| 3672 { | |
| 3673 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */ | |
| 3674 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */ | |
| 3675 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */ | |
| 3676 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */ | |
| 3677 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */ | |
| 3678 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */ | |
| 3679 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */ | |
| 3680 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */ | |
| 3681 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */ | |
| 3682 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */ | |
| 3683 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */ | |
| 3684 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */ | |
| 3685 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */ | |
| 3686 }; | |
| 3687 | |
| 3688 /* The following diagram shows the logical steps by which three octets | |
| 3689 get transformed into four base64 characters. | |
| 3690 | |
| 3691 .--------. .--------. .--------. | |
| 3692 |aaaaaabb| |bbbbcccc| |ccdddddd| | |
| 3693 `--------' `--------' `--------' | |
| 3694 6 2 4 4 2 6 | |
| 3695 .--------+--------+--------+--------. | |
| 3696 |00aaaaaa|00bbbbbb|00cccccc|00dddddd| | |
| 3697 `--------+--------+--------+--------' | |
| 3698 | |
| 3699 .--------+--------+--------+--------. | |
| 3700 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD| | |
| 3701 `--------+--------+--------+--------' | |
| 3702 | |
| 3703 The octets are divided into 6 bit chunks, which are then encoded into | |
| 3704 base64 characters. */ | |
| 3705 | |
| 2268 | 3706 static DECLARE_DOESNT_RETURN (base64_conversion_error (const char *, |
| 3707 Lisp_Object)); | |
| 3708 | |
| 575 | 3709 static DOESNT_RETURN |
| 563 | 3710 base64_conversion_error (const char *reason, Lisp_Object frob) |
| 3711 { | |
| 3712 signal_error (Qbase64_conversion_error, reason, frob); | |
| 3713 } | |
| 3714 | |
| 3715 #define ADVANCE_INPUT(c, stream) \ | |
| 867 | 3716 ((ec = Lstream_get_ichar (stream)) == -1 ? 0 : \ |
| 563 | 3717 ((ec > 255) ? \ |
| 3718 (base64_conversion_error ("Non-ascii character in base64 input", \ | |
| 3719 make_char (ec)), 0) \ | |
| 867 | 3720 : (c = (Ibyte)ec), 1)) |
| 665 | 3721 |
| 3722 static Bytebpos | |
| 867 | 3723 base64_encode_1 (Lstream *istream, Ibyte *to, int line_break) |
| 428 | 3724 { |
| 3725 EMACS_INT counter = 0; | |
| 867 | 3726 Ibyte *e = to; |
| 3727 Ichar ec; | |
| 428 | 3728 unsigned int value; |
| 3729 | |
| 3730 while (1) | |
| 3731 { | |
| 1204 | 3732 Ibyte c = 0; |
| 428 | 3733 if (!ADVANCE_INPUT (c, istream)) |
| 3734 break; | |
| 3735 | |
| 3736 /* Wrap line every 76 characters. */ | |
| 3737 if (line_break) | |
| 3738 { | |
| 3739 if (counter < MIME_LINE_LENGTH / 4) | |
| 3740 counter++; | |
| 3741 else | |
| 3742 { | |
| 3743 *e++ = '\n'; | |
| 3744 counter = 1; | |
| 3745 } | |
| 3746 } | |
| 3747 | |
| 3748 /* Process first byte of a triplet. */ | |
| 3749 *e++ = base64_value_to_char[0x3f & c >> 2]; | |
| 3750 value = (0x03 & c) << 4; | |
| 3751 | |
| 3752 /* Process second byte of a triplet. */ | |
| 3753 if (!ADVANCE_INPUT (c, istream)) | |
| 3754 { | |
| 3755 *e++ = base64_value_to_char[value]; | |
| 3756 *e++ = '='; | |
| 3757 *e++ = '='; | |
| 3758 break; | |
| 3759 } | |
| 3760 | |
| 3761 *e++ = base64_value_to_char[value | (0x0f & c >> 4)]; | |
| 3762 value = (0x0f & c) << 2; | |
| 3763 | |
| 3764 /* Process third byte of a triplet. */ | |
| 3765 if (!ADVANCE_INPUT (c, istream)) | |
| 3766 { | |
| 3767 *e++ = base64_value_to_char[value]; | |
| 3768 *e++ = '='; | |
| 3769 break; | |
| 3770 } | |
| 3771 | |
| 3772 *e++ = base64_value_to_char[value | (0x03 & c >> 6)]; | |
| 3773 *e++ = base64_value_to_char[0x3f & c]; | |
| 3774 } | |
| 3775 | |
| 3776 return e - to; | |
| 3777 } | |
| 3778 #undef ADVANCE_INPUT | |
| 3779 | |
| 3780 /* Get next character from the stream, except that non-base64 | |
| 3781 characters are ignored. This is in accordance with rfc2045. EC | |
| 867 | 3782 should be an Ichar, so that it can hold -1 as the value for EOF. */ |
| 428 | 3783 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \ |
| 867 | 3784 ec = Lstream_get_ichar (stream); \ |
| 428 | 3785 ++streampos; \ |
| 3786 /* IS_BASE64 may not be called with negative arguments so check for \ | |
| 3787 EOF first. */ \ | |
| 3788 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ | |
| 3789 break; \ | |
| 3790 } while (1) | |
| 3791 | |
| 3792 #define STORE_BYTE(pos, val, ccnt) do { \ | |
| 867 | 3793 pos += set_itext_ichar (pos, (Ichar)((unsigned char)(val))); \ |
| 428 | 3794 ++ccnt; \ |
| 3795 } while (0) | |
| 3796 | |
| 665 | 3797 static Bytebpos |
| 867 | 3798 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr) |
| 428 | 3799 { |
| 3800 Charcount ccnt = 0; | |
| 867 | 3801 Ibyte *e = to; |
| 428 | 3802 EMACS_INT streampos = 0; |
| 3803 | |
| 3804 while (1) | |
| 3805 { | |
| 867 | 3806 Ichar ec; |
| 428 | 3807 unsigned long value; |
| 3808 | |
| 3809 /* Process first byte of a quadruplet. */ | |
| 3810 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3811 if (ec < 0) | |
| 3812 break; | |
| 3813 if (ec == '=') | |
| 563 | 3814 base64_conversion_error ("Illegal `=' character while decoding base64", |
| 3815 make_int (streampos)); | |
| 428 | 3816 value = base64_char_to_value[ec] << 18; |
| 3817 | |
| 3818 /* Process second byte of a quadruplet. */ | |
| 3819 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3820 if (ec < 0) | |
| 563 | 3821 base64_conversion_error ("Premature EOF while decoding base64", |
| 3822 Qunbound); | |
| 428 | 3823 if (ec == '=') |
| 563 | 3824 base64_conversion_error ("Illegal `=' character while decoding base64", |
| 3825 make_int (streampos)); | |
| 428 | 3826 value |= base64_char_to_value[ec] << 12; |
| 3827 STORE_BYTE (e, value >> 16, ccnt); | |
| 3828 | |
| 3829 /* Process third byte of a quadruplet. */ | |
| 3830 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3831 if (ec < 0) | |
| 563 | 3832 base64_conversion_error ("Premature EOF while decoding base64", |
| 3833 Qunbound); | |
| 428 | 3834 |
| 3835 if (ec == '=') | |
| 3836 { | |
| 3837 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3838 if (ec < 0) | |
| 563 | 3839 base64_conversion_error ("Premature EOF while decoding base64", |
| 3840 Qunbound); | |
| 428 | 3841 if (ec != '=') |
| 563 | 3842 base64_conversion_error |
| 3843 ("Padding `=' expected but not found while decoding base64", | |
| 3844 make_int (streampos)); | |
| 428 | 3845 continue; |
| 3846 } | |
| 3847 | |
| 3848 value |= base64_char_to_value[ec] << 6; | |
| 3849 STORE_BYTE (e, 0xff & value >> 8, ccnt); | |
| 3850 | |
| 3851 /* Process fourth byte of a quadruplet. */ | |
| 3852 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3853 if (ec < 0) | |
| 563 | 3854 base64_conversion_error ("Premature EOF while decoding base64", |
| 3855 Qunbound); | |
| 428 | 3856 if (ec == '=') |
| 3857 continue; | |
| 3858 | |
| 3859 value |= base64_char_to_value[ec]; | |
| 3860 STORE_BYTE (e, 0xff & value, ccnt); | |
| 3861 } | |
| 3862 | |
| 3863 *ccptr = ccnt; | |
| 3864 return e - to; | |
| 3865 } | |
| 3866 #undef ADVANCE_INPUT | |
| 3867 #undef ADVANCE_INPUT_IGNORE_NONBASE64 | |
| 3868 #undef STORE_BYTE | |
| 3869 | |
| 3870 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* | |
| 444 | 3871 Base64-encode the region between START and END. |
| 428 | 3872 Return the length of the encoded text. |
| 3873 Optional third argument NO-LINE-BREAK means do not break long lines | |
| 3874 into shorter lines. | |
| 3875 */ | |
| 444 | 3876 (start, end, no_line_break)) |
| 428 | 3877 { |
| 867 | 3878 Ibyte *encoded; |
| 665 | 3879 Bytebpos encoded_length; |
| 428 | 3880 Charcount allength, length; |
| 3881 struct buffer *buf = current_buffer; | |
| 665 | 3882 Charbpos begv, zv, old_pt = BUF_PT (buf); |
| 428 | 3883 Lisp_Object input; |
| 851 | 3884 int speccount = specpdl_depth (); |
| 428 | 3885 |
| 444 | 3886 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
| 428 | 3887 barf_if_buffer_read_only (buf, begv, zv); |
| 3888 | |
| 3889 /* We need to allocate enough room for encoding the text. | |
| 3890 We need 33 1/3% more space, plus a newline every 76 | |
| 3891 characters, and then we round up. */ | |
| 3892 length = zv - begv; | |
| 3893 allength = length + length/3 + 1; | |
| 3894 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
| 3895 | |
| 3896 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
| 867 | 3897 /* We needn't multiply allength with MAX_ICHAR_LEN because all the |
| 428 | 3898 base64 characters will be single-byte. */ |
| 867 | 3899 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
| 428 | 3900 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
| 3901 NILP (no_line_break)); | |
| 3902 if (encoded_length > allength) | |
| 2500 | 3903 ABORT (); |
| 428 | 3904 Lstream_delete (XLSTREAM (input)); |
| 3905 | |
| 3906 /* Now we have encoded the region, so we insert the new contents | |
| 3907 and delete the old. (Insert first in order to preserve markers.) */ | |
| 3908 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); | |
| 851 | 3909 unbind_to (speccount); |
| 428 | 3910 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); |
| 3911 | |
| 3912 /* Simulate FSF Emacs implementation of this function: if point was | |
| 3913 in the region, place it at the beginning. */ | |
| 3914 if (old_pt >= begv && old_pt < zv) | |
| 3915 BUF_SET_PT (buf, begv); | |
| 3916 | |
| 3917 /* We return the length of the encoded text. */ | |
| 3918 return make_int (encoded_length); | |
| 3919 } | |
| 3920 | |
| 3921 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /* | |
| 3922 Base64 encode STRING and return the result. | |
| 444 | 3923 Optional argument NO-LINE-BREAK means do not break long lines |
| 3924 into shorter lines. | |
| 428 | 3925 */ |
| 3926 (string, no_line_break)) | |
| 3927 { | |
| 3928 Charcount allength, length; | |
| 665 | 3929 Bytebpos encoded_length; |
| 867 | 3930 Ibyte *encoded; |
| 428 | 3931 Lisp_Object input, result; |
| 3932 int speccount = specpdl_depth(); | |
| 3933 | |
| 3934 CHECK_STRING (string); | |
| 3935 | |
| 826 | 3936 length = string_char_length (string); |
| 428 | 3937 allength = length + length/3 + 1; |
| 3938 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
| 3939 | |
| 3940 input = make_lisp_string_input_stream (string, 0, -1); | |
| 867 | 3941 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
| 428 | 3942 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
| 3943 NILP (no_line_break)); | |
| 3944 if (encoded_length > allength) | |
| 2500 | 3945 ABORT (); |
| 428 | 3946 Lstream_delete (XLSTREAM (input)); |
| 3947 result = make_string (encoded, encoded_length); | |
| 851 | 3948 unbind_to (speccount); |
| 428 | 3949 return result; |
| 3950 } | |
| 3951 | |
| 3952 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* | |
| 444 | 3953 Base64-decode the region between START and END. |
| 428 | 3954 Return the length of the decoded text. |
| 3955 If the region can't be decoded, return nil and don't modify the buffer. | |
| 3956 Characters out of the base64 alphabet are ignored. | |
| 3957 */ | |
| 444 | 3958 (start, end)) |
| 428 | 3959 { |
| 3960 struct buffer *buf = current_buffer; | |
| 665 | 3961 Charbpos begv, zv, old_pt = BUF_PT (buf); |
| 867 | 3962 Ibyte *decoded; |
| 665 | 3963 Bytebpos decoded_length; |
| 428 | 3964 Charcount length, cc_decoded_length; |
| 3965 Lisp_Object input; | |
| 3966 int speccount = specpdl_depth(); | |
| 3967 | |
| 444 | 3968 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
| 428 | 3969 barf_if_buffer_read_only (buf, begv, zv); |
| 3970 | |
| 3971 length = zv - begv; | |
| 3972 | |
| 3973 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
| 3974 /* We need to allocate enough room for decoding the text. */ | |
| 867 | 3975 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
| 428 | 3976 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); |
| 867 | 3977 if (decoded_length > length * MAX_ICHAR_LEN) |
| 2500 | 3978 ABORT (); |
| 428 | 3979 Lstream_delete (XLSTREAM (input)); |
| 3980 | |
| 3981 /* Now we have decoded the region, so we insert the new contents | |
| 3982 and delete the old. (Insert first in order to preserve markers.) */ | |
| 3983 BUF_SET_PT (buf, begv); | |
| 3984 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); | |
| 851 | 3985 unbind_to (speccount); |
| 428 | 3986 buffer_delete_range (buf, begv + cc_decoded_length, |
| 3987 zv + cc_decoded_length, 0); | |
| 3988 | |
| 3989 /* Simulate FSF Emacs implementation of this function: if point was | |
| 3990 in the region, place it at the beginning. */ | |
| 3991 if (old_pt >= begv && old_pt < zv) | |
| 3992 BUF_SET_PT (buf, begv); | |
| 3993 | |
| 3994 return make_int (cc_decoded_length); | |
| 3995 } | |
| 3996 | |
| 3997 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* | |
| 3998 Base64-decode STRING and return the result. | |
| 3999 Characters out of the base64 alphabet are ignored. | |
| 4000 */ | |
| 4001 (string)) | |
| 4002 { | |
| 867 | 4003 Ibyte *decoded; |
| 665 | 4004 Bytebpos decoded_length; |
| 428 | 4005 Charcount length, cc_decoded_length; |
| 4006 Lisp_Object input, result; | |
| 4007 int speccount = specpdl_depth(); | |
| 4008 | |
| 4009 CHECK_STRING (string); | |
| 4010 | |
| 826 | 4011 length = string_char_length (string); |
| 428 | 4012 /* We need to allocate enough room for decoding the text. */ |
| 867 | 4013 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
| 428 | 4014 |
| 4015 input = make_lisp_string_input_stream (string, 0, -1); | |
| 4016 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, | |
| 4017 &cc_decoded_length); | |
| 867 | 4018 if (decoded_length > length * MAX_ICHAR_LEN) |
| 2500 | 4019 ABORT (); |
| 428 | 4020 Lstream_delete (XLSTREAM (input)); |
| 4021 | |
| 4022 result = make_string (decoded, decoded_length); | |
| 851 | 4023 unbind_to (speccount); |
| 428 | 4024 return result; |
| 4025 } | |
| 4026 | |
| 4027 Lisp_Object Qyes_or_no_p; | |
| 4028 | |
| 4029 void | |
| 4030 syms_of_fns (void) | |
| 4031 { | |
| 442 | 4032 INIT_LRECORD_IMPLEMENTATION (bit_vector); |
| 4033 | |
| 563 | 4034 DEFSYMBOL (Qstring_lessp); |
| 4035 DEFSYMBOL (Qidentity); | |
| 4036 DEFSYMBOL (Qyes_or_no_p); | |
| 4037 | |
| 4038 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error); | |
| 428 | 4039 |
| 4040 DEFSUBR (Fidentity); | |
| 4041 DEFSUBR (Frandom); | |
| 4042 DEFSUBR (Flength); | |
| 4043 DEFSUBR (Fsafe_length); | |
| 4044 DEFSUBR (Fstring_equal); | |
| 801 | 4045 DEFSUBR (Fcompare_strings); |
| 428 | 4046 DEFSUBR (Fstring_lessp); |
| 4047 DEFSUBR (Fstring_modified_tick); | |
| 4048 DEFSUBR (Fappend); | |
| 4049 DEFSUBR (Fconcat); | |
| 4050 DEFSUBR (Fvconcat); | |
| 4051 DEFSUBR (Fbvconcat); | |
| 4052 DEFSUBR (Fcopy_list); | |
| 4053 DEFSUBR (Fcopy_sequence); | |
| 4054 DEFSUBR (Fcopy_alist); | |
| 4055 DEFSUBR (Fcopy_tree); | |
| 4056 DEFSUBR (Fsubstring); | |
| 4057 DEFSUBR (Fsubseq); | |
| 4058 DEFSUBR (Fnthcdr); | |
| 4059 DEFSUBR (Fnth); | |
| 4060 DEFSUBR (Felt); | |
| 4061 DEFSUBR (Flast); | |
| 4062 DEFSUBR (Fbutlast); | |
| 4063 DEFSUBR (Fnbutlast); | |
| 4064 DEFSUBR (Fmember); | |
| 4065 DEFSUBR (Fold_member); | |
| 4066 DEFSUBR (Fmemq); | |
| 4067 DEFSUBR (Fold_memq); | |
| 4068 DEFSUBR (Fassoc); | |
| 4069 DEFSUBR (Fold_assoc); | |
| 4070 DEFSUBR (Fassq); | |
| 4071 DEFSUBR (Fold_assq); | |
| 4072 DEFSUBR (Frassoc); | |
| 4073 DEFSUBR (Fold_rassoc); | |
| 4074 DEFSUBR (Frassq); | |
| 4075 DEFSUBR (Fold_rassq); | |
| 4076 DEFSUBR (Fdelete); | |
| 4077 DEFSUBR (Fold_delete); | |
| 4078 DEFSUBR (Fdelq); | |
| 4079 DEFSUBR (Fold_delq); | |
| 4080 DEFSUBR (Fremassoc); | |
| 4081 DEFSUBR (Fremassq); | |
| 4082 DEFSUBR (Fremrassoc); | |
| 4083 DEFSUBR (Fremrassq); | |
| 4084 DEFSUBR (Fnreverse); | |
| 4085 DEFSUBR (Freverse); | |
| 4086 DEFSUBR (Fsort); | |
| 4087 DEFSUBR (Fplists_eq); | |
| 4088 DEFSUBR (Fplists_equal); | |
| 4089 DEFSUBR (Flax_plists_eq); | |
| 4090 DEFSUBR (Flax_plists_equal); | |
| 4091 DEFSUBR (Fplist_get); | |
| 4092 DEFSUBR (Fplist_put); | |
| 4093 DEFSUBR (Fplist_remprop); | |
| 4094 DEFSUBR (Fplist_member); | |
| 4095 DEFSUBR (Fcheck_valid_plist); | |
| 4096 DEFSUBR (Fvalid_plist_p); | |
| 4097 DEFSUBR (Fcanonicalize_plist); | |
| 4098 DEFSUBR (Flax_plist_get); | |
| 4099 DEFSUBR (Flax_plist_put); | |
| 4100 DEFSUBR (Flax_plist_remprop); | |
| 4101 DEFSUBR (Flax_plist_member); | |
| 4102 DEFSUBR (Fcanonicalize_lax_plist); | |
| 4103 DEFSUBR (Fdestructive_alist_to_plist); | |
| 4104 DEFSUBR (Fget); | |
| 4105 DEFSUBR (Fput); | |
| 4106 DEFSUBR (Fremprop); | |
| 4107 DEFSUBR (Fobject_plist); | |
| 4108 DEFSUBR (Fequal); | |
| 4109 DEFSUBR (Fold_equal); | |
| 4110 DEFSUBR (Ffillarray); | |
| 4111 DEFSUBR (Fnconc); | |
| 4112 DEFSUBR (Fmapcar); | |
| 4113 DEFSUBR (Fmapvector); | |
| 4114 DEFSUBR (Fmapc_internal); | |
| 4115 DEFSUBR (Fmapconcat); | |
| 442 | 4116 DEFSUBR (Freplace_list); |
| 428 | 4117 DEFSUBR (Fload_average); |
| 4118 DEFSUBR (Ffeaturep); | |
| 4119 DEFSUBR (Frequire); | |
| 4120 DEFSUBR (Fprovide); | |
| 4121 DEFSUBR (Fbase64_encode_region); | |
| 4122 DEFSUBR (Fbase64_encode_string); | |
| 4123 DEFSUBR (Fbase64_decode_region); | |
| 4124 DEFSUBR (Fbase64_decode_string); | |
| 771 | 4125 |
| 4126 DEFSUBR (Fsplit_string_by_char); | |
| 4127 DEFSUBR (Fsplit_path); /* #### */ | |
| 4128 } | |
| 4129 | |
| 4130 void | |
| 4131 vars_of_fns (void) | |
| 4132 { | |
| 4133 DEFVAR_LISP ("path-separator", &Vpath_separator /* | |
| 4134 The directory separator in search paths, as a string. | |
| 4135 */ ); | |
| 4136 { | |
| 4137 char c = SEPCHAR; | |
| 867 | 4138 Vpath_separator = make_string ((Ibyte *) &c, 1); |
| 771 | 4139 } |
| 428 | 4140 } |
| 4141 | |
| 4142 void | |
| 4143 init_provide_once (void) | |
| 4144 { | |
| 4145 DEFVAR_LISP ("features", &Vfeatures /* | |
| 4146 A list of symbols which are the features of the executing emacs. | |
| 4147 Used by `featurep' and `require', and altered by `provide'. | |
| 4148 */ ); | |
| 4149 Vfeatures = Qnil; | |
| 4150 | |
| 4151 Fprovide (intern ("base64")); | |
| 4152 } |