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.
563
+ − 4 Copyright (C) 2000, 2001 Ben Wing.
428
+ − 5
+ − 6 This file is part of XEmacs.
+ − 7
+ − 8 XEmacs is free software; you can redistribute it and/or modify it
+ − 9 under the terms of the GNU General Public License as published by the
+ − 10 Free Software Foundation; either version 2, or (at your option) any
+ − 11 later version.
+ − 12
+ − 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ − 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ − 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ − 16 for more details.
+ − 17
+ − 18 You should have received a copy of the GNU General Public License
+ − 19 along with XEmacs; see the file COPYING. If not, write to
+ − 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 21 Boston, MA 02111-1307, USA. */
+ − 22
+ − 23 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
+ − 24 XEmacs' symbols.c. */
+ − 25
+ − 26 /* This file has been Mule-ized. */
+ − 27
+ − 28 #include <config.h>
+ − 29 #include "lisp.h"
+ − 30
+ − 31 #include "buffer.h"
+ − 32 #include "bytecode.h"
+ − 33 #include "syssignal.h"
+ − 34
+ − 35 #ifdef LISP_FLOAT_TYPE
+ − 36 /* Need to define a differentiating symbol -- see sysfloat.h */
+ − 37 # define THIS_FILENAME data_c
+ − 38 # include "sysfloat.h"
+ − 39 #endif /* LISP_FLOAT_TYPE */
+ − 40
+ − 41 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
+ − 42 Lisp_Object Qerror_conditions, Qerror_message;
442
+ − 43 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
563
+ − 44 Lisp_Object Qlist_formation_error, Qstructure_formation_error;
442
+ − 45 Lisp_Object Qmalformed_list, Qmalformed_property_list;
+ − 46 Lisp_Object Qcircular_list, Qcircular_property_list;
563
+ − 47 Lisp_Object Qinvalid_argument, Qinvalid_constant, Qwrong_type_argument;
+ − 48 Lisp_Object Qargs_out_of_range;
442
+ − 49 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch;
563
+ − 50 Lisp_Object Qinternal_error, Qinvalid_state, Qstack_overflow, Qout_of_memory;
428
+ − 51 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
+ − 52 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
563
+ − 53 Lisp_Object Qinvalid_operation, Qinvalid_change, Qprinting_unreadable_object;
442
+ − 54 Lisp_Object Qsetting_constant;
+ − 55 Lisp_Object Qediting_error;
+ − 56 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
563
+ − 57 Lisp_Object Qio_error, Qfile_error, Qconversion_error, Qend_of_file;
580
+ − 58 Lisp_Object Qtext_conversion_error;
428
+ − 59 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
+ − 60 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
+ − 61 Lisp_Object Qintegerp, Qnatnump, Qsymbolp;
+ − 62 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
+ − 63 Lisp_Object Qconsp, Qsubrp;
+ − 64 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
+ − 65 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
+ − 66 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
+ − 67 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
+ − 68 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
+ − 69
563
+ − 70 Lisp_Object Qerror_lacks_explanatory_string;
428
+ − 71 Lisp_Object Qfloatp;
+ − 72
+ − 73 #ifdef DEBUG_XEMACS
+ − 74
+ − 75 int debug_issue_ebola_notices;
+ − 76
458
+ − 77 Fixnum debug_ebola_backtrace_length;
428
+ − 78
+ − 79 int
+ − 80 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
+ − 81 {
+ − 82 if (debug_issue_ebola_notices
+ − 83 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
+ − 84 {
+ − 85 /* #### It would be really nice if this were a proper warning
+ − 86 instead of brain-dead print ro Qexternal_debugging_output. */
+ − 87 write_c_string ("Comparison between integer and character is constant nil (",
+ − 88 Qexternal_debugging_output);
+ − 89 Fprinc (obj1, Qexternal_debugging_output);
+ − 90 write_c_string (" and ", Qexternal_debugging_output);
+ − 91 Fprinc (obj2, Qexternal_debugging_output);
+ − 92 write_c_string (")\n", Qexternal_debugging_output);
+ − 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 /* On some machines, XINT needs a temporary location.
+ − 168 Here it is, in case it is needed. */
+ − 169
+ − 170 EMACS_INT sign_extend_temp;
+ − 171
+ − 172 /* On a few machines, XINT can only be done by calling this. */
+ − 173 /* XEmacs: only used by m/convex.h */
+ − 174 EMACS_INT sign_extend_lisp_int (EMACS_INT num);
+ − 175 EMACS_INT
+ − 176 sign_extend_lisp_int (EMACS_INT num)
+ − 177 {
+ − 178 if (num & (1L << (VALBITS - 1)))
+ − 179 return num | ((-1L) << VALBITS);
+ − 180 else
+ − 181 return num & ((1L << VALBITS) - 1);
+ − 182 }
+ − 183
+ − 184
+ − 185 /* Data type predicates */
+ − 186
+ − 187 DEFUN ("eq", Feq, 2, 2, 0, /*
+ − 188 Return t if the two args are the same Lisp object.
+ − 189 */
444
+ − 190 (object1, object2))
428
+ − 191 {
444
+ − 192 return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil;
428
+ − 193 }
+ − 194
+ − 195 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
+ − 196 Return t if the two args are (in most cases) the same Lisp object.
+ − 197
+ − 198 Special kludge: A character is considered `old-eq' to its equivalent integer
+ − 199 even though they are not the same object and are in fact of different
+ − 200 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
+ − 201 preserve byte-code compatibility with v19. This kludge is known as the
+ − 202 \"char-int confoundance disease\" and appears in a number of other
+ − 203 functions with `old-foo' equivalents.
+ − 204
+ − 205 Do not use this function!
+ − 206 */
444
+ − 207 (object1, object2))
428
+ − 208 {
+ − 209 /* #### blasphemy */
444
+ − 210 return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
428
+ − 211 }
+ − 212
+ − 213 DEFUN ("null", Fnull, 1, 1, 0, /*
+ − 214 Return t if OBJECT is nil.
+ − 215 */
+ − 216 (object))
+ − 217 {
+ − 218 return NILP (object) ? Qt : Qnil;
+ − 219 }
+ − 220
+ − 221 DEFUN ("consp", Fconsp, 1, 1, 0, /*
+ − 222 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
+ − 223 */
+ − 224 (object))
+ − 225 {
+ − 226 return CONSP (object) ? Qt : Qnil;
+ − 227 }
+ − 228
+ − 229 DEFUN ("atom", Fatom, 1, 1, 0, /*
+ − 230 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
+ − 231 */
+ − 232 (object))
+ − 233 {
+ − 234 return CONSP (object) ? Qnil : Qt;
+ − 235 }
+ − 236
+ − 237 DEFUN ("listp", Flistp, 1, 1, 0, /*
+ − 238 Return t if OBJECT is a list. `nil' is a list.
+ − 239 */
+ − 240 (object))
+ − 241 {
+ − 242 return LISTP (object) ? Qt : Qnil;
+ − 243 }
+ − 244
+ − 245 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
+ − 246 Return t if OBJECT is not a list. `nil' is a list.
+ − 247 */
+ − 248 (object))
+ − 249 {
+ − 250 return LISTP (object) ? Qnil : Qt;
+ − 251 }
+ − 252
+ − 253 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
+ − 254 Return t if OBJECT is a non-dotted, i.e. nil-terminated, list.
+ − 255 */
+ − 256 (object))
+ − 257 {
+ − 258 return TRUE_LIST_P (object) ? Qt : Qnil;
+ − 259 }
+ − 260
+ − 261 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
+ − 262 Return t if OBJECT is a symbol.
+ − 263 */
+ − 264 (object))
+ − 265 {
+ − 266 return SYMBOLP (object) ? Qt : Qnil;
+ − 267 }
+ − 268
+ − 269 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
+ − 270 Return t if OBJECT is a keyword.
+ − 271 */
+ − 272 (object))
+ − 273 {
+ − 274 return KEYWORDP (object) ? Qt : Qnil;
+ − 275 }
+ − 276
+ − 277 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
+ − 278 Return t if OBJECT is a vector.
+ − 279 */
+ − 280 (object))
+ − 281 {
+ − 282 return VECTORP (object) ? Qt : Qnil;
+ − 283 }
+ − 284
+ − 285 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
+ − 286 Return t if OBJECT is a bit vector.
+ − 287 */
+ − 288 (object))
+ − 289 {
+ − 290 return BIT_VECTORP (object) ? Qt : Qnil;
+ − 291 }
+ − 292
+ − 293 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
+ − 294 Return t if OBJECT is a string.
+ − 295 */
+ − 296 (object))
+ − 297 {
+ − 298 return STRINGP (object) ? Qt : Qnil;
+ − 299 }
+ − 300
+ − 301 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
+ − 302 Return t if OBJECT is an array (string, vector, or bit vector).
+ − 303 */
+ − 304 (object))
+ − 305 {
+ − 306 return (VECTORP (object) ||
+ − 307 STRINGP (object) ||
+ − 308 BIT_VECTORP (object))
+ − 309 ? Qt : Qnil;
+ − 310 }
+ − 311
+ − 312 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
+ − 313 Return t if OBJECT is a sequence (list or array).
+ − 314 */
+ − 315 (object))
+ − 316 {
+ − 317 return (LISTP (object) ||
+ − 318 VECTORP (object) ||
+ − 319 STRINGP (object) ||
+ − 320 BIT_VECTORP (object))
+ − 321 ? Qt : Qnil;
+ − 322 }
+ − 323
+ − 324 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
+ − 325 Return t if OBJECT is a marker (editor pointer).
+ − 326 */
+ − 327 (object))
+ − 328 {
+ − 329 return MARKERP (object) ? Qt : Qnil;
+ − 330 }
+ − 331
+ − 332 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
+ − 333 Return t if OBJECT is a built-in function.
+ − 334 */
+ − 335 (object))
+ − 336 {
+ − 337 return SUBRP (object) ? Qt : Qnil;
+ − 338 }
+ − 339
+ − 340 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
+ − 341 Return minimum number of args built-in function SUBR may be called with.
+ − 342 */
+ − 343 (subr))
+ − 344 {
+ − 345 CHECK_SUBR (subr);
+ − 346 return make_int (XSUBR (subr)->min_args);
+ − 347 }
+ − 348
+ − 349 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
+ − 350 Return maximum number of args built-in function SUBR may be called with,
+ − 351 or nil if it takes an arbitrary number of arguments or is a special form.
+ − 352 */
+ − 353 (subr))
+ − 354 {
+ − 355 int nargs;
+ − 356 CHECK_SUBR (subr);
+ − 357 nargs = XSUBR (subr)->max_args;
+ − 358 if (nargs == MANY || nargs == UNEVALLED)
+ − 359 return Qnil;
+ − 360 else
+ − 361 return make_int (nargs);
+ − 362 }
+ − 363
+ − 364 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
444
+ − 365 Return the interactive spec of the subr object SUBR, or nil.
428
+ − 366 If non-nil, the return value will be a list whose first element is
+ − 367 `interactive' and whose second element is the interactive spec.
+ − 368 */
+ − 369 (subr))
+ − 370 {
442
+ − 371 const char *prompt;
428
+ − 372 CHECK_SUBR (subr);
+ − 373 prompt = XSUBR (subr)->prompt;
+ − 374 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
+ − 375 }
+ − 376
+ − 377
+ − 378 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
+ − 379 Return t if OBJECT is a character.
+ − 380 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
+ − 381 Any character can be converted into an equivalent integer using
+ − 382 `char-int'. To convert the other way, use `int-char'; however,
+ − 383 only some integers can be converted into characters. Such an integer
+ − 384 is called a `char-int'; see `char-int-p'.
+ − 385
+ − 386 Some functions that work on integers (e.g. the comparison functions
+ − 387 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
+ − 388 accept characters and implicitly convert them into integers. In
+ − 389 general, functions that work on characters also accept char-ints and
+ − 390 implicitly convert them into characters. WARNING: Neither of these
+ − 391 behaviors is very desirable, and they are maintained for backward
+ − 392 compatibility with old E-Lisp programs that confounded characters and
+ − 393 integers willy-nilly. These behaviors may change in the future; therefore,
+ − 394 do not rely on them. Instead, use the character-specific functions such
+ − 395 as `char='.
+ − 396 */
+ − 397 (object))
+ − 398 {
+ − 399 return CHARP (object) ? Qt : Qnil;
+ − 400 }
+ − 401
+ − 402 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
444
+ − 403 Convert CHARACTER into an equivalent integer.
428
+ − 404 The resulting integer will always be non-negative. The integers in
+ − 405 the range 0 - 255 map to characters as follows:
+ − 406
+ − 407 0 - 31 Control set 0
+ − 408 32 - 127 ASCII
+ − 409 128 - 159 Control set 1
+ − 410 160 - 255 Right half of ISO-8859-1
+ − 411
+ − 412 If support for Mule does not exist, these are the only valid character
+ − 413 values. When Mule support exists, the values assigned to other characters
+ − 414 may vary depending on the particular version of XEmacs, the order in which
+ − 415 character sets were loaded, etc., and you should not depend on them.
+ − 416 */
444
+ − 417 (character))
428
+ − 418 {
444
+ − 419 CHECK_CHAR (character);
+ − 420 return make_int (XCHAR (character));
428
+ − 421 }
+ − 422
+ − 423 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
444
+ − 424 Convert integer INTEGER into the equivalent character.
428
+ − 425 Not all integers correspond to valid characters; use `char-int-p' to
+ − 426 determine whether this is the case. If the integer cannot be converted,
+ − 427 nil is returned.
+ − 428 */
+ − 429 (integer))
+ − 430 {
+ − 431 CHECK_INT (integer);
+ − 432 if (CHAR_INTP (integer))
+ − 433 return make_char (XINT (integer));
+ − 434 else
+ − 435 return Qnil;
+ − 436 }
+ − 437
+ − 438 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
+ − 439 Return t if OBJECT is an integer that can be converted into a character.
+ − 440 See `char-int'.
+ − 441 */
+ − 442 (object))
+ − 443 {
+ − 444 return CHAR_INTP (object) ? Qt : Qnil;
+ − 445 }
+ − 446
+ − 447 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
+ − 448 Return t if OBJECT is a character or an integer that can be converted into one.
+ − 449 */
+ − 450 (object))
+ − 451 {
+ − 452 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
+ − 453 }
+ − 454
+ − 455 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
+ − 456 Return t if OBJECT is a character (or a char-int) or a string.
+ − 457 It is semi-hateful that we allow a char-int here, as it goes against
+ − 458 the name of this function, but it makes the most sense considering the
+ − 459 other steps we take to maintain compatibility with the old character/integer
+ − 460 confoundedness in older versions of E-Lisp.
+ − 461 */
+ − 462 (object))
+ − 463 {
+ − 464 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
+ − 465 }
+ − 466
+ − 467 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
+ − 468 Return t if OBJECT is an integer.
+ − 469 */
+ − 470 (object))
+ − 471 {
+ − 472 return INTP (object) ? Qt : Qnil;
+ − 473 }
+ − 474
+ − 475 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
+ − 476 Return t if OBJECT is an integer or a marker (editor pointer).
+ − 477 */
+ − 478 (object))
+ − 479 {
+ − 480 return INTP (object) || MARKERP (object) ? Qt : Qnil;
+ − 481 }
+ − 482
+ − 483 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
+ − 484 Return t if OBJECT is an integer or a character.
+ − 485 */
+ − 486 (object))
+ − 487 {
+ − 488 return INTP (object) || CHARP (object) ? Qt : Qnil;
+ − 489 }
+ − 490
+ − 491 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
+ − 492 Return t if OBJECT is an integer, character or a marker (editor pointer).
+ − 493 */
+ − 494 (object))
+ − 495 {
+ − 496 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
+ − 497 }
+ − 498
+ − 499 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
+ − 500 Return t if OBJECT is a nonnegative integer.
+ − 501 */
+ − 502 (object))
+ − 503 {
+ − 504 return NATNUMP (object) ? Qt : Qnil;
+ − 505 }
+ − 506
+ − 507 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
+ − 508 Return t if OBJECT is a bit (0 or 1).
+ − 509 */
+ − 510 (object))
+ − 511 {
+ − 512 return BITP (object) ? Qt : Qnil;
+ − 513 }
+ − 514
+ − 515 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
+ − 516 Return t if OBJECT is a number (floating point or integer).
+ − 517 */
+ − 518 (object))
+ − 519 {
+ − 520 return INT_OR_FLOATP (object) ? Qt : Qnil;
+ − 521 }
+ − 522
+ − 523 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
+ − 524 Return t if OBJECT is a number or a marker.
+ − 525 */
+ − 526 (object))
+ − 527 {
+ − 528 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
+ − 529 }
+ − 530
+ − 531 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
+ − 532 Return t if OBJECT is a number, character or a marker.
+ − 533 */
+ − 534 (object))
+ − 535 {
+ − 536 return (INT_OR_FLOATP (object) ||
+ − 537 CHARP (object) ||
+ − 538 MARKERP (object))
+ − 539 ? Qt : Qnil;
+ − 540 }
+ − 541
+ − 542 #ifdef LISP_FLOAT_TYPE
+ − 543 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
+ − 544 Return t if OBJECT is a floating point number.
+ − 545 */
+ − 546 (object))
+ − 547 {
+ − 548 return FLOATP (object) ? Qt : Qnil;
+ − 549 }
+ − 550 #endif /* LISP_FLOAT_TYPE */
+ − 551
+ − 552 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
+ − 553 Return a symbol representing the type of OBJECT.
+ − 554 */
+ − 555 (object))
+ − 556 {
+ − 557 switch (XTYPE (object))
+ − 558 {
+ − 559 case Lisp_Type_Record:
+ − 560 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
+ − 561
+ − 562 case Lisp_Type_Char: return Qcharacter;
+ − 563
+ − 564 default: return Qinteger;
+ − 565 }
+ − 566 }
+ − 567
+ − 568
+ − 569 /* Extract and set components of lists */
+ − 570
+ − 571 DEFUN ("car", Fcar, 1, 1, 0, /*
+ − 572 Return the car of LIST. If arg is nil, return nil.
+ − 573 Error if arg is not nil and not a cons cell. See also `car-safe'.
+ − 574 */
+ − 575 (list))
+ − 576 {
+ − 577 while (1)
+ − 578 {
+ − 579 if (CONSP (list))
+ − 580 return XCAR (list);
+ − 581 else if (NILP (list))
+ − 582 return Qnil;
+ − 583 else
+ − 584 list = wrong_type_argument (Qlistp, list);
+ − 585 }
+ − 586 }
+ − 587
+ − 588 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
+ − 589 Return the car of OBJECT if it is a cons cell, or else nil.
+ − 590 */
+ − 591 (object))
+ − 592 {
+ − 593 return CONSP (object) ? XCAR (object) : Qnil;
+ − 594 }
+ − 595
+ − 596 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
+ − 597 Return the cdr of LIST. If arg is nil, return nil.
+ − 598 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
+ − 599 */
+ − 600 (list))
+ − 601 {
+ − 602 while (1)
+ − 603 {
+ − 604 if (CONSP (list))
+ − 605 return XCDR (list);
+ − 606 else if (NILP (list))
+ − 607 return Qnil;
+ − 608 else
+ − 609 list = wrong_type_argument (Qlistp, list);
+ − 610 }
+ − 611 }
+ − 612
+ − 613 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
+ − 614 Return the cdr of OBJECT if it is a cons cell, else nil.
+ − 615 */
+ − 616 (object))
+ − 617 {
+ − 618 return CONSP (object) ? XCDR (object) : Qnil;
+ − 619 }
+ − 620
+ − 621 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
444
+ − 622 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR.
428
+ − 623 */
444
+ − 624 (cons_cell, newcar))
428
+ − 625 {
444
+ − 626 if (!CONSP (cons_cell))
+ − 627 cons_cell = wrong_type_argument (Qconsp, cons_cell);
428
+ − 628
444
+ − 629 XCAR (cons_cell) = newcar;
428
+ − 630 return newcar;
+ − 631 }
+ − 632
+ − 633 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
444
+ − 634 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR.
428
+ − 635 */
444
+ − 636 (cons_cell, newcdr))
428
+ − 637 {
444
+ − 638 if (!CONSP (cons_cell))
+ − 639 cons_cell = wrong_type_argument (Qconsp, cons_cell);
428
+ − 640
444
+ − 641 XCDR (cons_cell) = newcdr;
428
+ − 642 return newcdr;
+ − 643 }
+ − 644
+ − 645 /* Find the function at the end of a chain of symbol function indirections.
+ − 646
+ − 647 If OBJECT is a symbol, find the end of its function chain and
+ − 648 return the value found there. If OBJECT is not a symbol, just
+ − 649 return it. If there is a cycle in the function chain, signal a
+ − 650 cyclic-function-indirection error.
+ − 651
442
+ − 652 This is like Findirect_function when VOID_FUNCTION_ERRORP is true.
+ − 653 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end
+ − 654 of the chain ends up being Qunbound. */
428
+ − 655 Lisp_Object
442
+ − 656 indirect_function (Lisp_Object object, int void_function_errorp)
428
+ − 657 {
+ − 658 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
+ − 659 Lisp_Object tortoise, hare;
+ − 660 int count;
+ − 661
+ − 662 for (hare = tortoise = object, count = 0;
+ − 663 SYMBOLP (hare);
+ − 664 hare = XSYMBOL (hare)->function, count++)
+ − 665 {
+ − 666 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
+ − 667
+ − 668 if (count & 1)
+ − 669 tortoise = XSYMBOL (tortoise)->function;
+ − 670 if (EQ (hare, tortoise))
+ − 671 return Fsignal (Qcyclic_function_indirection, list1 (object));
+ − 672 }
+ − 673
442
+ − 674 if (void_function_errorp && UNBOUNDP (hare))
436
+ − 675 return signal_void_function_error (object);
428
+ − 676
+ − 677 return hare;
+ − 678 }
+ − 679
+ − 680 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
+ − 681 Return the function at the end of OBJECT's function chain.
+ − 682 If OBJECT is a symbol, follow all function indirections and return
+ − 683 the final function binding.
+ − 684 If OBJECT is not a symbol, just return it.
+ − 685 Signal a void-function error if the final symbol is unbound.
+ − 686 Signal a cyclic-function-indirection error if there is a loop in the
+ − 687 function chain of symbols.
+ − 688 */
+ − 689 (object))
+ − 690 {
+ − 691 return indirect_function (object, 1);
+ − 692 }
+ − 693
+ − 694 /* Extract and set vector and string elements */
+ − 695
+ − 696 DEFUN ("aref", Faref, 2, 2, 0, /*
+ − 697 Return the element of ARRAY at index INDEX.
+ − 698 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
+ − 699 */
+ − 700 (array, index_))
+ − 701 {
+ − 702 EMACS_INT idx;
+ − 703
+ − 704 retry:
+ − 705
+ − 706 if (INTP (index_)) idx = XINT (index_);
+ − 707 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
+ − 708 else
+ − 709 {
+ − 710 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
+ − 711 goto retry;
+ − 712 }
+ − 713
+ − 714 if (idx < 0) goto range_error;
+ − 715
+ − 716 if (VECTORP (array))
+ − 717 {
+ − 718 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
+ − 719 return XVECTOR_DATA (array)[idx];
+ − 720 }
+ − 721 else if (BIT_VECTORP (array))
+ − 722 {
647
+ − 723 if (idx >= (EMACS_INT) bit_vector_length (XBIT_VECTOR (array)))
+ − 724 goto range_error;
428
+ − 725 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
+ − 726 }
+ − 727 else if (STRINGP (array))
+ − 728 {
+ − 729 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
+ − 730 return make_char (string_char (XSTRING (array), idx));
+ − 731 }
+ − 732 #ifdef LOSING_BYTECODE
+ − 733 else if (COMPILED_FUNCTIONP (array))
+ − 734 {
+ − 735 /* Weird, gross compatibility kludge */
+ − 736 return Felt (array, index_);
+ − 737 }
+ − 738 #endif
+ − 739 else
+ − 740 {
+ − 741 check_losing_bytecode ("aref", array);
+ − 742 array = wrong_type_argument (Qarrayp, array);
+ − 743 goto retry;
+ − 744 }
+ − 745
+ − 746 range_error:
+ − 747 args_out_of_range (array, index_);
+ − 748 return Qnil; /* not reached */
+ − 749 }
+ − 750
+ − 751 DEFUN ("aset", Faset, 3, 3, 0, /*
+ − 752 Store into the element of ARRAY at index INDEX the value NEWVAL.
+ − 753 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
+ − 754 */
+ − 755 (array, index_, newval))
+ − 756 {
+ − 757 EMACS_INT idx;
+ − 758
+ − 759 retry:
+ − 760
+ − 761 if (INTP (index_)) idx = XINT (index_);
+ − 762 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
+ − 763 else
+ − 764 {
+ − 765 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
+ − 766 goto retry;
+ − 767 }
+ − 768
+ − 769 if (idx < 0) goto range_error;
+ − 770
+ − 771 if (VECTORP (array))
+ − 772 {
+ − 773 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
+ − 774 XVECTOR_DATA (array)[idx] = newval;
+ − 775 }
+ − 776 else if (BIT_VECTORP (array))
+ − 777 {
647
+ − 778 if (idx >= (EMACS_INT) bit_vector_length (XBIT_VECTOR (array)))
+ − 779 goto range_error;
428
+ − 780 CHECK_BIT (newval);
+ − 781 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
+ − 782 }
+ − 783 else if (STRINGP (array))
+ − 784 {
+ − 785 CHECK_CHAR_COERCE_INT (newval);
+ − 786 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
+ − 787 set_string_char (XSTRING (array), idx, XCHAR (newval));
+ − 788 bump_string_modiff (array);
+ − 789 }
+ − 790 else
+ − 791 {
+ − 792 array = wrong_type_argument (Qarrayp, array);
+ − 793 goto retry;
+ − 794 }
+ − 795
+ − 796 return newval;
+ − 797
+ − 798 range_error:
+ − 799 args_out_of_range (array, index_);
+ − 800 return Qnil; /* not reached */
+ − 801 }
+ − 802
+ − 803
+ − 804 /**********************************************************************/
+ − 805 /* Arithmetic functions */
+ − 806 /**********************************************************************/
+ − 807 typedef struct
+ − 808 {
+ − 809 int int_p;
+ − 810 union
+ − 811 {
+ − 812 EMACS_INT ival;
+ − 813 double dval;
+ − 814 } c;
+ − 815 } int_or_double;
+ − 816
+ − 817 static void
+ − 818 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
+ − 819 {
+ − 820 retry:
+ − 821 p->int_p = 1;
+ − 822 if (INTP (obj)) p->c.ival = XINT (obj);
+ − 823 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
+ − 824 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
+ − 825 #ifdef LISP_FLOAT_TYPE
+ − 826 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
+ − 827 #endif
+ − 828 else
+ − 829 {
+ − 830 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
+ − 831 goto retry;
+ − 832 }
+ − 833 }
+ − 834
+ − 835 static double
+ − 836 number_char_or_marker_to_double (Lisp_Object obj)
+ − 837 {
+ − 838 retry:
+ − 839 if (INTP (obj)) return (double) XINT (obj);
+ − 840 else if (CHARP (obj)) return (double) XCHAR (obj);
+ − 841 else if (MARKERP (obj)) return (double) marker_position (obj);
+ − 842 #ifdef LISP_FLOAT_TYPE
+ − 843 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
+ − 844 #endif
+ − 845 else
+ − 846 {
+ − 847 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
+ − 848 goto retry;
+ − 849 }
+ − 850 }
+ − 851
+ − 852 static EMACS_INT
+ − 853 integer_char_or_marker_to_int (Lisp_Object obj)
+ − 854 {
+ − 855 retry:
+ − 856 if (INTP (obj)) return XINT (obj);
+ − 857 else if (CHARP (obj)) return XCHAR (obj);
+ − 858 else if (MARKERP (obj)) return marker_position (obj);
+ − 859 else
+ − 860 {
+ − 861 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
+ − 862 goto retry;
+ − 863 }
+ − 864 }
+ − 865
+ − 866 #define ARITHCOMPARE_MANY(op) \
+ − 867 { \
+ − 868 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
+ − 869 Lisp_Object *args_end = args + nargs; \
+ − 870 \
+ − 871 number_char_or_marker_to_int_or_double (*args++, p); \
+ − 872 \
+ − 873 while (args < args_end) \
+ − 874 { \
+ − 875 number_char_or_marker_to_int_or_double (*args++, q); \
+ − 876 \
+ − 877 if (!((p->int_p && q->int_p) ? \
+ − 878 (p->c.ival op q->c.ival) : \
+ − 879 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
+ − 880 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
+ − 881 return Qnil; \
+ − 882 \
+ − 883 { /* swap */ int_or_double *r = p; p = q; q = r; } \
+ − 884 } \
+ − 885 return Qt; \
+ − 886 }
+ − 887
+ − 888 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
+ − 889 Return t if all the arguments are numerically equal.
+ − 890 The arguments may be numbers, characters or markers.
+ − 891 */
+ − 892 (int nargs, Lisp_Object *args))
+ − 893 {
+ − 894 ARITHCOMPARE_MANY (==)
+ − 895 }
+ − 896
+ − 897 DEFUN ("<", Flss, 1, MANY, 0, /*
+ − 898 Return t if the sequence of arguments is monotonically increasing.
+ − 899 The arguments may be numbers, characters or markers.
+ − 900 */
+ − 901 (int nargs, Lisp_Object *args))
+ − 902 {
+ − 903 ARITHCOMPARE_MANY (<)
+ − 904 }
+ − 905
+ − 906 DEFUN (">", Fgtr, 1, MANY, 0, /*
+ − 907 Return t if the sequence of arguments is monotonically decreasing.
+ − 908 The arguments may be numbers, characters or markers.
+ − 909 */
+ − 910 (int nargs, Lisp_Object *args))
+ − 911 {
+ − 912 ARITHCOMPARE_MANY (>)
+ − 913 }
+ − 914
+ − 915 DEFUN ("<=", Fleq, 1, MANY, 0, /*
+ − 916 Return t if the sequence of arguments is monotonically nondecreasing.
+ − 917 The arguments may be numbers, characters or markers.
+ − 918 */
+ − 919 (int nargs, Lisp_Object *args))
+ − 920 {
+ − 921 ARITHCOMPARE_MANY (<=)
+ − 922 }
+ − 923
+ − 924 DEFUN (">=", Fgeq, 1, MANY, 0, /*
+ − 925 Return t if the sequence of arguments is monotonically nonincreasing.
+ − 926 The arguments may be numbers, characters or markers.
+ − 927 */
+ − 928 (int nargs, Lisp_Object *args))
+ − 929 {
+ − 930 ARITHCOMPARE_MANY (>=)
+ − 931 }
+ − 932
+ − 933 DEFUN ("/=", Fneq, 1, MANY, 0, /*
+ − 934 Return t if no two arguments are numerically equal.
+ − 935 The arguments may be numbers, characters or markers.
+ − 936 */
+ − 937 (int nargs, Lisp_Object *args))
+ − 938 {
+ − 939 Lisp_Object *args_end = args + nargs;
+ − 940 Lisp_Object *p, *q;
+ − 941
+ − 942 /* Unlike all the other comparisons, this is an N*N algorithm.
+ − 943 We could use a hash table for nargs > 50 to make this linear. */
+ − 944 for (p = args; p < args_end; p++)
+ − 945 {
+ − 946 int_or_double iod1, iod2;
+ − 947 number_char_or_marker_to_int_or_double (*p, &iod1);
+ − 948
+ − 949 for (q = p + 1; q < args_end; q++)
+ − 950 {
+ − 951 number_char_or_marker_to_int_or_double (*q, &iod2);
+ − 952
+ − 953 if (!((iod1.int_p && iod2.int_p) ?
+ − 954 (iod1.c.ival != iod2.c.ival) :
+ − 955 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
+ − 956 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
+ − 957 return Qnil;
+ − 958 }
+ − 959 }
+ − 960 return Qt;
+ − 961 }
+ − 962
+ − 963 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
+ − 964 Return t if NUMBER is zero.
+ − 965 */
+ − 966 (number))
+ − 967 {
+ − 968 retry:
+ − 969 if (INTP (number))
+ − 970 return EQ (number, Qzero) ? Qt : Qnil;
+ − 971 #ifdef LISP_FLOAT_TYPE
+ − 972 else if (FLOATP (number))
+ − 973 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
+ − 974 #endif /* LISP_FLOAT_TYPE */
+ − 975 else
+ − 976 {
+ − 977 number = wrong_type_argument (Qnumberp, number);
+ − 978 goto retry;
+ − 979 }
+ − 980 }
+ − 981
+ − 982 /* Convert between a 32-bit value and a cons of two 16-bit values.
+ − 983 This is used to pass 32-bit integers to and from the user.
+ − 984 Use time_to_lisp() and lisp_to_time() for time values.
+ − 985
+ − 986 If you're thinking of using this to store a pointer into a Lisp Object
+ − 987 for internal purposes (such as when calling record_unwind_protect()),
+ − 988 try using make_opaque_ptr()/get_opaque_ptr() instead. */
+ − 989 Lisp_Object
+ − 990 word_to_lisp (unsigned int item)
+ − 991 {
+ − 992 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
+ − 993 }
+ − 994
+ − 995 unsigned int
+ − 996 lisp_to_word (Lisp_Object item)
+ − 997 {
+ − 998 if (INTP (item))
+ − 999 return XINT (item);
+ − 1000 else
+ − 1001 {
+ − 1002 Lisp_Object top = Fcar (item);
+ − 1003 Lisp_Object bot = Fcdr (item);
+ − 1004 CHECK_INT (top);
+ − 1005 CHECK_INT (bot);
+ − 1006 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
+ − 1007 }
+ − 1008 }
+ − 1009
+ − 1010
+ − 1011 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
444
+ − 1012 Convert NUMBER to a string by printing it in decimal.
428
+ − 1013 Uses a minus sign if negative.
444
+ − 1014 NUMBER may be an integer or a floating point number.
428
+ − 1015 */
444
+ − 1016 (number))
428
+ − 1017 {
444
+ − 1018 CHECK_INT_OR_FLOAT (number);
428
+ − 1019
+ − 1020 #ifdef LISP_FLOAT_TYPE
444
+ − 1021 if (FLOATP (number))
428
+ − 1022 {
+ − 1023 char pigbuf[350]; /* see comments in float_to_string */
+ − 1024
444
+ − 1025 float_to_string (pigbuf, XFLOAT_DATA (number));
428
+ − 1026 return build_string (pigbuf);
+ − 1027 }
+ − 1028 #endif /* LISP_FLOAT_TYPE */
+ − 1029
603
+ − 1030 {
+ − 1031 char buffer[DECIMAL_PRINT_SIZE (long)];
+ − 1032
+ − 1033 long_to_string (buffer, XINT (number));
+ − 1034 return build_string (buffer);
+ − 1035 }
428
+ − 1036 }
+ − 1037
+ − 1038 static int
+ − 1039 digit_to_number (int character, int base)
+ − 1040 {
+ − 1041 /* Assumes ASCII */
+ − 1042 int digit = ((character >= '0' && character <= '9') ? character - '0' :
+ − 1043 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
+ − 1044 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
+ − 1045 -1);
+ − 1046
+ − 1047 return digit >= base ? -1 : digit;
+ − 1048 }
+ − 1049
+ − 1050 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
444
+ − 1051 Convert STRING to a number by parsing it as a number in base BASE.
428
+ − 1052 This parses both integers and floating point numbers.
+ − 1053 It ignores leading spaces and tabs.
+ − 1054
444
+ − 1055 If BASE is nil or omitted, base 10 is used.
+ − 1056 BASE must be an integer between 2 and 16 (inclusive).
428
+ − 1057 Floating point numbers always use base 10.
+ − 1058 */
+ − 1059 (string, base))
+ − 1060 {
+ − 1061 char *p;
+ − 1062 int b;
+ − 1063
+ − 1064 CHECK_STRING (string);
+ − 1065
+ − 1066 if (NILP (base))
+ − 1067 b = 10;
+ − 1068 else
+ − 1069 {
+ − 1070 CHECK_INT (base);
+ − 1071 b = XINT (base);
+ − 1072 check_int_range (b, 2, 16);
+ − 1073 }
+ − 1074
+ − 1075 p = (char *) XSTRING_DATA (string);
+ − 1076
+ − 1077 /* Skip any whitespace at the front of the number. Some versions of
+ − 1078 atoi do this anyway, so we might as well make Emacs lisp consistent. */
+ − 1079 while (*p == ' ' || *p == '\t')
+ − 1080 p++;
+ − 1081
+ − 1082 #ifdef LISP_FLOAT_TYPE
442
+ − 1083 if (isfloat_string (p) && b == 10)
428
+ − 1084 return make_float (atof (p));
+ − 1085 #endif /* LISP_FLOAT_TYPE */
+ − 1086
+ − 1087 if (b == 10)
+ − 1088 {
+ − 1089 /* Use the system-provided functions for base 10. */
+ − 1090 #if SIZEOF_EMACS_INT == SIZEOF_INT
+ − 1091 return make_int (atoi (p));
+ − 1092 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
+ − 1093 return make_int (atol (p));
+ − 1094 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
+ − 1095 return make_int (atoll (p));
+ − 1096 #endif
+ − 1097 }
+ − 1098 else
+ − 1099 {
444
+ − 1100 int negative = 1;
428
+ − 1101 EMACS_INT v = 0;
+ − 1102
+ − 1103 if (*p == '-')
+ − 1104 {
+ − 1105 negative = -1;
+ − 1106 p++;
+ − 1107 }
+ − 1108 else if (*p == '+')
+ − 1109 p++;
+ − 1110 while (1)
+ − 1111 {
444
+ − 1112 int digit = digit_to_number (*p++, b);
428
+ − 1113 if (digit < 0)
+ − 1114 break;
+ − 1115 v = v * b + digit;
+ − 1116 }
+ − 1117 return make_int (negative * v);
+ − 1118 }
+ − 1119 }
+ − 1120
+ − 1121
+ − 1122 DEFUN ("+", Fplus, 0, MANY, 0, /*
+ − 1123 Return sum of any number of arguments.
+ − 1124 The arguments should all be numbers, characters or markers.
+ − 1125 */
+ − 1126 (int nargs, Lisp_Object *args))
+ − 1127 {
+ − 1128 EMACS_INT iaccum = 0;
+ − 1129 Lisp_Object *args_end = args + nargs;
+ − 1130
+ − 1131 while (args < args_end)
+ − 1132 {
+ − 1133 int_or_double iod;
+ − 1134 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1135 if (iod.int_p)
+ − 1136 iaccum += iod.c.ival;
+ − 1137 else
+ − 1138 {
+ − 1139 double daccum = (double) iaccum + iod.c.dval;
+ − 1140 while (args < args_end)
+ − 1141 daccum += number_char_or_marker_to_double (*args++);
+ − 1142 return make_float (daccum);
+ − 1143 }
+ − 1144 }
+ − 1145
+ − 1146 return make_int (iaccum);
+ − 1147 }
+ − 1148
+ − 1149 DEFUN ("-", Fminus, 1, MANY, 0, /*
+ − 1150 Negate number or subtract numbers, characters or markers.
+ − 1151 With one arg, negates it. With more than one arg,
+ − 1152 subtracts all but the first from the first.
+ − 1153 */
+ − 1154 (int nargs, Lisp_Object *args))
+ − 1155 {
+ − 1156 EMACS_INT iaccum;
+ − 1157 double daccum;
+ − 1158 Lisp_Object *args_end = args + nargs;
+ − 1159 int_or_double iod;
+ − 1160
+ − 1161 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1162 if (iod.int_p)
+ − 1163 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
+ − 1164 else
+ − 1165 {
+ − 1166 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
+ − 1167 goto do_float;
+ − 1168 }
+ − 1169
+ − 1170 while (args < args_end)
+ − 1171 {
+ − 1172 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1173 if (iod.int_p)
+ − 1174 iaccum -= iod.c.ival;
+ − 1175 else
+ − 1176 {
+ − 1177 daccum = (double) iaccum - iod.c.dval;
+ − 1178 goto do_float;
+ − 1179 }
+ − 1180 }
+ − 1181
+ − 1182 return make_int (iaccum);
+ − 1183
+ − 1184 do_float:
+ − 1185 for (; args < args_end; args++)
+ − 1186 daccum -= number_char_or_marker_to_double (*args);
+ − 1187 return make_float (daccum);
+ − 1188 }
+ − 1189
+ − 1190 DEFUN ("*", Ftimes, 0, MANY, 0, /*
+ − 1191 Return product of any number of arguments.
+ − 1192 The arguments should all be numbers, characters or markers.
+ − 1193 */
+ − 1194 (int nargs, Lisp_Object *args))
+ − 1195 {
+ − 1196 EMACS_INT iaccum = 1;
+ − 1197 Lisp_Object *args_end = args + nargs;
+ − 1198
+ − 1199 while (args < args_end)
+ − 1200 {
+ − 1201 int_or_double iod;
+ − 1202 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1203 if (iod.int_p)
+ − 1204 iaccum *= iod.c.ival;
+ − 1205 else
+ − 1206 {
+ − 1207 double daccum = (double) iaccum * iod.c.dval;
+ − 1208 while (args < args_end)
+ − 1209 daccum *= number_char_or_marker_to_double (*args++);
+ − 1210 return make_float (daccum);
+ − 1211 }
+ − 1212 }
+ − 1213
+ − 1214 return make_int (iaccum);
+ − 1215 }
+ − 1216
+ − 1217 DEFUN ("/", Fquo, 1, MANY, 0, /*
+ − 1218 Return first argument divided by all the remaining arguments.
+ − 1219 The arguments must be numbers, characters or markers.
+ − 1220 With one argument, reciprocates the argument.
+ − 1221 */
+ − 1222 (int nargs, Lisp_Object *args))
+ − 1223 {
+ − 1224 EMACS_INT iaccum;
+ − 1225 double daccum;
+ − 1226 Lisp_Object *args_end = args + nargs;
+ − 1227 int_or_double iod;
+ − 1228
+ − 1229 if (nargs == 1)
+ − 1230 iaccum = 1;
+ − 1231 else
+ − 1232 {
+ − 1233 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1234 if (iod.int_p)
+ − 1235 iaccum = iod.c.ival;
+ − 1236 else
+ − 1237 {
+ − 1238 daccum = iod.c.dval;
+ − 1239 goto divide_floats;
+ − 1240 }
+ − 1241 }
+ − 1242
+ − 1243 while (args < args_end)
+ − 1244 {
+ − 1245 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1246 if (iod.int_p)
+ − 1247 {
+ − 1248 if (iod.c.ival == 0) goto divide_by_zero;
+ − 1249 iaccum /= iod.c.ival;
+ − 1250 }
+ − 1251 else
+ − 1252 {
+ − 1253 if (iod.c.dval == 0) goto divide_by_zero;
+ − 1254 daccum = (double) iaccum / iod.c.dval;
+ − 1255 goto divide_floats;
+ − 1256 }
+ − 1257 }
+ − 1258
+ − 1259 return make_int (iaccum);
+ − 1260
+ − 1261 divide_floats:
+ − 1262 for (; args < args_end; args++)
+ − 1263 {
+ − 1264 double dval = number_char_or_marker_to_double (*args);
+ − 1265 if (dval == 0) goto divide_by_zero;
+ − 1266 daccum /= dval;
+ − 1267 }
+ − 1268 return make_float (daccum);
+ − 1269
+ − 1270 divide_by_zero:
+ − 1271 Fsignal (Qarith_error, Qnil);
+ − 1272 return Qnil; /* not reached */
+ − 1273 }
+ − 1274
+ − 1275 DEFUN ("max", Fmax, 1, MANY, 0, /*
+ − 1276 Return largest of all the arguments.
+ − 1277 All arguments must be numbers, characters or markers.
+ − 1278 The value is always a number; markers and characters are converted
+ − 1279 to numbers.
+ − 1280 */
+ − 1281 (int nargs, Lisp_Object *args))
+ − 1282 {
+ − 1283 EMACS_INT imax;
+ − 1284 double dmax;
+ − 1285 Lisp_Object *args_end = args + nargs;
+ − 1286 int_or_double iod;
+ − 1287
+ − 1288 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1289 if (iod.int_p)
+ − 1290 imax = iod.c.ival;
+ − 1291 else
+ − 1292 {
+ − 1293 dmax = iod.c.dval;
+ − 1294 goto max_floats;
+ − 1295 }
+ − 1296
+ − 1297 while (args < args_end)
+ − 1298 {
+ − 1299 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1300 if (iod.int_p)
+ − 1301 {
+ − 1302 if (imax < iod.c.ival) imax = iod.c.ival;
+ − 1303 }
+ − 1304 else
+ − 1305 {
+ − 1306 dmax = (double) imax;
+ − 1307 if (dmax < iod.c.dval) dmax = iod.c.dval;
+ − 1308 goto max_floats;
+ − 1309 }
+ − 1310 }
+ − 1311
+ − 1312 return make_int (imax);
+ − 1313
+ − 1314 max_floats:
+ − 1315 while (args < args_end)
+ − 1316 {
+ − 1317 double dval = number_char_or_marker_to_double (*args++);
+ − 1318 if (dmax < dval) dmax = dval;
+ − 1319 }
+ − 1320 return make_float (dmax);
+ − 1321 }
+ − 1322
+ − 1323 DEFUN ("min", Fmin, 1, MANY, 0, /*
+ − 1324 Return smallest of all the arguments.
+ − 1325 All arguments must be numbers, characters or markers.
+ − 1326 The value is always a number; markers and characters are converted
+ − 1327 to numbers.
+ − 1328 */
+ − 1329 (int nargs, Lisp_Object *args))
+ − 1330 {
+ − 1331 EMACS_INT imin;
+ − 1332 double dmin;
+ − 1333 Lisp_Object *args_end = args + nargs;
+ − 1334 int_or_double iod;
+ − 1335
+ − 1336 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1337 if (iod.int_p)
+ − 1338 imin = iod.c.ival;
+ − 1339 else
+ − 1340 {
+ − 1341 dmin = iod.c.dval;
+ − 1342 goto min_floats;
+ − 1343 }
+ − 1344
+ − 1345 while (args < args_end)
+ − 1346 {
+ − 1347 number_char_or_marker_to_int_or_double (*args++, &iod);
+ − 1348 if (iod.int_p)
+ − 1349 {
+ − 1350 if (imin > iod.c.ival) imin = iod.c.ival;
+ − 1351 }
+ − 1352 else
+ − 1353 {
+ − 1354 dmin = (double) imin;
+ − 1355 if (dmin > iod.c.dval) dmin = iod.c.dval;
+ − 1356 goto min_floats;
+ − 1357 }
+ − 1358 }
+ − 1359
+ − 1360 return make_int (imin);
+ − 1361
+ − 1362 min_floats:
+ − 1363 while (args < args_end)
+ − 1364 {
+ − 1365 double dval = number_char_or_marker_to_double (*args++);
+ − 1366 if (dmin > dval) dmin = dval;
+ − 1367 }
+ − 1368 return make_float (dmin);
+ − 1369 }
+ − 1370
+ − 1371 DEFUN ("logand", Flogand, 0, MANY, 0, /*
+ − 1372 Return bitwise-and of all the arguments.
+ − 1373 Arguments may be integers, or markers or characters converted to integers.
+ − 1374 */
+ − 1375 (int nargs, Lisp_Object *args))
+ − 1376 {
+ − 1377 EMACS_INT bits = ~0;
+ − 1378 Lisp_Object *args_end = args + nargs;
+ − 1379
+ − 1380 while (args < args_end)
+ − 1381 bits &= integer_char_or_marker_to_int (*args++);
+ − 1382
+ − 1383 return make_int (bits);
+ − 1384 }
+ − 1385
+ − 1386 DEFUN ("logior", Flogior, 0, MANY, 0, /*
+ − 1387 Return bitwise-or of all the arguments.
+ − 1388 Arguments may be integers, or markers or characters converted to integers.
+ − 1389 */
+ − 1390 (int nargs, Lisp_Object *args))
+ − 1391 {
+ − 1392 EMACS_INT bits = 0;
+ − 1393 Lisp_Object *args_end = args + nargs;
+ − 1394
+ − 1395 while (args < args_end)
+ − 1396 bits |= integer_char_or_marker_to_int (*args++);
+ − 1397
+ − 1398 return make_int (bits);
+ − 1399 }
+ − 1400
+ − 1401 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
+ − 1402 Return bitwise-exclusive-or of all the arguments.
+ − 1403 Arguments may be integers, or markers or characters converted to integers.
+ − 1404 */
+ − 1405 (int nargs, Lisp_Object *args))
+ − 1406 {
+ − 1407 EMACS_INT bits = 0;
+ − 1408 Lisp_Object *args_end = args + nargs;
+ − 1409
+ − 1410 while (args < args_end)
+ − 1411 bits ^= integer_char_or_marker_to_int (*args++);
+ − 1412
+ − 1413 return make_int (bits);
+ − 1414 }
+ − 1415
+ − 1416 DEFUN ("lognot", Flognot, 1, 1, 0, /*
+ − 1417 Return the bitwise complement of NUMBER.
+ − 1418 NUMBER may be an integer, marker or character converted to integer.
+ − 1419 */
+ − 1420 (number))
+ − 1421 {
+ − 1422 return make_int (~ integer_char_or_marker_to_int (number));
+ − 1423 }
+ − 1424
+ − 1425 DEFUN ("%", Frem, 2, 2, 0, /*
+ − 1426 Return remainder of first arg divided by second.
+ − 1427 Both must be integers, characters or markers.
+ − 1428 */
444
+ − 1429 (number1, number2))
428
+ − 1430 {
444
+ − 1431 EMACS_INT ival1 = integer_char_or_marker_to_int (number1);
+ − 1432 EMACS_INT ival2 = integer_char_or_marker_to_int (number2);
428
+ − 1433
+ − 1434 if (ival2 == 0)
+ − 1435 Fsignal (Qarith_error, Qnil);
+ − 1436
+ − 1437 return make_int (ival1 % ival2);
+ − 1438 }
+ − 1439
+ − 1440 /* Note, ANSI *requires* the presence of the fmod() library routine.
+ − 1441 If your system doesn't have it, complain to your vendor, because
+ − 1442 that is a bug. */
+ − 1443
+ − 1444 #ifndef HAVE_FMOD
+ − 1445 double
+ − 1446 fmod (double f1, double f2)
+ − 1447 {
+ − 1448 if (f2 < 0.0)
+ − 1449 f2 = -f2;
+ − 1450 return f1 - f2 * floor (f1/f2);
+ − 1451 }
+ − 1452 #endif /* ! HAVE_FMOD */
+ − 1453
+ − 1454
+ − 1455 DEFUN ("mod", Fmod, 2, 2, 0, /*
+ − 1456 Return X modulo Y.
+ − 1457 The result falls between zero (inclusive) and Y (exclusive).
+ − 1458 Both X and Y must be numbers, characters or markers.
+ − 1459 If either argument is a float, a float will be returned.
+ − 1460 */
+ − 1461 (x, y))
+ − 1462 {
+ − 1463 int_or_double iod1, iod2;
+ − 1464 number_char_or_marker_to_int_or_double (x, &iod1);
+ − 1465 number_char_or_marker_to_int_or_double (y, &iod2);
+ − 1466
+ − 1467 #ifdef LISP_FLOAT_TYPE
+ − 1468 if (!iod1.int_p || !iod2.int_p)
+ − 1469 {
+ − 1470 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
+ − 1471 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
+ − 1472 if (dval2 == 0) goto divide_by_zero;
+ − 1473 dval1 = fmod (dval1, dval2);
+ − 1474
+ − 1475 /* If the "remainder" comes out with the wrong sign, fix it. */
+ − 1476 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
+ − 1477 dval1 += dval2;
+ − 1478
+ − 1479 return make_float (dval1);
+ − 1480 }
+ − 1481 #endif /* LISP_FLOAT_TYPE */
+ − 1482 {
+ − 1483 EMACS_INT ival;
+ − 1484 if (iod2.c.ival == 0) goto divide_by_zero;
+ − 1485
+ − 1486 ival = iod1.c.ival % iod2.c.ival;
+ − 1487
+ − 1488 /* If the "remainder" comes out with the wrong sign, fix it. */
+ − 1489 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
+ − 1490 ival += iod2.c.ival;
+ − 1491
+ − 1492 return make_int (ival);
+ − 1493 }
+ − 1494
+ − 1495 divide_by_zero:
+ − 1496 Fsignal (Qarith_error, Qnil);
+ − 1497 return Qnil; /* not reached */
+ − 1498 }
+ − 1499
+ − 1500 DEFUN ("ash", Fash, 2, 2, 0, /*
+ − 1501 Return VALUE with its bits shifted left by COUNT.
+ − 1502 If COUNT is negative, shifting is actually to the right.
+ − 1503 In this case, the sign bit is duplicated.
+ − 1504 */
+ − 1505 (value, count))
+ − 1506 {
+ − 1507 CHECK_INT_COERCE_CHAR (value);
+ − 1508 CONCHECK_INT (count);
+ − 1509
+ − 1510 return make_int (XINT (count) > 0 ?
+ − 1511 XINT (value) << XINT (count) :
+ − 1512 XINT (value) >> -XINT (count));
+ − 1513 }
+ − 1514
+ − 1515 DEFUN ("lsh", Flsh, 2, 2, 0, /*
+ − 1516 Return VALUE with its bits shifted left by COUNT.
+ − 1517 If COUNT is negative, shifting is actually to the right.
+ − 1518 In this case, zeros are shifted in on the left.
+ − 1519 */
+ − 1520 (value, count))
+ − 1521 {
+ − 1522 CHECK_INT_COERCE_CHAR (value);
+ − 1523 CONCHECK_INT (count);
+ − 1524
+ − 1525 return make_int (XINT (count) > 0 ?
+ − 1526 XUINT (value) << XINT (count) :
+ − 1527 XUINT (value) >> -XINT (count));
+ − 1528 }
+ − 1529
+ − 1530 DEFUN ("1+", Fadd1, 1, 1, 0, /*
+ − 1531 Return NUMBER plus one. NUMBER may be a number, character or marker.
+ − 1532 Markers and characters are converted to integers.
+ − 1533 */
+ − 1534 (number))
+ − 1535 {
+ − 1536 retry:
+ − 1537
+ − 1538 if (INTP (number)) return make_int (XINT (number) + 1);
+ − 1539 if (CHARP (number)) return make_int (XCHAR (number) + 1);
+ − 1540 if (MARKERP (number)) return make_int (marker_position (number) + 1);
+ − 1541 #ifdef LISP_FLOAT_TYPE
+ − 1542 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
+ − 1543 #endif /* LISP_FLOAT_TYPE */
+ − 1544
+ − 1545 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
+ − 1546 goto retry;
+ − 1547 }
+ − 1548
+ − 1549 DEFUN ("1-", Fsub1, 1, 1, 0, /*
+ − 1550 Return NUMBER minus one. NUMBER may be a number, character or marker.
+ − 1551 Markers and characters are converted to integers.
+ − 1552 */
+ − 1553 (number))
+ − 1554 {
+ − 1555 retry:
+ − 1556
+ − 1557 if (INTP (number)) return make_int (XINT (number) - 1);
+ − 1558 if (CHARP (number)) return make_int (XCHAR (number) - 1);
+ − 1559 if (MARKERP (number)) return make_int (marker_position (number) - 1);
+ − 1560 #ifdef LISP_FLOAT_TYPE
+ − 1561 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
+ − 1562 #endif /* LISP_FLOAT_TYPE */
+ − 1563
+ − 1564 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
+ − 1565 goto retry;
+ − 1566 }
+ − 1567
+ − 1568
+ − 1569 /************************************************************************/
+ − 1570 /* weak lists */
+ − 1571 /************************************************************************/
+ − 1572
+ − 1573 /* A weak list is like a normal list except that elements automatically
+ − 1574 disappear when no longer in use, i.e. when no longer GC-protected.
+ − 1575 The basic idea is that we don't mark the elements during GC, but
+ − 1576 wait for them to be marked elsewhere. If they're not marked, we
+ − 1577 remove them. This is analogous to weak hash tables; see the explanation
+ − 1578 there for more info. */
+ − 1579
+ − 1580 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
+ − 1581
+ − 1582 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
+ − 1583
+ − 1584 static Lisp_Object
+ − 1585 mark_weak_list (Lisp_Object obj)
+ − 1586 {
+ − 1587 return Qnil; /* nichts ist gemarkt */
+ − 1588 }
+ − 1589
+ − 1590 static void
+ − 1591 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+ − 1592 {
+ − 1593 if (print_readably)
563
+ − 1594 printing_unreadable_object ("#<weak-list>");
428
+ − 1595
+ − 1596 write_c_string ("#<weak-list ", printcharfun);
+ − 1597 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
+ − 1598 printcharfun, 0);
+ − 1599 write_c_string (" ", printcharfun);
+ − 1600 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
+ − 1601 write_c_string (">", printcharfun);
+ − 1602 }
+ − 1603
+ − 1604 static int
+ − 1605 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+ − 1606 {
+ − 1607 struct weak_list *w1 = XWEAK_LIST (obj1);
+ − 1608 struct weak_list *w2 = XWEAK_LIST (obj2);
+ − 1609
+ − 1610 return ((w1->type == w2->type) &&
+ − 1611 internal_equal (w1->list, w2->list, depth + 1));
+ − 1612 }
+ − 1613
647
+ − 1614 static Hash_Code
428
+ − 1615 weak_list_hash (Lisp_Object obj, int depth)
+ − 1616 {
+ − 1617 struct weak_list *w = XWEAK_LIST (obj);
+ − 1618
647
+ − 1619 return HASH2 ((Hash_Code) w->type,
428
+ − 1620 internal_hash (w->list, depth + 1));
+ − 1621 }
+ − 1622
+ − 1623 Lisp_Object
+ − 1624 make_weak_list (enum weak_list_type type)
+ − 1625 {
+ − 1626 Lisp_Object result;
+ − 1627 struct weak_list *wl =
+ − 1628 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
+ − 1629
+ − 1630 wl->list = Qnil;
+ − 1631 wl->type = type;
+ − 1632 XSETWEAK_LIST (result, wl);
+ − 1633 wl->next_weak = Vall_weak_lists;
+ − 1634 Vall_weak_lists = result;
+ − 1635 return result;
+ − 1636 }
+ − 1637
+ − 1638 static const struct lrecord_description weak_list_description[] = {
440
+ − 1639 { XD_LISP_OBJECT, offsetof (struct weak_list, list) },
+ − 1640 { XD_LO_LINK, offsetof (struct weak_list, next_weak) },
428
+ − 1641 { XD_END }
+ − 1642 };
+ − 1643
+ − 1644 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
+ − 1645 mark_weak_list, print_weak_list,
+ − 1646 0, weak_list_equal, weak_list_hash,
+ − 1647 weak_list_description,
+ − 1648 struct weak_list);
+ − 1649 /*
+ − 1650 -- we do not mark the list elements (either the elements themselves
+ − 1651 or the cons cells that hold them) in the normal marking phase.
+ − 1652 -- at the end of marking, we go through all weak lists that are
+ − 1653 marked, and mark the cons cells that hold all marked
+ − 1654 objects, and possibly parts of the objects themselves.
+ − 1655 (See alloc.c, "after-mark".)
+ − 1656 -- after that, we prune away all the cons cells that are not marked.
+ − 1657
+ − 1658 WARNING WARNING WARNING WARNING WARNING:
+ − 1659
+ − 1660 The code in the following two functions is *unbelievably* tricky.
+ − 1661 Don't mess with it. You'll be sorry.
+ − 1662
+ − 1663 Linked lists just majorly suck, d'ya know?
+ − 1664 */
+ − 1665
+ − 1666 int
+ − 1667 finish_marking_weak_lists (void)
+ − 1668 {
+ − 1669 Lisp_Object rest;
+ − 1670 int did_mark = 0;
+ − 1671
+ − 1672 for (rest = Vall_weak_lists;
+ − 1673 !NILP (rest);
+ − 1674 rest = XWEAK_LIST (rest)->next_weak)
+ − 1675 {
+ − 1676 Lisp_Object rest2;
+ − 1677 enum weak_list_type type = XWEAK_LIST (rest)->type;
+ − 1678
+ − 1679 if (! marked_p (rest))
+ − 1680 /* The weak list is probably garbage. Ignore it. */
+ − 1681 continue;
+ − 1682
+ − 1683 for (rest2 = XWEAK_LIST (rest)->list;
+ − 1684 /* We need to be trickier since we're inside of GC;
+ − 1685 use CONSP instead of !NILP in case of user-visible
+ − 1686 imperfect lists */
+ − 1687 CONSP (rest2);
+ − 1688 rest2 = XCDR (rest2))
+ − 1689 {
+ − 1690 Lisp_Object elem;
+ − 1691 /* If the element is "marked" (meaning depends on the type
+ − 1692 of weak list), we need to mark the cons containing the
+ − 1693 element, and maybe the element itself (if only some part
+ − 1694 was already marked). */
+ − 1695 int need_to_mark_cons = 0;
+ − 1696 int need_to_mark_elem = 0;
+ − 1697
+ − 1698 /* If a cons is already marked, then its car is already marked
+ − 1699 (either because of an external pointer or because of
+ − 1700 a previous call to this function), and likewise for all
+ − 1701 the rest of the elements in the list, so we can stop now. */
+ − 1702 if (marked_p (rest2))
+ − 1703 break;
+ − 1704
+ − 1705 elem = XCAR (rest2);
+ − 1706
+ − 1707 switch (type)
+ − 1708 {
+ − 1709 case WEAK_LIST_SIMPLE:
+ − 1710 if (marked_p (elem))
+ − 1711 need_to_mark_cons = 1;
+ − 1712 break;
+ − 1713
+ − 1714 case WEAK_LIST_ASSOC:
+ − 1715 if (!CONSP (elem))
+ − 1716 {
+ − 1717 /* just leave bogus elements there */
+ − 1718 need_to_mark_cons = 1;
+ − 1719 need_to_mark_elem = 1;
+ − 1720 }
+ − 1721 else if (marked_p (XCAR (elem)) &&
+ − 1722 marked_p (XCDR (elem)))
+ − 1723 {
+ − 1724 need_to_mark_cons = 1;
+ − 1725 /* We still need to mark elem, because it's
+ − 1726 probably not marked. */
+ − 1727 need_to_mark_elem = 1;
+ − 1728 }
+ − 1729 break;
+ − 1730
+ − 1731 case WEAK_LIST_KEY_ASSOC:
+ − 1732 if (!CONSP (elem))
+ − 1733 {
+ − 1734 /* just leave bogus elements there */
+ − 1735 need_to_mark_cons = 1;
+ − 1736 need_to_mark_elem = 1;
+ − 1737 }
+ − 1738 else if (marked_p (XCAR (elem)))
+ − 1739 {
+ − 1740 need_to_mark_cons = 1;
+ − 1741 /* We still need to mark elem and XCDR (elem);
+ − 1742 marking elem does both */
+ − 1743 need_to_mark_elem = 1;
+ − 1744 }
+ − 1745 break;
+ − 1746
+ − 1747 case WEAK_LIST_VALUE_ASSOC:
+ − 1748 if (!CONSP (elem))
+ − 1749 {
+ − 1750 /* just leave bogus elements there */
+ − 1751 need_to_mark_cons = 1;
+ − 1752 need_to_mark_elem = 1;
+ − 1753 }
+ − 1754 else if (marked_p (XCDR (elem)))
+ − 1755 {
+ − 1756 need_to_mark_cons = 1;
+ − 1757 /* We still need to mark elem and XCAR (elem);
+ − 1758 marking elem does both */
+ − 1759 need_to_mark_elem = 1;
+ − 1760 }
+ − 1761 break;
+ − 1762
442
+ − 1763 case WEAK_LIST_FULL_ASSOC:
+ − 1764 if (!CONSP (elem))
+ − 1765 {
+ − 1766 /* just leave bogus elements there */
+ − 1767 need_to_mark_cons = 1;
+ − 1768 need_to_mark_elem = 1;
+ − 1769 }
+ − 1770 else if (marked_p (XCAR (elem)) ||
+ − 1771 marked_p (XCDR (elem)))
+ − 1772 {
+ − 1773 need_to_mark_cons = 1;
+ − 1774 /* We still need to mark elem and XCAR (elem);
+ − 1775 marking elem does both */
+ − 1776 need_to_mark_elem = 1;
+ − 1777 }
+ − 1778 break;
+ − 1779
428
+ − 1780 default:
+ − 1781 abort ();
+ − 1782 }
+ − 1783
+ − 1784 if (need_to_mark_elem && ! marked_p (elem))
+ − 1785 {
+ − 1786 mark_object (elem);
+ − 1787 did_mark = 1;
+ − 1788 }
+ − 1789
+ − 1790 /* We also need to mark the cons that holds the elem or
+ − 1791 assoc-pair. We do *not* want to call (mark_object) here
+ − 1792 because that will mark the entire list; we just want to
+ − 1793 mark the cons itself.
+ − 1794 */
+ − 1795 if (need_to_mark_cons)
+ − 1796 {
+ − 1797 Lisp_Cons *c = XCONS (rest2);
+ − 1798 if (!CONS_MARKED_P (c))
+ − 1799 {
+ − 1800 MARK_CONS (c);
+ − 1801 did_mark = 1;
+ − 1802 }
+ − 1803 }
+ − 1804 }
+ − 1805
+ − 1806 /* In case of imperfect list, need to mark the final cons
+ − 1807 because we're not removing it */
+ − 1808 if (!NILP (rest2) && ! marked_p (rest2))
+ − 1809 {
+ − 1810 mark_object (rest2);
+ − 1811 did_mark = 1;
+ − 1812 }
+ − 1813 }
+ − 1814
+ − 1815 return did_mark;
+ − 1816 }
+ − 1817
+ − 1818 void
+ − 1819 prune_weak_lists (void)
+ − 1820 {
+ − 1821 Lisp_Object rest, prev = Qnil;
+ − 1822
+ − 1823 for (rest = Vall_weak_lists;
+ − 1824 !NILP (rest);
+ − 1825 rest = XWEAK_LIST (rest)->next_weak)
+ − 1826 {
+ − 1827 if (! (marked_p (rest)))
+ − 1828 {
+ − 1829 /* This weak list itself is garbage. Remove it from the list. */
+ − 1830 if (NILP (prev))
+ − 1831 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
+ − 1832 else
+ − 1833 XWEAK_LIST (prev)->next_weak =
+ − 1834 XWEAK_LIST (rest)->next_weak;
+ − 1835 }
+ − 1836 else
+ − 1837 {
+ − 1838 Lisp_Object rest2, prev2 = Qnil;
+ − 1839 Lisp_Object tortoise;
+ − 1840 int go_tortoise = 0;
+ − 1841
+ − 1842 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
+ − 1843 /* We need to be trickier since we're inside of GC;
+ − 1844 use CONSP instead of !NILP in case of user-visible
+ − 1845 imperfect lists */
+ − 1846 CONSP (rest2);)
+ − 1847 {
+ − 1848 /* It suffices to check the cons for marking,
+ − 1849 regardless of the type of weak list:
+ − 1850
+ − 1851 -- if the cons is pointed to somewhere else,
+ − 1852 then it should stay around and will be marked.
+ − 1853 -- otherwise, if it should stay around, it will
+ − 1854 have been marked in finish_marking_weak_lists().
+ − 1855 -- otherwise, it's not marked and should disappear.
+ − 1856 */
+ − 1857 if (! marked_p (rest2))
+ − 1858 {
+ − 1859 /* bye bye :-( */
+ − 1860 if (NILP (prev2))
+ − 1861 XWEAK_LIST (rest)->list = XCDR (rest2);
+ − 1862 else
+ − 1863 XCDR (prev2) = XCDR (rest2);
+ − 1864 rest2 = XCDR (rest2);
+ − 1865 /* Ouch. Circularity checking is even trickier
+ − 1866 than I thought. When we cut out a link
+ − 1867 like this, we can't advance the turtle or
+ − 1868 it'll catch up to us. Imagine that we're
+ − 1869 standing on floor tiles and moving forward --
+ − 1870 what we just did here is as if the floor
+ − 1871 tile under us just disappeared and all the
+ − 1872 ones ahead of us slid one tile towards us.
+ − 1873 In other words, we didn't move at all;
+ − 1874 if the tortoise was one step behind us
+ − 1875 previously, it still is, and therefore
+ − 1876 it must not move. */
+ − 1877 }
+ − 1878 else
+ − 1879 {
+ − 1880 prev2 = rest2;
+ − 1881
+ − 1882 /* Implementing circularity checking is trickier here
+ − 1883 than in other places because we have to guarantee
+ − 1884 that we've processed all elements before exiting
+ − 1885 due to a circularity. (In most places, an error
+ − 1886 is issued upon encountering a circularity, so it
+ − 1887 doesn't really matter if all elements are processed.)
+ − 1888 The idea is that we process along with the hare
+ − 1889 rather than the tortoise. If at any point in
+ − 1890 our forward process we encounter the tortoise,
+ − 1891 we must have already visited the spot, so we exit.
+ − 1892 (If we process with the tortoise, we can fail to
+ − 1893 process cases where a cons points to itself, or
+ − 1894 where cons A points to cons B, which points to
+ − 1895 cons A.) */
+ − 1896
+ − 1897 rest2 = XCDR (rest2);
+ − 1898 if (go_tortoise)
+ − 1899 tortoise = XCDR (tortoise);
+ − 1900 go_tortoise = !go_tortoise;
+ − 1901 if (EQ (rest2, tortoise))
+ − 1902 break;
+ − 1903 }
+ − 1904 }
+ − 1905
+ − 1906 prev = rest;
+ − 1907 }
+ − 1908 }
+ − 1909 }
+ − 1910
+ − 1911 static enum weak_list_type
+ − 1912 decode_weak_list_type (Lisp_Object symbol)
+ − 1913 {
+ − 1914 CHECK_SYMBOL (symbol);
+ − 1915 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
+ − 1916 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
+ − 1917 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
+ − 1918 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
+ − 1919 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
442
+ − 1920 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC;
428
+ − 1921
563
+ − 1922 invalid_constant ("Invalid weak list type", symbol);
428
+ − 1923 return WEAK_LIST_SIMPLE; /* not reached */
+ − 1924 }
+ − 1925
+ − 1926 static Lisp_Object
+ − 1927 encode_weak_list_type (enum weak_list_type type)
+ − 1928 {
+ − 1929 switch (type)
+ − 1930 {
+ − 1931 case WEAK_LIST_SIMPLE: return Qsimple;
+ − 1932 case WEAK_LIST_ASSOC: return Qassoc;
+ − 1933 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
+ − 1934 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
442
+ − 1935 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc;
428
+ − 1936 default:
+ − 1937 abort ();
+ − 1938 }
+ − 1939
+ − 1940 return Qnil; /* not reached */
+ − 1941 }
+ − 1942
+ − 1943 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
+ − 1944 Return non-nil if OBJECT is a weak list.
+ − 1945 */
+ − 1946 (object))
+ − 1947 {
+ − 1948 return WEAK_LISTP (object) ? Qt : Qnil;
+ − 1949 }
+ − 1950
+ − 1951 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
+ − 1952 Return a new weak list object of type TYPE.
+ − 1953 A weak list object is an object that contains a list. This list behaves
+ − 1954 like any other list except that its elements do not count towards
456
+ − 1955 garbage collection -- if the only pointer to an object is inside a weak
428
+ − 1956 list (other than pointers in similar objects such as weak hash tables),
+ − 1957 the object is garbage collected and automatically removed from the list.
+ − 1958 This is used internally, for example, to manage the list holding the
+ − 1959 children of an extent -- an extent that is unused but has a parent will
+ − 1960 still be reclaimed, and will automatically be removed from its parent's
+ − 1961 list of children.
+ − 1962
+ − 1963 Optional argument TYPE specifies the type of the weak list, and defaults
+ − 1964 to `simple'. Recognized types are
+ − 1965
+ − 1966 `simple' Objects in the list disappear if not pointed to.
+ − 1967 `assoc' Objects in the list disappear if they are conses
+ − 1968 and either the car or the cdr of the cons is not
+ − 1969 pointed to.
+ − 1970 `key-assoc' Objects in the list disappear if they are conses
+ − 1971 and the car is not pointed to.
+ − 1972 `value-assoc' Objects in the list disappear if they are conses
+ − 1973 and the cdr is not pointed to.
442
+ − 1974 `full-assoc' Objects in the list disappear if they are conses
+ − 1975 and neither the car nor the cdr is pointed to.
428
+ − 1976 */
+ − 1977 (type))
+ − 1978 {
+ − 1979 if (NILP (type))
+ − 1980 type = Qsimple;
+ − 1981
+ − 1982 return make_weak_list (decode_weak_list_type (type));
+ − 1983 }
+ − 1984
+ − 1985 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
+ − 1986 Return the type of the given weak-list object.
+ − 1987 */
+ − 1988 (weak))
+ − 1989 {
+ − 1990 CHECK_WEAK_LIST (weak);
+ − 1991 return encode_weak_list_type (XWEAK_LIST (weak)->type);
+ − 1992 }
+ − 1993
+ − 1994 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
+ − 1995 Return the list contained in a weak-list object.
+ − 1996 */
+ − 1997 (weak))
+ − 1998 {
+ − 1999 CHECK_WEAK_LIST (weak);
+ − 2000 return XWEAK_LIST_LIST (weak);
+ − 2001 }
+ − 2002
+ − 2003 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
+ − 2004 Change the list contained in a weak-list object.
+ − 2005 */
+ − 2006 (weak, new_list))
+ − 2007 {
+ − 2008 CHECK_WEAK_LIST (weak);
+ − 2009 XWEAK_LIST_LIST (weak) = new_list;
+ − 2010 return new_list;
+ − 2011 }
+ − 2012
+ − 2013
+ − 2014 /************************************************************************/
+ − 2015 /* initialization */
+ − 2016 /************************************************************************/
+ − 2017
+ − 2018 static SIGTYPE
+ − 2019 arith_error (int signo)
+ − 2020 {
+ − 2021 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
+ − 2022 EMACS_UNBLOCK_SIGNAL (signo);
563
+ − 2023 signal_error (Qarith_error, 0, Qunbound);
428
+ − 2024 }
+ − 2025
+ − 2026 void
+ − 2027 init_data_very_early (void)
+ − 2028 {
+ − 2029 /* Don't do this if just dumping out.
+ − 2030 We don't want to call `signal' in this case
+ − 2031 so that we don't have trouble with dumping
+ − 2032 signal-delivering routines in an inconsistent state. */
+ − 2033 #ifndef CANNOT_DUMP
+ − 2034 if (!initialized)
+ − 2035 return;
+ − 2036 #endif /* CANNOT_DUMP */
613
+ − 2037 EMACS_SIGNAL (SIGFPE, arith_error);
428
+ − 2038 #ifdef uts
613
+ − 2039 EMACS_SIGNAL (SIGEMT, arith_error);
428
+ − 2040 #endif /* uts */
+ − 2041 }
+ − 2042
+ − 2043 void
+ − 2044 init_errors_once_early (void)
+ − 2045 {
442
+ − 2046 DEFSYMBOL (Qerror_conditions);
+ − 2047 DEFSYMBOL (Qerror_message);
428
+ − 2048
+ − 2049 /* We declare the errors here because some other deferrors depend
+ − 2050 on some of the errors below. */
+ − 2051
+ − 2052 /* ERROR is used as a signaler for random errors for which nothing
+ − 2053 else is right */
+ − 2054
442
+ − 2055 DEFERROR (Qerror, "error", Qnil);
+ − 2056 DEFERROR_STANDARD (Qquit, Qnil);
428
+ − 2057
563
+ − 2058 DEFERROR_STANDARD (Qinvalid_argument, Qerror);
+ − 2059
+ − 2060 DEFERROR_STANDARD (Qsyntax_error, Qinvalid_argument);
442
+ − 2061 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error);
563
+ − 2062 DEFERROR_STANDARD (Qstructure_formation_error, Qsyntax_error);
+ − 2063 DEFERROR_STANDARD (Qlist_formation_error, Qstructure_formation_error);
442
+ − 2064 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error);
+ − 2065 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list);
+ − 2066 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error);
+ − 2067 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list);
428
+ − 2068
442
+ − 2069 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument);
+ − 2070 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument);
+ − 2071 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument);
+ − 2072 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument);
563
+ − 2073 DEFERROR_STANDARD (Qinvalid_constant, Qinvalid_argument);
442
+ − 2074 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument);
+ − 2075
563
+ − 2076 DEFERROR_STANDARD (Qinvalid_state, Qerror);
442
+ − 2077 DEFERROR (Qvoid_function, "Symbol's function definition is void",
+ − 2078 Qinvalid_state);
+ − 2079 DEFERROR (Qcyclic_function_indirection,
+ − 2080 "Symbol's chain of function indirections contains a loop",
+ − 2081 Qinvalid_state);
+ − 2082 DEFERROR (Qvoid_variable, "Symbol's value as variable is void",
+ − 2083 Qinvalid_state);
+ − 2084 DEFERROR (Qcyclic_variable_indirection,
+ − 2085 "Symbol's chain of variable indirections contains a loop",
+ − 2086 Qinvalid_state);
563
+ − 2087 DEFERROR_STANDARD (Qstack_overflow, Qinvalid_state);
+ − 2088 DEFERROR_STANDARD (Qinternal_error, Qinvalid_state);
+ − 2089 DEFERROR_STANDARD (Qout_of_memory, Qinvalid_state);
428
+ − 2090
563
+ − 2091 DEFERROR_STANDARD (Qinvalid_operation, Qerror);
+ − 2092 DEFERROR_STANDARD (Qinvalid_change, Qinvalid_operation);
442
+ − 2093 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol",
+ − 2094 Qinvalid_change);
563
+ − 2095 DEFERROR_STANDARD (Qprinting_unreadable_object, Qinvalid_operation);
+ − 2096 DEFERROR (Qunimplemented, "Feature not yet implemented", Qinvalid_operation);
442
+ − 2097
563
+ − 2098 DEFERROR_STANDARD (Qediting_error, Qinvalid_operation);
442
+ − 2099 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error);
+ − 2100 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error);
+ − 2101 DEFERROR (Qbuffer_read_only, "Buffer is read-only", Qediting_error);
+ − 2102
+ − 2103 DEFERROR (Qio_error, "IO Error", Qinvalid_operation);
563
+ − 2104 DEFERROR_STANDARD (Qfile_error, Qio_error);
+ − 2105 DEFERROR (Qend_of_file, "End of file or stream", Qfile_error);
+ − 2106 DEFERROR_STANDARD (Qconversion_error, Qio_error);
580
+ − 2107 DEFERROR_STANDARD (Qtext_conversion_error, Qconversion_error);
442
+ − 2108
+ − 2109 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation);
+ − 2110 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error);
+ − 2111 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error);
+ − 2112 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error);
+ − 2113 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error);
+ − 2114 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error);
428
+ − 2115 }
+ − 2116
+ − 2117 void
+ − 2118 syms_of_data (void)
+ − 2119 {
442
+ − 2120 INIT_LRECORD_IMPLEMENTATION (weak_list);
+ − 2121
+ − 2122 DEFSYMBOL (Qquote);
+ − 2123 DEFSYMBOL (Qlambda);
+ − 2124 DEFSYMBOL (Qlistp);
+ − 2125 DEFSYMBOL (Qtrue_list_p);
+ − 2126 DEFSYMBOL (Qconsp);
+ − 2127 DEFSYMBOL (Qsubrp);
+ − 2128 DEFSYMBOL (Qsymbolp);
+ − 2129 DEFSYMBOL (Qintegerp);
+ − 2130 DEFSYMBOL (Qcharacterp);
+ − 2131 DEFSYMBOL (Qnatnump);
+ − 2132 DEFSYMBOL (Qstringp);
+ − 2133 DEFSYMBOL (Qarrayp);
+ − 2134 DEFSYMBOL (Qsequencep);
+ − 2135 DEFSYMBOL (Qbufferp);
+ − 2136 DEFSYMBOL (Qbitp);
+ − 2137 DEFSYMBOL_MULTIWORD_PREDICATE (Qbit_vectorp);
+ − 2138 DEFSYMBOL (Qvectorp);
+ − 2139 DEFSYMBOL (Qchar_or_string_p);
+ − 2140 DEFSYMBOL (Qmarkerp);
+ − 2141 DEFSYMBOL (Qinteger_or_marker_p);
+ − 2142 DEFSYMBOL (Qinteger_or_char_p);
+ − 2143 DEFSYMBOL (Qinteger_char_or_marker_p);
+ − 2144 DEFSYMBOL (Qnumberp);
+ − 2145 DEFSYMBOL (Qnumber_char_or_marker_p);
+ − 2146 DEFSYMBOL (Qcdr);
563
+ − 2147 DEFSYMBOL (Qerror_lacks_explanatory_string);
442
+ − 2148 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp);
428
+ − 2149
+ − 2150 #ifdef LISP_FLOAT_TYPE
442
+ − 2151 DEFSYMBOL (Qfloatp);
428
+ − 2152 #endif /* LISP_FLOAT_TYPE */
+ − 2153
+ − 2154 DEFSUBR (Fwrong_type_argument);
+ − 2155
+ − 2156 DEFSUBR (Feq);
+ − 2157 DEFSUBR (Fold_eq);
+ − 2158 DEFSUBR (Fnull);
+ − 2159 Ffset (intern ("not"), intern ("null"));
+ − 2160 DEFSUBR (Flistp);
+ − 2161 DEFSUBR (Fnlistp);
+ − 2162 DEFSUBR (Ftrue_list_p);
+ − 2163 DEFSUBR (Fconsp);
+ − 2164 DEFSUBR (Fatom);
+ − 2165 DEFSUBR (Fchar_or_string_p);
+ − 2166 DEFSUBR (Fcharacterp);
+ − 2167 DEFSUBR (Fchar_int_p);
+ − 2168 DEFSUBR (Fchar_to_int);
+ − 2169 DEFSUBR (Fint_to_char);
+ − 2170 DEFSUBR (Fchar_or_char_int_p);
+ − 2171 DEFSUBR (Fintegerp);
+ − 2172 DEFSUBR (Finteger_or_marker_p);
+ − 2173 DEFSUBR (Finteger_or_char_p);
+ − 2174 DEFSUBR (Finteger_char_or_marker_p);
+ − 2175 DEFSUBR (Fnumberp);
+ − 2176 DEFSUBR (Fnumber_or_marker_p);
+ − 2177 DEFSUBR (Fnumber_char_or_marker_p);
+ − 2178 #ifdef LISP_FLOAT_TYPE
+ − 2179 DEFSUBR (Ffloatp);
+ − 2180 #endif /* LISP_FLOAT_TYPE */
+ − 2181 DEFSUBR (Fnatnump);
+ − 2182 DEFSUBR (Fsymbolp);
+ − 2183 DEFSUBR (Fkeywordp);
+ − 2184 DEFSUBR (Fstringp);
+ − 2185 DEFSUBR (Fvectorp);
+ − 2186 DEFSUBR (Fbitp);
+ − 2187 DEFSUBR (Fbit_vector_p);
+ − 2188 DEFSUBR (Farrayp);
+ − 2189 DEFSUBR (Fsequencep);
+ − 2190 DEFSUBR (Fmarkerp);
+ − 2191 DEFSUBR (Fsubrp);
+ − 2192 DEFSUBR (Fsubr_min_args);
+ − 2193 DEFSUBR (Fsubr_max_args);
+ − 2194 DEFSUBR (Fsubr_interactive);
+ − 2195 DEFSUBR (Ftype_of);
+ − 2196 DEFSUBR (Fcar);
+ − 2197 DEFSUBR (Fcdr);
+ − 2198 DEFSUBR (Fcar_safe);
+ − 2199 DEFSUBR (Fcdr_safe);
+ − 2200 DEFSUBR (Fsetcar);
+ − 2201 DEFSUBR (Fsetcdr);
+ − 2202 DEFSUBR (Findirect_function);
+ − 2203 DEFSUBR (Faref);
+ − 2204 DEFSUBR (Faset);
+ − 2205
+ − 2206 DEFSUBR (Fnumber_to_string);
+ − 2207 DEFSUBR (Fstring_to_number);
+ − 2208 DEFSUBR (Feqlsign);
+ − 2209 DEFSUBR (Flss);
+ − 2210 DEFSUBR (Fgtr);
+ − 2211 DEFSUBR (Fleq);
+ − 2212 DEFSUBR (Fgeq);
+ − 2213 DEFSUBR (Fneq);
+ − 2214 DEFSUBR (Fzerop);
+ − 2215 DEFSUBR (Fplus);
+ − 2216 DEFSUBR (Fminus);
+ − 2217 DEFSUBR (Ftimes);
+ − 2218 DEFSUBR (Fquo);
+ − 2219 DEFSUBR (Frem);
+ − 2220 DEFSUBR (Fmod);
+ − 2221 DEFSUBR (Fmax);
+ − 2222 DEFSUBR (Fmin);
+ − 2223 DEFSUBR (Flogand);
+ − 2224 DEFSUBR (Flogior);
+ − 2225 DEFSUBR (Flogxor);
+ − 2226 DEFSUBR (Flsh);
+ − 2227 DEFSUBR (Fash);
+ − 2228 DEFSUBR (Fadd1);
+ − 2229 DEFSUBR (Fsub1);
+ − 2230 DEFSUBR (Flognot);
+ − 2231
+ − 2232 DEFSUBR (Fweak_list_p);
+ − 2233 DEFSUBR (Fmake_weak_list);
+ − 2234 DEFSUBR (Fweak_list_type);
+ − 2235 DEFSUBR (Fweak_list_list);
+ − 2236 DEFSUBR (Fset_weak_list_list);
+ − 2237 }
+ − 2238
+ − 2239 void
+ − 2240 vars_of_data (void)
+ − 2241 {
+ − 2242 /* This must not be staticpro'd */
+ − 2243 Vall_weak_lists = Qnil;
452
+ − 2244 dump_add_weak_object_chain (&Vall_weak_lists);
428
+ − 2245
+ − 2246 #ifdef DEBUG_XEMACS
+ − 2247 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
+ − 2248 If non-zero, note when your code may be suffering from char-int confoundance.
+ − 2249 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
+ − 2250 etc. where an int and a char with the same value are being compared,
+ − 2251 it will issue a notice on stderr to this effect, along with a backtrace.
+ − 2252 In such situations, the result would be different in XEmacs 19 versus
+ − 2253 XEmacs 20, and you probably don't want this.
+ − 2254
+ − 2255 Note that in order to see these notices, you have to byte compile your
+ − 2256 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
+ − 2257 have its chars and ints all confounded in the byte code, making it
+ − 2258 impossible to accurately determine Ebola infection.
+ − 2259 */ );
+ − 2260
+ − 2261 debug_issue_ebola_notices = 0;
+ − 2262
+ − 2263 DEFVAR_INT ("debug-ebola-backtrace-length",
+ − 2264 &debug_ebola_backtrace_length /*
+ − 2265 Length (in stack frames) of short backtrace printed out in Ebola notices.
+ − 2266 See `debug-issue-ebola-notices'.
+ − 2267 */ );
+ − 2268 debug_ebola_backtrace_length = 32;
+ − 2269
+ − 2270 #endif /* DEBUG_XEMACS */
+ − 2271 }
