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. */
33 #include "syssignal.h"
35 #ifdef LISP_FLOAT_TYPE
36 /* Need to define a differentiating symbol -- see sysfloat.h */
37 # define THIS_FILENAME data_c
38 # include "sysfloat.h"
39 #endif /* LISP_FLOAT_TYPE */
41 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
42 Lisp_Object Qerror_conditions, Qerror_message;
43 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
44 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
45 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
46 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
47 Lisp_Object Qmalformed_list, Qmalformed_property_list;
48 Lisp_Object Qcircular_list, Qcircular_property_list;
49 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
50 Lisp_Object Qio_error, Qend_of_file;
51 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
52 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
53 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
54 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp;
55 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
56 Lisp_Object Qconsp, Qsubrp;
57 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
58 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
59 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
60 Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p;
61 Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore;
67 int debug_issue_ebola_notices;
69 int debug_ebola_backtrace_length;
72 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
74 if (debug_issue_ebola_notices
75 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
77 /* #### It would be really nice if this were a proper warning
78 instead of brain-dead print ro Qexternal_debugging_output. */
79 write_c_string ("Comparison between integer and character is constant nil (",
80 Qexternal_debugging_output);
81 Fprinc (obj1, Qexternal_debugging_output);
82 write_c_string (" and ", Qexternal_debugging_output);
83 Fprinc (obj2, Qexternal_debugging_output);
84 write_c_string (")\n", Qexternal_debugging_output);
85 debug_short_backtrace (debug_ebola_backtrace_length);
87 return EQ (obj1, obj2);
90 #endif /* DEBUG_XEMACS */
95 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
97 /* This function can GC */
98 REGISTER Lisp_Object tem;
101 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
102 tem = call1 (predicate, value);
109 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
111 signal_error (Qwrong_type_argument, list2 (predicate, value));
114 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
115 Signal an error until the correct type value is given by the user.
116 This function loops, signalling a continuable `wrong-type-argument' error
117 with PREDICATE and VALUE as the data associated with the error and then
118 calling PREDICATE on the returned value, until the value gotten satisfies
119 PREDICATE. At that point, the gotten value is returned.
123 return wrong_type_argument (predicate, value);
127 c_write_error (Lisp_Object obj)
129 signal_simple_error ("Attempt to modify read-only object (c)", obj);
133 lisp_write_error (Lisp_Object obj)
135 signal_simple_error ("Attempt to modify read-only object (lisp)", 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))
549 case Lisp_Type_Record:
550 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
552 case Lisp_Type_Char: return Qcharacter;
554 default: return Qinteger;
559 /* Extract and set components of lists */
561 DEFUN ("car", Fcar, 1, 1, 0, /*
562 Return the car of LIST. If arg is nil, return nil.
563 Error if arg is not nil and not a cons cell. See also `car-safe'.
571 else if (NILP (list))
574 list = wrong_type_argument (Qlistp, list);
578 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
579 Return the car of OBJECT if it is a cons cell, or else nil.
583 return CONSP (object) ? XCAR (object) : Qnil;
586 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
587 Return the cdr of LIST. If arg is nil, return nil.
588 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
596 else if (NILP (list))
599 list = wrong_type_argument (Qlistp, list);
603 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
604 Return the cdr of OBJECT if it is a cons cell, else nil.
608 return CONSP (object) ? XCDR (object) : Qnil;
611 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
612 Set the car of CONSCELL to be NEWCAR. Return NEWCAR.
616 if (!CONSP (conscell))
617 conscell = wrong_type_argument (Qconsp, conscell);
619 CHECK_LISP_WRITEABLE (conscell);
620 XCAR (conscell) = newcar;
624 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
625 Set the cdr of CONSCELL to be NEWCDR. Return NEWCDR.
629 if (!CONSP (conscell))
630 conscell = wrong_type_argument (Qconsp, conscell);
632 CHECK_LISP_WRITEABLE (conscell);
633 XCDR (conscell) = newcdr;
637 /* Find the function at the end of a chain of symbol function indirections.
639 If OBJECT is a symbol, find the end of its function chain and
640 return the value found there. If OBJECT is not a symbol, just
641 return it. If there is a cycle in the function chain, signal a
642 cyclic-function-indirection error.
644 This is like Findirect_function, except that it doesn't signal an
645 error if the chain ends up unbound. */
647 indirect_function (Lisp_Object object, int errorp)
649 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
650 Lisp_Object tortoise, hare;
653 for (hare = tortoise = object, count = 0;
655 hare = XSYMBOL (hare)->function, count++)
657 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
660 tortoise = XSYMBOL (tortoise)->function;
661 if (EQ (hare, tortoise))
662 return Fsignal (Qcyclic_function_indirection, list1 (object));
665 if (errorp && UNBOUNDP (hare))
666 signal_void_function_error (object);
671 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
672 Return the function at the end of OBJECT's function chain.
673 If OBJECT is a symbol, follow all function indirections and return
674 the final function binding.
675 If OBJECT is not a symbol, just return it.
676 Signal a void-function error if the final symbol is unbound.
677 Signal a cyclic-function-indirection error if there is a loop in the
678 function chain of symbols.
682 return indirect_function (object, 1);
685 /* Extract and set vector and string elements */
687 DEFUN ("aref", Faref, 2, 2, 0, /*
688 Return the element of ARRAY at index INDEX.
689 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
697 if (INTP (index_)) idx = XINT (index_);
698 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
701 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
705 if (idx < 0) goto range_error;
709 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
710 return XVECTOR_DATA (array)[idx];
712 else if (BIT_VECTORP (array))
714 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
715 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
717 else if (STRINGP (array))
719 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
720 return make_char (string_char (XSTRING (array), idx));
722 #ifdef LOSING_BYTECODE
723 else if (COMPILED_FUNCTIONP (array))
725 /* Weird, gross compatibility kludge */
726 return Felt (array, index_);
731 check_losing_bytecode ("aref", array);
732 array = wrong_type_argument (Qarrayp, array);
737 args_out_of_range (array, index_);
738 return Qnil; /* not reached */
741 DEFUN ("aset", Faset, 3, 3, 0, /*
742 Store into the element of ARRAY at index INDEX the value NEWVAL.
743 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
745 (array, index_, newval))
751 if (INTP (index_)) idx = XINT (index_);
752 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
755 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
759 if (idx < 0) goto range_error;
761 CHECK_LISP_WRITEABLE (array);
765 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
766 XVECTOR_DATA (array)[idx] = newval;
768 else if (BIT_VECTORP (array))
770 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
772 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
774 else if (STRINGP (array))
776 CHECK_CHAR_COERCE_INT (newval);
777 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
778 set_string_char (XSTRING (array), idx, XCHAR (newval));
779 bump_string_modiff (array);
783 array = wrong_type_argument (Qarrayp, array);
790 args_out_of_range (array, index_);
791 return Qnil; /* not reached */
795 /**********************************************************************/
796 /* Arithmetic functions */
797 /**********************************************************************/
809 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
813 if (INTP (obj)) p->c.ival = XINT (obj);
814 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
815 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
816 #ifdef LISP_FLOAT_TYPE
817 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
821 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
827 number_char_or_marker_to_double (Lisp_Object obj)
830 if (INTP (obj)) return (double) XINT (obj);
831 else if (CHARP (obj)) return (double) XCHAR (obj);
832 else if (MARKERP (obj)) return (double) marker_position (obj);
833 #ifdef LISP_FLOAT_TYPE
834 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
838 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
844 integer_char_or_marker_to_int (Lisp_Object obj)
847 if (INTP (obj)) return XINT (obj);
848 else if (CHARP (obj)) return XCHAR (obj);
849 else if (MARKERP (obj)) return marker_position (obj);
852 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
857 #define ARITHCOMPARE_MANY(op) \
859 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
860 Lisp_Object *args_end = args + nargs; \
862 number_char_or_marker_to_int_or_double (*args++, p); \
864 while (args < args_end) \
866 number_char_or_marker_to_int_or_double (*args++, q); \
868 if (!((p->int_p && q->int_p) ? \
869 (p->c.ival op q->c.ival) : \
870 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
871 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
874 { /* swap */ int_or_double *r = p; p = q; q = r; } \
879 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
880 Return t if all the arguments are numerically equal.
881 The arguments may be numbers, characters or markers.
883 (int nargs, Lisp_Object *args))
885 ARITHCOMPARE_MANY (==)
888 DEFUN ("<", Flss, 1, MANY, 0, /*
889 Return t if the sequence of arguments is monotonically increasing.
890 The arguments may be numbers, characters or markers.
892 (int nargs, Lisp_Object *args))
894 ARITHCOMPARE_MANY (<)
897 DEFUN (">", Fgtr, 1, MANY, 0, /*
898 Return t if the sequence of arguments is monotonically decreasing.
899 The arguments may be numbers, characters or markers.
901 (int nargs, Lisp_Object *args))
903 ARITHCOMPARE_MANY (>)
906 DEFUN ("<=", Fleq, 1, MANY, 0, /*
907 Return t if the sequence of arguments is monotonically nondecreasing.
908 The arguments may be numbers, characters or markers.
910 (int nargs, Lisp_Object *args))
912 ARITHCOMPARE_MANY (<=)
915 DEFUN (">=", Fgeq, 1, MANY, 0, /*
916 Return t if the sequence of arguments is monotonically nonincreasing.
917 The arguments may be numbers, characters or markers.
919 (int nargs, Lisp_Object *args))
921 ARITHCOMPARE_MANY (>=)
924 DEFUN ("/=", Fneq, 1, MANY, 0, /*
925 Return t if no two arguments are numerically equal.
926 The arguments may be numbers, characters or markers.
928 (int nargs, Lisp_Object *args))
930 Lisp_Object *args_end = args + nargs;
933 /* Unlike all the other comparisons, this is an N*N algorithm.
934 We could use a hash table for nargs > 50 to make this linear. */
935 for (p = args; p < args_end; p++)
937 int_or_double iod1, iod2;
938 number_char_or_marker_to_int_or_double (*p, &iod1);
940 for (q = p + 1; q < args_end; q++)
942 number_char_or_marker_to_int_or_double (*q, &iod2);
944 if (!((iod1.int_p && iod2.int_p) ?
945 (iod1.c.ival != iod2.c.ival) :
946 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
947 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
954 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
955 Return t if NUMBER is zero.
961 return EQ (number, Qzero) ? Qt : Qnil;
962 #ifdef LISP_FLOAT_TYPE
963 else if (FLOATP (number))
964 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
965 #endif /* LISP_FLOAT_TYPE */
968 number = wrong_type_argument (Qnumberp, number);
973 /* Convert between a 32-bit value and a cons of two 16-bit values.
974 This is used to pass 32-bit integers to and from the user.
975 Use time_to_lisp() and lisp_to_time() for time values.
977 If you're thinking of using this to store a pointer into a Lisp Object
978 for internal purposes (such as when calling record_unwind_protect()),
979 try using make_opaque_ptr()/get_opaque_ptr() instead. */
981 word_to_lisp (unsigned int item)
983 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
987 lisp_to_word (Lisp_Object item)
993 Lisp_Object top = Fcar (item);
994 Lisp_Object bot = Fcdr (item);
997 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
1002 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
1003 Convert NUM to a string by printing it in decimal.
1004 Uses a minus sign if negative.
1005 NUM may be an integer or a floating point number.
1009 char buffer[VALBITS];
1011 CHECK_INT_OR_FLOAT (num);
1013 #ifdef LISP_FLOAT_TYPE
1016 char pigbuf[350]; /* see comments in float_to_string */
1018 float_to_string (pigbuf, XFLOAT_DATA (num));
1019 return build_string (pigbuf);
1021 #endif /* LISP_FLOAT_TYPE */
1023 long_to_string (buffer, XINT (num));
1024 return build_string (buffer);
1028 digit_to_number (int character, int base)
1031 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1032 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
1033 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
1036 return digit >= base ? -1 : digit;
1039 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
1040 Convert STRING to a number by parsing it as a decimal number.
1041 This parses both integers and floating point numbers.
1042 It ignores leading spaces and tabs.
1044 If BASE, interpret STRING as a number in that base. If BASE isn't
1045 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
1046 Floating point numbers always use base 10.
1053 CHECK_STRING (string);
1061 check_int_range (b, 2, 16);
1064 p = (char *) XSTRING_DATA (string);
1066 /* Skip any whitespace at the front of the number. Some versions of
1067 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1068 while (*p == ' ' || *p == '\t')
1071 #ifdef LISP_FLOAT_TYPE
1072 if (isfloat_string (p))
1073 return make_float (atof (p));
1074 #endif /* LISP_FLOAT_TYPE */
1078 /* Use the system-provided functions for base 10. */
1079 #if SIZEOF_EMACS_INT == SIZEOF_INT
1080 return make_int (atoi (p));
1081 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1082 return make_int (atol (p));
1083 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1084 return make_int (atoll (p));
1089 int digit, negative = 1;
1101 digit = digit_to_number (*p++, b);
1106 return make_int (negative * v);
1111 DEFUN ("+", Fplus, 0, MANY, 0, /*
1112 Return sum of any number of arguments.
1113 The arguments should all be numbers, characters or markers.
1115 (int nargs, Lisp_Object *args))
1117 EMACS_INT iaccum = 0;
1118 Lisp_Object *args_end = args + nargs;
1120 while (args < args_end)
1123 number_char_or_marker_to_int_or_double (*args++, &iod);
1125 iaccum += iod.c.ival;
1128 double daccum = (double) iaccum + iod.c.dval;
1129 while (args < args_end)
1130 daccum += number_char_or_marker_to_double (*args++);
1131 return make_float (daccum);
1135 return make_int (iaccum);
1138 DEFUN ("-", Fminus, 1, MANY, 0, /*
1139 Negate number or subtract numbers, characters or markers.
1140 With one arg, negates it. With more than one arg,
1141 subtracts all but the first from the first.
1143 (int nargs, Lisp_Object *args))
1147 Lisp_Object *args_end = args + nargs;
1150 number_char_or_marker_to_int_or_double (*args++, &iod);
1152 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
1155 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
1159 while (args < args_end)
1161 number_char_or_marker_to_int_or_double (*args++, &iod);
1163 iaccum -= iod.c.ival;
1166 daccum = (double) iaccum - iod.c.dval;
1171 return make_int (iaccum);
1174 for (; args < args_end; args++)
1175 daccum -= number_char_or_marker_to_double (*args);
1176 return make_float (daccum);
1179 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1180 Return product of any number of arguments.
1181 The arguments should all be numbers, characters or markers.
1183 (int nargs, Lisp_Object *args))
1185 EMACS_INT iaccum = 1;
1186 Lisp_Object *args_end = args + nargs;
1188 while (args < args_end)
1191 number_char_or_marker_to_int_or_double (*args++, &iod);
1193 iaccum *= iod.c.ival;
1196 double daccum = (double) iaccum * iod.c.dval;
1197 while (args < args_end)
1198 daccum *= number_char_or_marker_to_double (*args++);
1199 return make_float (daccum);
1203 return make_int (iaccum);
1206 DEFUN ("/", Fquo, 1, MANY, 0, /*
1207 Return first argument divided by all the remaining arguments.
1208 The arguments must be numbers, characters or markers.
1209 With one argument, reciprocates the argument.
1211 (int nargs, Lisp_Object *args))
1215 Lisp_Object *args_end = args + nargs;
1222 number_char_or_marker_to_int_or_double (*args++, &iod);
1224 iaccum = iod.c.ival;
1227 daccum = iod.c.dval;
1232 while (args < args_end)
1234 number_char_or_marker_to_int_or_double (*args++, &iod);
1237 if (iod.c.ival == 0) goto divide_by_zero;
1238 iaccum /= iod.c.ival;
1242 if (iod.c.dval == 0) goto divide_by_zero;
1243 daccum = (double) iaccum / iod.c.dval;
1248 return make_int (iaccum);
1251 for (; args < args_end; args++)
1253 double dval = number_char_or_marker_to_double (*args);
1254 if (dval == 0) goto divide_by_zero;
1257 return make_float (daccum);
1260 Fsignal (Qarith_error, Qnil);
1261 return Qnil; /* not reached */
1264 DEFUN ("max", Fmax, 1, MANY, 0, /*
1265 Return largest of all the arguments.
1266 All arguments must be numbers, characters or markers.
1267 The value is always a number; markers and characters are converted
1270 (int nargs, Lisp_Object *args))
1274 Lisp_Object *args_end = args + nargs;
1277 number_char_or_marker_to_int_or_double (*args++, &iod);
1286 while (args < args_end)
1288 number_char_or_marker_to_int_or_double (*args++, &iod);
1291 if (imax < iod.c.ival) imax = iod.c.ival;
1295 dmax = (double) imax;
1296 if (dmax < iod.c.dval) dmax = iod.c.dval;
1301 return make_int (imax);
1304 while (args < args_end)
1306 double dval = number_char_or_marker_to_double (*args++);
1307 if (dmax < dval) dmax = dval;
1309 return make_float (dmax);
1312 DEFUN ("min", Fmin, 1, MANY, 0, /*
1313 Return smallest of all the arguments.
1314 All arguments must be numbers, characters or markers.
1315 The value is always a number; markers and characters are converted
1318 (int nargs, Lisp_Object *args))
1322 Lisp_Object *args_end = args + nargs;
1325 number_char_or_marker_to_int_or_double (*args++, &iod);
1334 while (args < args_end)
1336 number_char_or_marker_to_int_or_double (*args++, &iod);
1339 if (imin > iod.c.ival) imin = iod.c.ival;
1343 dmin = (double) imin;
1344 if (dmin > iod.c.dval) dmin = iod.c.dval;
1349 return make_int (imin);
1352 while (args < args_end)
1354 double dval = number_char_or_marker_to_double (*args++);
1355 if (dmin > dval) dmin = dval;
1357 return make_float (dmin);
1360 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1361 Return bitwise-and of all the arguments.
1362 Arguments may be integers, or markers or characters converted to integers.
1364 (int nargs, Lisp_Object *args))
1366 EMACS_INT bits = ~0;
1367 Lisp_Object *args_end = args + nargs;
1369 while (args < args_end)
1370 bits &= integer_char_or_marker_to_int (*args++);
1372 return make_int (bits);
1375 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1376 Return bitwise-or of all the arguments.
1377 Arguments may be integers, or markers or characters converted to integers.
1379 (int nargs, Lisp_Object *args))
1382 Lisp_Object *args_end = args + nargs;
1384 while (args < args_end)
1385 bits |= integer_char_or_marker_to_int (*args++);
1387 return make_int (bits);
1390 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1391 Return bitwise-exclusive-or of all the arguments.
1392 Arguments may be integers, or markers or characters converted to integers.
1394 (int nargs, Lisp_Object *args))
1397 Lisp_Object *args_end = args + nargs;
1399 while (args < args_end)
1400 bits ^= integer_char_or_marker_to_int (*args++);
1402 return make_int (bits);
1405 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1406 Return the bitwise complement of NUMBER.
1407 NUMBER may be an integer, marker or character converted to integer.
1411 return make_int (~ integer_char_or_marker_to_int (number));
1414 DEFUN ("%", Frem, 2, 2, 0, /*
1415 Return remainder of first arg divided by second.
1416 Both must be integers, characters or markers.
1420 int ival1 = integer_char_or_marker_to_int (num1);
1421 int ival2 = integer_char_or_marker_to_int (num2);
1424 Fsignal (Qarith_error, Qnil);
1426 return make_int (ival1 % ival2);
1429 /* Note, ANSI *requires* the presence of the fmod() library routine.
1430 If your system doesn't have it, complain to your vendor, because
1435 fmod (double f1, double f2)
1439 return f1 - f2 * floor (f1/f2);
1441 #endif /* ! HAVE_FMOD */
1444 DEFUN ("mod", Fmod, 2, 2, 0, /*
1446 The result falls between zero (inclusive) and Y (exclusive).
1447 Both X and Y must be numbers, characters or markers.
1448 If either argument is a float, a float will be returned.
1452 int_or_double iod1, iod2;
1453 number_char_or_marker_to_int_or_double (x, &iod1);
1454 number_char_or_marker_to_int_or_double (y, &iod2);
1456 #ifdef LISP_FLOAT_TYPE
1457 if (!iod1.int_p || !iod2.int_p)
1459 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
1460 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
1461 if (dval2 == 0) goto divide_by_zero;
1462 dval1 = fmod (dval1, dval2);
1464 /* If the "remainder" comes out with the wrong sign, fix it. */
1465 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
1468 return make_float (dval1);
1470 #endif /* LISP_FLOAT_TYPE */
1473 if (iod2.c.ival == 0) goto divide_by_zero;
1475 ival = iod1.c.ival % iod2.c.ival;
1477 /* If the "remainder" comes out with the wrong sign, fix it. */
1478 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
1479 ival += iod2.c.ival;
1481 return make_int (ival);
1485 Fsignal (Qarith_error, Qnil);
1486 return Qnil; /* not reached */
1489 DEFUN ("ash", Fash, 2, 2, 0, /*
1490 Return VALUE with its bits shifted left by COUNT.
1491 If COUNT is negative, shifting is actually to the right.
1492 In this case, the sign bit is duplicated.
1496 CHECK_INT_COERCE_CHAR (value);
1497 CONCHECK_INT (count);
1499 return make_int (XINT (count) > 0 ?
1500 XINT (value) << XINT (count) :
1501 XINT (value) >> -XINT (count));
1504 DEFUN ("lsh", Flsh, 2, 2, 0, /*
1505 Return VALUE with its bits shifted left by COUNT.
1506 If COUNT is negative, shifting is actually to the right.
1507 In this case, zeros are shifted in on the left.
1511 CHECK_INT_COERCE_CHAR (value);
1512 CONCHECK_INT (count);
1514 return make_int (XINT (count) > 0 ?
1515 XUINT (value) << XINT (count) :
1516 XUINT (value) >> -XINT (count));
1519 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1520 Return NUMBER plus one. NUMBER may be a number, character or marker.
1521 Markers and characters are converted to integers.
1527 if (INTP (number)) return make_int (XINT (number) + 1);
1528 if (CHARP (number)) return make_int (XCHAR (number) + 1);
1529 if (MARKERP (number)) return make_int (marker_position (number) + 1);
1530 #ifdef LISP_FLOAT_TYPE
1531 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1532 #endif /* LISP_FLOAT_TYPE */
1534 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1538 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1539 Return NUMBER minus one. NUMBER may be a number, character or marker.
1540 Markers and characters are converted to integers.
1546 if (INTP (number)) return make_int (XINT (number) - 1);
1547 if (CHARP (number)) return make_int (XCHAR (number) - 1);
1548 if (MARKERP (number)) return make_int (marker_position (number) - 1);
1549 #ifdef LISP_FLOAT_TYPE
1550 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1551 #endif /* LISP_FLOAT_TYPE */
1553 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1558 /************************************************************************/
1560 /************************************************************************/
1562 /* A weak list is like a normal list except that elements automatically
1563 disappear when no longer in use, i.e. when no longer GC-protected.
1564 The basic idea is that we don't mark the elements during GC, but
1565 wait for them to be marked elsewhere. If they're not marked, we
1566 remove them. This is analogous to weak hash tables; see the explanation
1567 there for more info. */
1569 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1571 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1574 mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
1576 return Qnil; /* nichts ist gemarkt */
1580 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1583 error ("printing unreadable object #<weak-list>");
1585 write_c_string ("#<weak-list ", printcharfun);
1586 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
1588 write_c_string (" ", printcharfun);
1589 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1590 write_c_string (">", printcharfun);
1594 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1596 struct weak_list *w1 = XWEAK_LIST (obj1);
1597 struct weak_list *w2 = XWEAK_LIST (obj2);
1599 return ((w1->type == w2->type) &&
1600 internal_equal (w1->list, w2->list, depth + 1));
1603 static unsigned long
1604 weak_list_hash (Lisp_Object obj, int depth)
1606 struct weak_list *w = XWEAK_LIST (obj);
1608 return HASH2 ((unsigned long) w->type,
1609 internal_hash (w->list, depth + 1));
1613 make_weak_list (enum weak_list_type type)
1616 struct weak_list *wl =
1617 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
1621 XSETWEAK_LIST (result, wl);
1622 wl->next_weak = Vall_weak_lists;
1623 Vall_weak_lists = result;
1627 static const struct lrecord_description weak_list_description[] = {
1628 { XD_LISP_OBJECT, offsetof(struct weak_list, list), 1 },
1629 { XD_LISP_OBJECT, offsetof(struct weak_list, next_weak), 1 },
1633 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1634 mark_weak_list, print_weak_list,
1635 0, weak_list_equal, weak_list_hash,
1636 weak_list_description,
1639 -- we do not mark the list elements (either the elements themselves
1640 or the cons cells that hold them) in the normal marking phase.
1641 -- at the end of marking, we go through all weak lists that are
1642 marked, and mark the cons cells that hold all marked
1643 objects, and possibly parts of the objects themselves.
1644 (See alloc.c, "after-mark".)
1645 -- after that, we prune away all the cons cells that are not marked.
1647 WARNING WARNING WARNING WARNING WARNING:
1649 The code in the following two functions is *unbelievably* tricky.
1650 Don't mess with it. You'll be sorry.
1652 Linked lists just majorly suck, d'ya know?
1656 finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object),
1657 void (*markobj) (Lisp_Object))
1662 for (rest = Vall_weak_lists;
1664 rest = XWEAK_LIST (rest)->next_weak)
1667 enum weak_list_type type = XWEAK_LIST (rest)->type;
1669 if (! obj_marked_p (rest))
1670 /* The weak list is probably garbage. Ignore it. */
1673 for (rest2 = XWEAK_LIST (rest)->list;
1674 /* We need to be trickier since we're inside of GC;
1675 use CONSP instead of !NILP in case of user-visible
1678 rest2 = XCDR (rest2))
1681 /* If the element is "marked" (meaning depends on the type
1682 of weak list), we need to mark the cons containing the
1683 element, and maybe the element itself (if only some part
1684 was already marked). */
1685 int need_to_mark_cons = 0;
1686 int need_to_mark_elem = 0;
1688 /* If a cons is already marked, then its car is already marked
1689 (either because of an external pointer or because of
1690 a previous call to this function), and likewise for all
1691 the rest of the elements in the list, so we can stop now. */
1692 if (obj_marked_p (rest2))
1695 elem = XCAR (rest2);
1699 case WEAK_LIST_SIMPLE:
1700 if (obj_marked_p (elem))
1701 need_to_mark_cons = 1;
1704 case WEAK_LIST_ASSOC:
1705 if (!GC_CONSP (elem))
1707 /* just leave bogus elements there */
1708 need_to_mark_cons = 1;
1709 need_to_mark_elem = 1;
1711 else if (obj_marked_p (XCAR (elem)) &&
1712 obj_marked_p (XCDR (elem)))
1714 need_to_mark_cons = 1;
1715 /* We still need to mark elem, because it's
1716 probably not marked. */
1717 need_to_mark_elem = 1;
1721 case WEAK_LIST_KEY_ASSOC:
1722 if (!GC_CONSP (elem))
1724 /* just leave bogus elements there */
1725 need_to_mark_cons = 1;
1726 need_to_mark_elem = 1;
1728 else if (obj_marked_p (XCAR (elem)))
1730 need_to_mark_cons = 1;
1731 /* We still need to mark elem and XCDR (elem);
1732 marking elem does both */
1733 need_to_mark_elem = 1;
1737 case WEAK_LIST_VALUE_ASSOC:
1738 if (!GC_CONSP (elem))
1740 /* just leave bogus elements there */
1741 need_to_mark_cons = 1;
1742 need_to_mark_elem = 1;
1744 else if (obj_marked_p (XCDR (elem)))
1746 need_to_mark_cons = 1;
1747 /* We still need to mark elem and XCAR (elem);
1748 marking elem does both */
1749 need_to_mark_elem = 1;
1757 if (need_to_mark_elem && ! obj_marked_p (elem))
1763 /* We also need to mark the cons that holds the elem or
1764 assoc-pair. We do *not* want to call (markobj) here
1765 because that will mark the entire list; we just want to
1766 mark the cons itself.
1768 if (need_to_mark_cons)
1770 struct Lisp_Cons *ptr = XCONS (rest2);
1771 if (!CONS_MARKED_P (ptr))
1779 /* In case of imperfect list, need to mark the final cons
1780 because we're not removing it */
1781 if (!GC_NILP (rest2) && ! obj_marked_p (rest2))
1792 prune_weak_lists (int (*obj_marked_p) (Lisp_Object))
1794 Lisp_Object rest, prev = Qnil;
1796 for (rest = Vall_weak_lists;
1798 rest = XWEAK_LIST (rest)->next_weak)
1800 if (! (obj_marked_p (rest)))
1802 /* This weak list itself is garbage. Remove it from the list. */
1804 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1806 XWEAK_LIST (prev)->next_weak =
1807 XWEAK_LIST (rest)->next_weak;
1811 Lisp_Object rest2, prev2 = Qnil;
1812 Lisp_Object tortoise;
1813 int go_tortoise = 0;
1815 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1816 /* We need to be trickier since we're inside of GC;
1817 use CONSP instead of !NILP in case of user-visible
1821 /* It suffices to check the cons for marking,
1822 regardless of the type of weak list:
1824 -- if the cons is pointed to somewhere else,
1825 then it should stay around and will be marked.
1826 -- otherwise, if it should stay around, it will
1827 have been marked in finish_marking_weak_lists().
1828 -- otherwise, it's not marked and should disappear.
1830 if (! obj_marked_p (rest2))
1833 if (GC_NILP (prev2))
1834 XWEAK_LIST (rest)->list = XCDR (rest2);
1836 XCDR (prev2) = XCDR (rest2);
1837 rest2 = XCDR (rest2);
1838 /* Ouch. Circularity checking is even trickier
1839 than I thought. When we cut out a link
1840 like this, we can't advance the turtle or
1841 it'll catch up to us. Imagine that we're
1842 standing on floor tiles and moving forward --
1843 what we just did here is as if the floor
1844 tile under us just disappeared and all the
1845 ones ahead of us slid one tile towards us.
1846 In other words, we didn't move at all;
1847 if the tortoise was one step behind us
1848 previously, it still is, and therefore
1849 it must not move. */
1855 /* Implementing circularity checking is trickier here
1856 than in other places because we have to guarantee
1857 that we've processed all elements before exiting
1858 due to a circularity. (In most places, an error
1859 is issued upon encountering a circularity, so it
1860 doesn't really matter if all elements are processed.)
1861 The idea is that we process along with the hare
1862 rather than the tortoise. If at any point in
1863 our forward process we encounter the tortoise,
1864 we must have already visited the spot, so we exit.
1865 (If we process with the tortoise, we can fail to
1866 process cases where a cons points to itself, or
1867 where cons A points to cons B, which points to
1870 rest2 = XCDR (rest2);
1872 tortoise = XCDR (tortoise);
1873 go_tortoise = !go_tortoise;
1874 if (GC_EQ (rest2, tortoise))
1884 static enum weak_list_type
1885 decode_weak_list_type (Lisp_Object symbol)
1887 CHECK_SYMBOL (symbol);
1888 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1889 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1890 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1891 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1892 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1894 signal_simple_error ("Invalid weak list type", symbol);
1895 return WEAK_LIST_SIMPLE; /* not reached */
1899 encode_weak_list_type (enum weak_list_type type)
1903 case WEAK_LIST_SIMPLE: return Qsimple;
1904 case WEAK_LIST_ASSOC: return Qassoc;
1905 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1906 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1911 return Qnil; /* not reached */
1914 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
1915 Return non-nil if OBJECT is a weak list.
1919 return WEAK_LISTP (object) ? Qt : Qnil;
1922 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
1923 Return a new weak list object of type TYPE.
1924 A weak list object is an object that contains a list. This list behaves
1925 like any other list except that its elements do not count towards
1926 garbage collection -- if the only pointer to an object in inside a weak
1927 list (other than pointers in similar objects such as weak hash tables),
1928 the object is garbage collected and automatically removed from the list.
1929 This is used internally, for example, to manage the list holding the
1930 children of an extent -- an extent that is unused but has a parent will
1931 still be reclaimed, and will automatically be removed from its parent's
1934 Optional argument TYPE specifies the type of the weak list, and defaults
1935 to `simple'. Recognized types are
1937 `simple' Objects in the list disappear if not pointed to.
1938 `assoc' Objects in the list disappear if they are conses
1939 and either the car or the cdr of the cons is not
1941 `key-assoc' Objects in the list disappear if they are conses
1942 and the car is not pointed to.
1943 `value-assoc' Objects in the list disappear if they are conses
1944 and the cdr is not pointed to.
1951 return make_weak_list (decode_weak_list_type (type));
1954 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
1955 Return the type of the given weak-list object.
1959 CHECK_WEAK_LIST (weak);
1960 return encode_weak_list_type (XWEAK_LIST (weak)->type);
1963 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
1964 Return the list contained in a weak-list object.
1968 CHECK_WEAK_LIST (weak);
1969 return XWEAK_LIST_LIST (weak);
1972 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
1973 Change the list contained in a weak-list object.
1977 CHECK_WEAK_LIST (weak);
1978 XWEAK_LIST_LIST (weak) = new_list;
1983 /************************************************************************/
1984 /* initialization */
1985 /************************************************************************/
1988 arith_error (int signo)
1990 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
1991 EMACS_UNBLOCK_SIGNAL (signo);
1992 signal_error (Qarith_error, Qnil);
1996 init_data_very_early (void)
1998 /* Don't do this if just dumping out.
1999 We don't want to call `signal' in this case
2000 so that we don't have trouble with dumping
2001 signal-delivering routines in an inconsistent state. */
2005 #endif /* CANNOT_DUMP */
2006 signal (SIGFPE, arith_error);
2008 signal (SIGEMT, arith_error);
2013 init_errors_once_early (void)
2015 defsymbol (&Qerror_conditions, "error-conditions");
2016 defsymbol (&Qerror_message, "error-message");
2018 /* We declare the errors here because some other deferrors depend
2019 on some of the errors below. */
2021 /* ERROR is used as a signaler for random errors for which nothing
2024 deferror (&Qerror, "error", "error", Qnil);
2025 deferror (&Qquit, "quit", "Quit", Qnil);
2027 deferror (&Qwrong_type_argument, "wrong-type-argument",
2028 "Wrong type argument", Qerror);
2029 deferror (&Qargs_out_of_range, "args-out-of-range", "Args out of range",
2031 deferror (&Qvoid_function, "void-function",
2032 "Symbol's function definition is void", Qerror);
2033 deferror (&Qcyclic_function_indirection, "cyclic-function-indirection",
2034 "Symbol's chain of function indirections contains a loop", Qerror);
2035 deferror (&Qvoid_variable, "void-variable",
2036 "Symbol's value as variable is void", Qerror);
2037 deferror (&Qcyclic_variable_indirection, "cyclic-variable-indirection",
2038 "Symbol's chain of variable indirections contains a loop", Qerror);
2039 deferror (&Qsetting_constant, "setting-constant",
2040 "Attempt to set a constant symbol", Qerror);
2041 deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
2042 "Invalid read syntax", Qerror);
2044 /* Generated by list traversal macros */
2045 deferror (&Qmalformed_list, "malformed-list",
2046 "Malformed list", Qerror);
2047 deferror (&Qmalformed_property_list, "malformed-property-list",
2048 "Malformed property list", Qmalformed_list);
2049 deferror (&Qcircular_list, "circular-list",
2050 "Circular list", Qerror);
2051 deferror (&Qcircular_property_list, "circular-property-list",
2052 "Circular property list", Qcircular_list);
2054 deferror (&Qinvalid_function, "invalid-function", "Invalid function",
2056 deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
2057 "Wrong number of arguments", Qerror);
2058 deferror (&Qno_catch, "no-catch", "No catch for tag",
2060 deferror (&Qbeginning_of_buffer, "beginning-of-buffer",
2061 "Beginning of buffer", Qerror);
2062 deferror (&Qend_of_buffer, "end-of-buffer", "End of buffer", Qerror);
2063 deferror (&Qbuffer_read_only, "buffer-read-only", "Buffer is read-only",
2066 deferror (&Qio_error, "io-error", "IO Error", Qerror);
2067 deferror (&Qend_of_file, "end-of-file", "End of stream", Qio_error);
2069 deferror (&Qarith_error, "arith-error", "Arithmetic error", Qerror);
2070 deferror (&Qrange_error, "range-error", "Arithmetic range error",
2072 deferror (&Qdomain_error, "domain-error", "Arithmetic domain error",
2074 deferror (&Qsingularity_error, "singularity-error",
2075 "Arithmetic singularity error", Qdomain_error);
2076 deferror (&Qoverflow_error, "overflow-error",
2077 "Arithmetic overflow error", Qdomain_error);
2078 deferror (&Qunderflow_error, "underflow-error",
2079 "Arithmetic underflow error", Qdomain_error);
2085 defsymbol (&Qcons, "cons");
2086 defsymbol (&Qkeyword, "keyword");
2087 defsymbol (&Qquote, "quote");
2088 defsymbol (&Qlambda, "lambda");
2089 defsymbol (&Qignore, "ignore");
2090 defsymbol (&Qlistp, "listp");
2091 defsymbol (&Qtrue_list_p, "true-list-p");
2092 defsymbol (&Qconsp, "consp");
2093 defsymbol (&Qsubrp, "subrp");
2094 defsymbol (&Qsymbolp, "symbolp");
2095 defsymbol (&Qkeywordp, "keywordp");
2096 defsymbol (&Qintegerp, "integerp");
2097 defsymbol (&Qcharacterp, "characterp");
2098 defsymbol (&Qnatnump, "natnump");
2099 defsymbol (&Qstringp, "stringp");
2100 defsymbol (&Qarrayp, "arrayp");
2101 defsymbol (&Qsequencep, "sequencep");
2102 defsymbol (&Qbufferp, "bufferp");
2103 defsymbol (&Qbitp, "bitp");
2104 defsymbol (&Qbit_vectorp, "bit-vector-p");
2105 defsymbol (&Qvectorp, "vectorp");
2106 defsymbol (&Qchar_or_string_p, "char-or-string-p");
2107 defsymbol (&Qmarkerp, "markerp");
2108 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
2109 defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
2110 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
2111 defsymbol (&Qnumberp, "numberp");
2112 defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
2113 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p");
2114 defsymbol (&Qcdr, "cdr");
2115 defsymbol (&Qweak_listp, "weak-list-p");
2117 #ifdef LISP_FLOAT_TYPE
2118 defsymbol (&Qfloatp, "floatp");
2119 #endif /* LISP_FLOAT_TYPE */
2121 DEFSUBR (Fwrong_type_argument);
2126 Ffset (intern ("not"), intern ("null"));
2129 DEFSUBR (Ftrue_list_p);
2132 DEFSUBR (Fchar_or_string_p);
2133 DEFSUBR (Fcharacterp);
2134 DEFSUBR (Fchar_int_p);
2135 DEFSUBR (Fchar_to_int);
2136 DEFSUBR (Fint_to_char);
2137 DEFSUBR (Fchar_or_char_int_p);
2138 DEFSUBR (Fintegerp);
2139 DEFSUBR (Finteger_or_marker_p);
2140 DEFSUBR (Finteger_or_char_p);
2141 DEFSUBR (Finteger_char_or_marker_p);
2143 DEFSUBR (Fnumber_or_marker_p);
2144 DEFSUBR (Fnumber_char_or_marker_p);
2145 #ifdef LISP_FLOAT_TYPE
2147 #endif /* LISP_FLOAT_TYPE */
2150 DEFSUBR (Fkeywordp);
2154 DEFSUBR (Fbit_vector_p);
2156 DEFSUBR (Fsequencep);
2159 DEFSUBR (Fsubr_min_args);
2160 DEFSUBR (Fsubr_max_args);
2161 DEFSUBR (Fsubr_interactive);
2165 DEFSUBR (Fcar_safe);
2166 DEFSUBR (Fcdr_safe);
2169 DEFSUBR (Findirect_function);
2173 DEFSUBR (Fnumber_to_string);
2174 DEFSUBR (Fstring_to_number);
2199 DEFSUBR (Fweak_list_p);
2200 DEFSUBR (Fmake_weak_list);
2201 DEFSUBR (Fweak_list_type);
2202 DEFSUBR (Fweak_list_list);
2203 DEFSUBR (Fset_weak_list_list);
2209 /* This must not be staticpro'd */
2210 Vall_weak_lists = Qnil;
2213 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2214 If non-zero, note when your code may be suffering from char-int confoundance.
2215 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2216 etc. where an int and a char with the same value are being compared,
2217 it will issue a notice on stderr to this effect, along with a backtrace.
2218 In such situations, the result would be different in XEmacs 19 versus
2219 XEmacs 20, and you probably don't want this.
2221 Note that in order to see these notices, you have to byte compile your
2222 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2223 have its chars and ints all confounded in the byte code, making it
2224 impossible to accurately determine Ebola infection.
2227 debug_issue_ebola_notices = 0;
2229 DEFVAR_INT ("debug-ebola-backtrace-length",
2230 &debug_ebola_backtrace_length /*
2231 Length (in stack frames) of short backtrace printed out in Ebola notices.
2232 See `debug-issue-ebola-notices'.
2234 debug_ebola_backtrace_length = 32;
2236 #endif /* DEBUG_XEMACS */