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