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