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