Mercurial > hg > xemacs-beta
annotate src/data.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 | a98ca4640147 |
| children | db2db229ee82 |
| rev | line source |
|---|---|
| 428 | 1 /* Primitive operations on Lisp data types for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995 | |
| 3 Free Software Foundation, Inc. | |
| 1330 | 4 Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in | |
| 24 XEmacs' symbols.c. */ | |
| 25 | |
| 26 /* This file has been Mule-ized. */ | |
| 27 | |
| 28 #include <config.h> | |
| 29 #include "lisp.h" | |
| 30 | |
| 31 #include "buffer.h" | |
| 32 #include "bytecode.h" | |
| 33 #include "syssignal.h" | |
| 771 | 34 #include "sysfloat.h" |
| 428 | 35 |
| 36 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound; | |
| 37 Lisp_Object Qerror_conditions, Qerror_message; | |
| 442 | 38 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax; |
| 563 | 39 Lisp_Object Qlist_formation_error, Qstructure_formation_error; |
| 442 | 40 Lisp_Object Qmalformed_list, Qmalformed_property_list; |
| 41 Lisp_Object Qcircular_list, Qcircular_property_list; | |
| 563 | 42 Lisp_Object Qinvalid_argument, Qinvalid_constant, Qwrong_type_argument; |
| 43 Lisp_Object Qargs_out_of_range; | |
| 442 | 44 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch; |
| 563 | 45 Lisp_Object Qinternal_error, Qinvalid_state, Qstack_overflow, Qout_of_memory; |
| 428 | 46 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection; |
| 47 Lisp_Object Qvoid_function, Qcyclic_function_indirection; | |
| 563 | 48 Lisp_Object Qinvalid_operation, Qinvalid_change, Qprinting_unreadable_object; |
| 442 | 49 Lisp_Object Qsetting_constant; |
| 50 Lisp_Object Qediting_error; | |
| 51 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; | |
| 563 | 52 Lisp_Object Qio_error, Qfile_error, Qconversion_error, Qend_of_file; |
| 580 | 53 Lisp_Object Qtext_conversion_error; |
| 428 | 54 Lisp_Object Qarith_error, Qrange_error, Qdomain_error; |
| 55 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error; | |
| 1983 | 56 Lisp_Object Qintegerp, Qnatnump, Qnonnegativep, Qsymbolp; |
| 428 | 57 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp; |
| 58 Lisp_Object Qconsp, Qsubrp; | |
| 59 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp; | |
| 60 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp; | |
| 61 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p; | |
| 62 Lisp_Object Qnumberp, Qnumber_char_or_marker_p; | |
| 63 Lisp_Object Qbit_vectorp, Qbitp, Qcdr; | |
| 64 | |
| 563 | 65 Lisp_Object Qerror_lacks_explanatory_string; |
| 428 | 66 Lisp_Object Qfloatp; |
| 67 | |
| 68 #ifdef DEBUG_XEMACS | |
| 69 | |
| 70 int debug_issue_ebola_notices; | |
| 71 | |
| 458 | 72 Fixnum debug_ebola_backtrace_length; |
| 428 | 73 |
| 74 int | |
| 75 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2) | |
| 76 { | |
| 77 if (debug_issue_ebola_notices | |
| 78 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1)))) | |
| 79 { | |
| 80 /* #### It would be really nice if this were a proper warning | |
| 1551 | 81 instead of brain-dead print to Qexternal_debugging_output. */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
82 write_msg_string |
| 826 | 83 (Qexternal_debugging_output, |
| 84 "Comparison between integer and character is constant nil ("); | |
| 428 | 85 Fprinc (obj1, Qexternal_debugging_output); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
86 write_msg_string (Qexternal_debugging_output, " and "); |
| 428 | 87 Fprinc (obj2, Qexternal_debugging_output); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
88 write_msg_string (Qexternal_debugging_output, ")\n"); |
| 428 | 89 debug_short_backtrace (debug_ebola_backtrace_length); |
| 90 } | |
| 91 return EQ (obj1, obj2); | |
| 92 } | |
| 93 | |
| 94 #endif /* DEBUG_XEMACS */ | |
| 95 | |
| 96 | |
| 97 | |
| 98 Lisp_Object | |
| 99 wrong_type_argument (Lisp_Object predicate, Lisp_Object value) | |
| 100 { | |
| 101 /* This function can GC */ | |
| 102 REGISTER Lisp_Object tem; | |
| 103 do | |
| 104 { | |
| 105 value = Fsignal (Qwrong_type_argument, list2 (predicate, value)); | |
| 106 tem = call1 (predicate, value); | |
| 107 } | |
| 108 while (NILP (tem)); | |
| 109 return value; | |
| 110 } | |
| 111 | |
| 112 DOESNT_RETURN | |
| 113 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value) | |
| 114 { | |
| 563 | 115 signal_error_1 (Qwrong_type_argument, list2 (predicate, value)); |
| 428 | 116 } |
| 117 | |
| 118 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /* | |
| 119 Signal an error until the correct type value is given by the user. | |
| 120 This function loops, signalling a continuable `wrong-type-argument' error | |
| 121 with PREDICATE and VALUE as the data associated with the error and then | |
| 122 calling PREDICATE on the returned value, until the value gotten satisfies | |
| 123 PREDICATE. At that point, the gotten value is returned. | |
| 124 */ | |
| 125 (predicate, value)) | |
| 126 { | |
| 127 return wrong_type_argument (predicate, value); | |
| 128 } | |
| 129 | |
| 130 DOESNT_RETURN | |
| 131 c_write_error (Lisp_Object obj) | |
| 132 { | |
| 563 | 133 signal_error (Qsetting_constant, |
| 134 "Attempt to modify read-only object (c)", obj); | |
| 428 | 135 } |
| 136 | |
| 137 DOESNT_RETURN | |
| 138 lisp_write_error (Lisp_Object obj) | |
| 139 { | |
| 563 | 140 signal_error (Qsetting_constant, |
| 141 "Attempt to modify read-only object (lisp)", obj); | |
| 428 | 142 } |
| 143 | |
| 144 DOESNT_RETURN | |
| 145 args_out_of_range (Lisp_Object a1, Lisp_Object a2) | |
| 146 { | |
| 563 | 147 signal_error_1 (Qargs_out_of_range, list2 (a1, a2)); |
| 428 | 148 } |
| 149 | |
| 150 DOESNT_RETURN | |
| 151 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3) | |
| 152 { | |
| 563 | 153 signal_error_1 (Qargs_out_of_range, list3 (a1, a2, a3)); |
| 428 | 154 } |
| 155 | |
| 156 void | |
| 157 check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max) | |
| 158 { | |
| 159 if (val < min || val > max) | |
| 160 args_out_of_range_3 (make_int (val), make_int (min), make_int (max)); | |
| 161 } | |
| 162 | |
| 163 | |
| 164 /* Data type predicates */ | |
| 165 | |
| 166 DEFUN ("eq", Feq, 2, 2, 0, /* | |
| 167 Return t if the two args are the same Lisp object. | |
| 168 */ | |
| 444 | 169 (object1, object2)) |
| 428 | 170 { |
| 444 | 171 return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil; |
| 428 | 172 } |
| 173 | |
| 174 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /* | |
| 175 Return t if the two args are (in most cases) the same Lisp object. | |
| 176 | |
| 177 Special kludge: A character is considered `old-eq' to its equivalent integer | |
| 178 even though they are not the same object and are in fact of different | |
| 179 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to | |
| 180 preserve byte-code compatibility with v19. This kludge is known as the | |
| 181 \"char-int confoundance disease\" and appears in a number of other | |
| 182 functions with `old-foo' equivalents. | |
| 183 | |
| 184 Do not use this function! | |
| 185 */ | |
| 444 | 186 (object1, object2)) |
| 428 | 187 { |
| 188 /* #### blasphemy */ | |
| 444 | 189 return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil; |
| 428 | 190 } |
| 191 | |
| 192 DEFUN ("null", Fnull, 1, 1, 0, /* | |
| 193 Return t if OBJECT is nil. | |
| 194 */ | |
| 195 (object)) | |
| 196 { | |
| 197 return NILP (object) ? Qt : Qnil; | |
| 198 } | |
| 199 | |
| 200 DEFUN ("consp", Fconsp, 1, 1, 0, /* | |
| 201 Return t if OBJECT is a cons cell. `nil' is not a cons cell. | |
| 3343 | 202 |
| 3355 | 203 See the documentation for `cons' or the Lisp manual for more details on what |
| 204 a cons cell is. | |
| 428 | 205 */ |
| 206 (object)) | |
| 207 { | |
| 208 return CONSP (object) ? Qt : Qnil; | |
| 209 } | |
| 210 | |
| 211 DEFUN ("atom", Fatom, 1, 1, 0, /* | |
| 212 Return t if OBJECT is not a cons cell. `nil' is not a cons cell. | |
| 3355 | 213 |
| 214 See the documentation for `cons' or the Lisp manual for more details on what | |
| 215 a cons cell is. | |
| 428 | 216 */ |
| 217 (object)) | |
| 218 { | |
| 219 return CONSP (object) ? Qnil : Qt; | |
| 220 } | |
| 221 | |
| 222 DEFUN ("listp", Flistp, 1, 1, 0, /* | |
| 223 Return t if OBJECT is a list. `nil' is a list. | |
| 3343 | 224 |
| 3355 | 225 A list is either the Lisp object nil (a symbol), interpreted as the empty |
| 226 list in this context, or a cons cell whose CDR refers to either nil or a | |
| 227 cons cell. A "proper list" contains no cycles. | |
| 428 | 228 */ |
| 229 (object)) | |
| 230 { | |
| 231 return LISTP (object) ? Qt : Qnil; | |
| 232 } | |
| 233 | |
| 234 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /* | |
| 235 Return t if OBJECT is not a list. `nil' is a list. | |
| 236 */ | |
| 237 (object)) | |
| 238 { | |
| 239 return LISTP (object) ? Qnil : Qt; | |
| 240 } | |
| 241 | |
| 242 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /* | |
| 1551 | 243 Return t if OBJECT is an acyclic, nil-terminated (ie, not dotted), list. |
| 428 | 244 */ |
| 245 (object)) | |
| 246 { | |
| 247 return TRUE_LIST_P (object) ? Qt : Qnil; | |
| 248 } | |
| 249 | |
| 250 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /* | |
| 251 Return t if OBJECT is a symbol. | |
| 3343 | 252 |
| 253 A symbol is a Lisp object with a name. It can optionally have any and all of | |
| 254 a value, a property list and an associated function. | |
| 428 | 255 */ |
| 256 (object)) | |
| 257 { | |
| 258 return SYMBOLP (object) ? Qt : Qnil; | |
| 259 } | |
| 260 | |
| 261 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /* | |
| 262 Return t if OBJECT is a keyword. | |
| 263 */ | |
| 264 (object)) | |
| 265 { | |
| 266 return KEYWORDP (object) ? Qt : Qnil; | |
| 267 } | |
| 268 | |
| 269 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /* | |
| 270 Return t if OBJECT is a vector. | |
| 271 */ | |
| 272 (object)) | |
| 273 { | |
| 274 return VECTORP (object) ? Qt : Qnil; | |
| 275 } | |
| 276 | |
| 277 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /* | |
| 278 Return t if OBJECT is a bit vector. | |
| 279 */ | |
| 280 (object)) | |
| 281 { | |
| 282 return BIT_VECTORP (object) ? Qt : Qnil; | |
| 283 } | |
| 284 | |
| 285 DEFUN ("stringp", Fstringp, 1, 1, 0, /* | |
| 286 Return t if OBJECT is a string. | |
| 287 */ | |
| 288 (object)) | |
| 289 { | |
| 290 return STRINGP (object) ? Qt : Qnil; | |
| 291 } | |
| 292 | |
| 293 DEFUN ("arrayp", Farrayp, 1, 1, 0, /* | |
| 294 Return t if OBJECT is an array (string, vector, or bit vector). | |
| 295 */ | |
| 296 (object)) | |
| 297 { | |
| 298 return (VECTORP (object) || | |
| 299 STRINGP (object) || | |
| 300 BIT_VECTORP (object)) | |
| 301 ? Qt : Qnil; | |
| 302 } | |
| 303 | |
| 304 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /* | |
| 305 Return t if OBJECT is a sequence (list or array). | |
| 306 */ | |
| 307 (object)) | |
| 308 { | |
| 309 return (LISTP (object) || | |
| 310 VECTORP (object) || | |
| 311 STRINGP (object) || | |
| 312 BIT_VECTORP (object)) | |
| 313 ? Qt : Qnil; | |
| 314 } | |
| 315 | |
| 316 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /* | |
| 317 Return t if OBJECT is a marker (editor pointer). | |
| 318 */ | |
| 319 (object)) | |
| 320 { | |
| 321 return MARKERP (object) ? Qt : Qnil; | |
| 322 } | |
| 323 | |
| 324 DEFUN ("subrp", Fsubrp, 1, 1, 0, /* | |
| 325 Return t if OBJECT is a built-in function. | |
| 326 */ | |
| 327 (object)) | |
| 328 { | |
| 329 return SUBRP (object) ? Qt : Qnil; | |
| 330 } | |
| 331 | |
| 332 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /* | |
| 333 Return minimum number of args built-in function SUBR may be called with. | |
| 334 */ | |
| 335 (subr)) | |
| 336 { | |
| 337 CHECK_SUBR (subr); | |
| 338 return make_int (XSUBR (subr)->min_args); | |
| 339 } | |
| 340 | |
| 341 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /* | |
| 342 Return maximum number of args built-in function SUBR may be called with, | |
| 343 or nil if it takes an arbitrary number of arguments or is a special form. | |
| 344 */ | |
| 345 (subr)) | |
| 346 { | |
| 347 int nargs; | |
| 348 CHECK_SUBR (subr); | |
| 349 nargs = XSUBR (subr)->max_args; | |
| 350 if (nargs == MANY || nargs == UNEVALLED) | |
| 351 return Qnil; | |
| 352 else | |
| 353 return make_int (nargs); | |
| 354 } | |
| 355 | |
| 356 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /* | |
| 444 | 357 Return the interactive spec of the subr object SUBR, or nil. |
| 428 | 358 If non-nil, the return value will be a list whose first element is |
| 359 `interactive' and whose second element is the interactive spec. | |
| 360 */ | |
| 361 (subr)) | |
| 362 { | |
| 867 | 363 const CIbyte *prompt; |
| 428 | 364 CHECK_SUBR (subr); |
| 365 prompt = XSUBR (subr)->prompt; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
366 return prompt ? list2 (Qinteractive, build_msg_cistring (prompt)) : Qnil; |
| 428 | 367 } |
| 368 | |
| 369 | |
| 370 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /* | |
| 371 Return t if OBJECT is a character. | |
| 372 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type. | |
| 373 Any character can be converted into an equivalent integer using | |
| 374 `char-int'. To convert the other way, use `int-char'; however, | |
| 375 only some integers can be converted into characters. Such an integer | |
| 376 is called a `char-int'; see `char-int-p'. | |
| 377 | |
| 378 Some functions that work on integers (e.g. the comparison functions | |
| 379 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.) | |
| 380 accept characters and implicitly convert them into integers. In | |
| 381 general, functions that work on characters also accept char-ints and | |
| 382 implicitly convert them into characters. WARNING: Neither of these | |
| 383 behaviors is very desirable, and they are maintained for backward | |
| 384 compatibility with old E-Lisp programs that confounded characters and | |
| 385 integers willy-nilly. These behaviors may change in the future; therefore, | |
| 386 do not rely on them. Instead, use the character-specific functions such | |
| 387 as `char='. | |
| 388 */ | |
| 389 (object)) | |
| 390 { | |
| 391 return CHARP (object) ? Qt : Qnil; | |
| 392 } | |
| 393 | |
| 394 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /* | |
| 444 | 395 Convert CHARACTER into an equivalent integer. |
| 428 | 396 The resulting integer will always be non-negative. The integers in |
| 397 the range 0 - 255 map to characters as follows: | |
| 398 | |
| 399 0 - 31 Control set 0 | |
| 400 32 - 127 ASCII | |
| 401 128 - 159 Control set 1 | |
| 402 160 - 255 Right half of ISO-8859-1 | |
| 403 | |
| 404 If support for Mule does not exist, these are the only valid character | |
| 405 values. When Mule support exists, the values assigned to other characters | |
| 406 may vary depending on the particular version of XEmacs, the order in which | |
| 407 character sets were loaded, etc., and you should not depend on them. | |
| 408 */ | |
| 444 | 409 (character)) |
| 428 | 410 { |
| 444 | 411 CHECK_CHAR (character); |
| 412 return make_int (XCHAR (character)); | |
| 428 | 413 } |
| 414 | |
| 415 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /* | |
| 444 | 416 Convert integer INTEGER into the equivalent character. |
| 428 | 417 Not all integers correspond to valid characters; use `char-int-p' to |
| 418 determine whether this is the case. If the integer cannot be converted, | |
| 419 nil is returned. | |
| 420 */ | |
| 421 (integer)) | |
| 422 { | |
| 423 CHECK_INT (integer); | |
| 424 if (CHAR_INTP (integer)) | |
| 425 return make_char (XINT (integer)); | |
| 426 else | |
| 427 return Qnil; | |
| 428 } | |
| 429 | |
| 430 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /* | |
| 431 Return t if OBJECT is an integer that can be converted into a character. | |
| 432 See `char-int'. | |
| 433 */ | |
| 434 (object)) | |
| 435 { | |
| 436 return CHAR_INTP (object) ? Qt : Qnil; | |
| 437 } | |
| 438 | |
| 439 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /* | |
| 440 Return t if OBJECT is a character or an integer that can be converted into one. | |
| 441 */ | |
| 442 (object)) | |
| 443 { | |
| 444 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil; | |
| 445 } | |
| 446 | |
| 447 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /* | |
| 448 Return t if OBJECT is a character (or a char-int) or a string. | |
| 449 It is semi-hateful that we allow a char-int here, as it goes against | |
| 450 the name of this function, but it makes the most sense considering the | |
| 451 other steps we take to maintain compatibility with the old character/integer | |
| 452 confoundedness in older versions of E-Lisp. | |
| 453 */ | |
| 454 (object)) | |
| 455 { | |
| 456 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil; | |
| 457 } | |
| 458 | |
| 1983 | 459 #ifdef HAVE_BIGNUM |
| 460 /* In this case, integerp is defined in number.c. */ | |
| 461 DEFUN ("fixnump", Ffixnump, 1, 1, 0, /* | |
| 462 Return t if OBJECT is a fixnum. | |
| 463 */ | |
| 464 (object)) | |
| 465 { | |
| 466 return INTP (object) ? Qt : Qnil; | |
| 467 } | |
| 468 #else | |
| 428 | 469 DEFUN ("integerp", Fintegerp, 1, 1, 0, /* |
| 470 Return t if OBJECT is an integer. | |
| 471 */ | |
| 472 (object)) | |
| 473 { | |
| 474 return INTP (object) ? Qt : Qnil; | |
| 475 } | |
| 1983 | 476 #endif |
| 428 | 477 |
| 478 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /* | |
| 479 Return t if OBJECT is an integer or a marker (editor pointer). | |
| 480 */ | |
| 481 (object)) | |
| 482 { | |
| 483 return INTP (object) || MARKERP (object) ? Qt : Qnil; | |
| 484 } | |
| 485 | |
| 486 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /* | |
| 487 Return t if OBJECT is an integer or a character. | |
| 488 */ | |
| 489 (object)) | |
| 490 { | |
| 491 return INTP (object) || CHARP (object) ? Qt : Qnil; | |
| 492 } | |
| 493 | |
| 494 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /* | |
| 495 Return t if OBJECT is an integer, character or a marker (editor pointer). | |
| 496 */ | |
| 497 (object)) | |
| 498 { | |
| 499 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil; | |
| 500 } | |
| 501 | |
| 502 DEFUN ("natnump", Fnatnump, 1, 1, 0, /* | |
| 503 Return t if OBJECT is a nonnegative integer. | |
| 504 */ | |
| 505 (object)) | |
| 506 { | |
| 1983 | 507 return NATNUMP (object) |
| 508 #ifdef HAVE_BIGNUM | |
| 509 || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0) | |
| 510 #endif | |
| 511 ? Qt : Qnil; | |
| 512 } | |
| 513 | |
| 514 DEFUN ("nonnegativep", Fnonnegativep, 1, 1, 0, /* | |
| 515 Return t if OBJECT is a nonnegative number. | |
| 516 */ | |
| 517 (object)) | |
| 518 { | |
| 519 return NATNUMP (object) | |
| 520 #ifdef HAVE_BIGNUM | |
| 521 || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0) | |
| 522 #endif | |
| 523 #ifdef HAVE_RATIO | |
| 524 || (RATIOP (object) && ratio_sign (XRATIO_DATA (object)) >= 0) | |
| 525 #endif | |
| 526 #ifdef HAVE_BIGFLOAT | |
| 527 || (BIGFLOATP (object) && bigfloat_sign (XBIGFLOAT_DATA (object)) >= 0) | |
| 528 #endif | |
| 529 ? Qt : Qnil; | |
| 428 | 530 } |
| 531 | |
| 532 DEFUN ("bitp", Fbitp, 1, 1, 0, /* | |
| 533 Return t if OBJECT is a bit (0 or 1). | |
| 534 */ | |
| 535 (object)) | |
| 536 { | |
| 537 return BITP (object) ? Qt : Qnil; | |
| 538 } | |
| 539 | |
| 540 DEFUN ("numberp", Fnumberp, 1, 1, 0, /* | |
| 541 Return t if OBJECT is a number (floating point or integer). | |
| 542 */ | |
| 543 (object)) | |
| 544 { | |
| 1983 | 545 #ifdef WITH_NUMBER_TYPES |
| 546 return NUMBERP (object) ? Qt : Qnil; | |
| 547 #else | |
| 428 | 548 return INT_OR_FLOATP (object) ? Qt : Qnil; |
| 1983 | 549 #endif |
| 428 | 550 } |
| 551 | |
| 552 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /* | |
| 553 Return t if OBJECT is a number or a marker. | |
| 554 */ | |
| 555 (object)) | |
| 556 { | |
| 557 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil; | |
| 558 } | |
| 559 | |
| 560 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /* | |
| 561 Return t if OBJECT is a number, character or a marker. | |
| 562 */ | |
| 563 (object)) | |
| 564 { | |
| 565 return (INT_OR_FLOATP (object) || | |
| 566 CHARP (object) || | |
| 567 MARKERP (object)) | |
| 568 ? Qt : Qnil; | |
| 569 } | |
| 570 | |
| 571 DEFUN ("floatp", Ffloatp, 1, 1, 0, /* | |
| 572 Return t if OBJECT is a floating point number. | |
| 573 */ | |
| 574 (object)) | |
| 575 { | |
| 576 return FLOATP (object) ? Qt : Qnil; | |
| 577 } | |
| 578 | |
| 579 DEFUN ("type-of", Ftype_of, 1, 1, 0, /* | |
| 580 Return a symbol representing the type of OBJECT. | |
| 581 */ | |
| 582 (object)) | |
| 583 { | |
| 584 switch (XTYPE (object)) | |
| 585 { | |
| 586 case Lisp_Type_Record: | |
| 587 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name); | |
| 588 | |
| 589 case Lisp_Type_Char: return Qcharacter; | |
| 590 | |
| 591 default: return Qinteger; | |
| 592 } | |
| 593 } | |
| 594 | |
| 595 | |
| 596 /* Extract and set components of lists */ | |
| 597 | |
| 598 DEFUN ("car", Fcar, 1, 1, 0, /* | |
| 3343 | 599 Return the car of CONS. If CONS is nil, return nil. |
| 600 The car of a list or a dotted pair is its first element. | |
| 601 | |
| 602 Error if CONS is not nil and not a cons cell. See also `car-safe'. | |
| 428 | 603 */ |
| 3343 | 604 (cons)) |
| 428 | 605 { |
| 606 while (1) | |
| 607 { | |
| 3343 | 608 if (CONSP (cons)) |
| 609 return XCAR (cons); | |
| 610 else if (NILP (cons)) | |
| 428 | 611 return Qnil; |
| 612 else | |
| 3343 | 613 cons = wrong_type_argument (Qlistp, cons); |
| 428 | 614 } |
| 615 } | |
| 616 | |
| 617 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /* | |
| 618 Return the car of OBJECT if it is a cons cell, or else nil. | |
| 619 */ | |
| 620 (object)) | |
| 621 { | |
| 622 return CONSP (object) ? XCAR (object) : Qnil; | |
| 623 } | |
| 624 | |
| 625 DEFUN ("cdr", Fcdr, 1, 1, 0, /* | |
| 3343 | 626 Return the cdr of CONS. If CONS is nil, return nil. |
| 627 The cdr of a list is the list without its first element. The cdr of a | |
| 628 dotted pair (A . B) is the second element, B. | |
| 629 | |
| 428 | 630 Error if arg is not nil and not a cons cell. See also `cdr-safe'. |
| 631 */ | |
| 3343 | 632 (cons)) |
| 428 | 633 { |
| 634 while (1) | |
| 635 { | |
| 3343 | 636 if (CONSP (cons)) |
| 637 return XCDR (cons); | |
| 638 else if (NILP (cons)) | |
| 428 | 639 return Qnil; |
| 640 else | |
| 3343 | 641 cons = wrong_type_argument (Qlistp, cons); |
| 428 | 642 } |
| 643 } | |
| 644 | |
| 645 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /* | |
| 646 Return the cdr of OBJECT if it is a cons cell, else nil. | |
| 647 */ | |
| 648 (object)) | |
| 649 { | |
| 650 return CONSP (object) ? XCDR (object) : Qnil; | |
| 651 } | |
| 652 | |
| 653 DEFUN ("setcar", Fsetcar, 2, 2, 0, /* | |
| 444 | 654 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR. |
| 3343 | 655 The car of a list or a dotted pair is its first element. |
| 428 | 656 */ |
| 444 | 657 (cons_cell, newcar)) |
| 428 | 658 { |
| 444 | 659 if (!CONSP (cons_cell)) |
| 660 cons_cell = wrong_type_argument (Qconsp, cons_cell); | |
| 428 | 661 |
| 444 | 662 XCAR (cons_cell) = newcar; |
| 428 | 663 return newcar; |
| 664 } | |
| 665 | |
| 666 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /* | |
| 444 | 667 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR. |
| 3343 | 668 The cdr of a list is the list without its first element. The cdr of a |
| 669 dotted pair (A . B) is the second element, B. | |
| 428 | 670 */ |
| 444 | 671 (cons_cell, newcdr)) |
| 428 | 672 { |
| 444 | 673 if (!CONSP (cons_cell)) |
| 674 cons_cell = wrong_type_argument (Qconsp, cons_cell); | |
| 428 | 675 |
| 444 | 676 XCDR (cons_cell) = newcdr; |
| 428 | 677 return newcdr; |
| 678 } | |
| 679 | |
| 680 /* Find the function at the end of a chain of symbol function indirections. | |
| 681 | |
| 682 If OBJECT is a symbol, find the end of its function chain and | |
| 683 return the value found there. If OBJECT is not a symbol, just | |
| 684 return it. If there is a cycle in the function chain, signal a | |
| 685 cyclic-function-indirection error. | |
| 686 | |
| 442 | 687 This is like Findirect_function when VOID_FUNCTION_ERRORP is true. |
| 688 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end | |
| 689 of the chain ends up being Qunbound. */ | |
| 428 | 690 Lisp_Object |
| 442 | 691 indirect_function (Lisp_Object object, int void_function_errorp) |
| 428 | 692 { |
| 693 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16 | |
| 694 Lisp_Object tortoise, hare; | |
| 695 int count; | |
| 696 | |
| 697 for (hare = tortoise = object, count = 0; | |
| 698 SYMBOLP (hare); | |
| 699 hare = XSYMBOL (hare)->function, count++) | |
| 700 { | |
| 701 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue; | |
| 702 | |
| 703 if (count & 1) | |
| 704 tortoise = XSYMBOL (tortoise)->function; | |
| 705 if (EQ (hare, tortoise)) | |
| 706 return Fsignal (Qcyclic_function_indirection, list1 (object)); | |
| 707 } | |
| 708 | |
| 442 | 709 if (void_function_errorp && UNBOUNDP (hare)) |
| 436 | 710 return signal_void_function_error (object); |
| 428 | 711 |
| 712 return hare; | |
| 713 } | |
| 714 | |
| 715 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /* | |
| 716 Return the function at the end of OBJECT's function chain. | |
| 717 If OBJECT is a symbol, follow all function indirections and return | |
| 718 the final function binding. | |
| 719 If OBJECT is not a symbol, just return it. | |
| 720 Signal a void-function error if the final symbol is unbound. | |
| 721 Signal a cyclic-function-indirection error if there is a loop in the | |
| 722 function chain of symbols. | |
| 723 */ | |
| 724 (object)) | |
| 725 { | |
| 726 return indirect_function (object, 1); | |
| 727 } | |
| 728 | |
| 729 /* Extract and set vector and string elements */ | |
| 730 | |
| 731 DEFUN ("aref", Faref, 2, 2, 0, /* | |
| 732 Return the element of ARRAY at index INDEX. | |
| 733 ARRAY may be a vector, bit vector, or string. INDEX starts at 0. | |
| 734 */ | |
| 735 (array, index_)) | |
| 736 { | |
| 737 EMACS_INT idx; | |
| 738 | |
| 739 retry: | |
| 740 | |
| 741 if (INTP (index_)) idx = XINT (index_); | |
| 742 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ | |
| 743 else | |
| 744 { | |
| 745 index_ = wrong_type_argument (Qinteger_or_char_p, index_); | |
| 746 goto retry; | |
| 747 } | |
| 748 | |
| 749 if (idx < 0) goto range_error; | |
| 750 | |
| 751 if (VECTORP (array)) | |
| 752 { | |
| 753 if (idx >= XVECTOR_LENGTH (array)) goto range_error; | |
| 754 return XVECTOR_DATA (array)[idx]; | |
| 755 } | |
| 756 else if (BIT_VECTORP (array)) | |
| 757 { | |
| 647 | 758 if (idx >= (EMACS_INT) bit_vector_length (XBIT_VECTOR (array))) |
| 759 goto range_error; | |
| 428 | 760 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx)); |
| 761 } | |
| 762 else if (STRINGP (array)) | |
| 763 { | |
| 826 | 764 if (idx >= string_char_length (array)) goto range_error; |
| 867 | 765 return make_char (string_ichar (array, idx)); |
| 428 | 766 } |
| 767 #ifdef LOSING_BYTECODE | |
| 768 else if (COMPILED_FUNCTIONP (array)) | |
| 769 { | |
| 770 /* Weird, gross compatibility kludge */ | |
| 771 return Felt (array, index_); | |
| 772 } | |
| 773 #endif | |
| 774 else | |
| 775 { | |
| 776 check_losing_bytecode ("aref", array); | |
| 777 array = wrong_type_argument (Qarrayp, array); | |
| 778 goto retry; | |
| 779 } | |
| 780 | |
| 781 range_error: | |
| 782 args_out_of_range (array, index_); | |
| 1204 | 783 RETURN_NOT_REACHED (Qnil); |
| 428 | 784 } |
| 785 | |
| 786 DEFUN ("aset", Faset, 3, 3, 0, /* | |
| 787 Store into the element of ARRAY at index INDEX the value NEWVAL. | |
| 788 ARRAY may be a vector, bit vector, or string. INDEX starts at 0. | |
| 789 */ | |
| 790 (array, index_, newval)) | |
| 791 { | |
| 792 EMACS_INT idx; | |
| 793 | |
| 794 retry: | |
| 795 | |
| 796 if (INTP (index_)) idx = XINT (index_); | |
| 797 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ | |
| 798 else | |
| 799 { | |
| 800 index_ = wrong_type_argument (Qinteger_or_char_p, index_); | |
| 801 goto retry; | |
| 802 } | |
| 803 | |
| 804 if (idx < 0) goto range_error; | |
| 805 | |
| 771 | 806 CHECK_LISP_WRITEABLE (array); |
| 428 | 807 if (VECTORP (array)) |
| 808 { | |
| 809 if (idx >= XVECTOR_LENGTH (array)) goto range_error; | |
| 810 XVECTOR_DATA (array)[idx] = newval; | |
| 811 } | |
| 812 else if (BIT_VECTORP (array)) | |
| 813 { | |
| 647 | 814 if (idx >= (EMACS_INT) bit_vector_length (XBIT_VECTOR (array))) |
| 815 goto range_error; | |
| 428 | 816 CHECK_BIT (newval); |
| 817 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval)); | |
| 818 } | |
| 819 else if (STRINGP (array)) | |
| 820 { | |
| 821 CHECK_CHAR_COERCE_INT (newval); | |
| 826 | 822 if (idx >= string_char_length (array)) goto range_error; |
| 793 | 823 set_string_char (array, idx, XCHAR (newval)); |
| 428 | 824 bump_string_modiff (array); |
| 825 } | |
| 826 else | |
| 827 { | |
| 828 array = wrong_type_argument (Qarrayp, array); | |
| 829 goto retry; | |
| 830 } | |
| 831 | |
| 832 return newval; | |
| 833 | |
| 834 range_error: | |
| 835 args_out_of_range (array, index_); | |
| 1204 | 836 RETURN_NOT_REACHED (Qnil); |
| 428 | 837 } |
| 838 | |
| 839 | |
| 840 /**********************************************************************/ | |
| 841 /* Arithmetic functions */ | |
| 842 /**********************************************************************/ | |
| 2001 | 843 #ifndef WITH_NUMBER_TYPES |
| 428 | 844 typedef struct |
| 845 { | |
| 846 int int_p; | |
| 847 union | |
| 848 { | |
| 849 EMACS_INT ival; | |
| 850 double dval; | |
| 851 } c; | |
| 852 } int_or_double; | |
| 853 | |
| 854 static void | |
| 855 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p) | |
| 856 { | |
| 857 retry: | |
| 858 p->int_p = 1; | |
| 859 if (INTP (obj)) p->c.ival = XINT (obj); | |
| 860 else if (CHARP (obj)) p->c.ival = XCHAR (obj); | |
| 861 else if (MARKERP (obj)) p->c.ival = marker_position (obj); | |
| 862 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0; | |
| 863 else | |
| 864 { | |
| 865 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); | |
| 866 goto retry; | |
| 867 } | |
| 868 } | |
| 869 | |
| 870 static double | |
| 871 number_char_or_marker_to_double (Lisp_Object obj) | |
| 872 { | |
| 873 retry: | |
| 874 if (INTP (obj)) return (double) XINT (obj); | |
| 875 else if (CHARP (obj)) return (double) XCHAR (obj); | |
| 876 else if (MARKERP (obj)) return (double) marker_position (obj); | |
| 877 else if (FLOATP (obj)) return XFLOAT_DATA (obj); | |
| 878 else | |
| 879 { | |
| 880 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); | |
| 881 goto retry; | |
| 882 } | |
| 883 } | |
| 2001 | 884 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 885 |
| 886 static EMACS_INT | |
| 887 integer_char_or_marker_to_int (Lisp_Object obj) | |
| 888 { | |
| 889 retry: | |
| 890 if (INTP (obj)) return XINT (obj); | |
| 891 else if (CHARP (obj)) return XCHAR (obj); | |
| 892 else if (MARKERP (obj)) return marker_position (obj); | |
| 893 else | |
| 894 { | |
| 895 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj); | |
| 896 goto retry; | |
| 897 } | |
| 898 } | |
| 899 | |
| 1983 | 900 #ifdef WITH_NUMBER_TYPES |
| 901 | |
| 902 #ifdef HAVE_BIGNUM | |
| 903 #define BIGNUM_CASE(op) \ | |
| 904 case BIGNUM_T: \ | |
| 905 if (!bignum_##op (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))) \ | |
| 906 return Qnil; \ | |
| 907 break; | |
| 908 #else | |
| 909 #define BIGNUM_CASE(op) | |
| 910 #endif /* HAVE_BIGNUM */ | |
| 911 | |
| 912 #ifdef HAVE_RATIO | |
| 913 #define RATIO_CASE(op) \ | |
| 914 case RATIO_T: \ | |
| 915 if (!ratio_##op (XRATIO_DATA (obj1), XRATIO_DATA (obj2))) \ | |
| 916 return Qnil; \ | |
| 917 break; | |
| 918 #else | |
| 919 #define RATIO_CASE(op) | |
| 920 #endif /* HAVE_RATIO */ | |
| 921 | |
| 922 #ifdef HAVE_BIGFLOAT | |
| 923 #define BIGFLOAT_CASE(op) \ | |
| 924 case BIGFLOAT_T: \ | |
| 925 if (!bigfloat_##op (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))) \ | |
| 926 return Qnil; \ | |
| 927 break; | |
| 928 #else | |
| 929 #define BIGFLOAT_CASE(op) | |
| 930 #endif /* HAVE_BIGFLOAT */ | |
| 931 | |
| 932 #define ARITHCOMPARE_MANY(c_op,op) \ | |
| 933 { \ | |
| 934 REGISTER int i; \ | |
| 935 Lisp_Object obj1, obj2; \ | |
| 936 \ | |
| 937 for (i = 1; i < nargs; i++) \ | |
| 938 { \ | |
| 939 obj1 = args[i - 1]; \ | |
| 940 obj2 = args[i]; \ | |
| 941 switch (promote_args (&obj1, &obj2)) \ | |
| 942 { \ | |
| 943 case FIXNUM_T: \ | |
| 944 if (!(XREALINT (obj1) c_op XREALINT (obj2))) \ | |
| 945 return Qnil; \ | |
| 946 break; \ | |
| 947 BIGNUM_CASE (op) \ | |
| 948 RATIO_CASE (op) \ | |
| 949 case FLOAT_T: \ | |
| 950 if (!(XFLOAT_DATA (obj1) c_op XFLOAT_DATA (obj2))) \ | |
| 951 return Qnil; \ | |
| 952 break; \ | |
| 953 BIGFLOAT_CASE (op) \ | |
| 954 } \ | |
| 955 } \ | |
| 956 return Qt; \ | |
| 957 } | |
| 958 #else /* !WITH_NUMBER_TYPES */ | |
| 959 #define ARITHCOMPARE_MANY(c_op,op) \ | |
| 428 | 960 { \ |
| 961 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \ | |
| 962 Lisp_Object *args_end = args + nargs; \ | |
| 963 \ | |
| 964 number_char_or_marker_to_int_or_double (*args++, p); \ | |
| 965 \ | |
| 966 while (args < args_end) \ | |
| 967 { \ | |
| 968 number_char_or_marker_to_int_or_double (*args++, q); \ | |
| 969 \ | |
| 970 if (!((p->int_p && q->int_p) ? \ | |
| 1983 | 971 (p->c.ival c_op q->c.ival) : \ |
| 972 ((p->int_p ? (double) p->c.ival : p->c.dval) c_op \ | |
| 428 | 973 (q->int_p ? (double) q->c.ival : q->c.dval)))) \ |
| 974 return Qnil; \ | |
| 975 \ | |
| 976 { /* swap */ int_or_double *r = p; p = q; q = r; } \ | |
| 977 } \ | |
| 978 return Qt; \ | |
| 979 } | |
| 1983 | 980 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 981 |
| 982 DEFUN ("=", Feqlsign, 1, MANY, 0, /* | |
| 983 Return t if all the arguments are numerically equal. | |
| 984 The arguments may be numbers, characters or markers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
985 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
986 arguments: (FIRST &rest ARGS) |
| 428 | 987 */ |
| 988 (int nargs, Lisp_Object *args)) | |
| 989 { | |
| 1983 | 990 ARITHCOMPARE_MANY (==, eql) |
| 428 | 991 } |
| 992 | |
| 993 DEFUN ("<", Flss, 1, MANY, 0, /* | |
| 994 Return t if the sequence of arguments is monotonically increasing. | |
| 3343 | 995 |
| 996 (That is, if there is a second argument, it must be numerically greater than | |
| 997 the first. If there is a third, it must be numerically greater than the | |
| 998 second, and so on.) At least one argument is required. | |
| 999 | |
| 1000 The arguments may be numbers, characters or markers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1001 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1002 arguments: (FIRST &rest ARGS) |
| 428 | 1003 */ |
| 1004 (int nargs, Lisp_Object *args)) | |
| 1005 { | |
| 1983 | 1006 ARITHCOMPARE_MANY (<, lt) |
| 428 | 1007 } |
| 1008 | |
| 1009 DEFUN (">", Fgtr, 1, MANY, 0, /* | |
| 1010 Return t if the sequence of arguments is monotonically decreasing. | |
| 3343 | 1011 |
| 1012 (That is, if there is a second argument, it must be numerically less than | |
| 1013 the first. If there is a third, it must be numerically less than the | |
| 1014 second, and so forth.) At least one argument is required. | |
| 1015 | |
| 428 | 1016 The arguments may be numbers, characters or markers. |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1017 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1018 arguments: (FIRST &rest ARGS) |
| 428 | 1019 */ |
| 1020 (int nargs, Lisp_Object *args)) | |
| 1021 { | |
| 1983 | 1022 ARITHCOMPARE_MANY (>, gt) |
| 428 | 1023 } |
| 1024 | |
| 1025 DEFUN ("<=", Fleq, 1, MANY, 0, /* | |
| 1026 Return t if the sequence of arguments is monotonically nondecreasing. | |
| 1027 The arguments may be numbers, characters or markers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1028 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1029 arguments: (FIRST &rest ARGS) |
| 428 | 1030 */ |
| 1031 (int nargs, Lisp_Object *args)) | |
| 1032 { | |
| 1983 | 1033 ARITHCOMPARE_MANY (<=, le) |
| 428 | 1034 } |
| 1035 | |
| 1036 DEFUN (">=", Fgeq, 1, MANY, 0, /* | |
| 1037 Return t if the sequence of arguments is monotonically nonincreasing. | |
| 1038 The arguments may be numbers, characters or markers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1039 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1040 arguments: (FIRST &rest ARGS) |
| 428 | 1041 */ |
| 1042 (int nargs, Lisp_Object *args)) | |
| 1043 { | |
| 1983 | 1044 ARITHCOMPARE_MANY (>=, ge) |
| 428 | 1045 } |
| 1046 | |
| 1983 | 1047 /* Unlike all the other comparisons, this is an O(N*N) algorithm. But who |
| 1048 cares? Inspection of all elisp code distributed by xemacs.org shows that | |
| 1049 it is almost always called with 2 arguments, rarely with 3, and never with | |
| 1050 more than 3. The constant factors of algorithms with better asymptotic | |
| 1051 complexity are higher, which means that those algorithms will run SLOWER | |
| 1052 than this one in the common case. Optimize the common case! */ | |
| 428 | 1053 DEFUN ("/=", Fneq, 1, MANY, 0, /* |
| 1054 Return t if no two arguments are numerically equal. | |
| 1055 The arguments may be numbers, characters or markers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1056 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1057 arguments: (FIRST &rest ARGS) |
| 428 | 1058 */ |
| 1059 (int nargs, Lisp_Object *args)) | |
| 1060 { | |
| 1983 | 1061 #ifdef WITH_NUMBER_TYPES |
| 1062 REGISTER int i, j; | |
| 1063 Lisp_Object obj1, obj2; | |
| 1064 | |
| 1065 for (i = 0; i < nargs - 1; i++) | |
| 1066 { | |
| 1067 obj1 = args[i]; | |
| 1068 for (j = i + 1; j < nargs; j++) | |
| 1069 { | |
| 1070 obj2 = args[j]; | |
| 1071 switch (promote_args (&obj1, &obj2)) | |
| 1072 { | |
| 1073 case FIXNUM_T: | |
| 1074 if (XREALINT (obj1) == XREALINT (obj2)) | |
| 1075 return Qnil; | |
| 1076 break; | |
| 1077 #ifdef HAVE_BIGNUM | |
| 1078 case BIGNUM_T: | |
| 1079 if (bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))) | |
| 1080 return Qnil; | |
| 1081 break; | |
| 1082 #endif | |
| 1083 #ifdef HAVE_RATIO | |
| 1084 case RATIO_T: | |
| 1085 if (ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2))) | |
| 1086 return Qnil; | |
| 1087 break; | |
| 1088 #endif | |
| 1089 case FLOAT_T: | |
| 1090 if (XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2)) | |
| 1091 return Qnil; | |
| 1092 break; | |
| 1093 #ifdef HAVE_BIGFLOAT | |
| 1094 case BIGFLOAT_T: | |
| 1095 if (bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))) | |
| 1096 return Qnil; | |
| 1097 break; | |
| 1098 #endif | |
| 1099 } | |
| 1100 } | |
| 1101 } | |
| 1102 return Qt; | |
| 1103 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1104 Lisp_Object *args_end = args + nargs; |
| 1105 Lisp_Object *p, *q; | |
| 1106 | |
| 1107 /* Unlike all the other comparisons, this is an N*N algorithm. | |
| 1108 We could use a hash table for nargs > 50 to make this linear. */ | |
| 1109 for (p = args; p < args_end; p++) | |
| 1110 { | |
| 1111 int_or_double iod1, iod2; | |
| 1112 number_char_or_marker_to_int_or_double (*p, &iod1); | |
| 1113 | |
| 1114 for (q = p + 1; q < args_end; q++) | |
| 1115 { | |
| 1116 number_char_or_marker_to_int_or_double (*q, &iod2); | |
| 1117 | |
| 1118 if (!((iod1.int_p && iod2.int_p) ? | |
| 1119 (iod1.c.ival != iod2.c.ival) : | |
| 1120 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) != | |
| 1121 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval)))) | |
| 1122 return Qnil; | |
| 1123 } | |
| 1124 } | |
| 1125 return Qt; | |
| 1983 | 1126 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1127 } |
| 1128 | |
| 1129 DEFUN ("zerop", Fzerop, 1, 1, 0, /* | |
| 1130 Return t if NUMBER is zero. | |
| 1131 */ | |
| 1132 (number)) | |
| 1133 { | |
| 1134 retry: | |
| 1135 if (INTP (number)) | |
| 1136 return EQ (number, Qzero) ? Qt : Qnil; | |
| 1983 | 1137 #ifdef HAVE_BIGNUM |
| 1138 else if (BIGNUMP (number)) | |
| 1139 return bignum_sign (XBIGNUM_DATA (number)) == 0 ? Qt : Qnil; | |
| 1140 #endif | |
| 1141 #ifdef HAVE_RATIO | |
| 1142 else if (RATIOP (number)) | |
| 1143 return ratio_sign (XRATIO_DATA (number)) == 0 ? Qt : Qnil; | |
| 1144 #endif | |
| 428 | 1145 else if (FLOATP (number)) |
| 1146 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil; | |
| 1983 | 1147 #ifdef HAVE_BIGFLOAT |
| 1148 else if (BIGFLOATP (number)) | |
| 1149 return bigfloat_sign (XBIGFLOAT_DATA (number)) == 0 ? Qt : Qnil; | |
| 1150 #endif | |
| 428 | 1151 else |
| 1152 { | |
| 1153 number = wrong_type_argument (Qnumberp, number); | |
| 1154 goto retry; | |
| 1155 } | |
| 1156 } | |
| 1157 | |
| 1158 /* Convert between a 32-bit value and a cons of two 16-bit values. | |
| 1159 This is used to pass 32-bit integers to and from the user. | |
| 1160 Use time_to_lisp() and lisp_to_time() for time values. | |
| 1161 | |
| 1162 If you're thinking of using this to store a pointer into a Lisp Object | |
| 1163 for internal purposes (such as when calling record_unwind_protect()), | |
| 1164 try using make_opaque_ptr()/get_opaque_ptr() instead. */ | |
| 1165 Lisp_Object | |
| 1166 word_to_lisp (unsigned int item) | |
| 1167 { | |
| 1168 return Fcons (make_int (item >> 16), make_int (item & 0xffff)); | |
| 1169 } | |
| 1170 | |
| 1171 unsigned int | |
| 1172 lisp_to_word (Lisp_Object item) | |
| 1173 { | |
| 1174 if (INTP (item)) | |
| 1175 return XINT (item); | |
| 1176 else | |
| 1177 { | |
| 1178 Lisp_Object top = Fcar (item); | |
| 1179 Lisp_Object bot = Fcdr (item); | |
| 1180 CHECK_INT (top); | |
| 1181 CHECK_INT (bot); | |
| 1182 return (XINT (top) << 16) | (XINT (bot) & 0xffff); | |
| 1183 } | |
| 1184 } | |
| 1185 | |
| 1186 | |
| 1187 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /* | |
| 444 | 1188 Convert NUMBER to a string by printing it in decimal. |
| 428 | 1189 Uses a minus sign if negative. |
| 444 | 1190 NUMBER may be an integer or a floating point number. |
| 1983 | 1191 If supported, it may also be a ratio. |
| 428 | 1192 */ |
| 444 | 1193 (number)) |
| 428 | 1194 { |
| 1983 | 1195 #ifdef WITH_NUMBER_TYPES |
| 1196 CHECK_NUMBER (number); | |
| 1197 #else | |
| 444 | 1198 CHECK_INT_OR_FLOAT (number); |
| 1983 | 1199 #endif |
| 428 | 1200 |
| 444 | 1201 if (FLOATP (number)) |
| 428 | 1202 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1203 Ascbyte pigbuf[350]; /* see comments in float_to_string */ |
| 428 | 1204 |
| 444 | 1205 float_to_string (pigbuf, XFLOAT_DATA (number)); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1206 return build_ascstring (pigbuf); |
| 428 | 1207 } |
| 1983 | 1208 #ifdef HAVE_BIGNUM |
| 1209 if (BIGNUMP (number)) | |
| 1210 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1211 Ascbyte *str = bignum_to_string (XBIGNUM_DATA (number), 10); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1212 Lisp_Object retval = build_ascstring (str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1213 xfree (str, Ascbyte *); |
| 1983 | 1214 return retval; |
| 1215 } | |
| 1216 #endif | |
| 1217 #ifdef HAVE_RATIO | |
| 1218 if (RATIOP (number)) | |
| 1219 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1220 Ascbyte *str = ratio_to_string (XRATIO_DATA (number), 10); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1221 Lisp_Object retval = build_ascstring (str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1222 xfree (str, Ascbyte *); |
| 1983 | 1223 return retval; |
| 1224 } | |
| 1225 #endif | |
| 1226 #ifdef HAVE_BIGFLOAT | |
| 1227 if (BIGFLOATP (number)) | |
| 1228 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1229 Ascbyte *str = bigfloat_to_string (XBIGFLOAT_DATA (number), 10); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1230 Lisp_Object retval = build_ascstring (str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1231 xfree (str, Ascbyte *); |
| 1983 | 1232 return retval; |
| 1233 } | |
| 1234 #endif | |
| 428 | 1235 |
| 603 | 1236 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1237 Ascbyte buffer[DECIMAL_PRINT_SIZE (long)]; |
| 603 | 1238 |
| 1239 long_to_string (buffer, XINT (number)); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1240 return build_ascstring (buffer); |
| 603 | 1241 } |
| 428 | 1242 } |
| 1243 | |
| 2001 | 1244 #ifndef HAVE_BIGNUM |
| 428 | 1245 static int |
| 1246 digit_to_number (int character, int base) | |
| 1247 { | |
| 1248 /* Assumes ASCII */ | |
| 1249 int digit = ((character >= '0' && character <= '9') ? character - '0' : | |
| 1250 (character >= 'a' && character <= 'z') ? character - 'a' + 10 : | |
| 1251 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 : | |
| 1252 -1); | |
| 1253 | |
| 1254 return digit >= base ? -1 : digit; | |
| 1255 } | |
| 2001 | 1256 #endif |
| 428 | 1257 |
| 1258 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /* | |
| 444 | 1259 Convert STRING to a number by parsing it as a number in base BASE. |
| 428 | 1260 This parses both integers and floating point numbers. |
| 1983 | 1261 If they are supported, it also reads ratios. |
| 428 | 1262 It ignores leading spaces and tabs. |
| 1263 | |
| 444 | 1264 If BASE is nil or omitted, base 10 is used. |
| 1265 BASE must be an integer between 2 and 16 (inclusive). | |
| 428 | 1266 Floating point numbers always use base 10. |
| 1267 */ | |
| 1268 (string, base)) | |
| 1269 { | |
| 1995 | 1270 Ibyte *p; |
| 428 | 1271 int b; |
| 1272 | |
| 1273 CHECK_STRING (string); | |
| 1274 | |
| 1275 if (NILP (base)) | |
| 1276 b = 10; | |
| 1277 else | |
| 1278 { | |
| 1279 CHECK_INT (base); | |
| 1280 b = XINT (base); | |
| 1281 check_int_range (b, 2, 16); | |
| 1282 } | |
| 1283 | |
| 1995 | 1284 p = XSTRING_DATA (string); |
| 428 | 1285 |
| 1286 /* Skip any whitespace at the front of the number. Some versions of | |
| 1287 atoi do this anyway, so we might as well make Emacs lisp consistent. */ | |
| 1288 while (*p == ' ' || *p == '\t') | |
| 1289 p++; | |
| 1290 | |
| 1995 | 1291 if (isfloat_string ((const char *) p) && b == 10) |
| 1983 | 1292 { |
| 1293 #ifdef HAVE_BIGFLOAT | |
| 1294 if (ZEROP (Vdefault_float_precision)) | |
| 1295 #endif | |
| 1995 | 1296 return make_float (atof ((const char *) p)); |
| 1983 | 1297 #ifdef HAVE_BIGFLOAT |
| 1298 else | |
| 1299 { | |
| 2013 | 1300 /* The GMP version of bigfloat_set_string (mpf_set_str) has the |
| 1301 following limitation: if p starts with a '+' sign, it does | |
| 1302 nothing; i.e., it leaves its bigfloat argument untouched. | |
| 1303 Therefore, move p past any leading '+' signs. */ | |
| 2010 | 1304 if (*p == '+') |
| 1305 p++; | |
| 1983 | 1306 bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ()); |
| 1995 | 1307 bigfloat_set_string (scratch_bigfloat, (const char *) p, b); |
| 1983 | 1308 return make_bigfloat_bf (scratch_bigfloat); |
| 1309 } | |
| 1310 #endif | |
| 1311 } | |
| 1312 | |
| 1313 #ifdef HAVE_RATIO | |
| 1314 if (qxestrchr (p, '/') != NULL) | |
| 1315 { | |
| 2013 | 1316 /* The GMP version of ratio_set_string (mpq_set_str) has the following |
| 1317 limitations: | |
| 1318 - If p starts with a '+' sign, it does nothing; i.e., it leaves its | |
| 1319 ratio argument untouched. | |
| 1320 - If p has a '+' sign after the '/' (e.g., 300/+400), it sets the | |
| 1321 numerator from the string, but *leaves the denominator unchanged*. | |
| 1322 - If p has trailing nonnumeric characters, it sets the numerator from | |
| 1323 the string, but leaves the denominator unchanged. | |
| 1324 - If p has more than one '/', (e.g., 1/2/3), then it sets the | |
| 1325 numerator from the string, but leaves the denominator unchanged. | |
| 1326 | |
| 1327 Therefore, move p past any leading '+' signs, temporarily drop a null | |
| 1328 after the numeric characters we are trying to convert, and then put | |
| 1329 the nulled character back afterward. I am not going to fix problem | |
| 1330 #2; just don't write ratios that look like that. */ | |
| 1331 Ibyte *end, save; | |
| 1332 | |
| 2010 | 1333 if (*p == '+') |
| 1334 p++; | |
| 2013 | 1335 |
| 2014 | 1336 end = p; |
| 1337 if (*end == '-') | |
| 1338 end++; | |
| 1339 while ((*end >= '0' && *end <= '9') || | |
| 2013 | 1340 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) || |
| 2014 | 1341 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11)) |
| 1342 end++; | |
| 2013 | 1343 if (*end == '/') |
| 2014 | 1344 { |
| 1345 end++; | |
| 1346 if (*end == '-') | |
| 1347 end++; | |
| 1348 while ((*end >= '0' && *end <= '9') || | |
| 1349 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) || | |
| 1350 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11)) | |
| 1351 end++; | |
| 1352 } | |
| 2013 | 1353 save = *end; |
| 1354 *end = '\0'; | |
| 1995 | 1355 ratio_set_string (scratch_ratio, (const char *) p, b); |
| 2013 | 1356 *end = save; |
| 1357 ratio_canonicalize (scratch_ratio); | |
| 1983 | 1358 return make_ratio_rt (scratch_ratio); |
| 1359 } | |
| 1360 #endif /* HAVE_RATIO */ | |
| 1361 | |
| 1362 #ifdef HAVE_BIGNUM | |
| 2013 | 1363 { |
| 1364 /* The GMP version of bignum_set_string (mpz_set_str) has the following | |
| 1365 limitations: | |
| 1366 - If p starts with a '+' sign, it does nothing; i.e., it leaves its | |
| 1367 bignum argument untouched. | |
| 1368 - If p is the empty string, it does nothing. | |
| 1369 - If p has trailing nonnumeric characters, it does nothing. | |
| 1370 | |
| 1371 Therefore, move p past any leading '+' signs, temporarily drop a null | |
| 1372 after the numeric characters we are trying to convert, special case the | |
| 1373 empty string, and then put the nulled character back afterward. */ | |
| 1374 Ibyte *end, save; | |
| 1375 Lisp_Object retval; | |
| 1376 | |
| 1377 if (*p == '+') | |
| 1378 p++; | |
| 2014 | 1379 end = p; |
| 1380 if (*end == '-') | |
| 1381 end++; | |
| 1382 while ((*end >= '0' && *end <= '9') || | |
| 2013 | 1383 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) || |
| 2014 | 1384 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11)) |
| 1385 end++; | |
| 2013 | 1386 save = *end; |
| 1387 *end = '\0'; | |
| 1388 if (*p == '\0') | |
| 1389 retval = make_int (0); | |
| 1390 else | |
| 1391 { | |
| 1392 bignum_set_string (scratch_bignum, (const char *) p, b); | |
| 1393 retval = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 1394 } | |
| 1395 *end = save; | |
| 1396 return retval; | |
| 1397 } | |
| 1983 | 1398 #else |
| 428 | 1399 if (b == 10) |
| 1400 { | |
| 1401 /* Use the system-provided functions for base 10. */ | |
| 1402 #if SIZEOF_EMACS_INT == SIZEOF_INT | |
| 2054 | 1403 return make_int (atoi ((char*) p)); |
| 428 | 1404 #elif SIZEOF_EMACS_INT == SIZEOF_LONG |
| 2054 | 1405 return make_int (atol ((char*) p)); |
| 428 | 1406 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG |
| 2054 | 1407 return make_int (atoll ((char*) p)); |
| 428 | 1408 #endif |
| 1409 } | |
| 1410 else | |
| 1411 { | |
| 444 | 1412 int negative = 1; |
| 428 | 1413 EMACS_INT v = 0; |
| 1414 | |
| 1415 if (*p == '-') | |
| 1416 { | |
| 1417 negative = -1; | |
| 1418 p++; | |
| 1419 } | |
| 1420 else if (*p == '+') | |
| 1421 p++; | |
| 1422 while (1) | |
| 1423 { | |
| 444 | 1424 int digit = digit_to_number (*p++, b); |
| 428 | 1425 if (digit < 0) |
| 1426 break; | |
| 1427 v = v * b + digit; | |
| 1428 } | |
| 1429 return make_int (negative * v); | |
| 1430 } | |
| 1983 | 1431 #endif /* HAVE_BIGNUM */ |
| 428 | 1432 } |
| 1433 | |
| 1434 | |
| 1435 DEFUN ("+", Fplus, 0, MANY, 0, /* | |
| 1436 Return sum of any number of arguments. | |
| 1437 The arguments should all be numbers, characters or markers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1438 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1439 arguments: (&rest ARGS) |
| 428 | 1440 */ |
| 1441 (int nargs, Lisp_Object *args)) | |
| 1442 { | |
| 1983 | 1443 #ifdef WITH_NUMBER_TYPES |
| 1444 REGISTER int i; | |
| 1445 Lisp_Object accum = make_int (0), addend; | |
| 1446 | |
| 1447 for (i = 0; i < nargs; i++) | |
| 1448 { | |
| 1449 addend = args[i]; | |
| 1450 switch (promote_args (&accum, &addend)) | |
| 1451 { | |
| 1452 case FIXNUM_T: | |
| 1453 accum = make_integer (XREALINT (accum) + XREALINT (addend)); | |
| 1454 break; | |
| 1455 #ifdef HAVE_BIGNUM | |
| 1456 case BIGNUM_T: | |
| 1457 bignum_add (scratch_bignum, XBIGNUM_DATA (accum), | |
| 1458 XBIGNUM_DATA (addend)); | |
| 1459 accum = make_bignum_bg (scratch_bignum); | |
| 1460 break; | |
| 1461 #endif | |
| 1462 #ifdef HAVE_RATIO | |
| 1463 case RATIO_T: | |
| 1464 ratio_add (scratch_ratio, XRATIO_DATA (accum), | |
| 1465 XRATIO_DATA (addend)); | |
| 1466 accum = make_ratio_rt (scratch_ratio); | |
| 1467 break; | |
| 1468 #endif | |
| 1469 case FLOAT_T: | |
| 1470 accum = make_float (XFLOAT_DATA (accum) + XFLOAT_DATA (addend)); | |
| 1471 break; | |
| 1472 #ifdef HAVE_BIGFLOAT | |
| 1473 case BIGFLOAT_T: | |
| 1474 bigfloat_set_prec (scratch_bigfloat, | |
| 1475 max (XBIGFLOAT_GET_PREC (addend), | |
| 1476 XBIGFLOAT_GET_PREC (accum))); | |
| 1477 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1478 XBIGFLOAT_DATA (addend)); | |
| 1479 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1480 break; | |
| 1481 #endif | |
| 1482 } | |
| 1483 } | |
| 1484 return Fcanonicalize_number (accum); | |
| 1485 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1486 EMACS_INT iaccum = 0; |
| 1487 Lisp_Object *args_end = args + nargs; | |
| 1488 | |
| 1489 while (args < args_end) | |
| 1490 { | |
| 1491 int_or_double iod; | |
| 1492 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1493 if (iod.int_p) | |
| 1494 iaccum += iod.c.ival; | |
| 1495 else | |
| 1496 { | |
| 1497 double daccum = (double) iaccum + iod.c.dval; | |
| 1498 while (args < args_end) | |
| 1499 daccum += number_char_or_marker_to_double (*args++); | |
| 1500 return make_float (daccum); | |
| 1501 } | |
| 1502 } | |
| 1503 | |
| 1504 return make_int (iaccum); | |
| 1983 | 1505 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1506 } |
| 1507 | |
| 1508 DEFUN ("-", Fminus, 1, MANY, 0, /* | |
| 1509 Negate number or subtract numbers, characters or markers. | |
| 1510 With one arg, negates it. With more than one arg, | |
| 1511 subtracts all but the first from the first. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1512 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1513 arguments: (FIRST &rest ARGS) |
| 428 | 1514 */ |
| 1515 (int nargs, Lisp_Object *args)) | |
| 1516 { | |
| 1983 | 1517 #ifdef WITH_NUMBER_TYPES |
| 1518 REGISTER int i; | |
| 1519 Lisp_Object accum = args[0], subtrahend; | |
| 1520 | |
| 1521 if (nargs == 1) | |
| 1522 { | |
| 1523 if (CHARP (accum)) | |
| 1524 accum = make_int (XCHAR (accum)); | |
| 1525 else if (MARKERP (accum)) | |
| 1526 accum = make_int (marker_position (accum)); | |
| 1527 | |
| 1528 /* Invert the sign of accum */ | |
| 1529 CHECK_NUMBER (accum); | |
| 1530 switch (get_number_type (accum)) | |
| 1531 { | |
| 1532 case FIXNUM_T: | |
| 1533 return make_integer (-XREALINT (accum)); | |
| 1534 #ifdef HAVE_BIGNUM | |
| 1535 case BIGNUM_T: | |
| 1536 bignum_neg (scratch_bignum, XBIGNUM_DATA (accum)); | |
| 1537 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 1538 #endif | |
| 1539 #ifdef HAVE_RATIO | |
| 1540 case RATIO_T: | |
| 1541 ratio_neg (scratch_ratio, XRATIO_DATA (accum)); | |
| 1542 return make_ratio_rt (scratch_ratio); | |
| 1543 #endif | |
| 1544 case FLOAT_T: | |
| 1545 return make_float (-XFLOAT_DATA (accum)); | |
| 1546 #ifdef HAVE_BIGFLOAT | |
| 1547 case BIGFLOAT_T: | |
| 1548 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (accum)); | |
| 1549 bigfloat_neg (scratch_bigfloat, XBIGFLOAT_DATA (accum)); | |
| 1550 return make_bigfloat_bf (scratch_bigfloat); | |
| 1551 #endif | |
| 1552 } | |
| 1553 } | |
| 1554 else | |
| 1555 { | |
| 1556 /* Subtrace the remaining arguments from accum */ | |
| 1557 for (i = 1; i < nargs; i++) | |
| 1558 { | |
| 1559 subtrahend = args[i]; | |
| 1560 switch (promote_args (&accum, &subtrahend)) | |
| 1561 { | |
| 1562 case FIXNUM_T: | |
| 1563 accum = make_integer (XREALINT (accum) - XREALINT (subtrahend)); | |
| 1564 break; | |
| 1565 #ifdef HAVE_BIGNUM | |
| 1566 case BIGNUM_T: | |
| 1567 bignum_sub (scratch_bignum, XBIGNUM_DATA (accum), | |
| 1568 XBIGNUM_DATA (subtrahend)); | |
| 1569 accum = make_bignum_bg (scratch_bignum); | |
| 1570 break; | |
| 1571 #endif | |
| 1572 #ifdef HAVE_RATIO | |
| 1573 case RATIO_T: | |
| 1574 ratio_sub (scratch_ratio, XRATIO_DATA (accum), | |
| 1575 XRATIO_DATA (subtrahend)); | |
| 1576 accum = make_ratio_rt (scratch_ratio); | |
| 1577 break; | |
| 1578 #endif | |
| 1579 case FLOAT_T: | |
| 1580 accum = | |
| 1581 make_float (XFLOAT_DATA (accum) - XFLOAT_DATA (subtrahend)); | |
| 1582 break; | |
| 1583 #ifdef HAVE_BIGFLOAT | |
| 1584 case BIGFLOAT_T: | |
| 1585 bigfloat_set_prec (scratch_bigfloat, | |
| 1586 max (XBIGFLOAT_GET_PREC (subtrahend), | |
| 1587 XBIGFLOAT_GET_PREC (accum))); | |
| 1588 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1589 XBIGFLOAT_DATA (subtrahend)); | |
| 1590 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1591 break; | |
| 1592 #endif | |
| 1593 } | |
| 1594 } | |
| 1595 } | |
| 1596 return Fcanonicalize_number (accum); | |
| 1597 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1598 EMACS_INT iaccum; |
| 1599 double daccum; | |
| 1600 Lisp_Object *args_end = args + nargs; | |
| 1601 int_or_double iod; | |
| 1602 | |
| 1603 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1604 if (iod.int_p) | |
| 1605 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival; | |
| 1606 else | |
| 1607 { | |
| 1608 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval; | |
| 1609 goto do_float; | |
| 1610 } | |
| 1611 | |
| 1612 while (args < args_end) | |
| 1613 { | |
| 1614 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1615 if (iod.int_p) | |
| 1616 iaccum -= iod.c.ival; | |
| 1617 else | |
| 1618 { | |
| 1619 daccum = (double) iaccum - iod.c.dval; | |
| 1620 goto do_float; | |
| 1621 } | |
| 1622 } | |
| 1623 | |
| 1624 return make_int (iaccum); | |
| 1625 | |
| 1626 do_float: | |
| 1627 for (; args < args_end; args++) | |
| 1628 daccum -= number_char_or_marker_to_double (*args); | |
| 1629 return make_float (daccum); | |
| 1983 | 1630 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1631 } |
| 1632 | |
| 1633 DEFUN ("*", Ftimes, 0, MANY, 0, /* | |
| 1634 Return product of any number of arguments. | |
| 1635 The arguments should all be numbers, characters or markers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1636 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1637 arguments: (&rest ARGS) |
| 428 | 1638 */ |
| 1639 (int nargs, Lisp_Object *args)) | |
| 1640 { | |
| 1983 | 1641 #ifdef WITH_NUMBER_TYPES |
| 1642 REGISTER int i; | |
| 1643 /* Start with a bignum to avoid overflow */ | |
| 1644 Lisp_Object accum = make_bignum (1L), multiplier; | |
| 1645 | |
| 1646 for (i = 0; i < nargs; i++) | |
| 1647 { | |
| 1648 multiplier = args[i]; | |
| 1649 switch (promote_args (&accum, &multiplier)) | |
| 1650 { | |
| 1651 #ifdef HAVE_BIGNUM | |
| 1652 case BIGNUM_T: | |
| 1653 bignum_mul (scratch_bignum, XBIGNUM_DATA (accum), | |
| 1654 XBIGNUM_DATA (multiplier)); | |
| 1655 accum = make_bignum_bg (scratch_bignum); | |
| 1656 break; | |
| 1657 #endif | |
| 1658 #ifdef HAVE_RATIO | |
| 1659 case RATIO_T: | |
| 1660 ratio_mul (scratch_ratio, XRATIO_DATA (accum), | |
| 1661 XRATIO_DATA (multiplier)); | |
| 1662 accum = make_ratio_rt (scratch_ratio); | |
| 1663 break; | |
| 1664 #endif | |
| 1665 case FLOAT_T: | |
| 1666 accum = make_float (XFLOAT_DATA (accum) * XFLOAT_DATA (multiplier)); | |
| 1667 break; | |
| 1668 #ifdef HAVE_BIGFLOAT | |
| 1669 case BIGFLOAT_T: | |
| 1670 bigfloat_set_prec (scratch_bigfloat, | |
| 1671 max (XBIGFLOAT_GET_PREC (multiplier), | |
| 1672 XBIGFLOAT_GET_PREC (accum))); | |
| 1673 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1674 XBIGFLOAT_DATA (multiplier)); | |
| 1675 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1676 break; | |
| 1677 #endif | |
| 1678 } | |
| 1679 } | |
| 1680 return Fcanonicalize_number (accum); | |
| 1681 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1682 EMACS_INT iaccum = 1; |
| 1683 Lisp_Object *args_end = args + nargs; | |
| 1684 | |
| 1685 while (args < args_end) | |
| 1686 { | |
| 1687 int_or_double iod; | |
| 1688 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1689 if (iod.int_p) | |
| 1690 iaccum *= iod.c.ival; | |
| 1691 else | |
| 1692 { | |
| 1693 double daccum = (double) iaccum * iod.c.dval; | |
| 1694 while (args < args_end) | |
| 1695 daccum *= number_char_or_marker_to_double (*args++); | |
| 1696 return make_float (daccum); | |
| 1697 } | |
| 1698 } | |
| 1699 | |
| 1700 return make_int (iaccum); | |
| 1983 | 1701 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1702 } |
| 1703 | |
| 1983 | 1704 #ifdef HAVE_RATIO |
| 1705 DEFUN ("div", Fdiv, 1, MANY, 0, /* | |
| 1706 Same as `/', but dividing integers creates a ratio instead of truncating. | |
| 1707 Note that this is a departure from Common Lisp, where / creates ratios when | |
| 1708 dividing integers. Having a separate function lets us avoid breaking existing | |
| 1709 Emacs Lisp code that expects / to do integer division. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1710 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1711 arguments: (FIRST &rest ARGS) |
| 1983 | 1712 */ |
| 1713 (int nargs, Lisp_Object *args)) | |
| 1714 { | |
| 1715 REGISTER int i; | |
| 1716 Lisp_Object accum, divisor; | |
| 1717 | |
| 1718 if (nargs == 1) | |
| 1719 { | |
| 1720 i = 0; | |
| 1721 accum = make_int (1); | |
| 1722 } | |
| 1723 else | |
| 1724 { | |
| 1725 i = 1; | |
| 1726 accum = args[0]; | |
| 1727 } | |
| 1728 for (; i < nargs; i++) | |
| 1729 { | |
| 1730 divisor = args[i]; | |
| 1731 switch (promote_args (&accum, &divisor)) | |
| 1732 { | |
| 1733 case FIXNUM_T: | |
| 1734 if (XREALINT (divisor) == 0) goto divide_by_zero; | |
| 1735 bignum_set_long (scratch_bignum, XREALINT (accum)); | |
| 1736 bignum_set_long (scratch_bignum2, XREALINT (divisor)); | |
| 1737 accum = make_ratio_bg (scratch_bignum, scratch_bignum2); | |
| 1738 break; | |
| 1739 case BIGNUM_T: | |
| 1740 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1741 accum = make_ratio_bg (XBIGNUM_DATA (accum), XBIGNUM_DATA (divisor)); | |
| 1742 break; | |
| 1743 case RATIO_T: | |
| 1744 if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1745 ratio_div (scratch_ratio, XRATIO_DATA (accum), | |
| 1746 XRATIO_DATA (divisor)); | |
| 1747 accum = make_ratio_rt (scratch_ratio); | |
| 1748 break; | |
| 1749 case FLOAT_T: | |
| 1750 if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero; | |
| 1751 accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor)); | |
| 1752 break; | |
| 1753 #ifdef HAVE_BIGFLOAT | |
| 1754 case BIGFLOAT_T: | |
| 1755 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) | |
| 1756 goto divide_by_zero; | |
| 1757 bigfloat_set_prec (scratch_bigfloat, | |
| 1758 max (XBIGFLOAT_GET_PREC (divisor), | |
| 1759 XBIGFLOAT_GET_PREC (accum))); | |
| 1760 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1761 XBIGFLOAT_DATA (divisor)); | |
| 1762 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1763 break; | |
| 1764 #endif | |
| 1765 } | |
| 1766 } | |
| 1767 return Fcanonicalize_number (accum); | |
| 1768 | |
| 1769 divide_by_zero: | |
| 1770 Fsignal (Qarith_error, Qnil); | |
| 1771 return Qnil; /* not (usually) reached */ | |
| 1772 } | |
| 1773 #endif /* HAVE_RATIO */ | |
| 1774 | |
| 428 | 1775 DEFUN ("/", Fquo, 1, MANY, 0, /* |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1776 Return FIRST divided by all the remaining arguments. |
| 428 | 1777 The arguments must be numbers, characters or markers. |
| 1778 With one argument, reciprocates the argument. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1779 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1780 arguments: (FIRST &rest ARGS) |
| 428 | 1781 */ |
| 1782 (int nargs, Lisp_Object *args)) | |
| 1783 { | |
| 1983 | 1784 #ifdef WITH_NUMBER_TYPES |
| 1785 REGISTER int i; | |
| 1786 Lisp_Object accum, divisor; | |
| 1787 | |
| 1788 if (nargs == 1) | |
| 1789 { | |
| 1790 i = 0; | |
| 1791 accum = make_int (1); | |
| 1792 } | |
| 1793 else | |
| 1794 { | |
| 1795 i = 1; | |
| 1796 accum = args[0]; | |
| 1797 } | |
| 1798 for (; i < nargs; i++) | |
| 1799 { | |
| 1800 divisor = args[i]; | |
| 1801 switch (promote_args (&accum, &divisor)) | |
| 1802 { | |
| 1803 case FIXNUM_T: | |
| 1804 if (XREALINT (divisor) == 0) goto divide_by_zero; | |
| 1805 accum = make_integer (XREALINT (accum) / XREALINT (divisor)); | |
| 1806 break; | |
| 1807 #ifdef HAVE_BIGNUM | |
| 1808 case BIGNUM_T: | |
| 1809 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1810 bignum_div (scratch_bignum, XBIGNUM_DATA (accum), | |
| 1811 XBIGNUM_DATA (divisor)); | |
| 1812 accum = make_bignum_bg (scratch_bignum); | |
| 1813 break; | |
| 1814 #endif | |
| 1815 #ifdef HAVE_RATIO | |
| 1816 case RATIO_T: | |
| 1817 if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1818 ratio_div (scratch_ratio, XRATIO_DATA (accum), | |
| 1819 XRATIO_DATA (divisor)); | |
| 1820 accum = make_ratio_rt (scratch_ratio); | |
| 1821 break; | |
| 1822 #endif | |
| 1823 case FLOAT_T: | |
| 1824 if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero; | |
| 1825 accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor)); | |
| 1826 break; | |
| 1827 #ifdef HAVE_BIGFLOAT | |
| 1828 case BIGFLOAT_T: | |
| 1829 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) | |
| 1830 goto divide_by_zero; | |
| 1831 bigfloat_set_prec (scratch_bigfloat, | |
| 1832 max (XBIGFLOAT_GET_PREC (divisor), | |
| 1833 XBIGFLOAT_GET_PREC (accum))); | |
| 1834 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1835 XBIGFLOAT_DATA (divisor)); | |
| 1836 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1837 break; | |
| 1838 #endif | |
| 1839 } | |
| 1840 } | |
| 1841 return Fcanonicalize_number (accum); | |
| 1842 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1843 EMACS_INT iaccum; |
| 1844 double daccum; | |
| 1845 Lisp_Object *args_end = args + nargs; | |
| 1846 int_or_double iod; | |
| 1847 | |
| 1848 if (nargs == 1) | |
| 1849 iaccum = 1; | |
| 1850 else | |
| 1851 { | |
| 1852 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1853 if (iod.int_p) | |
| 1854 iaccum = iod.c.ival; | |
| 1855 else | |
| 1856 { | |
| 1857 daccum = iod.c.dval; | |
| 1858 goto divide_floats; | |
| 1859 } | |
| 1860 } | |
| 1861 | |
| 1862 while (args < args_end) | |
| 1863 { | |
| 1864 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1865 if (iod.int_p) | |
| 1866 { | |
| 1867 if (iod.c.ival == 0) goto divide_by_zero; | |
| 1868 iaccum /= iod.c.ival; | |
| 1869 } | |
| 1870 else | |
| 1871 { | |
| 1872 if (iod.c.dval == 0) goto divide_by_zero; | |
| 1873 daccum = (double) iaccum / iod.c.dval; | |
| 1874 goto divide_floats; | |
| 1875 } | |
| 1876 } | |
| 1877 | |
| 1878 return make_int (iaccum); | |
| 1879 | |
| 1880 divide_floats: | |
| 1881 for (; args < args_end; args++) | |
| 1882 { | |
| 1883 double dval = number_char_or_marker_to_double (*args); | |
| 1884 if (dval == 0) goto divide_by_zero; | |
| 1885 daccum /= dval; | |
| 1886 } | |
| 1887 return make_float (daccum); | |
| 1983 | 1888 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1889 |
| 1890 divide_by_zero: | |
| 1891 Fsignal (Qarith_error, Qnil); | |
| 801 | 1892 return Qnil; /* not (usually) reached */ |
| 428 | 1893 } |
| 1894 | |
| 1895 DEFUN ("max", Fmax, 1, MANY, 0, /* | |
| 1896 Return largest of all the arguments. | |
| 1983 | 1897 All arguments must be real numbers, characters or markers. |
| 428 | 1898 The value is always a number; markers and characters are converted |
| 1899 to numbers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1900 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1901 arguments: (FIRST &rest ARGS) |
| 428 | 1902 */ |
| 1903 (int nargs, Lisp_Object *args)) | |
| 1904 { | |
| 1983 | 1905 #ifdef WITH_NUMBER_TYPES |
| 1906 REGISTER int i, maxindex = 0; | |
| 1907 Lisp_Object comp1, comp2; | |
| 1908 | |
| 1909 while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0]))) | |
| 1910 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 1911 if (CHARP (args[0])) | |
| 1912 args[0] = make_int (XCHAR (args[0])); | |
| 1913 else if (MARKERP (args[0])) | |
| 1914 args[0] = make_int (marker_position (args[0])); | |
| 1915 for (i = 1; i < nargs; i++) | |
| 1916 { | |
| 1917 comp1 = args[maxindex]; | |
| 1918 comp2 = args[i]; | |
| 1919 switch (promote_args (&comp1, &comp2)) | |
| 1920 { | |
| 1921 case FIXNUM_T: | |
| 1922 if (XREALINT (comp1) < XREALINT (comp2)) | |
| 1923 maxindex = i; | |
| 1924 break; | |
| 1925 #ifdef HAVE_BIGNUM | |
| 1926 case BIGNUM_T: | |
| 1927 if (bignum_lt (XBIGNUM_DATA (comp1), XBIGNUM_DATA (comp2))) | |
| 1928 maxindex = i; | |
| 1929 break; | |
| 1930 #endif | |
| 1931 #ifdef HAVE_RATIO | |
| 1932 case RATIO_T: | |
| 1933 if (ratio_lt (XRATIO_DATA (comp1), XRATIO_DATA (comp2))) | |
| 1934 maxindex = i; | |
| 1935 break; | |
| 1936 #endif | |
| 1937 case FLOAT_T: | |
| 1938 if (XFLOAT_DATA (comp1) < XFLOAT_DATA (comp2)) | |
| 1939 maxindex = i; | |
| 1940 break; | |
| 1941 #ifdef HAVE_BIGFLOAT | |
| 1942 case BIGFLOAT_T: | |
| 1943 if (bigfloat_lt (XBIGFLOAT_DATA (comp1), XBIGFLOAT_DATA (comp2))) | |
| 1944 maxindex = i; | |
| 1945 break; | |
| 1946 #endif | |
| 1947 } | |
| 1948 } | |
| 1949 return args[maxindex]; | |
| 1950 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1951 EMACS_INT imax; |
| 1952 double dmax; | |
| 1953 Lisp_Object *args_end = args + nargs; | |
| 1954 int_or_double iod; | |
| 1955 | |
| 1956 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1957 if (iod.int_p) | |
| 1958 imax = iod.c.ival; | |
| 1959 else | |
| 1960 { | |
| 1961 dmax = iod.c.dval; | |
| 1962 goto max_floats; | |
| 1963 } | |
| 1964 | |
| 1965 while (args < args_end) | |
| 1966 { | |
| 1967 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1968 if (iod.int_p) | |
| 1969 { | |
| 1970 if (imax < iod.c.ival) imax = iod.c.ival; | |
| 1971 } | |
| 1972 else | |
| 1973 { | |
| 1974 dmax = (double) imax; | |
| 1975 if (dmax < iod.c.dval) dmax = iod.c.dval; | |
| 1976 goto max_floats; | |
| 1977 } | |
| 1978 } | |
| 1979 | |
| 1980 return make_int (imax); | |
| 1981 | |
| 1982 max_floats: | |
| 1983 while (args < args_end) | |
| 1984 { | |
| 1985 double dval = number_char_or_marker_to_double (*args++); | |
| 1986 if (dmax < dval) dmax = dval; | |
| 1987 } | |
| 1988 return make_float (dmax); | |
| 1983 | 1989 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1990 } |
| 1991 | |
| 1992 DEFUN ("min", Fmin, 1, MANY, 0, /* | |
| 1993 Return smallest of all the arguments. | |
| 1994 All arguments must be numbers, characters or markers. | |
| 1995 The value is always a number; markers and characters are converted | |
| 1996 to numbers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1997 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1998 arguments: (FIRST &rest ARGS) |
| 428 | 1999 */ |
| 2000 (int nargs, Lisp_Object *args)) | |
| 2001 { | |
| 1983 | 2002 #ifdef WITH_NUMBER_TYPES |
| 2003 REGISTER int i, minindex = 0; | |
| 2004 Lisp_Object comp1, comp2; | |
| 2005 | |
| 2006 while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0]))) | |
| 2007 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 2008 if (CHARP (args[0])) | |
| 2009 args[0] = make_int (XCHAR (args[0])); | |
| 2010 else if (MARKERP (args[0])) | |
| 2011 args[0] = make_int (marker_position (args[0])); | |
| 2012 for (i = 1; i < nargs; i++) | |
| 2013 { | |
| 2014 comp1 = args[minindex]; | |
| 2015 comp2 = args[i]; | |
| 2016 switch (promote_args (&comp1, &comp2)) | |
| 2017 { | |
| 2018 case FIXNUM_T: | |
| 2019 if (XREALINT (comp1) > XREALINT (comp2)) | |
| 2020 minindex = i; | |
| 2021 break; | |
| 2022 #ifdef HAVE_BIGNUM | |
| 2023 case BIGNUM_T: | |
| 2024 if (bignum_gt (XBIGNUM_DATA (comp1), XBIGNUM_DATA (comp2))) | |
| 2025 minindex = i; | |
| 2026 break; | |
| 2027 #endif | |
| 2028 #ifdef HAVE_RATIO | |
| 2029 case RATIO_T: | |
| 2030 if (ratio_gt (XRATIO_DATA (comp1), XRATIO_DATA (comp2))) | |
| 2031 minindex = i; | |
| 2032 break; | |
| 2033 #endif | |
| 2034 case FLOAT_T: | |
| 2035 if (XFLOAT_DATA (comp1) > XFLOAT_DATA (comp2)) | |
| 2036 minindex = i; | |
| 2037 break; | |
| 2038 #ifdef HAVE_BIGFLOAT | |
| 2039 case BIGFLOAT_T: | |
| 2040 if (bigfloat_gt (XBIGFLOAT_DATA (comp1), XBIGFLOAT_DATA (comp2))) | |
| 2041 minindex = i; | |
| 2042 break; | |
| 2043 #endif | |
| 2044 } | |
| 2045 } | |
| 2046 return args[minindex]; | |
| 2047 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 2048 EMACS_INT imin; |
| 2049 double dmin; | |
| 2050 Lisp_Object *args_end = args + nargs; | |
| 2051 int_or_double iod; | |
| 2052 | |
| 2053 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 2054 if (iod.int_p) | |
| 2055 imin = iod.c.ival; | |
| 2056 else | |
| 2057 { | |
| 2058 dmin = iod.c.dval; | |
| 2059 goto min_floats; | |
| 2060 } | |
| 2061 | |
| 2062 while (args < args_end) | |
| 2063 { | |
| 2064 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 2065 if (iod.int_p) | |
| 2066 { | |
| 2067 if (imin > iod.c.ival) imin = iod.c.ival; | |
| 2068 } | |
| 2069 else | |
| 2070 { | |
| 2071 dmin = (double) imin; | |
| 2072 if (dmin > iod.c.dval) dmin = iod.c.dval; | |
| 2073 goto min_floats; | |
| 2074 } | |
| 2075 } | |
| 2076 | |
| 2077 return make_int (imin); | |
| 2078 | |
| 2079 min_floats: | |
| 2080 while (args < args_end) | |
| 2081 { | |
| 2082 double dval = number_char_or_marker_to_double (*args++); | |
| 2083 if (dmin > dval) dmin = dval; | |
| 2084 } | |
| 2085 return make_float (dmin); | |
| 1983 | 2086 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 2087 } |
| 2088 | |
| 2089 DEFUN ("logand", Flogand, 0, MANY, 0, /* | |
| 2090 Return bitwise-and of all the arguments. | |
| 2091 Arguments may be integers, or markers or characters converted to integers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2092 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2093 arguments: (&rest ARGS) |
| 428 | 2094 */ |
| 2095 (int nargs, Lisp_Object *args)) | |
| 2096 { | |
| 1983 | 2097 #ifdef HAVE_BIGNUM |
| 2098 REGISTER int i; | |
| 2099 Lisp_Object result, other; | |
| 2100 | |
| 2101 if (nargs == 0) | |
| 2102 return make_int (~0); | |
| 2103 | |
| 2104 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) | |
| 2105 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 2106 | |
| 2107 result = args[0]; | |
| 2108 if (CHARP (result)) | |
| 2109 result = make_int (XCHAR (result)); | |
| 2110 else if (MARKERP (result)) | |
| 2111 result = make_int (marker_position (result)); | |
| 2112 for (i = 1; i < nargs; i++) | |
| 2113 { | |
| 2114 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) | |
| 2115 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); | |
| 2116 other = args[i]; | |
| 1995 | 2117 switch (promote_args (&result, &other)) |
| 1983 | 2118 { |
| 2119 case FIXNUM_T: | |
| 1995 | 2120 result = make_int (XREALINT (result) & XREALINT (other)); |
| 1983 | 2121 break; |
| 2122 case BIGNUM_T: | |
| 2123 bignum_and (scratch_bignum, XBIGNUM_DATA (result), | |
| 2124 XBIGNUM_DATA (other)); | |
| 2125 result = make_bignum_bg (scratch_bignum); | |
| 2126 break; | |
| 2127 } | |
| 2128 } | |
| 2129 return Fcanonicalize_number (result); | |
| 2130 #else /* !HAVE_BIGNUM */ | |
| 428 | 2131 EMACS_INT bits = ~0; |
| 2132 Lisp_Object *args_end = args + nargs; | |
| 2133 | |
| 2134 while (args < args_end) | |
| 2135 bits &= integer_char_or_marker_to_int (*args++); | |
| 2136 | |
| 2137 return make_int (bits); | |
| 1983 | 2138 #endif /* HAVE_BIGNUM */ |
| 428 | 2139 } |
| 2140 | |
| 2141 DEFUN ("logior", Flogior, 0, MANY, 0, /* | |
| 2142 Return bitwise-or of all the arguments. | |
| 2143 Arguments may be integers, or markers or characters converted to integers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2144 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2145 arguments: (&rest ARGS) |
| 428 | 2146 */ |
| 2147 (int nargs, Lisp_Object *args)) | |
| 2148 { | |
| 1983 | 2149 #ifdef HAVE_BIGNUM |
| 2150 REGISTER int i; | |
| 2151 Lisp_Object result, other; | |
| 2152 | |
| 2153 if (nargs == 0) | |
| 2154 return make_int (0); | |
| 2155 | |
| 2156 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) | |
| 2157 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 2158 | |
| 2159 result = args[0]; | |
| 2160 if (CHARP (result)) | |
| 2161 result = make_int (XCHAR (result)); | |
| 2162 else if (MARKERP (result)) | |
| 2163 result = make_int (marker_position (result)); | |
| 2164 for (i = 1; i < nargs; i++) | |
| 2165 { | |
| 2166 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) | |
| 2167 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); | |
| 2168 other = args[i]; | |
| 2169 switch (promote_args (&result, &other)) | |
| 2170 { | |
| 2171 case FIXNUM_T: | |
| 1992 | 2172 result = make_int (XREALINT (result) | XREALINT (other)); |
| 1983 | 2173 break; |
| 2174 case BIGNUM_T: | |
| 2175 bignum_ior (scratch_bignum, XBIGNUM_DATA (result), | |
| 2176 XBIGNUM_DATA (other)); | |
| 2177 result = make_bignum_bg (scratch_bignum); | |
| 2178 break; | |
| 2179 } | |
| 2180 } | |
| 2181 return Fcanonicalize_number (result); | |
| 2182 #else /* !HAVE_BIGNUM */ | |
| 428 | 2183 EMACS_INT bits = 0; |
| 2184 Lisp_Object *args_end = args + nargs; | |
| 2185 | |
| 2186 while (args < args_end) | |
| 2187 bits |= integer_char_or_marker_to_int (*args++); | |
| 2188 | |
| 2189 return make_int (bits); | |
| 1983 | 2190 #endif /* HAVE_BIGNUM */ |
| 428 | 2191 } |
| 2192 | |
| 2193 DEFUN ("logxor", Flogxor, 0, MANY, 0, /* | |
| 2194 Return bitwise-exclusive-or of all the arguments. | |
| 2195 Arguments may be integers, or markers or characters converted to integers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2196 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2197 arguments: (&rest ARGS) |
| 428 | 2198 */ |
| 2199 (int nargs, Lisp_Object *args)) | |
| 2200 { | |
| 1983 | 2201 #ifdef HAVE_BIGNUM |
| 2202 REGISTER int i; | |
| 2203 Lisp_Object result, other; | |
| 2204 | |
| 2205 if (nargs == 0) | |
| 2206 return make_int (0); | |
| 2207 | |
| 2208 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) | |
| 2209 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 2210 | |
| 2211 result = args[0]; | |
| 2212 if (CHARP (result)) | |
| 2213 result = make_int (XCHAR (result)); | |
| 2214 else if (MARKERP (result)) | |
| 2215 result = make_int (marker_position (result)); | |
| 2216 for (i = 1; i < nargs; i++) | |
| 2217 { | |
| 2218 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) | |
| 2219 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); | |
| 2220 other = args[i]; | |
| 2221 if (promote_args (&result, &other) == FIXNUM_T) | |
| 2222 { | |
| 2223 result = make_int (XREALINT (result) ^ XREALINT (other)); | |
| 2224 } | |
| 2225 else | |
| 2226 { | |
| 2227 bignum_xor (scratch_bignum, XBIGNUM_DATA (result), | |
| 2228 XBIGNUM_DATA (other)); | |
| 2229 result = make_bignum_bg (scratch_bignum); | |
| 2230 } | |
| 2231 } | |
| 2232 return Fcanonicalize_number (result); | |
| 2233 #else /* !HAVE_BIGNUM */ | |
| 428 | 2234 EMACS_INT bits = 0; |
| 2235 Lisp_Object *args_end = args + nargs; | |
| 2236 | |
| 2237 while (args < args_end) | |
| 2238 bits ^= integer_char_or_marker_to_int (*args++); | |
| 2239 | |
| 2240 return make_int (bits); | |
| 1983 | 2241 #endif /* !HAVE_BIGNUM */ |
| 428 | 2242 } |
| 2243 | |
| 2244 DEFUN ("lognot", Flognot, 1, 1, 0, /* | |
| 2245 Return the bitwise complement of NUMBER. | |
| 2246 NUMBER may be an integer, marker or character converted to integer. | |
| 2247 */ | |
| 2248 (number)) | |
| 2249 { | |
| 1983 | 2250 #ifdef HAVE_BIGNUM |
| 2251 if (BIGNUMP (number)) | |
| 2252 { | |
| 2253 bignum_not (scratch_bignum, XBIGNUM_DATA (number)); | |
| 2254 return make_bignum_bg (scratch_bignum); | |
| 2255 } | |
| 2256 #endif /* HAVE_BIGNUM */ | |
| 428 | 2257 return make_int (~ integer_char_or_marker_to_int (number)); |
| 2258 } | |
| 2259 | |
| 2260 DEFUN ("%", Frem, 2, 2, 0, /* | |
| 2261 Return remainder of first arg divided by second. | |
| 2262 Both must be integers, characters or markers. | |
| 2263 */ | |
| 444 | 2264 (number1, number2)) |
| 428 | 2265 { |
| 1983 | 2266 #ifdef HAVE_BIGNUM |
| 2267 while (!(CHARP (number1) || MARKERP (number1) || INTEGERP (number1))) | |
| 2268 number1 = wrong_type_argument (Qnumber_char_or_marker_p, number1); | |
| 2269 while (!(CHARP (number2) || MARKERP (number2) || INTEGERP (number2))) | |
| 2270 number2 = wrong_type_argument (Qnumber_char_or_marker_p, number2); | |
| 2271 | |
| 2272 if (promote_args (&number1, &number2) == FIXNUM_T) | |
| 2273 { | |
| 2274 if (XREALINT (number2) == 0) | |
| 2275 Fsignal (Qarith_error, Qnil); | |
| 2276 return make_int (XREALINT (number1) % XREALINT (number2)); | |
| 2277 } | |
| 2278 else | |
| 2279 { | |
| 2280 if (bignum_sign (XBIGNUM_DATA (number2)) == 0) | |
| 2281 Fsignal (Qarith_error, Qnil); | |
| 2282 bignum_mod (scratch_bignum, XBIGNUM_DATA (number1), | |
| 2283 XBIGNUM_DATA (number2)); | |
| 2284 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 2285 } | |
| 2286 #else /* !HAVE_BIGNUM */ | |
| 444 | 2287 EMACS_INT ival1 = integer_char_or_marker_to_int (number1); |
| 2288 EMACS_INT ival2 = integer_char_or_marker_to_int (number2); | |
| 428 | 2289 |
| 2290 if (ival2 == 0) | |
| 2291 Fsignal (Qarith_error, Qnil); | |
| 2292 | |
| 2293 return make_int (ival1 % ival2); | |
| 1983 | 2294 #endif /* HAVE_BIGNUM */ |
| 428 | 2295 } |
| 2296 | |
| 2297 /* Note, ANSI *requires* the presence of the fmod() library routine. | |
| 2298 If your system doesn't have it, complain to your vendor, because | |
| 2299 that is a bug. */ | |
| 2300 | |
| 2301 #ifndef HAVE_FMOD | |
| 2302 double | |
| 2303 fmod (double f1, double f2) | |
| 2304 { | |
| 2305 if (f2 < 0.0) | |
| 2306 f2 = -f2; | |
| 2307 return f1 - f2 * floor (f1/f2); | |
| 2308 } | |
| 2309 #endif /* ! HAVE_FMOD */ | |
| 2310 | |
| 2311 | |
| 2312 DEFUN ("mod", Fmod, 2, 2, 0, /* | |
| 2313 Return X modulo Y. | |
| 2314 The result falls between zero (inclusive) and Y (exclusive). | |
| 2315 Both X and Y must be numbers, characters or markers. | |
| 2316 If either argument is a float, a float will be returned. | |
| 2317 */ | |
| 2318 (x, y)) | |
| 2319 { | |
| 1983 | 2320 #ifdef WITH_NUMBER_TYPES |
| 2321 while (!(CHARP (x) || MARKERP (x) || REALP (x))) | |
| 2322 x = wrong_type_argument (Qnumber_char_or_marker_p, x); | |
| 2323 while (!(CHARP (y) || MARKERP (y) || REALP (y))) | |
| 2324 y = wrong_type_argument (Qnumber_char_or_marker_p, y); | |
| 2325 switch (promote_args (&x, &y)) | |
| 2326 { | |
| 2327 case FIXNUM_T: | |
| 2328 { | |
| 2329 EMACS_INT ival; | |
| 2330 if (XREALINT (y) == 0) goto divide_by_zero; | |
| 2331 ival = XREALINT (x) % XREALINT (y); | |
| 2332 /* If the "remainder" comes out with the wrong sign, fix it. */ | |
| 2333 if (XREALINT (y) < 0 ? ival > 0 : ival < 0) | |
| 2334 ival += XREALINT (y); | |
| 2335 return make_int (ival); | |
| 2336 } | |
| 2337 #ifdef HAVE_BIGNUM | |
| 2338 case BIGNUM_T: | |
| 2339 if (bignum_sign (XBIGNUM_DATA (y)) == 0) goto divide_by_zero; | |
| 2340 bignum_mod (scratch_bignum, XBIGNUM_DATA (x), XBIGNUM_DATA (y)); | |
| 2341 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 2342 #endif | |
| 2343 #ifdef HAVE_RATIO | |
| 2344 case RATIO_T: | |
| 2345 if (ratio_sign (XRATIO_DATA (y)) == 0) goto divide_by_zero; | |
| 2346 ratio_div (scratch_ratio, XRATIO_DATA (x), XRATIO_DATA (y)); | |
| 2347 bignum_div (scratch_bignum, ratio_numerator (scratch_ratio), | |
| 2348 ratio_denominator (scratch_ratio)); | |
| 2349 ratio_set_bignum (scratch_ratio, scratch_bignum); | |
| 2350 ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (y)); | |
| 2351 ratio_sub (scratch_ratio, XRATIO_DATA (x), scratch_ratio); | |
| 2352 return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); | |
| 2353 #endif | |
| 2354 case FLOAT_T: | |
| 2355 { | |
| 2356 double dval; | |
| 2357 if (XFLOAT_DATA (y) == 0.0) goto divide_by_zero; | |
| 2358 dval = fmod (XFLOAT_DATA (x), XFLOAT_DATA (y)); | |
| 2359 /* If the "remainder" comes out with the wrong sign, fix it. */ | |
| 2360 if (XFLOAT_DATA (y) < 0 ? dval > 0 : dval < 0) | |
| 2361 dval += XFLOAT_DATA (y); | |
| 2362 return make_float (dval); | |
| 2363 } | |
| 2364 #ifdef HAVE_BIGFLOAT | |
| 2365 case BIGFLOAT_T: | |
| 2366 bigfloat_set_prec (scratch_bigfloat, | |
| 2367 max (XBIGFLOAT_GET_PREC (x), XBIGFLOAT_GET_PREC (y))); | |
| 2368 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (x), XBIGFLOAT_DATA (y)); | |
| 2369 bigfloat_trunc (scratch_bigfloat, scratch_bigfloat); | |
| 2370 bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (y)); | |
| 2371 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (x), scratch_bigfloat); | |
| 2372 return make_bigfloat_bf (scratch_bigfloat); | |
| 2373 #endif | |
| 2374 } | |
| 2375 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 2376 int_or_double iod1, iod2; |
| 2377 number_char_or_marker_to_int_or_double (x, &iod1); | |
| 2378 number_char_or_marker_to_int_or_double (y, &iod2); | |
| 2379 | |
| 2380 if (!iod1.int_p || !iod2.int_p) | |
| 2381 { | |
| 2382 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval; | |
| 2383 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval; | |
| 2384 if (dval2 == 0) goto divide_by_zero; | |
| 2385 dval1 = fmod (dval1, dval2); | |
| 2386 | |
| 2387 /* If the "remainder" comes out with the wrong sign, fix it. */ | |
| 2388 if (dval2 < 0 ? dval1 > 0 : dval1 < 0) | |
| 2389 dval1 += dval2; | |
| 2390 | |
| 2391 return make_float (dval1); | |
| 2392 } | |
| 1104 | 2393 |
| 428 | 2394 { |
| 2395 EMACS_INT ival; | |
| 2396 if (iod2.c.ival == 0) goto divide_by_zero; | |
| 2397 | |
| 2398 ival = iod1.c.ival % iod2.c.ival; | |
| 2399 | |
| 2400 /* If the "remainder" comes out with the wrong sign, fix it. */ | |
| 2401 if (iod2.c.ival < 0 ? ival > 0 : ival < 0) | |
| 2402 ival += iod2.c.ival; | |
| 2403 | |
| 2404 return make_int (ival); | |
| 2405 } | |
| 1983 | 2406 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 2407 |
| 2408 divide_by_zero: | |
| 2409 Fsignal (Qarith_error, Qnil); | |
| 801 | 2410 return Qnil; /* not (usually) reached */ |
| 428 | 2411 } |
| 2412 | |
| 2413 DEFUN ("ash", Fash, 2, 2, 0, /* | |
| 2414 Return VALUE with its bits shifted left by COUNT. | |
| 2415 If COUNT is negative, shifting is actually to the right. | |
| 2416 In this case, the sign bit is duplicated. | |
| 1983 | 2417 This function cannot be applied to bignums, as there is no leftmost sign bit |
| 2418 to be duplicated. Use `lsh' instead. | |
| 428 | 2419 */ |
| 2420 (value, count)) | |
| 2421 { | |
| 2422 CHECK_INT_COERCE_CHAR (value); | |
| 2423 CONCHECK_INT (count); | |
| 2424 | |
| 2425 return make_int (XINT (count) > 0 ? | |
| 2426 XINT (value) << XINT (count) : | |
| 2427 XINT (value) >> -XINT (count)); | |
| 2428 } | |
| 2429 | |
| 2430 DEFUN ("lsh", Flsh, 2, 2, 0, /* | |
| 2431 Return VALUE with its bits shifted left by COUNT. | |
| 2432 If COUNT is negative, shifting is actually to the right. | |
| 2433 In this case, zeros are shifted in on the left. | |
| 2434 */ | |
| 2435 (value, count)) | |
| 2436 { | |
| 1983 | 2437 #ifdef HAVE_BIGNUM |
| 2438 while (!(CHARP (value) || MARKERP (value) || INTEGERP (value))) | |
| 2439 wrong_type_argument (Qnumber_char_or_marker_p, value); | |
| 2440 CONCHECK_INTEGER (count); | |
| 2441 | |
| 2442 if (promote_args (&value, &count) == FIXNUM_T) | |
| 2443 { | |
| 2444 if (XREALINT (count) <= 0) | |
| 2445 return make_int (XREALINT (value) >> -XREALINT (count)); | |
| 2446 /* Use bignums to avoid overflow */ | |
| 2447 bignum_set_long (scratch_bignum2, XREALINT (value)); | |
| 2448 bignum_lshift (scratch_bignum, scratch_bignum2, XREALINT (count)); | |
| 2449 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 2450 } | |
| 2451 else | |
| 2452 { | |
| 2453 if (bignum_sign (XBIGNUM_DATA (count)) <= 0) | |
| 2454 { | |
| 2455 bignum_neg (scratch_bignum, XBIGNUM_DATA (count)); | |
| 2456 if (!bignum_fits_ulong_p (scratch_bignum)) | |
| 2457 args_out_of_range (Qnumber_char_or_marker_p, count); | |
| 2458 bignum_rshift (scratch_bignum2, XBIGNUM_DATA (value), | |
| 2459 bignum_to_ulong (scratch_bignum)); | |
| 2460 } | |
| 2461 else | |
| 2462 { | |
| 2463 if (!bignum_fits_ulong_p (XBIGNUM_DATA (count))) | |
| 2464 args_out_of_range (Qnumber_char_or_marker_p, count); | |
| 2465 bignum_lshift (scratch_bignum2, XBIGNUM_DATA (value), | |
| 2466 bignum_to_ulong (XBIGNUM_DATA (count))); | |
| 2467 } | |
| 2468 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); | |
| 2469 } | |
| 2470 #else /* !HAVE_BIGNUM */ | |
| 428 | 2471 CHECK_INT_COERCE_CHAR (value); |
| 2472 CONCHECK_INT (count); | |
| 2473 | |
| 2474 return make_int (XINT (count) > 0 ? | |
| 2475 XUINT (value) << XINT (count) : | |
| 2476 XUINT (value) >> -XINT (count)); | |
| 1983 | 2477 #endif /* HAVE_BIGNUM */ |
| 428 | 2478 } |
| 2479 | |
| 2480 DEFUN ("1+", Fadd1, 1, 1, 0, /* | |
| 2481 Return NUMBER plus one. NUMBER may be a number, character or marker. | |
| 2482 Markers and characters are converted to integers. | |
| 2483 */ | |
| 2484 (number)) | |
| 2485 { | |
| 2486 retry: | |
| 2487 | |
| 1983 | 2488 if (INTP (number)) return make_integer (XINT (number) + 1); |
| 2489 if (CHARP (number)) return make_integer (XCHAR (number) + 1); | |
| 2490 if (MARKERP (number)) return make_integer (marker_position (number) + 1); | |
| 428 | 2491 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0); |
| 1983 | 2492 #ifdef HAVE_BIGNUM |
| 2493 if (BIGNUMP (number)) | |
| 2494 { | |
| 2495 bignum_set_long (scratch_bignum, 1L); | |
| 2496 bignum_add (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum); | |
| 2497 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); | |
| 2498 } | |
| 2499 #endif | |
| 2500 #ifdef HAVE_RATIO | |
| 2501 if (RATIOP (number)) | |
| 2502 { | |
| 2503 ratio_set_long (scratch_ratio, 1L); | |
| 2504 ratio_add (scratch_ratio, XRATIO_DATA (number), scratch_ratio); | |
| 2505 /* No need to canonicalize after adding 1 */ | |
| 2506 return make_ratio_rt (scratch_ratio); | |
| 2507 } | |
| 2508 #endif | |
| 2509 #ifdef HAVE_BIGFLOAT | |
| 2510 if (BIGFLOATP (number)) | |
| 2511 { | |
| 2512 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); | |
| 2513 bigfloat_set_long (scratch_bigfloat, 1L); | |
| 2514 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (number), | |
| 2515 scratch_bigfloat); | |
| 2516 return make_bigfloat_bf (scratch_bigfloat); | |
| 2517 } | |
| 2518 #endif | |
| 428 | 2519 |
| 2520 number = wrong_type_argument (Qnumber_char_or_marker_p, number); | |
| 2521 goto retry; | |
| 2522 } | |
| 2523 | |
| 2524 DEFUN ("1-", Fsub1, 1, 1, 0, /* | |
| 2525 Return NUMBER minus one. NUMBER may be a number, character or marker. | |
| 2526 Markers and characters are converted to integers. | |
| 2527 */ | |
| 2528 (number)) | |
| 2529 { | |
| 2530 retry: | |
| 2531 | |
| 1983 | 2532 if (INTP (number)) return make_integer (XINT (number) - 1); |
| 2533 if (CHARP (number)) return make_integer (XCHAR (number) - 1); | |
| 2534 if (MARKERP (number)) return make_integer (marker_position (number) - 1); | |
| 428 | 2535 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0); |
| 1983 | 2536 #ifdef HAVE_BIGNUM |
| 2537 if (BIGNUMP (number)) | |
| 2538 { | |
| 2539 bignum_set_long (scratch_bignum, 1L); | |
| 2540 bignum_sub (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum); | |
| 2541 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); | |
| 2542 } | |
| 2543 #endif | |
| 2544 #ifdef HAVE_RATIO | |
| 2545 if (RATIOP (number)) | |
| 2546 { | |
| 2547 ratio_set_long (scratch_ratio, 1L); | |
| 2548 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio); | |
| 2549 /* No need to canonicalize after subtracting 1 */ | |
| 2550 return make_ratio_rt (scratch_ratio); | |
| 2551 } | |
| 2552 #endif | |
| 2553 #ifdef HAVE_BIGFLOAT | |
| 2554 if (BIGFLOATP (number)) | |
| 2555 { | |
| 2556 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); | |
| 2557 bigfloat_set_long (scratch_bigfloat, 1L); | |
| 2558 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), | |
| 2559 scratch_bigfloat); | |
| 2560 return make_bigfloat_bf (scratch_bigfloat); | |
| 2561 } | |
| 2562 #endif | |
| 428 | 2563 |
| 2564 number = wrong_type_argument (Qnumber_char_or_marker_p, number); | |
| 2565 goto retry; | |
| 2566 } | |
| 2567 | |
| 2568 | |
| 2569 /************************************************************************/ | |
| 2570 /* weak lists */ | |
| 2571 /************************************************************************/ | |
| 2572 | |
| 2573 /* A weak list is like a normal list except that elements automatically | |
| 2574 disappear when no longer in use, i.e. when no longer GC-protected. | |
| 2575 The basic idea is that we don't mark the elements during GC, but | |
| 2576 wait for them to be marked elsewhere. If they're not marked, we | |
| 2577 remove them. This is analogous to weak hash tables; see the explanation | |
| 2578 there for more info. */ | |
| 2579 | |
| 2580 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ | |
| 2581 | |
| 2582 static Lisp_Object encode_weak_list_type (enum weak_list_type type); | |
| 2583 | |
| 2584 static Lisp_Object | |
| 2286 | 2585 mark_weak_list (Lisp_Object UNUSED (obj)) |
| 428 | 2586 { |
| 2587 return Qnil; /* nichts ist gemarkt */ | |
| 2588 } | |
| 2589 | |
| 2590 static void | |
| 2286 | 2591 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, |
| 2592 int UNUSED (escapeflag)) | |
| 428 | 2593 { |
| 2594 if (print_readably) | |
| 4846 | 2595 printing_unreadable_lcrecord (obj, 0); |
| 428 | 2596 |
| 800 | 2597 write_fmt_string_lisp (printcharfun, "#<weak-list %s %S>", 2, |
| 2598 encode_weak_list_type (XWEAK_LIST (obj)->type), | |
| 2599 XWEAK_LIST (obj)->list); | |
| 428 | 2600 } |
| 2601 | |
| 2602 static int | |
| 2603 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2604 { | |
| 2605 struct weak_list *w1 = XWEAK_LIST (obj1); | |
| 2606 struct weak_list *w2 = XWEAK_LIST (obj2); | |
| 2607 | |
| 2608 return ((w1->type == w2->type) && | |
| 2609 internal_equal (w1->list, w2->list, depth + 1)); | |
| 2610 } | |
| 2611 | |
| 665 | 2612 static Hashcode |
| 428 | 2613 weak_list_hash (Lisp_Object obj, int depth) |
| 2614 { | |
| 2615 struct weak_list *w = XWEAK_LIST (obj); | |
| 2616 | |
| 665 | 2617 return HASH2 ((Hashcode) w->type, |
| 428 | 2618 internal_hash (w->list, depth + 1)); |
| 2619 } | |
| 2620 | |
| 2621 Lisp_Object | |
| 2622 make_weak_list (enum weak_list_type type) | |
| 2623 { | |
| 2624 Lisp_Object result; | |
| 2625 struct weak_list *wl = | |
| 3017 | 2626 ALLOC_LCRECORD_TYPE (struct weak_list, &lrecord_weak_list); |
| 428 | 2627 |
| 2628 wl->list = Qnil; | |
| 2629 wl->type = type; | |
| 793 | 2630 result = wrap_weak_list (wl); |
| 428 | 2631 wl->next_weak = Vall_weak_lists; |
| 2632 Vall_weak_lists = result; | |
| 2633 return result; | |
| 2634 } | |
| 2635 | |
| 1204 | 2636 static const struct memory_description weak_list_description[] = { |
| 1598 | 2637 { XD_LISP_OBJECT, offsetof (struct weak_list, list), |
| 2551 | 2638 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 1598 | 2639 { XD_LO_LINK, offsetof (struct weak_list, next_weak), |
| 2551 | 2640 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 428 | 2641 { XD_END } |
| 2642 }; | |
| 2643 | |
| 934 | 2644 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list, |
| 2645 1, /*dumpable-flag*/ | |
| 2646 mark_weak_list, print_weak_list, | |
| 2647 0, weak_list_equal, weak_list_hash, | |
| 2648 weak_list_description, | |
| 2649 struct weak_list); | |
| 428 | 2650 /* |
| 2651 -- we do not mark the list elements (either the elements themselves | |
| 2652 or the cons cells that hold them) in the normal marking phase. | |
| 2653 -- at the end of marking, we go through all weak lists that are | |
| 2654 marked, and mark the cons cells that hold all marked | |
| 2655 objects, and possibly parts of the objects themselves. | |
| 2656 (See alloc.c, "after-mark".) | |
| 2657 -- after that, we prune away all the cons cells that are not marked. | |
| 2658 | |
| 2659 WARNING WARNING WARNING WARNING WARNING: | |
| 2660 | |
| 2661 The code in the following two functions is *unbelievably* tricky. | |
| 2662 Don't mess with it. You'll be sorry. | |
| 2663 | |
| 2664 Linked lists just majorly suck, d'ya know? | |
| 2665 */ | |
| 2666 | |
| 2667 int | |
| 2668 finish_marking_weak_lists (void) | |
| 2669 { | |
| 2670 Lisp_Object rest; | |
| 2671 int did_mark = 0; | |
| 2672 | |
| 2673 for (rest = Vall_weak_lists; | |
| 2674 !NILP (rest); | |
| 2675 rest = XWEAK_LIST (rest)->next_weak) | |
| 2676 { | |
| 2677 Lisp_Object rest2; | |
| 2678 enum weak_list_type type = XWEAK_LIST (rest)->type; | |
| 2679 | |
| 2680 if (! marked_p (rest)) | |
| 2681 /* The weak list is probably garbage. Ignore it. */ | |
| 2682 continue; | |
| 2683 | |
| 2684 for (rest2 = XWEAK_LIST (rest)->list; | |
| 2685 /* We need to be trickier since we're inside of GC; | |
| 2686 use CONSP instead of !NILP in case of user-visible | |
| 2687 imperfect lists */ | |
| 2688 CONSP (rest2); | |
| 2689 rest2 = XCDR (rest2)) | |
| 2690 { | |
| 2691 Lisp_Object elem; | |
| 2692 /* If the element is "marked" (meaning depends on the type | |
| 2693 of weak list), we need to mark the cons containing the | |
| 2694 element, and maybe the element itself (if only some part | |
| 2695 was already marked). */ | |
| 2696 int need_to_mark_cons = 0; | |
| 2697 int need_to_mark_elem = 0; | |
| 2698 | |
| 2699 /* If a cons is already marked, then its car is already marked | |
| 2700 (either because of an external pointer or because of | |
| 2701 a previous call to this function), and likewise for all | |
| 2702 the rest of the elements in the list, so we can stop now. */ | |
| 2703 if (marked_p (rest2)) | |
| 2704 break; | |
| 2705 | |
| 2706 elem = XCAR (rest2); | |
| 2707 | |
| 2708 switch (type) | |
| 2709 { | |
| 2710 case WEAK_LIST_SIMPLE: | |
| 2711 if (marked_p (elem)) | |
| 2712 need_to_mark_cons = 1; | |
| 2713 break; | |
| 2714 | |
| 2715 case WEAK_LIST_ASSOC: | |
| 2716 if (!CONSP (elem)) | |
| 2717 { | |
| 2718 /* just leave bogus elements there */ | |
| 2719 need_to_mark_cons = 1; | |
| 2720 need_to_mark_elem = 1; | |
| 2721 } | |
| 2722 else if (marked_p (XCAR (elem)) && | |
| 2723 marked_p (XCDR (elem))) | |
| 2724 { | |
| 2725 need_to_mark_cons = 1; | |
| 2726 /* We still need to mark elem, because it's | |
| 2727 probably not marked. */ | |
| 2728 need_to_mark_elem = 1; | |
| 2729 } | |
| 2730 break; | |
| 2731 | |
| 2732 case WEAK_LIST_KEY_ASSOC: | |
| 2733 if (!CONSP (elem)) | |
| 2734 { | |
| 2735 /* just leave bogus elements there */ | |
| 2736 need_to_mark_cons = 1; | |
| 2737 need_to_mark_elem = 1; | |
| 2738 } | |
| 2739 else if (marked_p (XCAR (elem))) | |
| 2740 { | |
| 2741 need_to_mark_cons = 1; | |
| 2742 /* We still need to mark elem and XCDR (elem); | |
| 2743 marking elem does both */ | |
| 2744 need_to_mark_elem = 1; | |
| 2745 } | |
| 2746 break; | |
| 2747 | |
| 2748 case WEAK_LIST_VALUE_ASSOC: | |
| 2749 if (!CONSP (elem)) | |
| 2750 { | |
| 2751 /* just leave bogus elements there */ | |
| 2752 need_to_mark_cons = 1; | |
| 2753 need_to_mark_elem = 1; | |
| 2754 } | |
| 2755 else if (marked_p (XCDR (elem))) | |
| 2756 { | |
| 2757 need_to_mark_cons = 1; | |
| 2758 /* We still need to mark elem and XCAR (elem); | |
| 2759 marking elem does both */ | |
| 2760 need_to_mark_elem = 1; | |
| 2761 } | |
| 2762 break; | |
| 2763 | |
| 442 | 2764 case WEAK_LIST_FULL_ASSOC: |
| 2765 if (!CONSP (elem)) | |
| 2766 { | |
| 2767 /* just leave bogus elements there */ | |
| 2768 need_to_mark_cons = 1; | |
| 2769 need_to_mark_elem = 1; | |
| 2770 } | |
| 2771 else if (marked_p (XCAR (elem)) || | |
| 2772 marked_p (XCDR (elem))) | |
| 2773 { | |
| 2774 need_to_mark_cons = 1; | |
| 2775 /* We still need to mark elem and XCAR (elem); | |
| 2776 marking elem does both */ | |
| 2777 need_to_mark_elem = 1; | |
| 2778 } | |
| 2779 break; | |
| 2780 | |
| 428 | 2781 default: |
| 2500 | 2782 ABORT (); |
| 428 | 2783 } |
| 2784 | |
| 2785 if (need_to_mark_elem && ! marked_p (elem)) | |
| 2786 { | |
| 1598 | 2787 #ifdef USE_KKCC |
| 2645 | 2788 kkcc_gc_stack_push_lisp_object (elem, 0, -1); |
| 1598 | 2789 #else /* NOT USE_KKCC */ |
| 428 | 2790 mark_object (elem); |
| 1598 | 2791 #endif /* NOT USE_KKCC */ |
| 428 | 2792 did_mark = 1; |
| 2793 } | |
| 2794 | |
| 2795 /* We also need to mark the cons that holds the elem or | |
| 2796 assoc-pair. We do *not* want to call (mark_object) here | |
| 2797 because that will mark the entire list; we just want to | |
| 2798 mark the cons itself. | |
| 2799 */ | |
| 2800 if (need_to_mark_cons) | |
| 2801 { | |
| 2802 Lisp_Cons *c = XCONS (rest2); | |
| 2803 if (!CONS_MARKED_P (c)) | |
| 2804 { | |
| 2805 MARK_CONS (c); | |
| 2806 did_mark = 1; | |
| 2807 } | |
| 2808 } | |
| 2809 } | |
| 2810 | |
| 2811 /* In case of imperfect list, need to mark the final cons | |
| 2812 because we're not removing it */ | |
| 2813 if (!NILP (rest2) && ! marked_p (rest2)) | |
| 2814 { | |
| 1598 | 2815 #ifdef USE_KKCC |
| 2645 | 2816 kkcc_gc_stack_push_lisp_object (rest2, 0, -1); |
| 1598 | 2817 #else /* NOT USE_KKCC */ |
| 428 | 2818 mark_object (rest2); |
| 1598 | 2819 #endif /* NOT USE_KKCC */ |
| 428 | 2820 did_mark = 1; |
| 2821 } | |
| 2822 } | |
| 2823 | |
| 2824 return did_mark; | |
| 2825 } | |
| 2826 | |
| 2827 void | |
| 2828 prune_weak_lists (void) | |
| 2829 { | |
| 2830 Lisp_Object rest, prev = Qnil; | |
| 2831 | |
| 2832 for (rest = Vall_weak_lists; | |
| 2833 !NILP (rest); | |
| 2834 rest = XWEAK_LIST (rest)->next_weak) | |
| 2835 { | |
| 2836 if (! (marked_p (rest))) | |
| 2837 { | |
| 2838 /* This weak list itself is garbage. Remove it from the list. */ | |
| 2839 if (NILP (prev)) | |
| 2840 Vall_weak_lists = XWEAK_LIST (rest)->next_weak; | |
| 2841 else | |
| 2842 XWEAK_LIST (prev)->next_weak = | |
| 2843 XWEAK_LIST (rest)->next_weak; | |
| 2844 } | |
| 2845 else | |
| 2846 { | |
| 2847 Lisp_Object rest2, prev2 = Qnil; | |
| 2848 Lisp_Object tortoise; | |
| 2849 int go_tortoise = 0; | |
| 2850 | |
| 2851 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2; | |
| 2852 /* We need to be trickier since we're inside of GC; | |
| 2853 use CONSP instead of !NILP in case of user-visible | |
| 2854 imperfect lists */ | |
| 2855 CONSP (rest2);) | |
| 2856 { | |
| 2857 /* It suffices to check the cons for marking, | |
| 2858 regardless of the type of weak list: | |
| 2859 | |
| 2860 -- if the cons is pointed to somewhere else, | |
| 2861 then it should stay around and will be marked. | |
| 2862 -- otherwise, if it should stay around, it will | |
| 2863 have been marked in finish_marking_weak_lists(). | |
| 2864 -- otherwise, it's not marked and should disappear. | |
| 2865 */ | |
| 2866 if (! marked_p (rest2)) | |
| 2867 { | |
| 2868 /* bye bye :-( */ | |
| 2869 if (NILP (prev2)) | |
| 2870 XWEAK_LIST (rest)->list = XCDR (rest2); | |
| 2871 else | |
| 2872 XCDR (prev2) = XCDR (rest2); | |
| 2873 rest2 = XCDR (rest2); | |
| 2874 /* Ouch. Circularity checking is even trickier | |
| 2875 than I thought. When we cut out a link | |
| 2876 like this, we can't advance the turtle or | |
| 2877 it'll catch up to us. Imagine that we're | |
| 2878 standing on floor tiles and moving forward -- | |
| 2879 what we just did here is as if the floor | |
| 2880 tile under us just disappeared and all the | |
| 2881 ones ahead of us slid one tile towards us. | |
| 2882 In other words, we didn't move at all; | |
| 2883 if the tortoise was one step behind us | |
| 2884 previously, it still is, and therefore | |
| 2885 it must not move. */ | |
| 2886 } | |
| 2887 else | |
| 2888 { | |
| 2889 prev2 = rest2; | |
| 2890 | |
| 2891 /* Implementing circularity checking is trickier here | |
| 2892 than in other places because we have to guarantee | |
| 2893 that we've processed all elements before exiting | |
| 2894 due to a circularity. (In most places, an error | |
| 2895 is issued upon encountering a circularity, so it | |
| 2896 doesn't really matter if all elements are processed.) | |
| 2897 The idea is that we process along with the hare | |
| 2898 rather than the tortoise. If at any point in | |
| 2899 our forward process we encounter the tortoise, | |
| 2900 we must have already visited the spot, so we exit. | |
| 2901 (If we process with the tortoise, we can fail to | |
| 2902 process cases where a cons points to itself, or | |
| 2903 where cons A points to cons B, which points to | |
| 2904 cons A.) */ | |
| 2905 | |
| 2906 rest2 = XCDR (rest2); | |
| 2907 if (go_tortoise) | |
| 2908 tortoise = XCDR (tortoise); | |
| 2909 go_tortoise = !go_tortoise; | |
| 2910 if (EQ (rest2, tortoise)) | |
| 2911 break; | |
| 2912 } | |
| 2913 } | |
| 2914 | |
| 2915 prev = rest; | |
| 2916 } | |
| 2917 } | |
| 2918 } | |
| 2919 | |
| 2920 static enum weak_list_type | |
| 2921 decode_weak_list_type (Lisp_Object symbol) | |
| 2922 { | |
| 2923 CHECK_SYMBOL (symbol); | |
| 2924 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE; | |
| 2925 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC; | |
| 2926 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */ | |
| 2927 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC; | |
| 2928 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC; | |
| 442 | 2929 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC; |
| 428 | 2930 |
| 563 | 2931 invalid_constant ("Invalid weak list type", symbol); |
| 1204 | 2932 RETURN_NOT_REACHED (WEAK_LIST_SIMPLE); |
| 428 | 2933 } |
| 2934 | |
| 2935 static Lisp_Object | |
| 2936 encode_weak_list_type (enum weak_list_type type) | |
| 2937 { | |
| 2938 switch (type) | |
| 2939 { | |
| 2940 case WEAK_LIST_SIMPLE: return Qsimple; | |
| 2941 case WEAK_LIST_ASSOC: return Qassoc; | |
| 2942 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc; | |
| 2943 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc; | |
| 442 | 2944 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc; |
| 428 | 2945 default: |
| 2500 | 2946 ABORT (); |
| 428 | 2947 } |
| 2948 | |
| 801 | 2949 return Qnil; /* not (usually) reached */ |
| 428 | 2950 } |
| 2951 | |
| 2952 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /* | |
| 2953 Return non-nil if OBJECT is a weak list. | |
| 2954 */ | |
| 2955 (object)) | |
| 2956 { | |
| 2957 return WEAK_LISTP (object) ? Qt : Qnil; | |
| 2958 } | |
| 2959 | |
| 2960 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /* | |
| 2961 Return a new weak list object of type TYPE. | |
| 2962 A weak list object is an object that contains a list. This list behaves | |
| 2963 like any other list except that its elements do not count towards | |
| 456 | 2964 garbage collection -- if the only pointer to an object is inside a weak |
| 428 | 2965 list (other than pointers in similar objects such as weak hash tables), |
| 2966 the object is garbage collected and automatically removed from the list. | |
| 2967 This is used internally, for example, to manage the list holding the | |
| 2968 children of an extent -- an extent that is unused but has a parent will | |
| 2969 still be reclaimed, and will automatically be removed from its parent's | |
| 2970 list of children. | |
| 2971 | |
| 2972 Optional argument TYPE specifies the type of the weak list, and defaults | |
| 2973 to `simple'. Recognized types are | |
| 2974 | |
| 2975 `simple' Objects in the list disappear if not pointed to. | |
| 2976 `assoc' Objects in the list disappear if they are conses | |
| 2977 and either the car or the cdr of the cons is not | |
| 2978 pointed to. | |
| 2979 `key-assoc' Objects in the list disappear if they are conses | |
| 2980 and the car is not pointed to. | |
| 2981 `value-assoc' Objects in the list disappear if they are conses | |
| 2982 and the cdr is not pointed to. | |
| 442 | 2983 `full-assoc' Objects in the list disappear if they are conses |
| 2984 and neither the car nor the cdr is pointed to. | |
| 428 | 2985 */ |
| 2986 (type)) | |
| 2987 { | |
| 2988 if (NILP (type)) | |
| 2989 type = Qsimple; | |
| 2990 | |
| 2991 return make_weak_list (decode_weak_list_type (type)); | |
| 2992 } | |
| 2993 | |
| 2994 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /* | |
| 2995 Return the type of the given weak-list object. | |
| 2996 */ | |
| 2997 (weak)) | |
| 2998 { | |
| 2999 CHECK_WEAK_LIST (weak); | |
| 3000 return encode_weak_list_type (XWEAK_LIST (weak)->type); | |
| 3001 } | |
| 3002 | |
| 3003 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /* | |
| 3004 Return the list contained in a weak-list object. | |
| 3005 */ | |
| 3006 (weak)) | |
| 3007 { | |
| 3008 CHECK_WEAK_LIST (weak); | |
| 3009 return XWEAK_LIST_LIST (weak); | |
| 3010 } | |
| 3011 | |
| 3012 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /* | |
| 3013 Change the list contained in a weak-list object. | |
| 3014 */ | |
| 3015 (weak, new_list)) | |
| 3016 { | |
| 3017 CHECK_WEAK_LIST (weak); | |
| 3018 XWEAK_LIST_LIST (weak) = new_list; | |
| 3019 return new_list; | |
| 3020 } | |
| 3021 | |
| 888 | 3022 |
| 858 | 3023 /************************************************************************/ |
| 3024 /* weak boxes */ | |
| 3025 /************************************************************************/ | |
| 3026 | |
| 3027 static Lisp_Object Vall_weak_boxes; /* Gemarke es niemals ever!!! */ | |
| 3028 | |
| 3029 void | |
| 3030 prune_weak_boxes (void) | |
| 3031 { | |
| 3032 Lisp_Object rest, prev = Qnil; | |
| 888 | 3033 int removep = 0; |
| 858 | 3034 |
| 3035 for (rest = Vall_weak_boxes; | |
| 3036 !NILP(rest); | |
| 3037 rest = XWEAK_BOX (rest)->next_weak_box) | |
| 3038 { | |
| 3039 if (! (marked_p (rest))) | |
| 888 | 3040 /* This weak box itself is garbage. */ |
| 3041 removep = 1; | |
| 3042 | |
| 3043 if (! marked_p (XWEAK_BOX (rest)->value)) | |
| 3044 { | |
| 3045 XSET_WEAK_BOX (rest, Qnil); | |
| 3046 removep = 1; | |
| 3047 } | |
| 3048 | |
| 3049 if (removep) | |
| 3050 { | |
| 3051 /* Remove weak box from list. */ | |
| 3052 if (NILP (prev)) | |
| 3053 Vall_weak_boxes = XWEAK_BOX (rest)->next_weak_box; | |
| 3054 else | |
| 3055 XWEAK_BOX (prev)->next_weak_box = XWEAK_BOX (rest)->next_weak_box; | |
| 3056 removep = 0; | |
| 3057 } | |
| 3058 else | |
| 3059 prev = rest; | |
| 858 | 3060 } |
| 3061 } | |
| 3062 | |
| 3063 static Lisp_Object | |
| 2286 | 3064 mark_weak_box (Lisp_Object UNUSED (obj)) |
| 858 | 3065 { |
| 3066 return Qnil; | |
| 3067 } | |
| 3068 | |
| 3069 static void | |
| 4846 | 3070 print_weak_box (Lisp_Object obj, Lisp_Object printcharfun, |
| 2286 | 3071 int UNUSED (escapeflag)) |
| 858 | 3072 { |
| 3073 if (print_readably) | |
| 4846 | 3074 printing_unreadable_lcrecord (obj, 0); |
| 3075 write_fmt_string (printcharfun, "#<weak-box>"); /* #### fix */ | |
| 858 | 3076 } |
| 3077 | |
| 3078 static int | |
| 3079 weak_box_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 3080 { | |
| 888 | 3081 struct weak_box *wb1 = XWEAK_BOX (obj1); |
| 3082 struct weak_box *wb2 = XWEAK_BOX (obj2); | |
| 858 | 3083 |
| 888 | 3084 return (internal_equal (wb1->value, wb2->value, depth + 1)); |
| 858 | 3085 } |
| 3086 | |
| 3087 static Hashcode | |
| 3088 weak_box_hash (Lisp_Object obj, int depth) | |
| 3089 { | |
| 888 | 3090 struct weak_box *wb = XWEAK_BOX (obj); |
| 858 | 3091 |
| 888 | 3092 return internal_hash (wb->value, depth + 1); |
| 858 | 3093 } |
| 3094 | |
| 3095 Lisp_Object | |
| 3096 make_weak_box (Lisp_Object value) | |
| 3097 { | |
| 3098 Lisp_Object result; | |
| 3099 | |
| 3100 struct weak_box *wb = | |
| 3017 | 3101 ALLOC_LCRECORD_TYPE (struct weak_box, &lrecord_weak_box); |
| 858 | 3102 |
| 3103 wb->value = value; | |
| 3104 result = wrap_weak_box (wb); | |
| 3105 wb->next_weak_box = Vall_weak_boxes; | |
| 3106 Vall_weak_boxes = result; | |
| 3107 return result; | |
| 3108 } | |
| 3109 | |
| 1204 | 3110 static const struct memory_description weak_box_description[] = { |
| 858 | 3111 { XD_LO_LINK, offsetof (struct weak_box, value) }, |
| 888 | 3112 { XD_END} |
| 858 | 3113 }; |
| 3114 | |
| 934 | 3115 DEFINE_LRECORD_IMPLEMENTATION ("weak_box", weak_box, |
| 3116 0, /*dumpable-flag*/ | |
| 3117 mark_weak_box, print_weak_box, | |
| 3118 0, weak_box_equal, weak_box_hash, | |
| 3119 weak_box_description, | |
| 3120 struct weak_box); | |
| 858 | 3121 |
| 3122 DEFUN ("make-weak-box", Fmake_weak_box, 1, 1, 0, /* | |
| 3123 Return a new weak box from value CONTENTS. | |
| 3124 The weak box is a reference to CONTENTS which may be extracted with | |
| 3125 `weak-box-ref'. However, the weak box does not contribute to the | |
| 3126 reachability of CONTENTS. When CONTENTS is garbage-collected, | |
| 3127 `weak-box-ref' will return NIL. | |
| 3128 */ | |
| 3129 (value)) | |
| 3130 { | |
| 3131 return make_weak_box(value); | |
| 3132 } | |
| 3133 | |
| 3134 DEFUN ("weak-box-ref", Fweak_box_ref, 1, 1, 0, /* | |
| 3135 Return the contents of weak box WEAK-BOX. | |
| 3136 If the contents have been GCed, return NIL. | |
| 3137 */ | |
| 888 | 3138 (wb)) |
| 858 | 3139 { |
| 888 | 3140 return XWEAK_BOX (wb)->value; |
| 858 | 3141 } |
| 3142 | |
| 3143 DEFUN ("weak-box-p", Fweak_boxp, 1, 1, 0, /* | |
| 3144 Return non-nil if OBJECT is a weak box. | |
| 3145 */ | |
| 3146 (object)) | |
| 3147 { | |
| 3148 return WEAK_BOXP (object) ? Qt : Qnil; | |
| 3149 } | |
| 3150 | |
| 888 | 3151 /************************************************************************/ |
| 3152 /* ephemerons */ | |
| 3153 /************************************************************************/ | |
| 3154 | |
| 993 | 3155 /* The concept of ephemerons is due to: |
| 3156 * Barry Hayes: Ephemerons: A New Finalization Mechanism. OOPSLA 1997: 176-183 | |
| 3157 * The original idea is due to George Bosworth of Digitalk, Inc. | |
| 3158 * | |
| 3159 * For a discussion of finalization and weakness that also reviews | |
| 3160 * ephemerons, refer to: | |
| 3161 * Simon Peyton Jones, Simon Marlow, Conal Elliot: | |
| 3162 * Stretching the storage manager | |
| 3163 * Implementation of Functional Languages, 1999 | |
| 3164 */ | |
| 3165 | |
| 888 | 3166 static Lisp_Object Vall_ephemerons; /* Gemarke es niemals ever!!! */ |
| 1590 | 3167 static Lisp_Object Vnew_all_ephemerons; |
| 888 | 3168 static Lisp_Object Vfinalize_list; |
| 3169 | |
| 1590 | 3170 void |
| 3171 init_marking_ephemerons(void) | |
| 3172 { | |
| 3173 Vnew_all_ephemerons = Qnil; | |
| 3174 } | |
| 3175 | |
| 3176 /* Move all live ephemerons with live keys over to | |
| 3177 * Vnew_all_ephemerons, marking the values and finalizers along the | |
| 3178 * way. */ | |
| 3179 | |
| 3180 int | |
| 3181 continue_marking_ephemerons(void) | |
| 3182 { | |
| 3183 Lisp_Object rest = Vall_ephemerons, next, prev = Qnil; | |
| 3184 int did_mark = 0; | |
| 3185 | |
| 3186 while (!NILP (rest)) | |
| 3187 { | |
| 3188 next = XEPHEMERON_NEXT (rest); | |
| 3189 | |
| 3190 if (marked_p (rest)) | |
| 3191 { | |
| 3192 MARK_CONS (XCONS (XEPHEMERON (rest)->cons_chain)); | |
| 3193 if (marked_p (XEPHEMERON (rest)->key)) | |
| 3194 { | |
| 1598 | 3195 #ifdef USE_KKCC |
| 3196 kkcc_gc_stack_push_lisp_object | |
| 2645 | 3197 (XCAR (XEPHEMERON (rest)->cons_chain), 0, -1); |
| 1598 | 3198 #else /* NOT USE_KKCC */ |
| 1590 | 3199 mark_object (XCAR (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3200 #endif /* NOT USE_KKCC */ |
| 1590 | 3201 did_mark = 1; |
| 3202 XSET_EPHEMERON_NEXT (rest, Vnew_all_ephemerons); | |
| 3203 Vnew_all_ephemerons = rest; | |
| 3204 if (NILP (prev)) | |
| 3205 Vall_ephemerons = next; | |
| 3206 else | |
| 3207 XSET_EPHEMERON_NEXT (prev, next); | |
| 3208 } | |
| 3209 else | |
| 3210 prev = rest; | |
| 3211 } | |
| 3212 else | |
| 3213 prev = rest; | |
| 3214 | |
| 3215 rest = next; | |
| 3216 } | |
| 3217 | |
| 3218 return did_mark; | |
| 3219 } | |
| 3220 | |
| 3221 /* At this point, everything that's in Vall_ephemerons is dead. | |
| 3222 * Well, almost: we still need to run the finalizers, so we need to | |
| 3223 * resurrect them. | |
| 3224 */ | |
| 3225 | |
| 888 | 3226 int |
| 3227 finish_marking_ephemerons(void) | |
| 3228 { | |
| 1590 | 3229 Lisp_Object rest = Vall_ephemerons, next, prev = Qnil; |
| 888 | 3230 int did_mark = 0; |
| 3231 | |
| 3232 while (! NILP (rest)) | |
| 3233 { | |
| 3234 next = XEPHEMERON_NEXT (rest); | |
| 3235 | |
| 3236 if (marked_p (rest)) | |
| 1590 | 3237 /* The ephemeron itself is live, but its key is garbage */ |
| 888 | 3238 { |
| 1590 | 3239 /* tombstone */ |
| 3240 XSET_EPHEMERON_VALUE (rest, Qnil); | |
| 3241 | |
| 3242 if (! NILP (XEPHEMERON_FINALIZER (rest))) | |
| 888 | 3243 { |
| 1590 | 3244 MARK_CONS (XCONS (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3245 #ifdef USE_KKCC |
| 3246 kkcc_gc_stack_push_lisp_object | |
| 2645 | 3247 (XCAR (XEPHEMERON (rest)->cons_chain), 0, -1); |
| 1598 | 3248 #else /* NOT USE_KKCC */ |
| 1590 | 3249 mark_object (XCAR (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3250 #endif /* NOT USE_KKCC */ |
| 1590 | 3251 |
| 3252 /* Register the finalizer */ | |
| 3253 XSET_EPHEMERON_NEXT (rest, Vfinalize_list); | |
| 3254 Vfinalize_list = XEPHEMERON (rest)->cons_chain; | |
| 3255 did_mark = 1; | |
| 888 | 3256 } |
| 3257 | |
| 3258 /* Remove it from the list. */ | |
| 3259 if (NILP (prev)) | |
| 3260 Vall_ephemerons = next; | |
| 3261 else | |
| 3262 XSET_EPHEMERON_NEXT (prev, next); | |
| 3263 } | |
| 3264 else | |
| 3265 prev = rest; | |
| 3266 | |
| 3267 rest = next; | |
| 3268 } | |
| 1590 | 3269 |
| 3270 return did_mark; | |
| 3271 } | |
| 3272 | |
| 3273 void | |
| 3274 prune_ephemerons(void) | |
| 3275 { | |
| 3276 Vall_ephemerons = Vnew_all_ephemerons; | |
| 888 | 3277 } |
| 3278 | |
| 3279 Lisp_Object | |
| 3280 zap_finalize_list(void) | |
| 3281 { | |
| 3282 Lisp_Object finalizers = Vfinalize_list; | |
| 3283 | |
| 3284 Vfinalize_list = Qnil; | |
| 3285 | |
| 3286 return finalizers; | |
| 3287 } | |
| 3288 | |
| 3289 static Lisp_Object | |
| 2286 | 3290 mark_ephemeron (Lisp_Object UNUSED (obj)) |
| 888 | 3291 { |
| 3292 return Qnil; | |
| 3293 } | |
| 3294 | |
| 3295 static void | |
| 4846 | 3296 print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun, |
| 2286 | 3297 int UNUSED (escapeflag)) |
| 888 | 3298 { |
| 3299 if (print_readably) | |
| 4846 | 3300 printing_unreadable_lcrecord (obj, 0); |
| 3301 write_fmt_string (printcharfun, "#<ephemeron>"); /* #### fix */ | |
| 888 | 3302 } |
| 3303 | |
| 3304 static int | |
| 3305 ephemeron_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 3306 { | |
| 3307 return | |
| 3308 internal_equal (XEPHEMERON_REF (obj1), XEPHEMERON_REF(obj2), depth + 1); | |
| 3309 } | |
| 3310 | |
| 3311 static Hashcode | |
| 3312 ephemeron_hash(Lisp_Object obj, int depth) | |
| 3313 { | |
| 3314 return internal_hash (XEPHEMERON_REF (obj), depth + 1); | |
| 3315 } | |
| 3316 | |
| 3317 Lisp_Object | |
| 3318 make_ephemeron(Lisp_Object key, Lisp_Object value, Lisp_Object finalizer) | |
| 3319 { | |
| 3320 Lisp_Object result, temp = Qnil; | |
| 3321 struct gcpro gcpro1, gcpro2; | |
| 3322 | |
| 3323 struct ephemeron *eph = | |
| 3017 | 3324 ALLOC_LCRECORD_TYPE (struct ephemeron, &lrecord_ephemeron); |
| 888 | 3325 |
| 3326 eph->key = Qnil; | |
| 3327 eph->cons_chain = Qnil; | |
| 3328 eph->value = Qnil; | |
| 3329 | |
| 3330 result = wrap_ephemeron(eph); | |
| 3331 GCPRO2 (result, temp); | |
| 3332 | |
| 3333 eph->key = key; | |
| 3334 temp = Fcons(value, finalizer); | |
| 3335 eph->cons_chain = Fcons(temp, Vall_ephemerons); | |
| 3336 eph->value = value; | |
| 3337 | |
| 3338 Vall_ephemerons = result; | |
| 3339 | |
| 3340 UNGCPRO; | |
| 3341 return result; | |
| 3342 } | |
| 3343 | |
| 1598 | 3344 /* Ephemerons are special cases in the KKCC mark algorithm, so nothing |
| 3345 is marked here. */ | |
| 1204 | 3346 static const struct memory_description ephemeron_description[] = { |
| 3347 { XD_LISP_OBJECT, offsetof(struct ephemeron, key), | |
| 2551 | 3348 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 1204 | 3349 { XD_LISP_OBJECT, offsetof(struct ephemeron, cons_chain), |
| 2551 | 3350 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 1204 | 3351 { XD_LISP_OBJECT, offsetof(struct ephemeron, value), |
| 2551 | 3352 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 888 | 3353 { XD_END } |
| 3354 }; | |
| 3355 | |
| 934 | 3356 DEFINE_LRECORD_IMPLEMENTATION ("ephemeron", ephemeron, |
| 3357 0, /*dumpable-flag*/ | |
| 3358 mark_ephemeron, print_ephemeron, | |
| 3359 0, ephemeron_equal, ephemeron_hash, | |
| 3360 ephemeron_description, | |
| 3361 struct ephemeron); | |
| 888 | 3362 |
| 3363 DEFUN ("make-ephemeron", Fmake_ephemeron, 2, 3, 0, /* | |
| 1590 | 3364 Return a new ephemeron with key KEY, value VALUE, and finalizer FINALIZER. |
| 3365 The ephemeron is a reference to VALUE which may be extracted with | |
| 3366 `ephemeron-ref'. VALUE is only reachable through the ephemeron as | |
| 888 | 3367 long as KEY is reachable; the ephemeron does not contribute to the |
| 3368 reachability of KEY. When KEY becomes unreachable while the ephemeron | |
| 1590 | 3369 itself is still reachable, VALUE is queued for finalization: FINALIZER |
| 3370 will possibly be called on VALUE some time in the future. Moreover, | |
| 888 | 3371 future calls to `ephemeron-ref' will return NIL. |
| 3372 */ | |
| 3373 (key, value, finalizer)) | |
| 3374 { | |
| 3375 return make_ephemeron(key, value, finalizer); | |
| 3376 } | |
| 3377 | |
| 3378 DEFUN ("ephemeron-ref", Fephemeron_ref, 1, 1, 0, /* | |
| 3379 Return the contents of ephemeron EPHEMERON. | |
| 3380 If the contents have been GCed, return NIL. | |
| 3381 */ | |
| 3382 (eph)) | |
| 3383 { | |
| 3384 return XEPHEMERON_REF (eph); | |
| 3385 } | |
| 3386 | |
| 3387 DEFUN ("ephemeron-p", Fephemeronp, 1, 1, 0, /* | |
| 3388 Return non-nil if OBJECT is an ephemeron. | |
| 3389 */ | |
| 3390 (object)) | |
| 3391 { | |
| 3392 return EPHEMERONP (object) ? Qt : Qnil; | |
| 3393 } | |
| 428 | 3394 |
| 3395 /************************************************************************/ | |
| 3396 /* initialization */ | |
| 3397 /************************************************************************/ | |
| 3398 | |
| 3399 static SIGTYPE | |
| 3400 arith_error (int signo) | |
| 3401 { | |
| 3402 EMACS_REESTABLISH_SIGNAL (signo, arith_error); | |
| 3403 EMACS_UNBLOCK_SIGNAL (signo); | |
| 563 | 3404 signal_error (Qarith_error, 0, Qunbound); |
| 428 | 3405 } |
| 3406 | |
| 3407 void | |
| 3408 init_data_very_early (void) | |
| 3409 { | |
| 3410 /* Don't do this if just dumping out. | |
| 3411 We don't want to call `signal' in this case | |
| 3412 so that we don't have trouble with dumping | |
| 3413 signal-delivering routines in an inconsistent state. */ | |
| 3414 if (!initialized) | |
| 3415 return; | |
| 613 | 3416 EMACS_SIGNAL (SIGFPE, arith_error); |
| 428 | 3417 #ifdef uts |
| 613 | 3418 EMACS_SIGNAL (SIGEMT, arith_error); |
| 428 | 3419 #endif /* uts */ |
| 3420 } | |
| 3421 | |
| 3422 void | |
| 3423 init_errors_once_early (void) | |
| 3424 { | |
| 442 | 3425 DEFSYMBOL (Qerror_conditions); |
| 3426 DEFSYMBOL (Qerror_message); | |
| 428 | 3427 |
| 3428 /* We declare the errors here because some other deferrors depend | |
| 3429 on some of the errors below. */ | |
| 3430 | |
| 3431 /* ERROR is used as a signaler for random errors for which nothing | |
| 3432 else is right */ | |
| 3433 | |
| 442 | 3434 DEFERROR (Qerror, "error", Qnil); |
| 3435 DEFERROR_STANDARD (Qquit, Qnil); | |
| 428 | 3436 |
| 563 | 3437 DEFERROR_STANDARD (Qinvalid_argument, Qerror); |
| 3438 | |
| 3439 DEFERROR_STANDARD (Qsyntax_error, Qinvalid_argument); | |
| 442 | 3440 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error); |
| 563 | 3441 DEFERROR_STANDARD (Qstructure_formation_error, Qsyntax_error); |
| 3442 DEFERROR_STANDARD (Qlist_formation_error, Qstructure_formation_error); | |
| 442 | 3443 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error); |
| 3444 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list); | |
| 3445 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error); | |
| 3446 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list); | |
| 428 | 3447 |
| 442 | 3448 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument); |
| 3449 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument); | |
| 3450 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument); | |
| 3451 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument); | |
| 563 | 3452 DEFERROR_STANDARD (Qinvalid_constant, Qinvalid_argument); |
| 442 | 3453 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument); |
| 3454 | |
| 563 | 3455 DEFERROR_STANDARD (Qinvalid_state, Qerror); |
| 442 | 3456 DEFERROR (Qvoid_function, "Symbol's function definition is void", |
| 3457 Qinvalid_state); | |
| 3458 DEFERROR (Qcyclic_function_indirection, | |
| 3459 "Symbol's chain of function indirections contains a loop", | |
| 3460 Qinvalid_state); | |
| 3461 DEFERROR (Qvoid_variable, "Symbol's value as variable is void", | |
| 3462 Qinvalid_state); | |
| 3463 DEFERROR (Qcyclic_variable_indirection, | |
| 3464 "Symbol's chain of variable indirections contains a loop", | |
| 3465 Qinvalid_state); | |
| 563 | 3466 DEFERROR_STANDARD (Qstack_overflow, Qinvalid_state); |
| 3467 DEFERROR_STANDARD (Qinternal_error, Qinvalid_state); | |
| 3468 DEFERROR_STANDARD (Qout_of_memory, Qinvalid_state); | |
| 428 | 3469 |
| 563 | 3470 DEFERROR_STANDARD (Qinvalid_operation, Qerror); |
| 3471 DEFERROR_STANDARD (Qinvalid_change, Qinvalid_operation); | |
| 442 | 3472 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol", |
| 3473 Qinvalid_change); | |
| 563 | 3474 DEFERROR_STANDARD (Qprinting_unreadable_object, Qinvalid_operation); |
| 3475 DEFERROR (Qunimplemented, "Feature not yet implemented", Qinvalid_operation); | |
| 442 | 3476 |
| 563 | 3477 DEFERROR_STANDARD (Qediting_error, Qinvalid_operation); |
| 442 | 3478 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error); |
| 3479 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error); | |
| 3480 DEFERROR (Qbuffer_read_only, "Buffer is read-only", Qediting_error); | |
| 3481 | |
| 3482 DEFERROR (Qio_error, "IO Error", Qinvalid_operation); | |
| 563 | 3483 DEFERROR_STANDARD (Qfile_error, Qio_error); |
| 3484 DEFERROR (Qend_of_file, "End of file or stream", Qfile_error); | |
| 3485 DEFERROR_STANDARD (Qconversion_error, Qio_error); | |
| 580 | 3486 DEFERROR_STANDARD (Qtext_conversion_error, Qconversion_error); |
| 442 | 3487 |
| 3488 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation); | |
| 3489 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error); | |
| 3490 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error); | |
| 3491 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error); | |
| 3492 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error); | |
| 3493 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error); | |
| 428 | 3494 } |
| 3495 | |
| 3496 void | |
| 3497 syms_of_data (void) | |
| 3498 { | |
| 442 | 3499 INIT_LRECORD_IMPLEMENTATION (weak_list); |
| 888 | 3500 INIT_LRECORD_IMPLEMENTATION (ephemeron); |
| 858 | 3501 INIT_LRECORD_IMPLEMENTATION (weak_box); |
| 442 | 3502 |
| 3503 DEFSYMBOL (Qquote); | |
| 3504 DEFSYMBOL (Qlambda); | |
| 3505 DEFSYMBOL (Qlistp); | |
| 3506 DEFSYMBOL (Qtrue_list_p); | |
| 3507 DEFSYMBOL (Qconsp); | |
| 3508 DEFSYMBOL (Qsubrp); | |
| 3509 DEFSYMBOL (Qsymbolp); | |
| 3510 DEFSYMBOL (Qintegerp); | |
| 3511 DEFSYMBOL (Qcharacterp); | |
| 3512 DEFSYMBOL (Qnatnump); | |
| 1983 | 3513 DEFSYMBOL (Qnonnegativep); |
| 442 | 3514 DEFSYMBOL (Qstringp); |
| 3515 DEFSYMBOL (Qarrayp); | |
| 3516 DEFSYMBOL (Qsequencep); | |
| 3517 DEFSYMBOL (Qbufferp); | |
| 3518 DEFSYMBOL (Qbitp); | |
| 3519 DEFSYMBOL_MULTIWORD_PREDICATE (Qbit_vectorp); | |
| 3520 DEFSYMBOL (Qvectorp); | |
| 3521 DEFSYMBOL (Qchar_or_string_p); | |
| 3522 DEFSYMBOL (Qmarkerp); | |
| 3523 DEFSYMBOL (Qinteger_or_marker_p); | |
| 3524 DEFSYMBOL (Qinteger_or_char_p); | |
| 3525 DEFSYMBOL (Qinteger_char_or_marker_p); | |
| 3526 DEFSYMBOL (Qnumberp); | |
| 3527 DEFSYMBOL (Qnumber_char_or_marker_p); | |
| 3528 DEFSYMBOL (Qcdr); | |
| 563 | 3529 DEFSYMBOL (Qerror_lacks_explanatory_string); |
| 442 | 3530 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp); |
| 3531 DEFSYMBOL (Qfloatp); | |
| 428 | 3532 |
| 3533 DEFSUBR (Fwrong_type_argument); | |
| 3534 | |
| 1983 | 3535 #ifdef HAVE_RATIO |
| 3536 DEFSUBR (Fdiv); | |
| 3537 #endif | |
| 428 | 3538 DEFSUBR (Feq); |
| 3539 DEFSUBR (Fold_eq); | |
| 3540 DEFSUBR (Fnull); | |
| 3541 Ffset (intern ("not"), intern ("null")); | |
| 3542 DEFSUBR (Flistp); | |
| 3543 DEFSUBR (Fnlistp); | |
| 3544 DEFSUBR (Ftrue_list_p); | |
| 3545 DEFSUBR (Fconsp); | |
| 3546 DEFSUBR (Fatom); | |
| 3547 DEFSUBR (Fchar_or_string_p); | |
| 3548 DEFSUBR (Fcharacterp); | |
| 3549 DEFSUBR (Fchar_int_p); | |
| 3550 DEFSUBR (Fchar_to_int); | |
| 3551 DEFSUBR (Fint_to_char); | |
| 3552 DEFSUBR (Fchar_or_char_int_p); | |
| 1983 | 3553 #ifdef HAVE_BIGNUM |
| 3554 DEFSUBR (Ffixnump); | |
| 3555 #else | |
| 428 | 3556 DEFSUBR (Fintegerp); |
| 1983 | 3557 #endif |
| 428 | 3558 DEFSUBR (Finteger_or_marker_p); |
| 3559 DEFSUBR (Finteger_or_char_p); | |
| 3560 DEFSUBR (Finteger_char_or_marker_p); | |
| 3561 DEFSUBR (Fnumberp); | |
| 3562 DEFSUBR (Fnumber_or_marker_p); | |
| 3563 DEFSUBR (Fnumber_char_or_marker_p); | |
| 3564 DEFSUBR (Ffloatp); | |
| 3565 DEFSUBR (Fnatnump); | |
| 1983 | 3566 DEFSUBR (Fnonnegativep); |
| 428 | 3567 DEFSUBR (Fsymbolp); |
| 3568 DEFSUBR (Fkeywordp); | |
| 3569 DEFSUBR (Fstringp); | |
| 3570 DEFSUBR (Fvectorp); | |
| 3571 DEFSUBR (Fbitp); | |
| 3572 DEFSUBR (Fbit_vector_p); | |
| 3573 DEFSUBR (Farrayp); | |
| 3574 DEFSUBR (Fsequencep); | |
| 3575 DEFSUBR (Fmarkerp); | |
| 3576 DEFSUBR (Fsubrp); | |
| 3577 DEFSUBR (Fsubr_min_args); | |
| 3578 DEFSUBR (Fsubr_max_args); | |
| 3579 DEFSUBR (Fsubr_interactive); | |
| 3580 DEFSUBR (Ftype_of); | |
| 3581 DEFSUBR (Fcar); | |
| 3582 DEFSUBR (Fcdr); | |
| 3583 DEFSUBR (Fcar_safe); | |
| 3584 DEFSUBR (Fcdr_safe); | |
| 3585 DEFSUBR (Fsetcar); | |
| 3586 DEFSUBR (Fsetcdr); | |
| 3587 DEFSUBR (Findirect_function); | |
| 3588 DEFSUBR (Faref); | |
| 3589 DEFSUBR (Faset); | |
| 3590 | |
| 3591 DEFSUBR (Fnumber_to_string); | |
| 3592 DEFSUBR (Fstring_to_number); | |
| 3593 DEFSUBR (Feqlsign); | |
| 3594 DEFSUBR (Flss); | |
| 3595 DEFSUBR (Fgtr); | |
| 3596 DEFSUBR (Fleq); | |
| 3597 DEFSUBR (Fgeq); | |
| 3598 DEFSUBR (Fneq); | |
| 3599 DEFSUBR (Fzerop); | |
| 3600 DEFSUBR (Fplus); | |
| 3601 DEFSUBR (Fminus); | |
| 3602 DEFSUBR (Ftimes); | |
| 3603 DEFSUBR (Fquo); | |
| 3604 DEFSUBR (Frem); | |
| 3605 DEFSUBR (Fmod); | |
| 3606 DEFSUBR (Fmax); | |
| 3607 DEFSUBR (Fmin); | |
| 3608 DEFSUBR (Flogand); | |
| 3609 DEFSUBR (Flogior); | |
| 3610 DEFSUBR (Flogxor); | |
| 3611 DEFSUBR (Flsh); | |
| 3612 DEFSUBR (Fash); | |
| 3613 DEFSUBR (Fadd1); | |
| 3614 DEFSUBR (Fsub1); | |
| 3615 DEFSUBR (Flognot); | |
| 3616 | |
| 3617 DEFSUBR (Fweak_list_p); | |
| 3618 DEFSUBR (Fmake_weak_list); | |
| 3619 DEFSUBR (Fweak_list_type); | |
| 3620 DEFSUBR (Fweak_list_list); | |
| 3621 DEFSUBR (Fset_weak_list_list); | |
| 858 | 3622 |
| 888 | 3623 DEFSUBR (Fmake_ephemeron); |
| 3624 DEFSUBR (Fephemeron_ref); | |
| 3625 DEFSUBR (Fephemeronp); | |
| 858 | 3626 DEFSUBR (Fmake_weak_box); |
| 3627 DEFSUBR (Fweak_box_ref); | |
| 3628 DEFSUBR (Fweak_boxp); | |
| 428 | 3629 } |
| 3630 | |
| 3631 void | |
| 3632 vars_of_data (void) | |
| 3633 { | |
| 3634 /* This must not be staticpro'd */ | |
| 3635 Vall_weak_lists = Qnil; | |
| 452 | 3636 dump_add_weak_object_chain (&Vall_weak_lists); |
| 428 | 3637 |
| 888 | 3638 Vall_ephemerons = Qnil; |
| 3639 dump_add_weak_object_chain (&Vall_ephemerons); | |
| 3640 | |
| 3641 Vfinalize_list = Qnil; | |
| 3642 staticpro (&Vfinalize_list); | |
| 3643 | |
| 858 | 3644 Vall_weak_boxes = Qnil; |
| 3645 dump_add_weak_object_chain (&Vall_weak_boxes); | |
| 3646 | |
| 428 | 3647 #ifdef DEBUG_XEMACS |
| 3648 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* | |
| 3649 If non-zero, note when your code may be suffering from char-int confoundance. | |
| 3650 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', | |
| 3651 etc. where an int and a char with the same value are being compared, | |
| 3652 it will issue a notice on stderr to this effect, along with a backtrace. | |
| 3653 In such situations, the result would be different in XEmacs 19 versus | |
| 3654 XEmacs 20, and you probably don't want this. | |
| 3655 | |
| 3656 Note that in order to see these notices, you have to byte compile your | |
| 3657 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will | |
| 3658 have its chars and ints all confounded in the byte code, making it | |
| 3659 impossible to accurately determine Ebola infection. | |
| 3660 */ ); | |
| 3661 | |
| 3662 debug_issue_ebola_notices = 0; | |
| 3663 | |
| 3664 DEFVAR_INT ("debug-ebola-backtrace-length", | |
| 3665 &debug_ebola_backtrace_length /* | |
| 3666 Length (in stack frames) of short backtrace printed out in Ebola notices. | |
| 3667 See `debug-issue-ebola-notices'. | |
| 3668 */ ); | |
| 3669 debug_ebola_backtrace_length = 32; | |
| 3670 | |
| 3671 #endif /* DEBUG_XEMACS */ | |
| 3672 } |