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.
4 Copyright (C) 2000 Ben Wing.
6 This file is part of XEmacs.
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
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
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. */
23 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
26 /* This file has been Mule-ized. */
33 #include "syssignal.h"
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 */
41 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
42 Lisp_Object Qerror_conditions, Qerror_message;
43 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
44 Lisp_Object Qlist_formation_error;
45 Lisp_Object Qmalformed_list, Qmalformed_property_list;
46 Lisp_Object Qcircular_list, Qcircular_property_list;
47 Lisp_Object Qinvalid_argument, Qwrong_type_argument, Qargs_out_of_range;
48 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch;
49 Lisp_Object Qinternal_error, Qinvalid_state;
50 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
51 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
52 Lisp_Object Qinvalid_operation, Qinvalid_change;
53 Lisp_Object Qsetting_constant;
54 Lisp_Object Qediting_error;
55 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
56 Lisp_Object Qio_error, Qend_of_file;
57 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
58 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
59 Lisp_Object Qintegerp, Qnatnump, Qsymbolp;
60 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
61 Lisp_Object Qconsp, Qsubrp;
62 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
63 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
64 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
65 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
66 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
72 int debug_issue_ebola_notices;
74 Fixnum debug_ebola_backtrace_length;
77 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
79 if (debug_issue_ebola_notices
80 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
82 /* #### It would be really nice if this were a proper warning
83 instead of brain-dead print ro Qexternal_debugging_output. */
84 write_c_string ("Comparison between integer and character is constant nil (",
85 Qexternal_debugging_output);
86 Fprinc (obj1, Qexternal_debugging_output);
87 write_c_string (" and ", Qexternal_debugging_output);
88 Fprinc (obj2, Qexternal_debugging_output);
89 write_c_string (")\n", Qexternal_debugging_output);
90 debug_short_backtrace (debug_ebola_backtrace_length);
92 return EQ (obj1, obj2);
95 #endif /* DEBUG_XEMACS */
100 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
102 /* This function can GC */
103 REGISTER Lisp_Object tem;
106 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
107 tem = call1 (predicate, value);
114 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
116 signal_error (Qwrong_type_argument, list2 (predicate, value));
119 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
120 Signal an error until the correct type value is given by the user.
121 This function loops, signalling a continuable `wrong-type-argument' error
122 with PREDICATE and VALUE as the data associated with the error and then
123 calling PREDICATE on the returned value, until the value gotten satisfies
124 PREDICATE. At that point, the gotten value is returned.
128 return wrong_type_argument (predicate, value);
132 c_write_error (Lisp_Object obj)
134 signal_simple_error ("Attempt to modify read-only object (c)", obj);
138 lisp_write_error (Lisp_Object obj)
140 signal_simple_error ("Attempt to modify read-only object (lisp)", obj);
144 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
146 signal_error (Qargs_out_of_range, list2 (a1, a2));
150 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
152 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
156 check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max)
158 if (val < min || val > max)
159 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
162 /* On some machines, XINT needs a temporary location.
163 Here it is, in case it is needed. */
165 EMACS_INT sign_extend_temp;
167 /* On a few machines, XINT can only be done by calling this. */
168 /* XEmacs: only used by m/convex.h */
169 EMACS_INT sign_extend_lisp_int (EMACS_INT num);
171 sign_extend_lisp_int (EMACS_INT num)
173 if (num & (1L << (VALBITS - 1)))
174 return num | ((-1L) << VALBITS);
176 return num & ((1L << VALBITS) - 1);
180 /* Data type predicates */
182 DEFUN ("eq", Feq, 2, 2, 0, /*
183 Return t if the two args are the same Lisp object.
187 return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil;
190 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
191 Return t if the two args are (in most cases) the same Lisp object.
193 Special kludge: A character is considered `old-eq' to its equivalent integer
194 even though they are not the same object and are in fact of different
195 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
196 preserve byte-code compatibility with v19. This kludge is known as the
197 \"char-int confoundance disease\" and appears in a number of other
198 functions with `old-foo' equivalents.
200 Do not use this function!
205 return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
208 DEFUN ("null", Fnull, 1, 1, 0, /*
209 Return t if OBJECT is nil.
213 return NILP (object) ? Qt : Qnil;
216 DEFUN ("consp", Fconsp, 1, 1, 0, /*
217 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
221 return CONSP (object) ? Qt : Qnil;
224 DEFUN ("atom", Fatom, 1, 1, 0, /*
225 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
229 return CONSP (object) ? Qnil : Qt;
232 DEFUN ("listp", Flistp, 1, 1, 0, /*
233 Return t if OBJECT is a list. `nil' is a list.
237 return LISTP (object) ? Qt : Qnil;
240 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
241 Return t if OBJECT is not a list. `nil' is a list.
245 return LISTP (object) ? Qnil : Qt;
248 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
249 Return t if OBJECT is a non-dotted, i.e. nil-terminated, list.
253 return TRUE_LIST_P (object) ? Qt : Qnil;
256 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
257 Return t if OBJECT is a symbol.
261 return SYMBOLP (object) ? Qt : Qnil;
264 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
265 Return t if OBJECT is a keyword.
269 return KEYWORDP (object) ? Qt : Qnil;
272 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
273 Return t if OBJECT is a vector.
277 return VECTORP (object) ? Qt : Qnil;
280 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
281 Return t if OBJECT is a bit vector.
285 return BIT_VECTORP (object) ? Qt : Qnil;
288 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
289 Return t if OBJECT is a string.
293 return STRINGP (object) ? Qt : Qnil;
296 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
297 Return t if OBJECT is an array (string, vector, or bit vector).
301 return (VECTORP (object) ||
303 BIT_VECTORP (object))
307 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
308 Return t if OBJECT is a sequence (list or array).
312 return (LISTP (object) ||
315 BIT_VECTORP (object))
319 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
320 Return t if OBJECT is a marker (editor pointer).
324 return MARKERP (object) ? Qt : Qnil;
327 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
328 Return t if OBJECT is a built-in function.
332 return SUBRP (object) ? Qt : Qnil;
335 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
336 Return minimum number of args built-in function SUBR may be called with.
341 return make_int (XSUBR (subr)->min_args);
344 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
345 Return maximum number of args built-in function SUBR may be called with,
346 or nil if it takes an arbitrary number of arguments or is a special form.
352 nargs = XSUBR (subr)->max_args;
353 if (nargs == MANY || nargs == UNEVALLED)
356 return make_int (nargs);
359 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
360 Return the interactive spec of the subr object SUBR, or nil.
361 If non-nil, the return value will be a list whose first element is
362 `interactive' and whose second element is the interactive spec.
368 prompt = XSUBR (subr)->prompt;
369 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
373 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
374 Return t if OBJECT is a character.
375 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
376 Any character can be converted into an equivalent integer using
377 `char-int'. To convert the other way, use `int-char'; however,
378 only some integers can be converted into characters. Such an integer
379 is called a `char-int'; see `char-int-p'.
381 Some functions that work on integers (e.g. the comparison functions
382 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
383 accept characters and implicitly convert them into integers. In
384 general, functions that work on characters also accept char-ints and
385 implicitly convert them into characters. WARNING: Neither of these
386 behaviors is very desirable, and they are maintained for backward
387 compatibility with old E-Lisp programs that confounded characters and
388 integers willy-nilly. These behaviors may change in the future; therefore,
389 do not rely on them. Instead, use the character-specific functions such
394 return CHARP (object) ? Qt : Qnil;
397 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
398 Convert CHARACTER into an equivalent integer.
399 The resulting integer will always be non-negative. The integers in
400 the range 0 - 255 map to characters as follows:
404 128 - 159 Control set 1
405 160 - 255 Right half of ISO-8859-1
407 If support for Mule does not exist, these are the only valid character
408 values. When Mule support exists, the values assigned to other characters
409 may vary depending on the particular version of XEmacs, the order in which
410 character sets were loaded, etc., and you should not depend on them.
414 CHECK_CHAR (character);
415 return make_int (XCHAR (character));
418 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
419 Convert integer INTEGER into the equivalent character.
420 Not all integers correspond to valid characters; use `char-int-p' to
421 determine whether this is the case. If the integer cannot be converted,
427 if (CHAR_INTP (integer))
428 return make_char (XINT (integer));
433 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
434 Return t if OBJECT is an integer that can be converted into a character.
439 return CHAR_INTP (object) ? Qt : Qnil;
442 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
443 Return t if OBJECT is a character or an integer that can be converted into one.
447 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
450 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
451 Return t if OBJECT is a character (or a char-int) or a string.
452 It is semi-hateful that we allow a char-int here, as it goes against
453 the name of this function, but it makes the most sense considering the
454 other steps we take to maintain compatibility with the old character/integer
455 confoundedness in older versions of E-Lisp.
459 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
462 DEFUN ("char-ref-p", Fchar_ref_p, 1, 1, 0, /*
463 Return t if OBJECT is a character-reference.
467 return CONSP (object) && KEYWORDP (XCAR (object)) ? Qt : Qnil;
470 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
471 Return t if OBJECT is an integer.
475 return INTP (object) ? Qt : Qnil;
478 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
479 Return t if OBJECT is an integer or a marker (editor pointer).
483 return INTP (object) || MARKERP (object) ? Qt : Qnil;
486 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
487 Return t if OBJECT is an integer or a character.
491 return INTP (object) || CHARP (object) ? Qt : Qnil;
494 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
495 Return t if OBJECT is an integer, character or a marker (editor pointer).
499 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
502 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
503 Return t if OBJECT is a nonnegative integer.
507 return NATNUMP (object) ? Qt : Qnil;
510 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
511 Return t if OBJECT is a bit (0 or 1).
515 return BITP (object) ? Qt : Qnil;
518 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
519 Return t if OBJECT is a number (floating point or integer).
523 return INT_OR_FLOATP (object) ? Qt : Qnil;
526 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
527 Return t if OBJECT is a number or a marker.
531 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
534 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
535 Return t if OBJECT is a number, character or a marker.
539 return (INT_OR_FLOATP (object) ||
545 #ifdef LISP_FLOAT_TYPE
546 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
547 Return t if OBJECT is a floating point number.
551 return FLOATP (object) ? Qt : Qnil;
553 #endif /* LISP_FLOAT_TYPE */
555 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
556 Return a symbol representing the type of OBJECT.
560 switch (XTYPE (object))
562 case Lisp_Type_Record:
563 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
565 case Lisp_Type_Char: return Qcharacter;
567 default: return Qinteger;
572 /* Extract and set components of lists */
574 DEFUN ("car", Fcar, 1, 1, 0, /*
575 Return the car of LIST. If arg is nil, return nil.
576 Error if arg is not nil and not a cons cell. See also `car-safe'.
584 else if (NILP (list))
587 list = wrong_type_argument (Qlistp, list);
591 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
592 Return the car of OBJECT if it is a cons cell, or else nil.
596 return CONSP (object) ? XCAR (object) : Qnil;
599 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
600 Return the cdr of LIST. If arg is nil, return nil.
601 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
609 else if (NILP (list))
612 list = wrong_type_argument (Qlistp, list);
616 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
617 Return the cdr of OBJECT if it is a cons cell, else nil.
621 return CONSP (object) ? XCDR (object) : Qnil;
624 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
625 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR.
629 if (!CONSP (cons_cell))
630 cons_cell = wrong_type_argument (Qconsp, cons_cell);
632 XCAR (cons_cell) = newcar;
636 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
637 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR.
641 if (!CONSP (cons_cell))
642 cons_cell = wrong_type_argument (Qconsp, cons_cell);
644 XCDR (cons_cell) = newcdr;
648 /* Find the function at the end of a chain of symbol function indirections.
650 If OBJECT is a symbol, find the end of its function chain and
651 return the value found there. If OBJECT is not a symbol, just
652 return it. If there is a cycle in the function chain, signal a
653 cyclic-function-indirection error.
655 This is like Findirect_function when VOID_FUNCTION_ERRORP is true.
656 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end
657 of the chain ends up being Qunbound. */
659 indirect_function (Lisp_Object object, int void_function_errorp)
661 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
662 Lisp_Object tortoise, hare;
665 for (hare = tortoise = object, count = 0;
667 hare = XSYMBOL (hare)->function, count++)
669 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
672 tortoise = XSYMBOL (tortoise)->function;
673 if (EQ (hare, tortoise))
674 return Fsignal (Qcyclic_function_indirection, list1 (object));
677 if (void_function_errorp && UNBOUNDP (hare))
678 return signal_void_function_error (object);
683 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
684 Return the function at the end of OBJECT's function chain.
685 If OBJECT is a symbol, follow all function indirections and return
686 the final function binding.
687 If OBJECT is not a symbol, just return it.
688 Signal a void-function error if the final symbol is unbound.
689 Signal a cyclic-function-indirection error if there is a loop in the
690 function chain of symbols.
694 return indirect_function (object, 1);
697 /* Extract and set vector and string elements */
699 DEFUN ("aref", Faref, 2, 2, 0, /*
700 Return the element of ARRAY at index INDEX.
701 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
709 if (INTP (index_)) idx = XINT (index_);
710 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
713 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
717 if (idx < 0) goto range_error;
721 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
722 return XVECTOR_DATA (array)[idx];
724 else if (BIT_VECTORP (array))
726 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
727 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
729 else if (STRINGP (array))
731 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
732 return make_char (string_char (XSTRING (array), idx));
734 #ifdef LOSING_BYTECODE
735 else if (COMPILED_FUNCTIONP (array))
737 /* Weird, gross compatibility kludge */
738 return Felt (array, index_);
743 check_losing_bytecode ("aref", array);
744 array = wrong_type_argument (Qarrayp, array);
749 args_out_of_range (array, index_);
750 return Qnil; /* not reached */
753 DEFUN ("aset", Faset, 3, 3, 0, /*
754 Store into the element of ARRAY at index INDEX the value NEWVAL.
755 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
757 (array, index_, newval))
763 if (INTP (index_)) idx = XINT (index_);
764 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
767 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
771 if (idx < 0) goto range_error;
775 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
776 XVECTOR_DATA (array)[idx] = newval;
778 else if (BIT_VECTORP (array))
780 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
782 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
784 else if (STRINGP (array))
786 CHECK_CHAR_COERCE_INT (newval);
787 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
788 set_string_char (XSTRING (array), idx, XCHAR (newval));
789 bump_string_modiff (array);
793 array = wrong_type_argument (Qarrayp, array);
800 args_out_of_range (array, index_);
801 return Qnil; /* not reached */
805 /**********************************************************************/
806 /* Arithmetic functions */
807 /**********************************************************************/
819 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
823 if (INTP (obj)) p->c.ival = XINT (obj);
824 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
825 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
826 #ifdef LISP_FLOAT_TYPE
827 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
831 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
837 number_char_or_marker_to_double (Lisp_Object obj)
840 if (INTP (obj)) return (double) XINT (obj);
841 else if (CHARP (obj)) return (double) XCHAR (obj);
842 else if (MARKERP (obj)) return (double) marker_position (obj);
843 #ifdef LISP_FLOAT_TYPE
844 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
848 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
854 integer_char_or_marker_to_int (Lisp_Object obj)
857 if (INTP (obj)) return XINT (obj);
858 else if (CHARP (obj)) return XCHAR (obj);
859 else if (MARKERP (obj)) return marker_position (obj);
862 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
867 #define ARITHCOMPARE_MANY(op) \
869 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
870 Lisp_Object *args_end = args + nargs; \
872 number_char_or_marker_to_int_or_double (*args++, p); \
874 while (args < args_end) \
876 number_char_or_marker_to_int_or_double (*args++, q); \
878 if (!((p->int_p && q->int_p) ? \
879 (p->c.ival op q->c.ival) : \
880 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
881 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
884 { /* swap */ int_or_double *r = p; p = q; q = r; } \
889 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
890 Return t if all the arguments are numerically equal.
891 The arguments may be numbers, characters or markers.
893 (int nargs, Lisp_Object *args))
895 ARITHCOMPARE_MANY (==)
898 DEFUN ("<", Flss, 1, MANY, 0, /*
899 Return t if the sequence of arguments is monotonically increasing.
900 The arguments may be numbers, characters or markers.
902 (int nargs, Lisp_Object *args))
904 ARITHCOMPARE_MANY (<)
907 DEFUN (">", Fgtr, 1, MANY, 0, /*
908 Return t if the sequence of arguments is monotonically decreasing.
909 The arguments may be numbers, characters or markers.
911 (int nargs, Lisp_Object *args))
913 ARITHCOMPARE_MANY (>)
916 DEFUN ("<=", Fleq, 1, MANY, 0, /*
917 Return t if the sequence of arguments is monotonically nondecreasing.
918 The arguments may be numbers, characters or markers.
920 (int nargs, Lisp_Object *args))
922 ARITHCOMPARE_MANY (<=)
925 DEFUN (">=", Fgeq, 1, MANY, 0, /*
926 Return t if the sequence of arguments is monotonically nonincreasing.
927 The arguments may be numbers, characters or markers.
929 (int nargs, Lisp_Object *args))
931 ARITHCOMPARE_MANY (>=)
934 DEFUN ("/=", Fneq, 1, MANY, 0, /*
935 Return t if no two arguments are numerically equal.
936 The arguments may be numbers, characters or markers.
938 (int nargs, Lisp_Object *args))
940 Lisp_Object *args_end = args + nargs;
943 /* Unlike all the other comparisons, this is an N*N algorithm.
944 We could use a hash table for nargs > 50 to make this linear. */
945 for (p = args; p < args_end; p++)
947 int_or_double iod1, iod2;
948 number_char_or_marker_to_int_or_double (*p, &iod1);
950 for (q = p + 1; q < args_end; q++)
952 number_char_or_marker_to_int_or_double (*q, &iod2);
954 if (!((iod1.int_p && iod2.int_p) ?
955 (iod1.c.ival != iod2.c.ival) :
956 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
957 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
964 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
965 Return t if NUMBER is zero.
971 return EQ (number, Qzero) ? Qt : Qnil;
972 #ifdef LISP_FLOAT_TYPE
973 else if (FLOATP (number))
974 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
975 #endif /* LISP_FLOAT_TYPE */
978 number = wrong_type_argument (Qnumberp, number);
983 /* Convert between a 32-bit value and a cons of two 16-bit values.
984 This is used to pass 32-bit integers to and from the user.
985 Use time_to_lisp() and lisp_to_time() for time values.
987 If you're thinking of using this to store a pointer into a Lisp Object
988 for internal purposes (such as when calling record_unwind_protect()),
989 try using make_opaque_ptr()/get_opaque_ptr() instead. */
991 word_to_lisp (unsigned int item)
993 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
997 lisp_to_word (Lisp_Object item)
1003 Lisp_Object top = Fcar (item);
1004 Lisp_Object bot = Fcdr (item);
1007 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
1012 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
1013 Convert NUMBER to a string by printing it in decimal.
1014 Uses a minus sign if negative.
1015 NUMBER may be an integer or a floating point number.
1019 char buffer[VALBITS];
1021 CHECK_INT_OR_FLOAT (number);
1023 #ifdef LISP_FLOAT_TYPE
1024 if (FLOATP (number))
1026 char pigbuf[350]; /* see comments in float_to_string */
1028 float_to_string (pigbuf, XFLOAT_DATA (number));
1029 return build_string (pigbuf);
1031 #endif /* LISP_FLOAT_TYPE */
1033 long_to_string (buffer, XINT (number));
1034 return build_string (buffer);
1038 digit_to_number (int character, int base)
1041 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1042 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
1043 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
1046 return digit >= base ? -1 : digit;
1049 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
1050 Convert STRING to a number by parsing it as a number in base BASE.
1051 This parses both integers and floating point numbers.
1052 It ignores leading spaces and tabs.
1054 If BASE is nil or omitted, base 10 is used.
1055 BASE must be an integer between 2 and 16 (inclusive).
1056 Floating point numbers always use base 10.
1063 CHECK_STRING (string);
1071 check_int_range (b, 2, 16);
1074 p = (char *) XSTRING_DATA (string);
1076 /* Skip any whitespace at the front of the number. Some versions of
1077 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1078 while (*p == ' ' || *p == '\t')
1081 #ifdef LISP_FLOAT_TYPE
1082 if (isfloat_string (p) && b == 10)
1083 return make_float (atof (p));
1084 #endif /* LISP_FLOAT_TYPE */
1088 /* Use the system-provided functions for base 10. */
1089 #if SIZEOF_EMACS_INT == SIZEOF_INT
1090 return make_int (atoi (p));
1091 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1092 return make_int (atol (p));
1093 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1094 return make_int (atoll (p));
1111 int digit = digit_to_number (*p++, b);
1116 return make_int (negative * v);
1121 DEFUN ("+", Fplus, 0, MANY, 0, /*
1122 Return sum of any number of arguments.
1123 The arguments should all be numbers, characters or markers.
1125 (int nargs, Lisp_Object *args))
1127 EMACS_INT iaccum = 0;
1128 Lisp_Object *args_end = args + nargs;
1130 while (args < args_end)
1133 number_char_or_marker_to_int_or_double (*args++, &iod);
1135 iaccum += iod.c.ival;
1138 double daccum = (double) iaccum + iod.c.dval;
1139 while (args < args_end)
1140 daccum += number_char_or_marker_to_double (*args++);
1141 return make_float (daccum);
1145 return make_int (iaccum);
1148 DEFUN ("-", Fminus, 1, MANY, 0, /*
1149 Negate number or subtract numbers, characters or markers.
1150 With one arg, negates it. With more than one arg,
1151 subtracts all but the first from the first.
1153 (int nargs, Lisp_Object *args))
1157 Lisp_Object *args_end = args + nargs;
1160 number_char_or_marker_to_int_or_double (*args++, &iod);
1162 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
1165 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
1169 while (args < args_end)
1171 number_char_or_marker_to_int_or_double (*args++, &iod);
1173 iaccum -= iod.c.ival;
1176 daccum = (double) iaccum - iod.c.dval;
1181 return make_int (iaccum);
1184 for (; args < args_end; args++)
1185 daccum -= number_char_or_marker_to_double (*args);
1186 return make_float (daccum);
1189 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1190 Return product of any number of arguments.
1191 The arguments should all be numbers, characters or markers.
1193 (int nargs, Lisp_Object *args))
1195 EMACS_INT iaccum = 1;
1196 Lisp_Object *args_end = args + nargs;
1198 while (args < args_end)
1201 number_char_or_marker_to_int_or_double (*args++, &iod);
1203 iaccum *= iod.c.ival;
1206 double daccum = (double) iaccum * iod.c.dval;
1207 while (args < args_end)
1208 daccum *= number_char_or_marker_to_double (*args++);
1209 return make_float (daccum);
1213 return make_int (iaccum);
1216 DEFUN ("/", Fquo, 1, MANY, 0, /*
1217 Return first argument divided by all the remaining arguments.
1218 The arguments must be numbers, characters or markers.
1219 With one argument, reciprocates the argument.
1221 (int nargs, Lisp_Object *args))
1225 Lisp_Object *args_end = args + nargs;
1232 number_char_or_marker_to_int_or_double (*args++, &iod);
1234 iaccum = iod.c.ival;
1237 daccum = iod.c.dval;
1242 while (args < args_end)
1244 number_char_or_marker_to_int_or_double (*args++, &iod);
1247 if (iod.c.ival == 0) goto divide_by_zero;
1248 iaccum /= iod.c.ival;
1252 if (iod.c.dval == 0) goto divide_by_zero;
1253 daccum = (double) iaccum / iod.c.dval;
1258 return make_int (iaccum);
1261 for (; args < args_end; args++)
1263 double dval = number_char_or_marker_to_double (*args);
1264 if (dval == 0) goto divide_by_zero;
1267 return make_float (daccum);
1270 Fsignal (Qarith_error, Qnil);
1271 return Qnil; /* not reached */
1274 DEFUN ("max", Fmax, 1, MANY, 0, /*
1275 Return largest of all the arguments.
1276 All arguments must be numbers, characters or markers.
1277 The value is always a number; markers and characters are converted
1280 (int nargs, Lisp_Object *args))
1284 Lisp_Object *args_end = args + nargs;
1287 number_char_or_marker_to_int_or_double (*args++, &iod);
1296 while (args < args_end)
1298 number_char_or_marker_to_int_or_double (*args++, &iod);
1301 if (imax < iod.c.ival) imax = iod.c.ival;
1305 dmax = (double) imax;
1306 if (dmax < iod.c.dval) dmax = iod.c.dval;
1311 return make_int (imax);
1314 while (args < args_end)
1316 double dval = number_char_or_marker_to_double (*args++);
1317 if (dmax < dval) dmax = dval;
1319 return make_float (dmax);
1322 DEFUN ("min", Fmin, 1, MANY, 0, /*
1323 Return smallest of all the arguments.
1324 All arguments must be numbers, characters or markers.
1325 The value is always a number; markers and characters are converted
1328 (int nargs, Lisp_Object *args))
1332 Lisp_Object *args_end = args + nargs;
1335 number_char_or_marker_to_int_or_double (*args++, &iod);
1344 while (args < args_end)
1346 number_char_or_marker_to_int_or_double (*args++, &iod);
1349 if (imin > iod.c.ival) imin = iod.c.ival;
1353 dmin = (double) imin;
1354 if (dmin > iod.c.dval) dmin = iod.c.dval;
1359 return make_int (imin);
1362 while (args < args_end)
1364 double dval = number_char_or_marker_to_double (*args++);
1365 if (dmin > dval) dmin = dval;
1367 return make_float (dmin);
1370 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1371 Return bitwise-and of all the arguments.
1372 Arguments may be integers, or markers or characters converted to integers.
1374 (int nargs, Lisp_Object *args))
1376 EMACS_INT bits = ~0;
1377 Lisp_Object *args_end = args + nargs;
1379 while (args < args_end)
1380 bits &= integer_char_or_marker_to_int (*args++);
1382 return make_int (bits);
1385 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1386 Return bitwise-or of all the arguments.
1387 Arguments may be integers, or markers or characters converted to integers.
1389 (int nargs, Lisp_Object *args))
1392 Lisp_Object *args_end = args + nargs;
1394 while (args < args_end)
1395 bits |= integer_char_or_marker_to_int (*args++);
1397 return make_int (bits);
1400 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1401 Return bitwise-exclusive-or of all the arguments.
1402 Arguments may be integers, or markers or characters converted to integers.
1404 (int nargs, Lisp_Object *args))
1407 Lisp_Object *args_end = args + nargs;
1409 while (args < args_end)
1410 bits ^= integer_char_or_marker_to_int (*args++);
1412 return make_int (bits);
1415 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1416 Return the bitwise complement of NUMBER.
1417 NUMBER may be an integer, marker or character converted to integer.
1421 return make_int (~ integer_char_or_marker_to_int (number));
1424 DEFUN ("%", Frem, 2, 2, 0, /*
1425 Return remainder of first arg divided by second.
1426 Both must be integers, characters or markers.
1430 EMACS_INT ival1 = integer_char_or_marker_to_int (number1);
1431 EMACS_INT ival2 = integer_char_or_marker_to_int (number2);
1434 Fsignal (Qarith_error, Qnil);
1436 return make_int (ival1 % ival2);
1439 /* Note, ANSI *requires* the presence of the fmod() library routine.
1440 If your system doesn't have it, complain to your vendor, because
1445 fmod (double f1, double f2)
1449 return f1 - f2 * floor (f1/f2);
1451 #endif /* ! HAVE_FMOD */
1454 DEFUN ("mod", Fmod, 2, 2, 0, /*
1456 The result falls between zero (inclusive) and Y (exclusive).
1457 Both X and Y must be numbers, characters or markers.
1458 If either argument is a float, a float will be returned.
1462 int_or_double iod1, iod2;
1463 number_char_or_marker_to_int_or_double (x, &iod1);
1464 number_char_or_marker_to_int_or_double (y, &iod2);
1466 #ifdef LISP_FLOAT_TYPE
1467 if (!iod1.int_p || !iod2.int_p)
1469 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
1470 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
1471 if (dval2 == 0) goto divide_by_zero;
1472 dval1 = fmod (dval1, dval2);
1474 /* If the "remainder" comes out with the wrong sign, fix it. */
1475 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
1478 return make_float (dval1);
1480 #endif /* LISP_FLOAT_TYPE */
1483 if (iod2.c.ival == 0) goto divide_by_zero;
1485 ival = iod1.c.ival % iod2.c.ival;
1487 /* If the "remainder" comes out with the wrong sign, fix it. */
1488 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
1489 ival += iod2.c.ival;
1491 return make_int (ival);
1495 Fsignal (Qarith_error, Qnil);
1496 return Qnil; /* not reached */
1499 DEFUN ("ash", Fash, 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, the sign bit is duplicated.
1506 CHECK_INT_COERCE_CHAR (value);
1507 CONCHECK_INT (count);
1509 return make_int (XINT (count) > 0 ?
1510 XINT (value) << XINT (count) :
1511 XINT (value) >> -XINT (count));
1514 DEFUN ("lsh", Flsh, 2, 2, 0, /*
1515 Return VALUE with its bits shifted left by COUNT.
1516 If COUNT is negative, shifting is actually to the right.
1517 In this case, zeros are shifted in on the left.
1521 CHECK_INT_COERCE_CHAR (value);
1522 CONCHECK_INT (count);
1524 return make_int (XINT (count) > 0 ?
1525 XUINT (value) << XINT (count) :
1526 XUINT (value) >> -XINT (count));
1529 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1530 Return NUMBER plus one. NUMBER may be a number, character or marker.
1531 Markers and characters are converted to integers.
1537 if (INTP (number)) return make_int (XINT (number) + 1);
1538 if (CHARP (number)) return make_int (XCHAR (number) + 1);
1539 if (MARKERP (number)) return make_int (marker_position (number) + 1);
1540 #ifdef LISP_FLOAT_TYPE
1541 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1542 #endif /* LISP_FLOAT_TYPE */
1544 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1548 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1549 Return NUMBER minus one. NUMBER may be a number, character or marker.
1550 Markers and characters are converted to integers.
1556 if (INTP (number)) return make_int (XINT (number) - 1);
1557 if (CHARP (number)) return make_int (XCHAR (number) - 1);
1558 if (MARKERP (number)) return make_int (marker_position (number) - 1);
1559 #ifdef LISP_FLOAT_TYPE
1560 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1561 #endif /* LISP_FLOAT_TYPE */
1563 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1568 /************************************************************************/
1570 /************************************************************************/
1572 /* A weak list is like a normal list except that elements automatically
1573 disappear when no longer in use, i.e. when no longer GC-protected.
1574 The basic idea is that we don't mark the elements during GC, but
1575 wait for them to be marked elsewhere. If they're not marked, we
1576 remove them. This is analogous to weak hash tables; see the explanation
1577 there for more info. */
1579 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1581 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1584 mark_weak_list (Lisp_Object obj)
1586 return Qnil; /* nichts ist gemarkt */
1590 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1593 error ("printing unreadable object #<weak-list>");
1595 write_c_string ("#<weak-list ", printcharfun);
1596 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
1598 write_c_string (" ", printcharfun);
1599 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1600 write_c_string (">", printcharfun);
1604 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1606 struct weak_list *w1 = XWEAK_LIST (obj1);
1607 struct weak_list *w2 = XWEAK_LIST (obj2);
1609 return ((w1->type == w2->type) &&
1610 internal_equal (w1->list, w2->list, depth + 1));
1613 static unsigned long
1614 weak_list_hash (Lisp_Object obj, int depth)
1616 struct weak_list *w = XWEAK_LIST (obj);
1618 return HASH2 ((unsigned long) w->type,
1619 internal_hash (w->list, depth + 1));
1623 make_weak_list (enum weak_list_type type)
1626 struct weak_list *wl =
1627 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
1631 XSETWEAK_LIST (result, wl);
1632 wl->next_weak = Vall_weak_lists;
1633 Vall_weak_lists = result;
1637 static const struct lrecord_description weak_list_description[] = {
1638 { XD_LISP_OBJECT, offsetof (struct weak_list, list) },
1639 { XD_LO_LINK, offsetof (struct weak_list, next_weak) },
1643 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1644 mark_weak_list, print_weak_list,
1645 0, weak_list_equal, weak_list_hash,
1646 weak_list_description,
1649 -- we do not mark the list elements (either the elements themselves
1650 or the cons cells that hold them) in the normal marking phase.
1651 -- at the end of marking, we go through all weak lists that are
1652 marked, and mark the cons cells that hold all marked
1653 objects, and possibly parts of the objects themselves.
1654 (See alloc.c, "after-mark".)
1655 -- after that, we prune away all the cons cells that are not marked.
1657 WARNING WARNING WARNING WARNING WARNING:
1659 The code in the following two functions is *unbelievably* tricky.
1660 Don't mess with it. You'll be sorry.
1662 Linked lists just majorly suck, d'ya know?
1666 finish_marking_weak_lists (void)
1671 for (rest = Vall_weak_lists;
1673 rest = XWEAK_LIST (rest)->next_weak)
1676 enum weak_list_type type = XWEAK_LIST (rest)->type;
1678 if (! marked_p (rest))
1679 /* The weak list is probably garbage. Ignore it. */
1682 for (rest2 = XWEAK_LIST (rest)->list;
1683 /* We need to be trickier since we're inside of GC;
1684 use CONSP instead of !NILP in case of user-visible
1687 rest2 = XCDR (rest2))
1690 /* If the element is "marked" (meaning depends on the type
1691 of weak list), we need to mark the cons containing the
1692 element, and maybe the element itself (if only some part
1693 was already marked). */
1694 int need_to_mark_cons = 0;
1695 int need_to_mark_elem = 0;
1697 /* If a cons is already marked, then its car is already marked
1698 (either because of an external pointer or because of
1699 a previous call to this function), and likewise for all
1700 the rest of the elements in the list, so we can stop now. */
1701 if (marked_p (rest2))
1704 elem = XCAR (rest2);
1708 case WEAK_LIST_SIMPLE:
1709 if (marked_p (elem))
1710 need_to_mark_cons = 1;
1713 case WEAK_LIST_ASSOC:
1716 /* just leave bogus elements there */
1717 need_to_mark_cons = 1;
1718 need_to_mark_elem = 1;
1720 else if (marked_p (XCAR (elem)) &&
1721 marked_p (XCDR (elem)))
1723 need_to_mark_cons = 1;
1724 /* We still need to mark elem, because it's
1725 probably not marked. */
1726 need_to_mark_elem = 1;
1730 case WEAK_LIST_KEY_ASSOC:
1733 /* just leave bogus elements there */
1734 need_to_mark_cons = 1;
1735 need_to_mark_elem = 1;
1737 else if (marked_p (XCAR (elem)))
1739 need_to_mark_cons = 1;
1740 /* We still need to mark elem and XCDR (elem);
1741 marking elem does both */
1742 need_to_mark_elem = 1;
1746 case WEAK_LIST_VALUE_ASSOC:
1749 /* just leave bogus elements there */
1750 need_to_mark_cons = 1;
1751 need_to_mark_elem = 1;
1753 else if (marked_p (XCDR (elem)))
1755 need_to_mark_cons = 1;
1756 /* We still need to mark elem and XCAR (elem);
1757 marking elem does both */
1758 need_to_mark_elem = 1;
1762 case WEAK_LIST_FULL_ASSOC:
1765 /* just leave bogus elements there */
1766 need_to_mark_cons = 1;
1767 need_to_mark_elem = 1;
1769 else if (marked_p (XCAR (elem)) ||
1770 marked_p (XCDR (elem)))
1772 need_to_mark_cons = 1;
1773 /* We still need to mark elem and XCAR (elem);
1774 marking elem does both */
1775 need_to_mark_elem = 1;
1783 if (need_to_mark_elem && ! marked_p (elem))
1789 /* We also need to mark the cons that holds the elem or
1790 assoc-pair. We do *not* want to call (mark_object) here
1791 because that will mark the entire list; we just want to
1792 mark the cons itself.
1794 if (need_to_mark_cons)
1796 Lisp_Cons *c = XCONS (rest2);
1797 if (!CONS_MARKED_P (c))
1805 /* In case of imperfect list, need to mark the final cons
1806 because we're not removing it */
1807 if (!NILP (rest2) && ! marked_p (rest2))
1809 mark_object (rest2);
1818 prune_weak_lists (void)
1820 Lisp_Object rest, prev = Qnil;
1822 for (rest = Vall_weak_lists;
1824 rest = XWEAK_LIST (rest)->next_weak)
1826 if (! (marked_p (rest)))
1828 /* This weak list itself is garbage. Remove it from the list. */
1830 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1832 XWEAK_LIST (prev)->next_weak =
1833 XWEAK_LIST (rest)->next_weak;
1837 Lisp_Object rest2, prev2 = Qnil;
1838 Lisp_Object tortoise;
1839 int go_tortoise = 0;
1841 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1842 /* We need to be trickier since we're inside of GC;
1843 use CONSP instead of !NILP in case of user-visible
1847 /* It suffices to check the cons for marking,
1848 regardless of the type of weak list:
1850 -- if the cons is pointed to somewhere else,
1851 then it should stay around and will be marked.
1852 -- otherwise, if it should stay around, it will
1853 have been marked in finish_marking_weak_lists().
1854 -- otherwise, it's not marked and should disappear.
1856 if (! marked_p (rest2))
1860 XWEAK_LIST (rest)->list = XCDR (rest2);
1862 XCDR (prev2) = XCDR (rest2);
1863 rest2 = XCDR (rest2);
1864 /* Ouch. Circularity checking is even trickier
1865 than I thought. When we cut out a link
1866 like this, we can't advance the turtle or
1867 it'll catch up to us. Imagine that we're
1868 standing on floor tiles and moving forward --
1869 what we just did here is as if the floor
1870 tile under us just disappeared and all the
1871 ones ahead of us slid one tile towards us.
1872 In other words, we didn't move at all;
1873 if the tortoise was one step behind us
1874 previously, it still is, and therefore
1875 it must not move. */
1881 /* Implementing circularity checking is trickier here
1882 than in other places because we have to guarantee
1883 that we've processed all elements before exiting
1884 due to a circularity. (In most places, an error
1885 is issued upon encountering a circularity, so it
1886 doesn't really matter if all elements are processed.)
1887 The idea is that we process along with the hare
1888 rather than the tortoise. If at any point in
1889 our forward process we encounter the tortoise,
1890 we must have already visited the spot, so we exit.
1891 (If we process with the tortoise, we can fail to
1892 process cases where a cons points to itself, or
1893 where cons A points to cons B, which points to
1896 rest2 = XCDR (rest2);
1898 tortoise = XCDR (tortoise);
1899 go_tortoise = !go_tortoise;
1900 if (EQ (rest2, tortoise))
1910 static enum weak_list_type
1911 decode_weak_list_type (Lisp_Object symbol)
1913 CHECK_SYMBOL (symbol);
1914 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1915 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1916 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1917 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1918 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1919 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC;
1921 signal_simple_error ("Invalid weak list type", symbol);
1922 return WEAK_LIST_SIMPLE; /* not reached */
1926 encode_weak_list_type (enum weak_list_type type)
1930 case WEAK_LIST_SIMPLE: return Qsimple;
1931 case WEAK_LIST_ASSOC: return Qassoc;
1932 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1933 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1934 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc;
1939 return Qnil; /* not reached */
1942 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
1943 Return non-nil if OBJECT is a weak list.
1947 return WEAK_LISTP (object) ? Qt : Qnil;
1950 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
1951 Return a new weak list object of type TYPE.
1952 A weak list object is an object that contains a list. This list behaves
1953 like any other list except that its elements do not count towards
1954 garbage collection -- if the only pointer to an object is inside a weak
1955 list (other than pointers in similar objects such as weak hash tables),
1956 the object is garbage collected and automatically removed from the list.
1957 This is used internally, for example, to manage the list holding the
1958 children of an extent -- an extent that is unused but has a parent will
1959 still be reclaimed, and will automatically be removed from its parent's
1962 Optional argument TYPE specifies the type of the weak list, and defaults
1963 to `simple'. Recognized types are
1965 `simple' Objects in the list disappear if not pointed to.
1966 `assoc' Objects in the list disappear if they are conses
1967 and either the car or the cdr of the cons is not
1969 `key-assoc' Objects in the list disappear if they are conses
1970 and the car is not pointed to.
1971 `value-assoc' Objects in the list disappear if they are conses
1972 and the cdr is not pointed to.
1973 `full-assoc' Objects in the list disappear if they are conses
1974 and neither the car nor the cdr is pointed to.
1981 return make_weak_list (decode_weak_list_type (type));
1984 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
1985 Return the type of the given weak-list object.
1989 CHECK_WEAK_LIST (weak);
1990 return encode_weak_list_type (XWEAK_LIST (weak)->type);
1993 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
1994 Return the list contained in a weak-list object.
1998 CHECK_WEAK_LIST (weak);
1999 return XWEAK_LIST_LIST (weak);
2002 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
2003 Change the list contained in a weak-list object.
2007 CHECK_WEAK_LIST (weak);
2008 XWEAK_LIST_LIST (weak) = new_list;
2013 /************************************************************************/
2014 /* initialization */
2015 /************************************************************************/
2018 arith_error (int signo)
2020 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
2021 EMACS_UNBLOCK_SIGNAL (signo);
2022 signal_error (Qarith_error, Qnil);
2026 init_data_very_early (void)
2028 /* Don't do this if just dumping out.
2029 We don't want to call `signal' in this case
2030 so that we don't have trouble with dumping
2031 signal-delivering routines in an inconsistent state. */
2035 #endif /* CANNOT_DUMP */
2036 signal (SIGFPE, arith_error);
2038 signal (SIGEMT, arith_error);
2043 init_errors_once_early (void)
2045 DEFSYMBOL (Qerror_conditions);
2046 DEFSYMBOL (Qerror_message);
2048 /* We declare the errors here because some other deferrors depend
2049 on some of the errors below. */
2051 /* ERROR is used as a signaler for random errors for which nothing
2054 DEFERROR (Qerror, "error", Qnil);
2055 DEFERROR_STANDARD (Qquit, Qnil);
2057 DEFERROR (Qunimplemented, "Feature not yet implemented", Qerror);
2058 DEFERROR_STANDARD (Qsyntax_error, Qerror);
2059 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error);
2060 DEFERROR_STANDARD (Qlist_formation_error, Qsyntax_error);
2062 /* Generated by list traversal macros */
2063 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error);
2064 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list);
2065 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error);
2066 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list);
2068 DEFERROR_STANDARD (Qinvalid_argument, Qerror);
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);
2073 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument);
2075 DEFERROR_STANDARD (Qinternal_error, Qerror);
2077 DEFERROR (Qinvalid_state, "Properties or values have been set incorrectly",
2079 DEFERROR (Qvoid_function, "Symbol's function definition is void",
2081 DEFERROR (Qcyclic_function_indirection,
2082 "Symbol's chain of function indirections contains a loop",
2084 DEFERROR (Qvoid_variable, "Symbol's value as variable is void",
2086 DEFERROR (Qcyclic_variable_indirection,
2087 "Symbol's chain of variable indirections contains a loop",
2090 DEFERROR (Qinvalid_operation,
2091 "Operation not allowed or error during operation", Qerror);
2092 DEFERROR (Qinvalid_change, "Attempt to set properties or values incorrectly",
2093 Qinvalid_operation);
2094 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol",
2097 DEFERROR (Qediting_error, "Invalid operation during editing",
2098 Qinvalid_operation);
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);
2103 DEFERROR (Qio_error, "IO Error", Qinvalid_operation);
2104 DEFERROR (Qend_of_file, "End of file or stream", Qio_error);
2106 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation);
2107 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error);
2108 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error);
2109 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error);
2110 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error);
2111 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error);
2117 INIT_LRECORD_IMPLEMENTATION (weak_list);
2120 DEFSYMBOL (Qlambda);
2122 DEFSYMBOL (Qtrue_list_p);
2125 DEFSYMBOL (Qsymbolp);
2126 DEFSYMBOL (Qintegerp);
2127 DEFSYMBOL (Qcharacterp);
2128 DEFSYMBOL (Qnatnump);
2129 DEFSYMBOL (Qstringp);
2130 DEFSYMBOL (Qarrayp);
2131 DEFSYMBOL (Qsequencep);
2132 DEFSYMBOL (Qbufferp);
2134 DEFSYMBOL_MULTIWORD_PREDICATE (Qbit_vectorp);
2135 DEFSYMBOL (Qvectorp);
2136 DEFSYMBOL (Qchar_or_string_p);
2137 DEFSYMBOL (Qmarkerp);
2138 DEFSYMBOL (Qinteger_or_marker_p);
2139 DEFSYMBOL (Qinteger_or_char_p);
2140 DEFSYMBOL (Qinteger_char_or_marker_p);
2141 DEFSYMBOL (Qnumberp);
2142 DEFSYMBOL (Qnumber_char_or_marker_p);
2144 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp);
2146 #ifdef LISP_FLOAT_TYPE
2147 DEFSYMBOL (Qfloatp);
2148 #endif /* LISP_FLOAT_TYPE */
2150 DEFSUBR (Fwrong_type_argument);
2155 Ffset (intern ("not"), intern ("null"));
2158 DEFSUBR (Ftrue_list_p);
2161 DEFSUBR (Fchar_or_string_p);
2162 DEFSUBR (Fcharacterp);
2163 DEFSUBR (Fchar_int_p);
2164 DEFSUBR (Fchar_to_int);
2165 DEFSUBR (Fint_to_char);
2166 DEFSUBR (Fchar_or_char_int_p);
2167 DEFSUBR (Fchar_ref_p);
2168 DEFSUBR (Fintegerp);
2169 DEFSUBR (Finteger_or_marker_p);
2170 DEFSUBR (Finteger_or_char_p);
2171 DEFSUBR (Finteger_char_or_marker_p);
2173 DEFSUBR (Fnumber_or_marker_p);
2174 DEFSUBR (Fnumber_char_or_marker_p);
2175 #ifdef LISP_FLOAT_TYPE
2177 #endif /* LISP_FLOAT_TYPE */
2180 DEFSUBR (Fkeywordp);
2184 DEFSUBR (Fbit_vector_p);
2186 DEFSUBR (Fsequencep);
2189 DEFSUBR (Fsubr_min_args);
2190 DEFSUBR (Fsubr_max_args);
2191 DEFSUBR (Fsubr_interactive);
2195 DEFSUBR (Fcar_safe);
2196 DEFSUBR (Fcdr_safe);
2199 DEFSUBR (Findirect_function);
2203 DEFSUBR (Fnumber_to_string);
2204 DEFSUBR (Fstring_to_number);
2229 DEFSUBR (Fweak_list_p);
2230 DEFSUBR (Fmake_weak_list);
2231 DEFSUBR (Fweak_list_type);
2232 DEFSUBR (Fweak_list_list);
2233 DEFSUBR (Fset_weak_list_list);
2239 /* This must not be staticpro'd */
2240 Vall_weak_lists = Qnil;
2241 dump_add_weak_object_chain (&Vall_weak_lists);
2244 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2245 If non-zero, note when your code may be suffering from char-int confoundance.
2246 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2247 etc. where an int and a char with the same value are being compared,
2248 it will issue a notice on stderr to this effect, along with a backtrace.
2249 In such situations, the result would be different in XEmacs 19 versus
2250 XEmacs 20, and you probably don't want this.
2252 Note that in order to see these notices, you have to byte compile your
2253 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2254 have its chars and ints all confounded in the byte code, making it
2255 impossible to accurately determine Ebola infection.
2258 debug_issue_ebola_notices = 0;
2260 DEFVAR_INT ("debug-ebola-backtrace-length",
2261 &debug_ebola_backtrace_length /*
2262 Length (in stack frames) of short backtrace printed out in Ebola notices.
2263 See `debug-issue-ebola-notices'.
2265 debug_ebola_backtrace_length = 32;
2267 #endif /* DEBUG_XEMACS */