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