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.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
25 /* This file has been Mule-ized. */
32 #include "syssignal.h"
34 #ifdef LISP_FLOAT_TYPE
35 /* Need to define a differentiating symbol -- see sysfloat.h */
36 # define THIS_FILENAME data_c
37 # include "sysfloat.h"
38 #endif /* LISP_FLOAT_TYPE */
40 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
41 Lisp_Object Qerror_conditions, Qerror_message;
42 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
43 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
44 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
45 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
46 Lisp_Object Qmalformed_list, Qmalformed_property_list;
47 Lisp_Object Qcircular_list, Qcircular_property_list;
48 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
49 Lisp_Object Qio_error, Qend_of_file;
50 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
51 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
52 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
53 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp;
54 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
55 Lisp_Object Qconsp, Qsubrp;
56 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
57 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
58 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
59 Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p;
60 Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore;
62 #ifdef LISP_FLOAT_TYPE
68 int debug_issue_ebola_notices;
70 int debug_ebola_backtrace_length;
73 /*#ifndef LRECORD_SYMBOL*/
74 #include "backtrace.h"
78 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
80 if (debug_issue_ebola_notices != -42 /* abracadabra */ &&
81 (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1)))
82 && (debug_issue_ebola_notices >= 2
83 || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))))
85 write_c_string ("Comparison between integer and character is constant nil (",
86 Qexternal_debugging_output);
87 Fprinc (obj1, Qexternal_debugging_output);
88 write_c_string (" and ", Qexternal_debugging_output);
89 Fprinc (obj2, Qexternal_debugging_output);
90 write_c_string (")\n", Qexternal_debugging_output);
91 debug_short_backtrace (debug_ebola_backtrace_length);
93 return EQ (obj1, obj2);
96 #endif /* DEBUG_XEMACS */
101 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
103 /* This function can GC */
104 REGISTER Lisp_Object tem;
107 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
108 tem = call1 (predicate, value);
115 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
117 signal_error (Qwrong_type_argument, list2 (predicate, value));
120 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
121 Signal an error until the correct type value is given by the user.
122 This function loops, signalling a continuable `wrong-type-argument' error
123 with PREDICATE and VALUE as the data associated with the error and then
124 calling PREDICATE on the returned value, until the value gotten satisfies
125 PREDICATE. At that point, the gotten value is returned.
129 return wrong_type_argument (predicate, value);
133 pure_write_error (Lisp_Object obj)
135 signal_simple_error ("Attempt to modify read-only object", obj);
139 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
141 signal_error (Qargs_out_of_range, list2 (a1, a2));
145 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
147 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
151 check_int_range (int val, int min, int max)
153 if (val < min || val > max)
154 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
157 /* On some machines, XINT needs a temporary location.
158 Here it is, in case it is needed. */
160 EMACS_INT sign_extend_temp;
162 /* On a few machines, XINT can only be done by calling this. */
163 /* XEmacs: only used by m/convex.h */
164 int sign_extend_lisp_int (EMACS_INT num);
166 sign_extend_lisp_int (EMACS_INT num)
168 if (num & (1L << (VALBITS - 1)))
169 return num | ((-1L) << VALBITS);
171 return num & ((1L << VALBITS) - 1);
175 /* Data type predicates */
177 DEFUN ("eq", Feq, 2, 2, 0, /*
178 Return t if the two args are the same Lisp object.
182 return EQ_WITH_EBOLA_NOTICE (obj1, obj2) ? Qt : Qnil;
185 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
186 Return t if the two args are (in most cases) the same Lisp object.
188 Special kludge: A character is considered `old-eq' to its equivalent integer
189 even though they are not the same object and are in fact of different
190 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
191 preserve byte-code compatibility with v19. This kludge is known as the
192 \"char-int confoundance disease\" and appears in a number of other
193 functions with `old-foo' equivalents.
195 Do not use this function!
200 return HACKEQ_UNSAFE (obj1, obj2) ? Qt : Qnil;
203 DEFUN ("null", Fnull, 1, 1, 0, /*
204 Return t if OBJECT is nil.
208 return NILP (object) ? Qt : Qnil;
211 DEFUN ("consp", Fconsp, 1, 1, 0, /*
212 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
216 return CONSP (object) ? Qt : Qnil;
219 DEFUN ("atom", Fatom, 1, 1, 0, /*
220 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
224 return CONSP (object) ? Qnil : Qt;
227 DEFUN ("listp", Flistp, 1, 1, 0, /*
228 Return t if OBJECT is a list. `nil' is a list.
232 return LISTP (object) ? Qt : Qnil;
235 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
236 Return t if OBJECT is not a list. `nil' is a list.
240 return LISTP (object) ? Qnil : Qt;
243 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
244 Return t if OBJECT is a non-dotted, i.e. nil-terminated, list.
248 return TRUE_LIST_P (object) ? Qt : Qnil;
251 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
252 Return t if OBJECT is a symbol.
256 return SYMBOLP (object) ? Qt : Qnil;
259 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
260 Return t if OBJECT is a keyword.
264 return KEYWORDP (object) ? Qt : Qnil;
267 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
268 Return t if OBJECT is a vector.
272 return VECTORP (object) ? Qt : Qnil;
275 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
276 Return t if OBJECT is a bit vector.
280 return BIT_VECTORP (object) ? Qt : Qnil;
283 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
284 Return t if OBJECT is a string.
288 return STRINGP (object) ? Qt : Qnil;
291 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
292 Return t if OBJECT is an array (string, vector, or bit vector).
296 return (VECTORP (object) ||
298 BIT_VECTORP (object))
302 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
303 Return t if OBJECT is a sequence (list or array).
307 return (LISTP (object) ||
310 BIT_VECTORP (object))
314 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
315 Return t if OBJECT is a marker (editor pointer).
319 return MARKERP (object) ? Qt : Qnil;
322 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
323 Return t if OBJECT is a built-in function.
327 return SUBRP (object) ? Qt : Qnil;
330 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
331 Return minimum number of args built-in function SUBR may be called with.
336 return make_int (XSUBR (subr)->min_args);
339 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
340 Return maximum number of args built-in function SUBR may be called with,
341 or nil if it takes an arbitrary number of arguments or is a special form.
347 nargs = XSUBR (subr)->max_args;
348 if (nargs == MANY || nargs == UNEVALLED)
351 return make_int (nargs);
354 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
355 Return the interactive spec of the subr object, or nil.
356 If non-nil, the return value will be a list whose first element is
357 `interactive' and whose second element is the interactive spec.
363 prompt = XSUBR (subr)->prompt;
364 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
368 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
369 Return t if OBJECT is a character.
370 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
371 Any character can be converted into an equivalent integer using
372 `char-int'. To convert the other way, use `int-char'; however,
373 only some integers can be converted into characters. Such an integer
374 is called a `char-int'; see `char-int-p'.
376 Some functions that work on integers (e.g. the comparison functions
377 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
378 accept characters and implicitly convert them into integers. In
379 general, functions that work on characters also accept char-ints and
380 implicitly convert them into characters. WARNING: Neither of these
381 behaviors is very desirable, and they are maintained for backward
382 compatibility with old E-Lisp programs that confounded characters and
383 integers willy-nilly. These behaviors may change in the future; therefore,
384 do not rely on them. Instead, use the character-specific functions such
389 return CHARP (object) ? Qt : Qnil;
392 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
393 Convert a character into an equivalent integer.
394 The resulting integer will always be non-negative. The integers in
395 the range 0 - 255 map to characters as follows:
399 128 - 159 Control set 1
400 160 - 255 Right half of ISO-8859-1
402 If support for Mule does not exist, these are the only valid character
403 values. When Mule support exists, the values assigned to other characters
404 may vary depending on the particular version of XEmacs, the order in which
405 character sets were loaded, etc., and you should not depend on them.
410 return make_int (XCHAR (ch));
413 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
414 Convert an integer into the equivalent character.
415 Not all integers correspond to valid characters; use `char-int-p' to
416 determine whether this is the case. If the integer cannot be converted,
422 if (CHAR_INTP (integer))
423 return make_char (XINT (integer));
428 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
429 Return t if OBJECT is an integer that can be converted into a character.
434 return CHAR_INTP (object) ? Qt : Qnil;
437 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
438 Return t if OBJECT is a character or an integer that can be converted into one.
442 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
445 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
446 Return t if OBJECT is a character (or a char-int) or a string.
447 It is semi-hateful that we allow a char-int here, as it goes against
448 the name of this function, but it makes the most sense considering the
449 other steps we take to maintain compatibility with the old character/integer
450 confoundedness in older versions of E-Lisp.
454 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
457 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
458 Return t if OBJECT is an integer.
462 return INTP (object) ? Qt : Qnil;
465 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
466 Return t if OBJECT is an integer or a marker (editor pointer).
470 return INTP (object) || MARKERP (object) ? Qt : Qnil;
473 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
474 Return t if OBJECT is an integer or a character.
478 return INTP (object) || CHARP (object) ? Qt : Qnil;
481 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
482 Return t if OBJECT is an integer, character or a marker (editor pointer).
486 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
489 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
490 Return t if OBJECT is a nonnegative integer.
494 return NATNUMP (object) ? Qt : Qnil;
497 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
498 Return t if OBJECT is a bit (0 or 1).
502 return BITP (object) ? Qt : Qnil;
505 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
506 Return t if OBJECT is a number (floating point or integer).
510 return INT_OR_FLOATP (object) ? Qt : Qnil;
513 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
514 Return t if OBJECT is a number or a marker.
518 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
521 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
522 Return t if OBJECT is a number, character or a marker.
526 return (INT_OR_FLOATP (object) ||
532 #ifdef LISP_FLOAT_TYPE
533 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
534 Return t if OBJECT is a floating point number.
538 return FLOATP (object) ? Qt : Qnil;
540 #endif /* LISP_FLOAT_TYPE */
542 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
543 Return a symbol representing the type of OBJECT.
547 switch (XTYPE (object))
550 case Lisp_Type_Cons: return Qcons;
553 #ifndef LRECORD_SYMBOL
554 case Lisp_Type_Symbol: return Qsymbol;
557 #ifndef LRECORD_STRING
558 case Lisp_Type_String: return Qstring;
561 #ifndef LRECORD_VECTOR
562 case Lisp_Type_Vector: return Qvector;
565 case Lisp_Type_Record:
566 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
568 case Lisp_Type_Char: return Qcharacter;
570 default: return Qinteger;
575 /* Extract and set components of lists */
577 DEFUN ("car", Fcar, 1, 1, 0, /*
578 Return the car of LIST. If arg is nil, return nil.
579 Error if arg is not nil and not a cons cell. See also `car-safe'.
587 else if (NILP (list))
590 list = wrong_type_argument (Qlistp, list);
594 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
595 Return the car of OBJECT if it is a cons cell, or else nil.
599 return CONSP (object) ? XCAR (object) : Qnil;
602 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
603 Return the cdr of LIST. If arg is nil, return nil.
604 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
612 else if (NILP (list))
615 list = wrong_type_argument (Qlistp, list);
619 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
620 Return the cdr of OBJECT if it is a cons cell, else nil.
624 return CONSP (object) ? XCDR (object) : Qnil;
627 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
628 Set the car of CONSCELL to be NEWCAR. Return NEWCAR.
632 if (!CONSP (conscell))
633 conscell = wrong_type_argument (Qconsp, conscell);
635 CHECK_IMPURE (conscell);
636 XCAR (conscell) = newcar;
640 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
641 Set the cdr of CONSCELL to be NEWCDR. Return NEWCDR.
645 if (!CONSP (conscell))
646 conscell = wrong_type_argument (Qconsp, conscell);
648 CHECK_IMPURE (conscell);
649 XCDR (conscell) = newcdr;
653 /* Find the function at the end of a chain of symbol function indirections.
655 If OBJECT is a symbol, find the end of its function chain and
656 return the value found there. If OBJECT is not a symbol, just
657 return it. If there is a cycle in the function chain, signal a
658 cyclic-function-indirection error.
660 This is like Findirect_function, except that it doesn't signal an
661 error if the chain ends up unbound. */
663 indirect_function (Lisp_Object object, int errorp)
665 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
666 Lisp_Object tortoise, hare;
669 for (hare = tortoise = object, count = 0;
671 hare = XSYMBOL (hare)->function, count++)
673 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
676 tortoise = XSYMBOL (tortoise)->function;
677 if (EQ (hare, tortoise))
678 return Fsignal (Qcyclic_function_indirection, list1 (object));
681 if (errorp && UNBOUNDP (hare))
682 signal_void_function_error (object);
687 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
688 Return the function at the end of OBJECT's function chain.
689 If OBJECT is a symbol, follow all function indirections and return
690 the final function binding.
691 If OBJECT is not a symbol, just return it.
692 Signal a void-function error if the final symbol is unbound.
693 Signal a cyclic-function-indirection error if there is a loop in the
694 function chain of symbols.
698 return indirect_function (object, 1);
701 /* Extract and set vector and string elements */
703 DEFUN ("aref", Faref, 2, 2, 0, /*
704 Return the element of ARRAY at index INDEX.
705 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
713 if (INTP (index_)) idx = XINT (index_);
714 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
717 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
721 if (idx < 0) goto range_error;
725 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
726 return XVECTOR_DATA (array)[idx];
728 else if (BIT_VECTORP (array))
730 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
731 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
733 else if (STRINGP (array))
735 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
736 return make_char (string_char (XSTRING (array), idx));
738 #ifdef LOSING_BYTECODE
739 else if (COMPILED_FUNCTIONP (array))
741 /* Weird, gross compatibility kludge */
742 return Felt (array, index_);
747 check_losing_bytecode ("aref", array);
748 array = wrong_type_argument (Qarrayp, array);
753 args_out_of_range (array, index_);
754 return Qnil; /* not reached */
757 DEFUN ("aset", Faset, 3, 3, 0, /*
758 Store into the element of ARRAY at index INDEX the value NEWVAL.
759 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
761 (array, index_, newval))
767 if (INTP (index_)) idx = XINT (index_);
768 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
771 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
775 if (idx < 0) goto range_error;
777 CHECK_IMPURE (array);
781 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
782 XVECTOR_DATA (array)[idx] = newval;
784 else if (BIT_VECTORP (array))
786 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
788 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
790 else if (STRINGP (array))
792 CHECK_CHAR_COERCE_INT (newval);
793 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
794 set_string_char (XSTRING (array), idx, XCHAR (newval));
795 bump_string_modiff (array);
799 array = wrong_type_argument (Qarrayp, array);
806 args_out_of_range (array, index_);
807 return Qnil; /* not reached */
811 /**********************************************************************/
812 /* Arithmetic functions */
813 /**********************************************************************/
825 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
829 if (INTP (obj)) p->c.ival = XINT (obj);
830 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
831 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
832 #ifdef LISP_FLOAT_TYPE
833 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
837 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
843 number_char_or_marker_to_double (Lisp_Object obj)
846 if (INTP (obj)) return (double) XINT (obj);
847 else if (CHARP (obj)) return (double) XCHAR (obj);
848 else if (MARKERP (obj)) return (double) marker_position (obj);
849 #ifdef LISP_FLOAT_TYPE
850 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
854 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
860 integer_char_or_marker_to_int (Lisp_Object obj)
863 if (INTP (obj)) return XINT (obj);
864 else if (CHARP (obj)) return XCHAR (obj);
865 else if (MARKERP (obj)) return marker_position (obj);
868 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
873 #define ARITHCOMPARE_MANY(op) \
875 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
876 Lisp_Object *args_end = args + nargs; \
878 number_char_or_marker_to_int_or_double (*args++, p); \
880 while (args < args_end) \
882 number_char_or_marker_to_int_or_double (*args++, q); \
884 if (!((p->int_p && q->int_p) ? \
885 (p->c.ival op q->c.ival) : \
886 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
887 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
890 { /* swap */ int_or_double *r = p; p = q; q = r; } \
895 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
896 Return t if all the arguments are numerically equal.
897 The arguments may be numbers, characters or markers.
899 (int nargs, Lisp_Object *args))
901 ARITHCOMPARE_MANY (==)
904 DEFUN ("<", Flss, 1, MANY, 0, /*
905 Return t if the sequence of arguments is monotonically increasing.
906 The arguments may be numbers, characters or markers.
908 (int nargs, Lisp_Object *args))
910 ARITHCOMPARE_MANY (<)
913 DEFUN (">", Fgtr, 1, MANY, 0, /*
914 Return t if the sequence of arguments is monotonically decreasing.
915 The arguments may be numbers, characters or markers.
917 (int nargs, Lisp_Object *args))
919 ARITHCOMPARE_MANY (>)
922 DEFUN ("<=", Fleq, 1, MANY, 0, /*
923 Return t if the sequence of arguments is monotonically nondecreasing.
924 The arguments may be numbers, characters or markers.
926 (int nargs, Lisp_Object *args))
928 ARITHCOMPARE_MANY (<=)
931 DEFUN (">=", Fgeq, 1, MANY, 0, /*
932 Return t if the sequence of arguments is monotonically nonincreasing.
933 The arguments may be numbers, characters or markers.
935 (int nargs, Lisp_Object *args))
937 ARITHCOMPARE_MANY (>=)
940 DEFUN ("/=", Fneq, 1, MANY, 0, /*
941 Return t if no two arguments are numerically equal.
942 The arguments may be numbers, characters or markers.
944 (int nargs, Lisp_Object *args))
946 Lisp_Object *args_end = args + nargs;
949 /* Unlike all the other comparisons, this is an N*N algorithm.
950 We could use a hash table for nargs > 50 to make this linear. */
951 for (p = args; p < args_end; p++)
953 int_or_double iod1, iod2;
954 number_char_or_marker_to_int_or_double (*p, &iod1);
956 for (q = p + 1; q < args_end; q++)
958 number_char_or_marker_to_int_or_double (*q, &iod2);
960 if (!((iod1.int_p && iod2.int_p) ?
961 (iod1.c.ival != iod2.c.ival) :
962 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
963 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
970 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
971 Return t if NUMBER is zero.
977 return EQ (number, Qzero) ? Qt : Qnil;
978 #ifdef LISP_FLOAT_TYPE
979 else if (FLOATP (number))
980 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
981 #endif /* LISP_FLOAT_TYPE */
984 number = wrong_type_argument (Qnumberp, number);
989 /* Convert between a 32-bit value and a cons of two 16-bit values.
990 This is used to pass 32-bit integers to and from the user.
991 Use time_to_lisp() and lisp_to_time() for time values.
993 If you're thinking of using this to store a pointer into a Lisp Object
994 for internal purposes (such as when calling record_unwind_protect()),
995 try using make_opaque_ptr()/get_opaque_ptr() instead. */
997 word_to_lisp (unsigned int item)
999 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
1003 lisp_to_word (Lisp_Object item)
1009 Lisp_Object top = Fcar (item);
1010 Lisp_Object bot = Fcdr (item);
1013 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
1018 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
1019 Convert NUM to a string by printing it in decimal.
1020 Uses a minus sign if negative.
1021 NUM may be an integer or a floating point number.
1025 char buffer[VALBITS];
1027 CHECK_INT_OR_FLOAT (num);
1029 #ifdef LISP_FLOAT_TYPE
1032 char pigbuf[350]; /* see comments in float_to_string */
1034 float_to_string (pigbuf, XFLOAT_DATA (num));
1035 return build_string (pigbuf);
1037 #endif /* LISP_FLOAT_TYPE */
1039 long_to_string (buffer, XINT (num));
1040 return build_string (buffer);
1044 digit_to_number (int character, int base)
1047 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1048 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
1049 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
1052 return digit >= base ? -1 : digit;
1055 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
1056 Convert STRING to a number by parsing it as a decimal number.
1057 This parses both integers and floating point numbers.
1058 It ignores leading spaces and tabs.
1060 If BASE, interpret STRING as a number in that base. If BASE isn't
1061 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
1062 Floating point numbers always use base 10.
1069 CHECK_STRING (string);
1077 check_int_range (b, 2, 16);
1080 p = (char *) XSTRING_DATA (string);
1082 /* Skip any whitespace at the front of the number. Some versions of
1083 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1084 while (*p == ' ' || *p == '\t')
1087 #ifdef LISP_FLOAT_TYPE
1088 if (isfloat_string (p))
1089 return make_float (atof (p));
1090 #endif /* LISP_FLOAT_TYPE */
1094 /* Use the system-provided functions for base 10. */
1095 #if SIZEOF_EMACS_INT == SIZEOF_INT
1096 return make_int (atoi (p));
1097 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1098 return make_int (atol (p));
1099 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1100 return make_int (atoll (p));
1105 int digit, negative = 1;
1117 digit = digit_to_number (*p++, b);
1122 return make_int (negative * v);
1127 DEFUN ("+", Fplus, 0, MANY, 0, /*
1128 Return sum of any number of arguments.
1129 The arguments should all be numbers, characters or markers.
1131 (int nargs, Lisp_Object *args))
1133 EMACS_INT iaccum = 0;
1134 Lisp_Object *args_end = args + nargs;
1136 while (args < args_end)
1139 number_char_or_marker_to_int_or_double (*args++, &iod);
1141 iaccum += iod.c.ival;
1144 double daccum = (double) iaccum + iod.c.dval;
1145 while (args < args_end)
1146 daccum += number_char_or_marker_to_double (*args++);
1147 return make_float (daccum);
1151 return make_int (iaccum);
1154 DEFUN ("-", Fminus, 1, MANY, 0, /*
1155 Negate number or subtract numbers, characters or markers.
1156 With one arg, negates it. With more than one arg,
1157 subtracts all but the first from the first.
1159 (int nargs, Lisp_Object *args))
1163 Lisp_Object *args_end = args + nargs;
1166 number_char_or_marker_to_int_or_double (*args++, &iod);
1168 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
1171 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
1175 while (args < args_end)
1177 number_char_or_marker_to_int_or_double (*args++, &iod);
1179 iaccum -= iod.c.ival;
1182 daccum = (double) iaccum - iod.c.dval;
1187 return make_int (iaccum);
1190 for (; args < args_end; args++)
1191 daccum -= number_char_or_marker_to_double (*args);
1192 return make_float (daccum);
1195 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1196 Return product of any number of arguments.
1197 The arguments should all be numbers, characters or markers.
1199 (int nargs, Lisp_Object *args))
1201 EMACS_INT iaccum = 1;
1202 Lisp_Object *args_end = args + nargs;
1204 while (args < args_end)
1207 number_char_or_marker_to_int_or_double (*args++, &iod);
1209 iaccum *= iod.c.ival;
1212 double daccum = (double) iaccum * iod.c.dval;
1213 while (args < args_end)
1214 daccum *= number_char_or_marker_to_double (*args++);
1215 return make_float (daccum);
1219 return make_int (iaccum);
1222 DEFUN ("/", Fquo, 1, MANY, 0, /*
1223 Return first argument divided by all the remaining arguments.
1224 The arguments must be numbers, characters or markers.
1225 With one argument, reciprocates the argument.
1227 (int nargs, Lisp_Object *args))
1231 Lisp_Object *args_end = args + nargs;
1238 number_char_or_marker_to_int_or_double (*args++, &iod);
1240 iaccum = iod.c.ival;
1243 daccum = iod.c.dval;
1248 while (args < args_end)
1250 number_char_or_marker_to_int_or_double (*args++, &iod);
1253 if (iod.c.ival == 0) goto divide_by_zero;
1254 iaccum /= iod.c.ival;
1258 if (iod.c.dval == 0) goto divide_by_zero;
1259 daccum = (double) iaccum / iod.c.dval;
1264 return make_int (iaccum);
1267 for (; args < args_end; args++)
1269 double dval = number_char_or_marker_to_double (*args);
1270 if (dval == 0) goto divide_by_zero;
1273 return make_float (daccum);
1276 Fsignal (Qarith_error, Qnil);
1277 return Qnil; /* not reached */
1280 DEFUN ("max", Fmax, 1, MANY, 0, /*
1281 Return largest of all the arguments.
1282 All arguments must be numbers, characters or markers.
1283 The value is always a number; markers and characters are converted
1286 (int nargs, Lisp_Object *args))
1290 Lisp_Object *args_end = args + nargs;
1293 number_char_or_marker_to_int_or_double (*args++, &iod);
1302 while (args < args_end)
1304 number_char_or_marker_to_int_or_double (*args++, &iod);
1307 if (imax < iod.c.ival) imax = iod.c.ival;
1311 dmax = (double) imax;
1312 if (dmax < iod.c.dval) dmax = iod.c.dval;
1317 return make_int (imax);
1320 while (args < args_end)
1322 double dval = number_char_or_marker_to_double (*args++);
1323 if (dmax < dval) dmax = dval;
1325 return make_float (dmax);
1328 DEFUN ("min", Fmin, 1, MANY, 0, /*
1329 Return smallest of all the arguments.
1330 All arguments must be numbers, characters or markers.
1331 The value is always a number; markers and characters are converted
1334 (int nargs, Lisp_Object *args))
1338 Lisp_Object *args_end = args + nargs;
1341 number_char_or_marker_to_int_or_double (*args++, &iod);
1350 while (args < args_end)
1352 number_char_or_marker_to_int_or_double (*args++, &iod);
1355 if (imin > iod.c.ival) imin = iod.c.ival;
1359 dmin = (double) imin;
1360 if (dmin > iod.c.dval) dmin = iod.c.dval;
1365 return make_int (imin);
1368 while (args < args_end)
1370 double dval = number_char_or_marker_to_double (*args++);
1371 if (dmin > dval) dmin = dval;
1373 return make_float (dmin);
1376 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1377 Return bitwise-and of all the arguments.
1378 Arguments may be integers, or markers or characters converted to integers.
1380 (int nargs, Lisp_Object *args))
1382 EMACS_INT bits = ~0;
1383 Lisp_Object *args_end = args + nargs;
1385 while (args < args_end)
1386 bits &= integer_char_or_marker_to_int (*args++);
1388 return make_int (bits);
1391 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1392 Return bitwise-or of all the arguments.
1393 Arguments may be integers, or markers or characters converted to integers.
1395 (int nargs, Lisp_Object *args))
1398 Lisp_Object *args_end = args + nargs;
1400 while (args < args_end)
1401 bits |= integer_char_or_marker_to_int (*args++);
1403 return make_int (bits);
1406 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1407 Return bitwise-exclusive-or of all the arguments.
1408 Arguments may be integers, or markers or characters converted to integers.
1410 (int nargs, Lisp_Object *args))
1413 Lisp_Object *args_end = args + nargs;
1415 while (args < args_end)
1416 bits ^= integer_char_or_marker_to_int (*args++);
1418 return make_int (bits);
1421 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1422 Return the bitwise complement of NUMBER.
1423 NUMBER may be an integer, marker or character converted to integer.
1427 return make_int (~ integer_char_or_marker_to_int (number));
1430 DEFUN ("%", Frem, 2, 2, 0, /*
1431 Return remainder of first arg divided by second.
1432 Both must be integers, characters or markers.
1436 int ival1 = integer_char_or_marker_to_int (num1);
1437 int ival2 = integer_char_or_marker_to_int (num2);
1440 Fsignal (Qarith_error, Qnil);
1442 return make_int (ival1 % ival2);
1445 /* Note, ANSI *requires* the presence of the fmod() library routine.
1446 If your system doesn't have it, complain to your vendor, because
1451 fmod (double f1, double f2)
1455 return f1 - f2 * floor (f1/f2);
1457 #endif /* ! HAVE_FMOD */
1460 DEFUN ("mod", Fmod, 2, 2, 0, /*
1462 The result falls between zero (inclusive) and Y (exclusive).
1463 Both X and Y must be numbers, characters or markers.
1464 If either argument is a float, a float will be returned.
1468 int_or_double iod1, iod2;
1469 number_char_or_marker_to_int_or_double (x, &iod1);
1470 number_char_or_marker_to_int_or_double (y, &iod2);
1472 #ifdef LISP_FLOAT_TYPE
1473 if (!iod1.int_p || !iod2.int_p)
1475 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
1476 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
1477 if (dval2 == 0) goto divide_by_zero;
1478 dval1 = fmod (dval1, dval2);
1480 /* If the "remainder" comes out with the wrong sign, fix it. */
1481 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
1484 return make_float (dval1);
1486 #endif /* LISP_FLOAT_TYPE */
1489 if (iod2.c.ival == 0) goto divide_by_zero;
1491 ival = iod1.c.ival % iod2.c.ival;
1493 /* If the "remainder" comes out with the wrong sign, fix it. */
1494 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
1495 ival += iod2.c.ival;
1497 return make_int (ival);
1501 Fsignal (Qarith_error, Qnil);
1502 return Qnil; /* not reached */
1505 DEFUN ("ash", Fash, 2, 2, 0, /*
1506 Return VALUE with its bits shifted left by COUNT.
1507 If COUNT is negative, shifting is actually to the right.
1508 In this case, the sign bit is duplicated.
1512 CHECK_INT_COERCE_CHAR (value);
1513 CONCHECK_INT (count);
1515 return make_int (XINT (count) > 0 ?
1516 XINT (value) << XINT (count) :
1517 XINT (value) >> -XINT (count));
1520 DEFUN ("lsh", Flsh, 2, 2, 0, /*
1521 Return VALUE with its bits shifted left by COUNT.
1522 If COUNT is negative, shifting is actually to the right.
1523 In this case, zeros are shifted in on the left.
1527 CHECK_INT_COERCE_CHAR (value);
1528 CONCHECK_INT (count);
1530 return make_int (XINT (count) > 0 ?
1531 XUINT (value) << XINT (count) :
1532 XUINT (value) >> -XINT (count));
1535 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1536 Return NUMBER plus one. NUMBER may be a number, character or marker.
1537 Markers and characters are converted to integers.
1543 if (INTP (number)) return make_int (XINT (number) + 1);
1544 if (CHARP (number)) return make_int (XCHAR (number) + 1);
1545 if (MARKERP (number)) return make_int (marker_position (number) + 1);
1546 #ifdef LISP_FLOAT_TYPE
1547 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1548 #endif /* LISP_FLOAT_TYPE */
1550 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1554 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1555 Return NUMBER minus one. NUMBER may be a number, character or marker.
1556 Markers and characters are converted to integers.
1562 if (INTP (number)) return make_int (XINT (number) - 1);
1563 if (CHARP (number)) return make_int (XCHAR (number) - 1);
1564 if (MARKERP (number)) return make_int (marker_position (number) - 1);
1565 #ifdef LISP_FLOAT_TYPE
1566 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1567 #endif /* LISP_FLOAT_TYPE */
1569 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1574 /************************************************************************/
1576 /************************************************************************/
1578 /* A weak list is like a normal list except that elements automatically
1579 disappear when no longer in use, i.e. when no longer GC-protected.
1580 The basic idea is that we don't mark the elements during GC, but
1581 wait for them to be marked elsewhere. If they're not marked, we
1582 remove them. This is analogous to weak hash tables; see the explanation
1583 there for more info. */
1585 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1587 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1590 mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
1592 return Qnil; /* nichts ist gemarkt */
1596 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1599 error ("printing unreadable object #<weak-list>");
1601 write_c_string ("#<weak-list ", printcharfun);
1602 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
1604 write_c_string (" ", printcharfun);
1605 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1606 write_c_string (">", printcharfun);
1610 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1612 struct weak_list *w1 = XWEAK_LIST (obj1);
1613 struct weak_list *w2 = XWEAK_LIST (obj2);
1615 return ((w1->type == w2->type) &&
1616 internal_equal (w1->list, w2->list, depth + 1));
1619 static unsigned long
1620 weak_list_hash (Lisp_Object obj, int depth)
1622 struct weak_list *w = XWEAK_LIST (obj);
1624 return HASH2 ((unsigned long) w->type,
1625 internal_hash (w->list, depth + 1));
1629 make_weak_list (enum weak_list_type type)
1632 struct weak_list *wl =
1633 alloc_lcrecord_type (struct weak_list, lrecord_weak_list);
1637 XSETWEAK_LIST (result, wl);
1638 wl->next_weak = Vall_weak_lists;
1639 Vall_weak_lists = result;
1643 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1644 mark_weak_list, print_weak_list,
1645 0, weak_list_equal, weak_list_hash,
1648 -- we do not mark the list elements (either the elements themselves
1649 or the cons cells that hold them) in the normal marking phase.
1650 -- at the end of marking, we go through all weak lists that are
1651 marked, and mark the cons cells that hold all marked
1652 objects, and possibly parts of the objects themselves.
1653 (See alloc.c, "after-mark".)
1654 -- after that, we prune away all the cons cells that are not marked.
1656 WARNING WARNING WARNING WARNING WARNING:
1658 The code in the following two functions is *unbelievably* tricky.
1659 Don't mess with it. You'll be sorry.
1661 Linked lists just majorly suck, d'ya know?
1665 finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object),
1666 void (*markobj) (Lisp_Object))
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 (! obj_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 (obj_marked_p (rest2))
1704 elem = XCAR (rest2);
1708 case WEAK_LIST_SIMPLE:
1709 if (obj_marked_p (elem))
1710 need_to_mark_cons = 1;
1713 case WEAK_LIST_ASSOC:
1714 if (!GC_CONSP (elem))
1716 /* just leave bogus elements there */
1717 need_to_mark_cons = 1;
1718 need_to_mark_elem = 1;
1720 else if (obj_marked_p (XCAR (elem)) &&
1721 obj_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:
1731 if (!GC_CONSP (elem))
1733 /* just leave bogus elements there */
1734 need_to_mark_cons = 1;
1735 need_to_mark_elem = 1;
1737 else if (obj_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:
1747 if (!GC_CONSP (elem))
1749 /* just leave bogus elements there */
1750 need_to_mark_cons = 1;
1751 need_to_mark_elem = 1;
1753 else if (obj_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;
1766 if (need_to_mark_elem && ! obj_marked_p (elem))
1772 /* We also need to mark the cons that holds the elem or
1773 assoc-pair. We do *not* want to call (markobj) here
1774 because that will mark the entire list; we just want to
1775 mark the cons itself.
1777 if (need_to_mark_cons)
1779 struct Lisp_Cons *ptr = XCONS (rest2);
1780 if (!CONS_MARKED_P (ptr))
1788 /* In case of imperfect list, need to mark the final cons
1789 because we're not removing it */
1790 if (!GC_NILP (rest2) && ! obj_marked_p (rest2))
1801 prune_weak_lists (int (*obj_marked_p) (Lisp_Object))
1803 Lisp_Object rest, prev = Qnil;
1805 for (rest = Vall_weak_lists;
1807 rest = XWEAK_LIST (rest)->next_weak)
1809 if (! (obj_marked_p (rest)))
1811 /* This weak list itself is garbage. Remove it from the list. */
1813 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1815 XWEAK_LIST (prev)->next_weak =
1816 XWEAK_LIST (rest)->next_weak;
1820 Lisp_Object rest2, prev2 = Qnil;
1821 Lisp_Object tortoise;
1822 int go_tortoise = 0;
1824 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1825 /* We need to be trickier since we're inside of GC;
1826 use CONSP instead of !NILP in case of user-visible
1830 /* It suffices to check the cons for marking,
1831 regardless of the type of weak list:
1833 -- if the cons is pointed to somewhere else,
1834 then it should stay around and will be marked.
1835 -- otherwise, if it should stay around, it will
1836 have been marked in finish_marking_weak_lists().
1837 -- otherwise, it's not marked and should disappear.
1839 if (! obj_marked_p (rest2))
1842 if (GC_NILP (prev2))
1843 XWEAK_LIST (rest)->list = XCDR (rest2);
1845 XCDR (prev2) = XCDR (rest2);
1846 rest2 = XCDR (rest2);
1847 /* Ouch. Circularity checking is even trickier
1848 than I thought. When we cut out a link
1849 like this, we can't advance the turtle or
1850 it'll catch up to us. Imagine that we're
1851 standing on floor tiles and moving forward --
1852 what we just did here is as if the floor
1853 tile under us just disappeared and all the
1854 ones ahead of us slid one tile towards us.
1855 In other words, we didn't move at all;
1856 if the tortoise was one step behind us
1857 previously, it still is, and therefore
1858 it must not move. */
1864 /* Implementing circularity checking is trickier here
1865 than in other places because we have to guarantee
1866 that we've processed all elements before exiting
1867 due to a circularity. (In most places, an error
1868 is issued upon encountering a circularity, so it
1869 doesn't really matter if all elements are processed.)
1870 The idea is that we process along with the hare
1871 rather than the tortoise. If at any point in
1872 our forward process we encounter the tortoise,
1873 we must have already visited the spot, so we exit.
1874 (If we process with the tortoise, we can fail to
1875 process cases where a cons points to itself, or
1876 where cons A points to cons B, which points to
1879 rest2 = XCDR (rest2);
1881 tortoise = XCDR (tortoise);
1882 go_tortoise = !go_tortoise;
1883 if (GC_EQ (rest2, tortoise))
1893 static enum weak_list_type
1894 decode_weak_list_type (Lisp_Object symbol)
1896 CHECK_SYMBOL (symbol);
1897 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1898 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1899 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1900 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1901 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1903 signal_simple_error ("Invalid weak list type", symbol);
1904 return WEAK_LIST_SIMPLE; /* not reached */
1908 encode_weak_list_type (enum weak_list_type type)
1912 case WEAK_LIST_SIMPLE: return Qsimple;
1913 case WEAK_LIST_ASSOC: return Qassoc;
1914 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1915 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1920 return Qnil; /* not reached */
1923 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
1924 Return non-nil if OBJECT is a weak list.
1928 return WEAK_LISTP (object) ? Qt : Qnil;
1931 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
1932 Return a new weak list object of type TYPE.
1933 A weak list object is an object that contains a list. This list behaves
1934 like any other list except that its elements do not count towards
1935 garbage collection -- if the only pointer to an object in inside a weak
1936 list (other than pointers in similar objects such as weak hash tables),
1937 the object is garbage collected and automatically removed from the list.
1938 This is used internally, for example, to manage the list holding the
1939 children of an extent -- an extent that is unused but has a parent will
1940 still be reclaimed, and will automatically be removed from its parent's
1943 Optional argument TYPE specifies the type of the weak list, and defaults
1944 to `simple'. Recognized types are
1946 `simple' Objects in the list disappear if not pointed to.
1947 `assoc' Objects in the list disappear if they are conses
1948 and either the car or the cdr of the cons is not
1950 `key-assoc' Objects in the list disappear if they are conses
1951 and the car is not pointed to.
1952 `value-assoc' Objects in the list disappear if they are conses
1953 and the cdr is not pointed to.
1960 return make_weak_list (decode_weak_list_type (type));
1963 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
1964 Return the type of the given weak-list object.
1968 CHECK_WEAK_LIST (weak);
1969 return encode_weak_list_type (XWEAK_LIST (weak)->type);
1972 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
1973 Return the list contained in a weak-list object.
1977 CHECK_WEAK_LIST (weak);
1978 return XWEAK_LIST_LIST (weak);
1981 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
1982 Change the list contained in a weak-list object.
1986 CHECK_WEAK_LIST (weak);
1987 XWEAK_LIST_LIST (weak) = new_list;
1992 /************************************************************************/
1993 /* initialization */
1994 /************************************************************************/
1997 arith_error (int signo)
1999 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
2000 EMACS_UNBLOCK_SIGNAL (signo);
2001 signal_error (Qarith_error, Qnil);
2005 init_data_very_early (void)
2007 /* Don't do this if just dumping out.
2008 We don't want to call `signal' in this case
2009 so that we don't have trouble with dumping
2010 signal-delivering routines in an inconsistent state. */
2014 #endif /* CANNOT_DUMP */
2015 signal (SIGFPE, arith_error);
2017 signal (SIGEMT, arith_error);
2022 init_errors_once_early (void)
2024 defsymbol (&Qerror_conditions, "error-conditions");
2025 defsymbol (&Qerror_message, "error-message");
2027 /* We declare the errors here because some other deferrors depend
2028 on some of the errors below. */
2030 /* ERROR is used as a signaler for random errors for which nothing
2033 deferror (&Qerror, "error", "error", Qnil);
2034 deferror (&Qquit, "quit", "Quit", Qnil);
2036 deferror (&Qwrong_type_argument, "wrong-type-argument",
2037 "Wrong type argument", Qerror);
2038 deferror (&Qargs_out_of_range, "args-out-of-range", "Args out of range",
2040 deferror (&Qvoid_function, "void-function",
2041 "Symbol's function definition is void", Qerror);
2042 deferror (&Qcyclic_function_indirection, "cyclic-function-indirection",
2043 "Symbol's chain of function indirections contains a loop", Qerror);
2044 deferror (&Qvoid_variable, "void-variable",
2045 "Symbol's value as variable is void", Qerror);
2046 deferror (&Qcyclic_variable_indirection, "cyclic-variable-indirection",
2047 "Symbol's chain of variable indirections contains a loop", Qerror);
2048 deferror (&Qsetting_constant, "setting-constant",
2049 "Attempt to set a constant symbol", Qerror);
2050 deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
2051 "Invalid read syntax", Qerror);
2053 /* Generated by list traversal macros */
2054 deferror (&Qmalformed_list, "malformed-list",
2055 "Malformed list", Qerror);
2056 deferror (&Qmalformed_property_list, "malformed-property-list",
2057 "Malformed property list", Qmalformed_list);
2058 deferror (&Qcircular_list, "circular-list",
2059 "Circular list", Qerror);
2060 deferror (&Qcircular_property_list, "circular-property-list",
2061 "Circular property list", Qcircular_list);
2063 deferror (&Qinvalid_function, "invalid-function", "Invalid function",
2065 deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
2066 "Wrong number of arguments", Qerror);
2067 deferror (&Qno_catch, "no-catch", "No catch for tag",
2069 deferror (&Qbeginning_of_buffer, "beginning-of-buffer",
2070 "Beginning of buffer", Qerror);
2071 deferror (&Qend_of_buffer, "end-of-buffer", "End of buffer", Qerror);
2072 deferror (&Qbuffer_read_only, "buffer-read-only", "Buffer is read-only",
2075 deferror (&Qio_error, "io-error", "IO Error", Qerror);
2076 deferror (&Qend_of_file, "end-of-file", "End of stream", Qio_error);
2078 deferror (&Qarith_error, "arith-error", "Arithmetic error", Qerror);
2079 deferror (&Qrange_error, "range-error", "Arithmetic range error",
2081 deferror (&Qdomain_error, "domain-error", "Arithmetic domain error",
2083 deferror (&Qsingularity_error, "singularity-error",
2084 "Arithmetic singularity error", Qdomain_error);
2085 deferror (&Qoverflow_error, "overflow-error",
2086 "Arithmetic overflow error", Qdomain_error);
2087 deferror (&Qunderflow_error, "underflow-error",
2088 "Arithmetic underflow error", Qdomain_error);
2094 defsymbol (&Qcons, "cons");
2095 defsymbol (&Qkeyword, "keyword");
2096 defsymbol (&Qquote, "quote");
2097 defsymbol (&Qlambda, "lambda");
2098 defsymbol (&Qignore, "ignore");
2099 defsymbol (&Qlistp, "listp");
2100 defsymbol (&Qtrue_list_p, "true-list-p");
2101 defsymbol (&Qconsp, "consp");
2102 defsymbol (&Qsubrp, "subrp");
2103 defsymbol (&Qsymbolp, "symbolp");
2104 defsymbol (&Qkeywordp, "keywordp");
2105 defsymbol (&Qintegerp, "integerp");
2106 defsymbol (&Qcharacterp, "characterp");
2107 defsymbol (&Qnatnump, "natnump");
2108 defsymbol (&Qstringp, "stringp");
2109 defsymbol (&Qarrayp, "arrayp");
2110 defsymbol (&Qsequencep, "sequencep");
2111 defsymbol (&Qbufferp, "bufferp");
2112 defsymbol (&Qbitp, "bitp");
2113 defsymbol (&Qbit_vectorp, "bit-vector-p");
2114 defsymbol (&Qvectorp, "vectorp");
2115 defsymbol (&Qchar_or_string_p, "char-or-string-p");
2116 defsymbol (&Qmarkerp, "markerp");
2117 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
2118 defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
2119 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
2120 defsymbol (&Qnumberp, "numberp");
2121 defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
2122 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p");
2123 defsymbol (&Qcdr, "cdr");
2124 defsymbol (&Qweak_listp, "weak-list-p");
2126 #ifdef LISP_FLOAT_TYPE
2127 defsymbol (&Qfloatp, "floatp");
2128 #endif /* LISP_FLOAT_TYPE */
2130 DEFSUBR (Fwrong_type_argument);
2135 Ffset (intern ("not"), intern ("null"));
2138 DEFSUBR (Ftrue_list_p);
2141 DEFSUBR (Fchar_or_string_p);
2142 DEFSUBR (Fcharacterp);
2143 DEFSUBR (Fchar_int_p);
2144 DEFSUBR (Fchar_to_int);
2145 DEFSUBR (Fint_to_char);
2146 DEFSUBR (Fchar_or_char_int_p);
2147 DEFSUBR (Fintegerp);
2148 DEFSUBR (Finteger_or_marker_p);
2149 DEFSUBR (Finteger_or_char_p);
2150 DEFSUBR (Finteger_char_or_marker_p);
2152 DEFSUBR (Fnumber_or_marker_p);
2153 DEFSUBR (Fnumber_char_or_marker_p);
2154 #ifdef LISP_FLOAT_TYPE
2156 #endif /* LISP_FLOAT_TYPE */
2159 DEFSUBR (Fkeywordp);
2163 DEFSUBR (Fbit_vector_p);
2165 DEFSUBR (Fsequencep);
2168 DEFSUBR (Fsubr_min_args);
2169 DEFSUBR (Fsubr_max_args);
2170 DEFSUBR (Fsubr_interactive);
2174 DEFSUBR (Fcar_safe);
2175 DEFSUBR (Fcdr_safe);
2178 DEFSUBR (Findirect_function);
2182 DEFSUBR (Fnumber_to_string);
2183 DEFSUBR (Fstring_to_number);
2208 DEFSUBR (Fweak_list_p);
2209 DEFSUBR (Fmake_weak_list);
2210 DEFSUBR (Fweak_list_type);
2211 DEFSUBR (Fweak_list_list);
2212 DEFSUBR (Fset_weak_list_list);
2218 /* This must not be staticpro'd */
2219 Vall_weak_lists = Qnil;
2222 DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2223 If non-zero, note when your code may be suffering from char-int confoundance.
2224 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2225 etc. where an int and a char with the same value are being compared,
2226 it will issue a notice on stderr to this effect, along with a backtrace.
2227 In such situations, the result would be different in XEmacs 19 versus
2228 XEmacs 20, and you probably don't want this.
2230 Note that in order to see these notices, you have to byte compile your
2231 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2232 have its chars and ints all confounded in the byte code, making it
2233 impossible to accurately determine Ebola infection.
2236 debug_issue_ebola_notices = 2; /* #### temporary hack */
2238 DEFVAR_INT ("debug-ebola-backtrace-length",
2239 &debug_ebola_backtrace_length /*
2240 Length (in stack frames) of short backtrace printed out in Ebola notices.
2241 See `debug-issue-ebola-notices'.
2243 debug_ebola_backtrace_length = 32;
2245 #endif /* DEBUG_XEMACS */