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