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;
66 int debug_issue_ebola_notices;
68 int debug_ebola_backtrace_length;
71 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
73 if (debug_issue_ebola_notices
74 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
76 /* #### It would be really nice if this were a proper warning
77 instead of brain-dead print ro Qexternal_debugging_output. */
78 write_c_string ("Comparison between integer and character is constant nil (",
79 Qexternal_debugging_output);
80 Fprinc (obj1, Qexternal_debugging_output);
81 write_c_string (" and ", Qexternal_debugging_output);
82 Fprinc (obj2, Qexternal_debugging_output);
83 write_c_string (")\n", Qexternal_debugging_output);
84 debug_short_backtrace (debug_ebola_backtrace_length);
86 return EQ (obj1, obj2);
89 #endif /* DEBUG_XEMACS */
94 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
96 /* This function can GC */
97 REGISTER Lisp_Object tem;
100 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
101 tem = call1 (predicate, value);
108 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
110 signal_error (Qwrong_type_argument, list2 (predicate, value));
113 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
114 Signal an error until the correct type value is given by the user.
115 This function loops, signalling a continuable `wrong-type-argument' error
116 with PREDICATE and VALUE as the data associated with the error and then
117 calling PREDICATE on the returned value, until the value gotten satisfies
118 PREDICATE. At that point, the gotten value is returned.
122 return wrong_type_argument (predicate, value);
126 c_write_error (Lisp_Object obj)
128 signal_simple_error ("Attempt to modify read-only object (c)", obj);
132 lisp_write_error (Lisp_Object obj)
134 signal_simple_error ("Attempt to modify read-only object (lisp)", obj);
138 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
140 signal_error (Qargs_out_of_range, list2 (a1, a2));
144 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
146 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
150 check_int_range (int val, int min, int max)
152 if (val < min || val > max)
153 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
156 /* On some machines, XINT needs a temporary location.
157 Here it is, in case it is needed. */
159 EMACS_INT sign_extend_temp;
161 /* On a few machines, XINT can only be done by calling this. */
162 /* XEmacs: only used by m/convex.h */
163 int sign_extend_lisp_int (EMACS_INT num);
165 sign_extend_lisp_int (EMACS_INT num)
167 if (num & (1L << (VALBITS - 1)))
168 return num | ((-1L) << VALBITS);
170 return num & ((1L << VALBITS) - 1);
174 /* Data type predicates */
176 DEFUN ("eq", Feq, 2, 2, 0, /*
177 Return t if the two args are the same Lisp object.
181 return EQ_WITH_EBOLA_NOTICE (obj1, obj2) ? Qt : Qnil;
184 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
185 Return t if the two args are (in most cases) the same Lisp object.
187 Special kludge: A character is considered `old-eq' to its equivalent integer
188 even though they are not the same object and are in fact of different
189 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
190 preserve byte-code compatibility with v19. This kludge is known as the
191 \"char-int confoundance disease\" and appears in a number of other
192 functions with `old-foo' equivalents.
194 Do not use this function!
199 return HACKEQ_UNSAFE (obj1, obj2) ? Qt : Qnil;
202 DEFUN ("null", Fnull, 1, 1, 0, /*
203 Return t if OBJECT is nil.
207 return NILP (object) ? Qt : Qnil;
210 DEFUN ("consp", Fconsp, 1, 1, 0, /*
211 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
215 return CONSP (object) ? Qt : Qnil;
218 DEFUN ("atom", Fatom, 1, 1, 0, /*
219 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
223 return CONSP (object) ? Qnil : Qt;
226 DEFUN ("listp", Flistp, 1, 1, 0, /*
227 Return t if OBJECT is a list. `nil' is a list.
231 return LISTP (object) ? Qt : Qnil;
234 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
235 Return t if OBJECT is not a list. `nil' is a list.
239 return LISTP (object) ? Qnil : Qt;
242 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
243 Return t if OBJECT is a non-dotted, i.e. nil-terminated, list.
247 return TRUE_LIST_P (object) ? Qt : Qnil;
250 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
251 Return t if OBJECT is a symbol.
255 return SYMBOLP (object) ? Qt : Qnil;
258 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
259 Return t if OBJECT is a keyword.
263 return KEYWORDP (object) ? Qt : Qnil;
266 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
267 Return t if OBJECT is a vector.
271 return VECTORP (object) ? Qt : Qnil;
274 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
275 Return t if OBJECT is a bit vector.
279 return BIT_VECTORP (object) ? Qt : Qnil;
282 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
283 Return t if OBJECT is a string.
287 return STRINGP (object) ? Qt : Qnil;
290 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
291 Return t if OBJECT is an array (string, vector, or bit vector).
295 return (VECTORP (object) ||
297 BIT_VECTORP (object))
301 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
302 Return t if OBJECT is a sequence (list or array).
306 return (LISTP (object) ||
309 BIT_VECTORP (object))
313 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
314 Return t if OBJECT is a marker (editor pointer).
318 return MARKERP (object) ? Qt : Qnil;
321 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
322 Return t if OBJECT is a built-in function.
326 return SUBRP (object) ? Qt : Qnil;
329 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
330 Return minimum number of args built-in function SUBR may be called with.
335 return make_int (XSUBR (subr)->min_args);
338 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
339 Return maximum number of args built-in function SUBR may be called with,
340 or nil if it takes an arbitrary number of arguments or is a special form.
346 nargs = XSUBR (subr)->max_args;
347 if (nargs == MANY || nargs == UNEVALLED)
350 return make_int (nargs);
353 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
354 Return the interactive spec of the subr object, or nil.
355 If non-nil, the return value will be a list whose first element is
356 `interactive' and whose second element is the interactive spec.
362 prompt = XSUBR (subr)->prompt;
363 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
367 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
368 Return t if OBJECT is a character.
369 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
370 Any character can be converted into an equivalent integer using
371 `char-int'. To convert the other way, use `int-char'; however,
372 only some integers can be converted into characters. Such an integer
373 is called a `char-int'; see `char-int-p'.
375 Some functions that work on integers (e.g. the comparison functions
376 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
377 accept characters and implicitly convert them into integers. In
378 general, functions that work on characters also accept char-ints and
379 implicitly convert them into characters. WARNING: Neither of these
380 behaviors is very desirable, and they are maintained for backward
381 compatibility with old E-Lisp programs that confounded characters and
382 integers willy-nilly. These behaviors may change in the future; therefore,
383 do not rely on them. Instead, use the character-specific functions such
388 return CHARP (object) ? Qt : Qnil;
391 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
392 Convert a character into an equivalent integer.
393 The resulting integer will always be non-negative. The integers in
394 the range 0 - 255 map to characters as follows:
398 128 - 159 Control set 1
399 160 - 255 Right half of ISO-8859-1
401 If support for Mule does not exist, these are the only valid character
402 values. When Mule support exists, the values assigned to other characters
403 may vary depending on the particular version of XEmacs, the order in which
404 character sets were loaded, etc., and you should not depend on them.
409 return make_int (XCHAR (ch));
412 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
413 Convert an integer into the equivalent character.
414 Not all integers correspond to valid characters; use `char-int-p' to
415 determine whether this is the case. If the integer cannot be converted,
421 if (CHAR_INTP (integer))
422 return make_char (XINT (integer));
427 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
428 Return t if OBJECT is an integer that can be converted into a character.
433 return CHAR_INTP (object) ? Qt : Qnil;
436 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
437 Return t if OBJECT is a character or an integer that can be converted into one.
441 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
444 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
445 Return t if OBJECT is a character (or a char-int) or a string.
446 It is semi-hateful that we allow a char-int here, as it goes against
447 the name of this function, but it makes the most sense considering the
448 other steps we take to maintain compatibility with the old character/integer
449 confoundedness in older versions of E-Lisp.
453 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
456 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
457 Return t if OBJECT is an integer.
461 return INTP (object) ? Qt : Qnil;
464 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
465 Return t if OBJECT is an integer or a marker (editor pointer).
469 return INTP (object) || MARKERP (object) ? Qt : Qnil;
472 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
473 Return t if OBJECT is an integer or a character.
477 return INTP (object) || CHARP (object) ? Qt : Qnil;
480 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
481 Return t if OBJECT is an integer, character or a marker (editor pointer).
485 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
488 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
489 Return t if OBJECT is a nonnegative integer.
493 return NATNUMP (object) ? Qt : Qnil;
496 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
497 Return t if OBJECT is a bit (0 or 1).
501 return BITP (object) ? Qt : Qnil;
504 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
505 Return t if OBJECT is a number (floating point or integer).
509 return INT_OR_FLOATP (object) ? Qt : Qnil;
512 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
513 Return t if OBJECT is a number or a marker.
517 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
520 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
521 Return t if OBJECT is a number, character or a marker.
525 return (INT_OR_FLOATP (object) ||
531 #ifdef LISP_FLOAT_TYPE
532 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
533 Return t if OBJECT is a floating point number.
537 return FLOATP (object) ? Qt : Qnil;
539 #endif /* LISP_FLOAT_TYPE */
541 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
542 Return a symbol representing the type of OBJECT.
546 switch (XTYPE (object))
548 case Lisp_Type_Record:
549 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
551 case Lisp_Type_Char: return Qcharacter;
553 default: return Qinteger;
558 /* Extract and set components of lists */
560 DEFUN ("car", Fcar, 1, 1, 0, /*
561 Return the car of LIST. If arg is nil, return nil.
562 Error if arg is not nil and not a cons cell. See also `car-safe'.
570 else if (NILP (list))
573 list = wrong_type_argument (Qlistp, list);
577 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
578 Return the car of OBJECT if it is a cons cell, or else nil.
582 return CONSP (object) ? XCAR (object) : Qnil;
585 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
586 Return the cdr of LIST. If arg is nil, return nil.
587 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
595 else if (NILP (list))
598 list = wrong_type_argument (Qlistp, list);
602 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
603 Return the cdr of OBJECT if it is a cons cell, else nil.
607 return CONSP (object) ? XCDR (object) : Qnil;
610 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
611 Set the car of CONSCELL to be NEWCAR. Return NEWCAR.
615 if (!CONSP (conscell))
616 conscell = wrong_type_argument (Qconsp, conscell);
618 CHECK_LISP_WRITEABLE (conscell);
619 XCAR (conscell) = newcar;
623 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
624 Set the cdr of CONSCELL to be NEWCDR. Return NEWCDR.
628 if (!CONSP (conscell))
629 conscell = wrong_type_argument (Qconsp, conscell);
631 CHECK_LISP_WRITEABLE (conscell);
632 XCDR (conscell) = newcdr;
636 /* Find the function at the end of a chain of symbol function indirections.
638 If OBJECT is a symbol, find the end of its function chain and
639 return the value found there. If OBJECT is not a symbol, just
640 return it. If there is a cycle in the function chain, signal a
641 cyclic-function-indirection error.
643 This is like Findirect_function, except that it doesn't signal an
644 error if the chain ends up unbound. */
646 indirect_function (Lisp_Object object, int errorp)
648 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
649 Lisp_Object tortoise, hare;
652 for (hare = tortoise = object, count = 0;
654 hare = XSYMBOL (hare)->function, count++)
656 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
659 tortoise = XSYMBOL (tortoise)->function;
660 if (EQ (hare, tortoise))
661 return Fsignal (Qcyclic_function_indirection, list1 (object));
664 if (errorp && UNBOUNDP (hare))
665 signal_void_function_error (object);
670 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
671 Return the function at the end of OBJECT's function chain.
672 If OBJECT is a symbol, follow all function indirections and return
673 the final function binding.
674 If OBJECT is not a symbol, just return it.
675 Signal a void-function error if the final symbol is unbound.
676 Signal a cyclic-function-indirection error if there is a loop in the
677 function chain of symbols.
681 return indirect_function (object, 1);
684 /* Extract and set vector and string elements */
686 DEFUN ("aref", Faref, 2, 2, 0, /*
687 Return the element of ARRAY at index INDEX.
688 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
696 if (INTP (index_)) idx = XINT (index_);
697 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
700 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
704 if (idx < 0) goto range_error;
708 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
709 return XVECTOR_DATA (array)[idx];
711 else if (BIT_VECTORP (array))
713 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
714 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
716 else if (STRINGP (array))
718 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
719 return make_char (string_char (XSTRING (array), idx));
721 #ifdef LOSING_BYTECODE
722 else if (COMPILED_FUNCTIONP (array))
724 /* Weird, gross compatibility kludge */
725 return Felt (array, index_);
730 check_losing_bytecode ("aref", array);
731 array = wrong_type_argument (Qarrayp, array);
736 args_out_of_range (array, index_);
737 return Qnil; /* not reached */
740 DEFUN ("aset", Faset, 3, 3, 0, /*
741 Store into the element of ARRAY at index INDEX the value NEWVAL.
742 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
744 (array, index_, newval))
750 if (INTP (index_)) idx = XINT (index_);
751 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
754 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
758 if (idx < 0) goto range_error;
760 CHECK_LISP_WRITEABLE (array);
764 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
765 XVECTOR_DATA (array)[idx] = newval;
767 else if (BIT_VECTORP (array))
769 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
771 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
773 else if (STRINGP (array))
775 CHECK_CHAR_COERCE_INT (newval);
776 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
777 set_string_char (XSTRING (array), idx, XCHAR (newval));
778 bump_string_modiff (array);
782 array = wrong_type_argument (Qarrayp, array);
789 args_out_of_range (array, index_);
790 return Qnil; /* not reached */
794 /**********************************************************************/
795 /* Arithmetic functions */
796 /**********************************************************************/
808 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
812 if (INTP (obj)) p->c.ival = XINT (obj);
813 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
814 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
815 #ifdef LISP_FLOAT_TYPE
816 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
820 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
826 number_char_or_marker_to_double (Lisp_Object obj)
829 if (INTP (obj)) return (double) XINT (obj);
830 else if (CHARP (obj)) return (double) XCHAR (obj);
831 else if (MARKERP (obj)) return (double) marker_position (obj);
832 #ifdef LISP_FLOAT_TYPE
833 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
837 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
843 integer_char_or_marker_to_int (Lisp_Object obj)
846 if (INTP (obj)) return XINT (obj);
847 else if (CHARP (obj)) return XCHAR (obj);
848 else if (MARKERP (obj)) return marker_position (obj);
851 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
856 #define ARITHCOMPARE_MANY(op) \
858 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
859 Lisp_Object *args_end = args + nargs; \
861 number_char_or_marker_to_int_or_double (*args++, p); \
863 while (args < args_end) \
865 number_char_or_marker_to_int_or_double (*args++, q); \
867 if (!((p->int_p && q->int_p) ? \
868 (p->c.ival op q->c.ival) : \
869 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
870 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
873 { /* swap */ int_or_double *r = p; p = q; q = r; } \
878 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
879 Return t if all the arguments are numerically equal.
880 The arguments may be numbers, characters or markers.
882 (int nargs, Lisp_Object *args))
884 ARITHCOMPARE_MANY (==)
887 DEFUN ("<", Flss, 1, MANY, 0, /*
888 Return t if the sequence of arguments is monotonically increasing.
889 The arguments may be numbers, characters or markers.
891 (int nargs, Lisp_Object *args))
893 ARITHCOMPARE_MANY (<)
896 DEFUN (">", Fgtr, 1, MANY, 0, /*
897 Return t if the sequence of arguments is monotonically decreasing.
898 The arguments may be numbers, characters or markers.
900 (int nargs, Lisp_Object *args))
902 ARITHCOMPARE_MANY (>)
905 DEFUN ("<=", Fleq, 1, MANY, 0, /*
906 Return t if the sequence of arguments is monotonically nondecreasing.
907 The arguments may be numbers, characters or markers.
909 (int nargs, Lisp_Object *args))
911 ARITHCOMPARE_MANY (<=)
914 DEFUN (">=", Fgeq, 1, MANY, 0, /*
915 Return t if the sequence of arguments is monotonically nonincreasing.
916 The arguments may be numbers, characters or markers.
918 (int nargs, Lisp_Object *args))
920 ARITHCOMPARE_MANY (>=)
923 DEFUN ("/=", Fneq, 1, MANY, 0, /*
924 Return t if no two arguments are numerically equal.
925 The arguments may be numbers, characters or markers.
927 (int nargs, Lisp_Object *args))
929 Lisp_Object *args_end = args + nargs;
932 /* Unlike all the other comparisons, this is an N*N algorithm.
933 We could use a hash table for nargs > 50 to make this linear. */
934 for (p = args; p < args_end; p++)
936 int_or_double iod1, iod2;
937 number_char_or_marker_to_int_or_double (*p, &iod1);
939 for (q = p + 1; q < args_end; q++)
941 number_char_or_marker_to_int_or_double (*q, &iod2);
943 if (!((iod1.int_p && iod2.int_p) ?
944 (iod1.c.ival != iod2.c.ival) :
945 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
946 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
953 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
954 Return t if NUMBER is zero.
960 return EQ (number, Qzero) ? Qt : Qnil;
961 #ifdef LISP_FLOAT_TYPE
962 else if (FLOATP (number))
963 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
964 #endif /* LISP_FLOAT_TYPE */
967 number = wrong_type_argument (Qnumberp, number);
972 /* Convert between a 32-bit value and a cons of two 16-bit values.
973 This is used to pass 32-bit integers to and from the user.
974 Use time_to_lisp() and lisp_to_time() for time values.
976 If you're thinking of using this to store a pointer into a Lisp Object
977 for internal purposes (such as when calling record_unwind_protect()),
978 try using make_opaque_ptr()/get_opaque_ptr() instead. */
980 word_to_lisp (unsigned int item)
982 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
986 lisp_to_word (Lisp_Object item)
992 Lisp_Object top = Fcar (item);
993 Lisp_Object bot = Fcdr (item);
996 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
1001 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
1002 Convert NUM to a string by printing it in decimal.
1003 Uses a minus sign if negative.
1004 NUM may be an integer or a floating point number.
1008 char buffer[VALBITS];
1010 CHECK_INT_OR_FLOAT (num);
1012 #ifdef LISP_FLOAT_TYPE
1015 char pigbuf[350]; /* see comments in float_to_string */
1017 float_to_string (pigbuf, XFLOAT_DATA (num));
1018 return build_string (pigbuf);
1020 #endif /* LISP_FLOAT_TYPE */
1022 long_to_string (buffer, XINT (num));
1023 return build_string (buffer);
1027 digit_to_number (int character, int base)
1030 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1031 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
1032 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
1035 return digit >= base ? -1 : digit;
1038 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
1039 Convert STRING to a number by parsing it as a decimal number.
1040 This parses both integers and floating point numbers.
1041 It ignores leading spaces and tabs.
1043 If BASE, interpret STRING as a number in that base. If BASE isn't
1044 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
1045 Floating point numbers always use base 10.
1052 CHECK_STRING (string);
1060 check_int_range (b, 2, 16);
1063 p = (char *) XSTRING_DATA (string);
1065 /* Skip any whitespace at the front of the number. Some versions of
1066 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1067 while (*p == ' ' || *p == '\t')
1070 #ifdef LISP_FLOAT_TYPE
1071 if (isfloat_string (p) && b == 10)
1072 return make_float (atof (p));
1073 #endif /* LISP_FLOAT_TYPE */
1077 /* Use the system-provided functions for base 10. */
1078 #if SIZEOF_EMACS_INT == SIZEOF_INT
1079 return make_int (atoi (p));
1080 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1081 return make_int (atol (p));
1082 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1083 return make_int (atoll (p));
1088 int digit, negative = 1;
1100 digit = digit_to_number (*p++, b);
1105 return make_int (negative * v);
1110 DEFUN ("+", Fplus, 0, MANY, 0, /*
1111 Return sum of any number of arguments.
1112 The arguments should all be numbers, characters or markers.
1114 (int nargs, Lisp_Object *args))
1116 EMACS_INT iaccum = 0;
1117 Lisp_Object *args_end = args + nargs;
1119 while (args < args_end)
1122 number_char_or_marker_to_int_or_double (*args++, &iod);
1124 iaccum += iod.c.ival;
1127 double daccum = (double) iaccum + iod.c.dval;
1128 while (args < args_end)
1129 daccum += number_char_or_marker_to_double (*args++);
1130 return make_float (daccum);
1134 return make_int (iaccum);
1137 DEFUN ("-", Fminus, 1, MANY, 0, /*
1138 Negate number or subtract numbers, characters or markers.
1139 With one arg, negates it. With more than one arg,
1140 subtracts all but the first from the first.
1142 (int nargs, Lisp_Object *args))
1146 Lisp_Object *args_end = args + nargs;
1149 number_char_or_marker_to_int_or_double (*args++, &iod);
1151 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
1154 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
1158 while (args < args_end)
1160 number_char_or_marker_to_int_or_double (*args++, &iod);
1162 iaccum -= iod.c.ival;
1165 daccum = (double) iaccum - iod.c.dval;
1170 return make_int (iaccum);
1173 for (; args < args_end; args++)
1174 daccum -= number_char_or_marker_to_double (*args);
1175 return make_float (daccum);
1178 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1179 Return product of any number of arguments.
1180 The arguments should all be numbers, characters or markers.
1182 (int nargs, Lisp_Object *args))
1184 EMACS_INT iaccum = 1;
1185 Lisp_Object *args_end = args + nargs;
1187 while (args < args_end)
1190 number_char_or_marker_to_int_or_double (*args++, &iod);
1192 iaccum *= iod.c.ival;
1195 double daccum = (double) iaccum * iod.c.dval;
1196 while (args < args_end)
1197 daccum *= number_char_or_marker_to_double (*args++);
1198 return make_float (daccum);
1202 return make_int (iaccum);
1205 DEFUN ("/", Fquo, 1, MANY, 0, /*
1206 Return first argument divided by all the remaining arguments.
1207 The arguments must be numbers, characters or markers.
1208 With one argument, reciprocates the argument.
1210 (int nargs, Lisp_Object *args))
1214 Lisp_Object *args_end = args + nargs;
1221 number_char_or_marker_to_int_or_double (*args++, &iod);
1223 iaccum = iod.c.ival;
1226 daccum = iod.c.dval;
1231 while (args < args_end)
1233 number_char_or_marker_to_int_or_double (*args++, &iod);
1236 if (iod.c.ival == 0) goto divide_by_zero;
1237 iaccum /= iod.c.ival;
1241 if (iod.c.dval == 0) goto divide_by_zero;
1242 daccum = (double) iaccum / iod.c.dval;
1247 return make_int (iaccum);
1250 for (; args < args_end; args++)
1252 double dval = number_char_or_marker_to_double (*args);
1253 if (dval == 0) goto divide_by_zero;
1256 return make_float (daccum);
1259 Fsignal (Qarith_error, Qnil);
1260 return Qnil; /* not reached */
1263 DEFUN ("max", Fmax, 1, MANY, 0, /*
1264 Return largest of all the arguments.
1265 All arguments must be numbers, characters or markers.
1266 The value is always a number; markers and characters are converted
1269 (int nargs, Lisp_Object *args))
1273 Lisp_Object *args_end = args + nargs;
1276 number_char_or_marker_to_int_or_double (*args++, &iod);
1285 while (args < args_end)
1287 number_char_or_marker_to_int_or_double (*args++, &iod);
1290 if (imax < iod.c.ival) imax = iod.c.ival;
1294 dmax = (double) imax;
1295 if (dmax < iod.c.dval) dmax = iod.c.dval;
1300 return make_int (imax);
1303 while (args < args_end)
1305 double dval = number_char_or_marker_to_double (*args++);
1306 if (dmax < dval) dmax = dval;
1308 return make_float (dmax);
1311 DEFUN ("min", Fmin, 1, MANY, 0, /*
1312 Return smallest of all the arguments.
1313 All arguments must be numbers, characters or markers.
1314 The value is always a number; markers and characters are converted
1317 (int nargs, Lisp_Object *args))
1321 Lisp_Object *args_end = args + nargs;
1324 number_char_or_marker_to_int_or_double (*args++, &iod);
1333 while (args < args_end)
1335 number_char_or_marker_to_int_or_double (*args++, &iod);
1338 if (imin > iod.c.ival) imin = iod.c.ival;
1342 dmin = (double) imin;
1343 if (dmin > iod.c.dval) dmin = iod.c.dval;
1348 return make_int (imin);
1351 while (args < args_end)
1353 double dval = number_char_or_marker_to_double (*args++);
1354 if (dmin > dval) dmin = dval;
1356 return make_float (dmin);
1359 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1360 Return bitwise-and of all the arguments.
1361 Arguments may be integers, or markers or characters converted to integers.
1363 (int nargs, Lisp_Object *args))
1365 EMACS_INT bits = ~0;
1366 Lisp_Object *args_end = args + nargs;
1368 while (args < args_end)
1369 bits &= integer_char_or_marker_to_int (*args++);
1371 return make_int (bits);
1374 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1375 Return bitwise-or of all the arguments.
1376 Arguments may be integers, or markers or characters converted to integers.
1378 (int nargs, Lisp_Object *args))
1381 Lisp_Object *args_end = args + nargs;
1383 while (args < args_end)
1384 bits |= integer_char_or_marker_to_int (*args++);
1386 return make_int (bits);
1389 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1390 Return bitwise-exclusive-or of all the arguments.
1391 Arguments may be integers, or markers or characters converted to integers.
1393 (int nargs, Lisp_Object *args))
1396 Lisp_Object *args_end = args + nargs;
1398 while (args < args_end)
1399 bits ^= integer_char_or_marker_to_int (*args++);
1401 return make_int (bits);
1404 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1405 Return the bitwise complement of NUMBER.
1406 NUMBER may be an integer, marker or character converted to integer.
1410 return make_int (~ integer_char_or_marker_to_int (number));
1413 DEFUN ("%", Frem, 2, 2, 0, /*
1414 Return remainder of first arg divided by second.
1415 Both must be integers, characters or markers.
1419 int ival1 = integer_char_or_marker_to_int (num1);
1420 int ival2 = integer_char_or_marker_to_int (num2);
1423 Fsignal (Qarith_error, Qnil);
1425 return make_int (ival1 % ival2);
1428 /* Note, ANSI *requires* the presence of the fmod() library routine.
1429 If your system doesn't have it, complain to your vendor, because
1434 fmod (double f1, double f2)
1438 return f1 - f2 * floor (f1/f2);
1440 #endif /* ! HAVE_FMOD */
1443 DEFUN ("mod", Fmod, 2, 2, 0, /*
1445 The result falls between zero (inclusive) and Y (exclusive).
1446 Both X and Y must be numbers, characters or markers.
1447 If either argument is a float, a float will be returned.
1451 int_or_double iod1, iod2;
1452 number_char_or_marker_to_int_or_double (x, &iod1);
1453 number_char_or_marker_to_int_or_double (y, &iod2);
1455 #ifdef LISP_FLOAT_TYPE
1456 if (!iod1.int_p || !iod2.int_p)
1458 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
1459 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
1460 if (dval2 == 0) goto divide_by_zero;
1461 dval1 = fmod (dval1, dval2);
1463 /* If the "remainder" comes out with the wrong sign, fix it. */
1464 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
1467 return make_float (dval1);
1469 #endif /* LISP_FLOAT_TYPE */
1472 if (iod2.c.ival == 0) goto divide_by_zero;
1474 ival = iod1.c.ival % iod2.c.ival;
1476 /* If the "remainder" comes out with the wrong sign, fix it. */
1477 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
1478 ival += iod2.c.ival;
1480 return make_int (ival);
1484 Fsignal (Qarith_error, Qnil);
1485 return Qnil; /* not reached */
1488 DEFUN ("ash", Fash, 2, 2, 0, /*
1489 Return VALUE with its bits shifted left by COUNT.
1490 If COUNT is negative, shifting is actually to the right.
1491 In this case, the sign bit is duplicated.
1495 CHECK_INT_COERCE_CHAR (value);
1496 CONCHECK_INT (count);
1498 return make_int (XINT (count) > 0 ?
1499 XINT (value) << XINT (count) :
1500 XINT (value) >> -XINT (count));
1503 DEFUN ("lsh", Flsh, 2, 2, 0, /*
1504 Return VALUE with its bits shifted left by COUNT.
1505 If COUNT is negative, shifting is actually to the right.
1506 In this case, zeros are shifted in on the left.
1510 CHECK_INT_COERCE_CHAR (value);
1511 CONCHECK_INT (count);
1513 return make_int (XINT (count) > 0 ?
1514 XUINT (value) << XINT (count) :
1515 XUINT (value) >> -XINT (count));
1518 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1519 Return NUMBER plus one. NUMBER may be a number, character or marker.
1520 Markers and characters are converted to integers.
1526 if (INTP (number)) return make_int (XINT (number) + 1);
1527 if (CHARP (number)) return make_int (XCHAR (number) + 1);
1528 if (MARKERP (number)) return make_int (marker_position (number) + 1);
1529 #ifdef LISP_FLOAT_TYPE
1530 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1531 #endif /* LISP_FLOAT_TYPE */
1533 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1537 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1538 Return NUMBER minus one. NUMBER may be a number, character or marker.
1539 Markers and characters are converted to integers.
1545 if (INTP (number)) return make_int (XINT (number) - 1);
1546 if (CHARP (number)) return make_int (XCHAR (number) - 1);
1547 if (MARKERP (number)) return make_int (marker_position (number) - 1);
1548 #ifdef LISP_FLOAT_TYPE
1549 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1550 #endif /* LISP_FLOAT_TYPE */
1552 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1557 /************************************************************************/
1559 /************************************************************************/
1561 /* A weak list is like a normal list except that elements automatically
1562 disappear when no longer in use, i.e. when no longer GC-protected.
1563 The basic idea is that we don't mark the elements during GC, but
1564 wait for them to be marked elsewhere. If they're not marked, we
1565 remove them. This is analogous to weak hash tables; see the explanation
1566 there for more info. */
1568 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1570 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1573 mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
1575 return Qnil; /* nichts ist gemarkt */
1579 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1582 error ("printing unreadable object #<weak-list>");
1584 write_c_string ("#<weak-list ", printcharfun);
1585 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
1587 write_c_string (" ", printcharfun);
1588 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1589 write_c_string (">", printcharfun);
1593 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1595 struct weak_list *w1 = XWEAK_LIST (obj1);
1596 struct weak_list *w2 = XWEAK_LIST (obj2);
1598 return ((w1->type == w2->type) &&
1599 internal_equal (w1->list, w2->list, depth + 1));
1602 static unsigned long
1603 weak_list_hash (Lisp_Object obj, int depth)
1605 struct weak_list *w = XWEAK_LIST (obj);
1607 return HASH2 ((unsigned long) w->type,
1608 internal_hash (w->list, depth + 1));
1612 make_weak_list (enum weak_list_type type)
1615 struct weak_list *wl =
1616 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
1620 XSETWEAK_LIST (result, wl);
1621 wl->next_weak = Vall_weak_lists;
1622 Vall_weak_lists = result;
1626 static const struct lrecord_description weak_list_description[] = {
1627 { XD_LISP_OBJECT, offsetof(struct weak_list, list), 1 },
1628 { XD_LISP_OBJECT, offsetof(struct weak_list, next_weak), 1 },
1632 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1633 mark_weak_list, print_weak_list,
1634 0, weak_list_equal, weak_list_hash,
1635 weak_list_description,
1638 -- we do not mark the list elements (either the elements themselves
1639 or the cons cells that hold them) in the normal marking phase.
1640 -- at the end of marking, we go through all weak lists that are
1641 marked, and mark the cons cells that hold all marked
1642 objects, and possibly parts of the objects themselves.
1643 (See alloc.c, "after-mark".)
1644 -- after that, we prune away all the cons cells that are not marked.
1646 WARNING WARNING WARNING WARNING WARNING:
1648 The code in the following two functions is *unbelievably* tricky.
1649 Don't mess with it. You'll be sorry.
1651 Linked lists just majorly suck, d'ya know?
1655 finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object),
1656 void (*markobj) (Lisp_Object))
1661 for (rest = Vall_weak_lists;
1663 rest = XWEAK_LIST (rest)->next_weak)
1666 enum weak_list_type type = XWEAK_LIST (rest)->type;
1668 if (! obj_marked_p (rest))
1669 /* The weak list is probably garbage. Ignore it. */
1672 for (rest2 = XWEAK_LIST (rest)->list;
1673 /* We need to be trickier since we're inside of GC;
1674 use CONSP instead of !NILP in case of user-visible
1677 rest2 = XCDR (rest2))
1680 /* If the element is "marked" (meaning depends on the type
1681 of weak list), we need to mark the cons containing the
1682 element, and maybe the element itself (if only some part
1683 was already marked). */
1684 int need_to_mark_cons = 0;
1685 int need_to_mark_elem = 0;
1687 /* If a cons is already marked, then its car is already marked
1688 (either because of an external pointer or because of
1689 a previous call to this function), and likewise for all
1690 the rest of the elements in the list, so we can stop now. */
1691 if (obj_marked_p (rest2))
1694 elem = XCAR (rest2);
1698 case WEAK_LIST_SIMPLE:
1699 if (obj_marked_p (elem))
1700 need_to_mark_cons = 1;
1703 case WEAK_LIST_ASSOC:
1704 if (!GC_CONSP (elem))
1706 /* just leave bogus elements there */
1707 need_to_mark_cons = 1;
1708 need_to_mark_elem = 1;
1710 else if (obj_marked_p (XCAR (elem)) &&
1711 obj_marked_p (XCDR (elem)))
1713 need_to_mark_cons = 1;
1714 /* We still need to mark elem, because it's
1715 probably not marked. */
1716 need_to_mark_elem = 1;
1720 case WEAK_LIST_KEY_ASSOC:
1721 if (!GC_CONSP (elem))
1723 /* just leave bogus elements there */
1724 need_to_mark_cons = 1;
1725 need_to_mark_elem = 1;
1727 else if (obj_marked_p (XCAR (elem)))
1729 need_to_mark_cons = 1;
1730 /* We still need to mark elem and XCDR (elem);
1731 marking elem does both */
1732 need_to_mark_elem = 1;
1736 case WEAK_LIST_VALUE_ASSOC:
1737 if (!GC_CONSP (elem))
1739 /* just leave bogus elements there */
1740 need_to_mark_cons = 1;
1741 need_to_mark_elem = 1;
1743 else if (obj_marked_p (XCDR (elem)))
1745 need_to_mark_cons = 1;
1746 /* We still need to mark elem and XCAR (elem);
1747 marking elem does both */
1748 need_to_mark_elem = 1;
1756 if (need_to_mark_elem && ! obj_marked_p (elem))
1762 /* We also need to mark the cons that holds the elem or
1763 assoc-pair. We do *not* want to call (markobj) here
1764 because that will mark the entire list; we just want to
1765 mark the cons itself.
1767 if (need_to_mark_cons)
1769 struct Lisp_Cons *ptr = XCONS (rest2);
1770 if (!CONS_MARKED_P (ptr))
1778 /* In case of imperfect list, need to mark the final cons
1779 because we're not removing it */
1780 if (!GC_NILP (rest2) && ! obj_marked_p (rest2))
1791 prune_weak_lists (int (*obj_marked_p) (Lisp_Object))
1793 Lisp_Object rest, prev = Qnil;
1795 for (rest = Vall_weak_lists;
1797 rest = XWEAK_LIST (rest)->next_weak)
1799 if (! (obj_marked_p (rest)))
1801 /* This weak list itself is garbage. Remove it from the list. */
1803 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1805 XWEAK_LIST (prev)->next_weak =
1806 XWEAK_LIST (rest)->next_weak;
1810 Lisp_Object rest2, prev2 = Qnil;
1811 Lisp_Object tortoise;
1812 int go_tortoise = 0;
1814 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1815 /* We need to be trickier since we're inside of GC;
1816 use CONSP instead of !NILP in case of user-visible
1820 /* It suffices to check the cons for marking,
1821 regardless of the type of weak list:
1823 -- if the cons is pointed to somewhere else,
1824 then it should stay around and will be marked.
1825 -- otherwise, if it should stay around, it will
1826 have been marked in finish_marking_weak_lists().
1827 -- otherwise, it's not marked and should disappear.
1829 if (! obj_marked_p (rest2))
1832 if (GC_NILP (prev2))
1833 XWEAK_LIST (rest)->list = XCDR (rest2);
1835 XCDR (prev2) = XCDR (rest2);
1836 rest2 = XCDR (rest2);
1837 /* Ouch. Circularity checking is even trickier
1838 than I thought. When we cut out a link
1839 like this, we can't advance the turtle or
1840 it'll catch up to us. Imagine that we're
1841 standing on floor tiles and moving forward --
1842 what we just did here is as if the floor
1843 tile under us just disappeared and all the
1844 ones ahead of us slid one tile towards us.
1845 In other words, we didn't move at all;
1846 if the tortoise was one step behind us
1847 previously, it still is, and therefore
1848 it must not move. */
1854 /* Implementing circularity checking is trickier here
1855 than in other places because we have to guarantee
1856 that we've processed all elements before exiting
1857 due to a circularity. (In most places, an error
1858 is issued upon encountering a circularity, so it
1859 doesn't really matter if all elements are processed.)
1860 The idea is that we process along with the hare
1861 rather than the tortoise. If at any point in
1862 our forward process we encounter the tortoise,
1863 we must have already visited the spot, so we exit.
1864 (If we process with the tortoise, we can fail to
1865 process cases where a cons points to itself, or
1866 where cons A points to cons B, which points to
1869 rest2 = XCDR (rest2);
1871 tortoise = XCDR (tortoise);
1872 go_tortoise = !go_tortoise;
1873 if (GC_EQ (rest2, tortoise))
1883 static enum weak_list_type
1884 decode_weak_list_type (Lisp_Object symbol)
1886 CHECK_SYMBOL (symbol);
1887 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1888 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1889 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1890 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1891 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1893 signal_simple_error ("Invalid weak list type", symbol);
1894 return WEAK_LIST_SIMPLE; /* not reached */
1898 encode_weak_list_type (enum weak_list_type type)
1902 case WEAK_LIST_SIMPLE: return Qsimple;
1903 case WEAK_LIST_ASSOC: return Qassoc;
1904 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1905 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1910 return Qnil; /* not reached */
1913 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
1914 Return non-nil if OBJECT is a weak list.
1918 return WEAK_LISTP (object) ? Qt : Qnil;
1921 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
1922 Return a new weak list object of type TYPE.
1923 A weak list object is an object that contains a list. This list behaves
1924 like any other list except that its elements do not count towards
1925 garbage collection -- if the only pointer to an object in inside a weak
1926 list (other than pointers in similar objects such as weak hash tables),
1927 the object is garbage collected and automatically removed from the list.
1928 This is used internally, for example, to manage the list holding the
1929 children of an extent -- an extent that is unused but has a parent will
1930 still be reclaimed, and will automatically be removed from its parent's
1933 Optional argument TYPE specifies the type of the weak list, and defaults
1934 to `simple'. Recognized types are
1936 `simple' Objects in the list disappear if not pointed to.
1937 `assoc' Objects in the list disappear if they are conses
1938 and either the car or the cdr of the cons is not
1940 `key-assoc' Objects in the list disappear if they are conses
1941 and the car is not pointed to.
1942 `value-assoc' Objects in the list disappear if they are conses
1943 and the cdr is not pointed to.
1950 return make_weak_list (decode_weak_list_type (type));
1953 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
1954 Return the type of the given weak-list object.
1958 CHECK_WEAK_LIST (weak);
1959 return encode_weak_list_type (XWEAK_LIST (weak)->type);
1962 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
1963 Return the list contained in a weak-list object.
1967 CHECK_WEAK_LIST (weak);
1968 return XWEAK_LIST_LIST (weak);
1971 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
1972 Change the list contained in a weak-list object.
1976 CHECK_WEAK_LIST (weak);
1977 XWEAK_LIST_LIST (weak) = new_list;
1982 /************************************************************************/
1983 /* initialization */
1984 /************************************************************************/
1987 arith_error (int signo)
1989 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
1990 EMACS_UNBLOCK_SIGNAL (signo);
1991 signal_error (Qarith_error, Qnil);
1995 init_data_very_early (void)
1997 /* Don't do this if just dumping out.
1998 We don't want to call `signal' in this case
1999 so that we don't have trouble with dumping
2000 signal-delivering routines in an inconsistent state. */
2004 #endif /* CANNOT_DUMP */
2005 signal (SIGFPE, arith_error);
2007 signal (SIGEMT, arith_error);
2012 init_errors_once_early (void)
2014 defsymbol (&Qerror_conditions, "error-conditions");
2015 defsymbol (&Qerror_message, "error-message");
2017 /* We declare the errors here because some other deferrors depend
2018 on some of the errors below. */
2020 /* ERROR is used as a signaler for random errors for which nothing
2023 deferror (&Qerror, "error", "error", Qnil);
2024 deferror (&Qquit, "quit", "Quit", Qnil);
2026 deferror (&Qwrong_type_argument, "wrong-type-argument",
2027 "Wrong type argument", Qerror);
2028 deferror (&Qargs_out_of_range, "args-out-of-range", "Args out of range",
2030 deferror (&Qvoid_function, "void-function",
2031 "Symbol's function definition is void", Qerror);
2032 deferror (&Qcyclic_function_indirection, "cyclic-function-indirection",
2033 "Symbol's chain of function indirections contains a loop", Qerror);
2034 deferror (&Qvoid_variable, "void-variable",
2035 "Symbol's value as variable is void", Qerror);
2036 deferror (&Qcyclic_variable_indirection, "cyclic-variable-indirection",
2037 "Symbol's chain of variable indirections contains a loop", Qerror);
2038 deferror (&Qsetting_constant, "setting-constant",
2039 "Attempt to set a constant symbol", Qerror);
2040 deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
2041 "Invalid read syntax", Qerror);
2043 /* Generated by list traversal macros */
2044 deferror (&Qmalformed_list, "malformed-list",
2045 "Malformed list", Qerror);
2046 deferror (&Qmalformed_property_list, "malformed-property-list",
2047 "Malformed property list", Qmalformed_list);
2048 deferror (&Qcircular_list, "circular-list",
2049 "Circular list", Qerror);
2050 deferror (&Qcircular_property_list, "circular-property-list",
2051 "Circular property list", Qcircular_list);
2053 deferror (&Qinvalid_function, "invalid-function", "Invalid function",
2055 deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
2056 "Wrong number of arguments", Qerror);
2057 deferror (&Qno_catch, "no-catch", "No catch for tag",
2059 deferror (&Qbeginning_of_buffer, "beginning-of-buffer",
2060 "Beginning of buffer", Qerror);
2061 deferror (&Qend_of_buffer, "end-of-buffer", "End of buffer", Qerror);
2062 deferror (&Qbuffer_read_only, "buffer-read-only", "Buffer is read-only",
2065 deferror (&Qio_error, "io-error", "IO Error", Qerror);
2066 deferror (&Qend_of_file, "end-of-file", "End of stream", Qio_error);
2068 deferror (&Qarith_error, "arith-error", "Arithmetic error", Qerror);
2069 deferror (&Qrange_error, "range-error", "Arithmetic range error",
2071 deferror (&Qdomain_error, "domain-error", "Arithmetic domain error",
2073 deferror (&Qsingularity_error, "singularity-error",
2074 "Arithmetic singularity error", Qdomain_error);
2075 deferror (&Qoverflow_error, "overflow-error",
2076 "Arithmetic overflow error", Qdomain_error);
2077 deferror (&Qunderflow_error, "underflow-error",
2078 "Arithmetic underflow error", Qdomain_error);
2084 defsymbol (&Qcons, "cons");
2085 defsymbol (&Qkeyword, "keyword");
2086 defsymbol (&Qquote, "quote");
2087 defsymbol (&Qlambda, "lambda");
2088 defsymbol (&Qignore, "ignore");
2089 defsymbol (&Qlistp, "listp");
2090 defsymbol (&Qtrue_list_p, "true-list-p");
2091 defsymbol (&Qconsp, "consp");
2092 defsymbol (&Qsubrp, "subrp");
2093 defsymbol (&Qsymbolp, "symbolp");
2094 defsymbol (&Qkeywordp, "keywordp");
2095 defsymbol (&Qintegerp, "integerp");
2096 defsymbol (&Qcharacterp, "characterp");
2097 defsymbol (&Qnatnump, "natnump");
2098 defsymbol (&Qstringp, "stringp");
2099 defsymbol (&Qarrayp, "arrayp");
2100 defsymbol (&Qsequencep, "sequencep");
2101 defsymbol (&Qbufferp, "bufferp");
2102 defsymbol (&Qbitp, "bitp");
2103 defsymbol (&Qbit_vectorp, "bit-vector-p");
2104 defsymbol (&Qvectorp, "vectorp");
2105 defsymbol (&Qchar_or_string_p, "char-or-string-p");
2106 defsymbol (&Qmarkerp, "markerp");
2107 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
2108 defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
2109 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
2110 defsymbol (&Qnumberp, "numberp");
2111 defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
2112 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p");
2113 defsymbol (&Qcdr, "cdr");
2114 defsymbol (&Qweak_listp, "weak-list-p");
2116 #ifdef LISP_FLOAT_TYPE
2117 defsymbol (&Qfloatp, "floatp");
2118 #endif /* LISP_FLOAT_TYPE */
2120 DEFSUBR (Fwrong_type_argument);
2125 Ffset (intern ("not"), intern ("null"));
2128 DEFSUBR (Ftrue_list_p);
2131 DEFSUBR (Fchar_or_string_p);
2132 DEFSUBR (Fcharacterp);
2133 DEFSUBR (Fchar_int_p);
2134 DEFSUBR (Fchar_to_int);
2135 DEFSUBR (Fint_to_char);
2136 DEFSUBR (Fchar_or_char_int_p);
2137 DEFSUBR (Fintegerp);
2138 DEFSUBR (Finteger_or_marker_p);
2139 DEFSUBR (Finteger_or_char_p);
2140 DEFSUBR (Finteger_char_or_marker_p);
2142 DEFSUBR (Fnumber_or_marker_p);
2143 DEFSUBR (Fnumber_char_or_marker_p);
2144 #ifdef LISP_FLOAT_TYPE
2146 #endif /* LISP_FLOAT_TYPE */
2149 DEFSUBR (Fkeywordp);
2153 DEFSUBR (Fbit_vector_p);
2155 DEFSUBR (Fsequencep);
2158 DEFSUBR (Fsubr_min_args);
2159 DEFSUBR (Fsubr_max_args);
2160 DEFSUBR (Fsubr_interactive);
2164 DEFSUBR (Fcar_safe);
2165 DEFSUBR (Fcdr_safe);
2168 DEFSUBR (Findirect_function);
2172 DEFSUBR (Fnumber_to_string);
2173 DEFSUBR (Fstring_to_number);
2198 DEFSUBR (Fweak_list_p);
2199 DEFSUBR (Fmake_weak_list);
2200 DEFSUBR (Fweak_list_type);
2201 DEFSUBR (Fweak_list_list);
2202 DEFSUBR (Fset_weak_list_list);
2208 /* This must not be staticpro'd */
2209 Vall_weak_lists = Qnil;
2212 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2213 If non-zero, note when your code may be suffering from char-int confoundance.
2214 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2215 etc. where an int and a char with the same value are being compared,
2216 it will issue a notice on stderr to this effect, along with a backtrace.
2217 In such situations, the result would be different in XEmacs 19 versus
2218 XEmacs 20, and you probably don't want this.
2220 Note that in order to see these notices, you have to byte compile your
2221 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2222 have its chars and ints all confounded in the byte code, making it
2223 impossible to accurately determine Ebola infection.
2226 debug_issue_ebola_notices = 0;
2228 DEFVAR_INT ("debug-ebola-backtrace-length",
2229 &debug_ebola_backtrace_length /*
2230 Length (in stack frames) of short backtrace printed out in Ebola notices.
2231 See `debug-issue-ebola-notices'.
2233 debug_ebola_backtrace_length = 32;
2235 #endif /* DEBUG_XEMACS */