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