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