1 /* Primitive operations on Lisp data types for XEmacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995
3 Free Software Foundation, Inc.
4 Copyright (C) 2000 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
26 /* This file has been Mule-ized. */
33 #include "syssignal.h"
35 #ifdef LISP_FLOAT_TYPE
36 /* Need to define a differentiating symbol -- see sysfloat.h */
37 # define THIS_FILENAME data_c
38 # include "sysfloat.h"
39 #endif /* LISP_FLOAT_TYPE */
41 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
43 Lisp_Object Qunloaded;
45 Lisp_Object Qerror_conditions, Qerror_message;
46 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
47 Lisp_Object Qlist_formation_error;
48 Lisp_Object Qmalformed_list, Qmalformed_property_list;
49 Lisp_Object Qcircular_list, Qcircular_property_list;
50 Lisp_Object Qinvalid_argument, Qwrong_type_argument, Qargs_out_of_range;
51 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch;
52 Lisp_Object Qinternal_error, Qinvalid_state;
53 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
54 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
55 Lisp_Object Qinvalid_operation, Qinvalid_change;
56 Lisp_Object Qsetting_constant;
57 Lisp_Object Qediting_error;
58 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
59 Lisp_Object Qio_error, Qend_of_file;
60 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
61 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
62 Lisp_Object Qintegerp, Qnatnump, Qsymbolp;
63 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
64 Lisp_Object Qconsp, Qsubrp;
65 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
66 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
67 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
68 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
69 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
75 int debug_issue_ebola_notices;
77 Fixnum debug_ebola_backtrace_length;
80 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
82 if (debug_issue_ebola_notices
83 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
85 /* #### It would be really nice if this were a proper warning
86 instead of brain-dead print ro Qexternal_debugging_output. */
87 write_c_string ("Comparison between integer and character is constant nil (",
88 Qexternal_debugging_output);
89 Fprinc (obj1, Qexternal_debugging_output);
90 write_c_string (" and ", Qexternal_debugging_output);
91 Fprinc (obj2, Qexternal_debugging_output);
92 write_c_string (")\n", Qexternal_debugging_output);
93 debug_short_backtrace (debug_ebola_backtrace_length);
95 return EQ (obj1, obj2);
98 #endif /* DEBUG_XEMACS */
103 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
105 /* This function can GC */
106 REGISTER Lisp_Object tem;
109 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
110 tem = call1 (predicate, value);
117 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
119 signal_error (Qwrong_type_argument, list2 (predicate, value));
122 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
123 Signal an error until the correct type value is given by the user.
124 This function loops, signalling a continuable `wrong-type-argument' error
125 with PREDICATE and VALUE as the data associated with the error and then
126 calling PREDICATE on the returned value, until the value gotten satisfies
127 PREDICATE. At that point, the gotten value is returned.
131 return wrong_type_argument (predicate, value);
135 c_write_error (Lisp_Object obj)
137 signal_simple_error ("Attempt to modify read-only object (c)", obj);
141 lisp_write_error (Lisp_Object obj)
143 signal_simple_error ("Attempt to modify read-only object (lisp)", obj);
147 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
149 signal_error (Qargs_out_of_range, list2 (a1, a2));
153 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
155 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
159 check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max)
161 if (val < min || val > max)
162 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
165 /* On some machines, XINT needs a temporary location.
166 Here it is, in case it is needed. */
168 EMACS_INT sign_extend_temp;
170 /* On a few machines, XINT can only be done by calling this. */
171 /* XEmacs: only used by m/convex.h */
172 EMACS_INT sign_extend_lisp_int (EMACS_INT num);
174 sign_extend_lisp_int (EMACS_INT num)
176 if (num & (1L << (VALBITS - 1)))
177 return num | ((-1L) << VALBITS);
179 return num & ((1L << VALBITS) - 1);
183 /* Data type predicates */
185 DEFUN ("eq", Feq, 2, 2, 0, /*
186 Return t if the two args are the same Lisp object.
190 return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil;
193 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
194 Return t if the two args are (in most cases) the same Lisp object.
196 Special kludge: A character is considered `old-eq' to its equivalent integer
197 even though they are not the same object and are in fact of different
198 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
199 preserve byte-code compatibility with v19. This kludge is known as the
200 \"char-int confoundance disease\" and appears in a number of other
201 functions with `old-foo' equivalents.
203 Do not use this function!
208 return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
211 DEFUN ("null", Fnull, 1, 1, 0, /*
212 Return t if OBJECT is nil.
216 return NILP (object) ? Qt : Qnil;
219 DEFUN ("consp", Fconsp, 1, 1, 0, /*
220 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
224 return CONSP (object) ? Qt : Qnil;
227 DEFUN ("atom", Fatom, 1, 1, 0, /*
228 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
232 return CONSP (object) ? Qnil : Qt;
235 DEFUN ("listp", Flistp, 1, 1, 0, /*
236 Return t if OBJECT is a list. `nil' is a list.
240 return LISTP (object) ? Qt : Qnil;
243 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
244 Return t if OBJECT is not a list. `nil' is a list.
248 return LISTP (object) ? Qnil : Qt;
251 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
252 Return t if OBJECT is a non-dotted, i.e. nil-terminated, list.
256 return TRUE_LIST_P (object) ? Qt : Qnil;
259 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
260 Return t if OBJECT is a symbol.
264 return SYMBOLP (object) ? Qt : Qnil;
267 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
268 Return t if OBJECT is a keyword.
272 return KEYWORDP (object) ? Qt : Qnil;
275 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
276 Return t if OBJECT is a vector.
280 return VECTORP (object) ? Qt : Qnil;
283 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
284 Return t if OBJECT is a bit vector.
288 return BIT_VECTORP (object) ? Qt : Qnil;
291 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
292 Return t if OBJECT is a string.
296 return STRINGP (object) ? Qt : Qnil;
299 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
300 Return t if OBJECT is an array (string, vector, or bit vector).
304 return (VECTORP (object) ||
306 BIT_VECTORP (object))
310 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
311 Return t if OBJECT is a sequence (list or array).
315 return (LISTP (object) ||
318 BIT_VECTORP (object))
322 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
323 Return t if OBJECT is a marker (editor pointer).
327 return MARKERP (object) ? Qt : Qnil;
330 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
331 Return t if OBJECT is a built-in function.
335 return SUBRP (object) ? Qt : Qnil;
338 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
339 Return minimum number of args built-in function SUBR may be called with.
344 return make_int (XSUBR (subr)->min_args);
347 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
348 Return maximum number of args built-in function SUBR may be called with,
349 or nil if it takes an arbitrary number of arguments or is a special form.
355 nargs = XSUBR (subr)->max_args;
356 if (nargs == MANY || nargs == UNEVALLED)
359 return make_int (nargs);
362 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
363 Return the interactive spec of the subr object SUBR, or nil.
364 If non-nil, the return value will be a list whose first element is
365 `interactive' and whose second element is the interactive spec.
371 prompt = XSUBR (subr)->prompt;
372 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
376 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
377 Return t if OBJECT is a character.
378 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
379 Any character can be converted into an equivalent integer using
380 `char-int'. To convert the other way, use `int-char'; however,
381 only some integers can be converted into characters. Such an integer
382 is called a `char-int'; see `char-int-p'.
384 Some functions that work on integers (e.g. the comparison functions
385 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
386 accept characters and implicitly convert them into integers. In
387 general, functions that work on characters also accept char-ints and
388 implicitly convert them into characters. WARNING: Neither of these
389 behaviors is very desirable, and they are maintained for backward
390 compatibility with old E-Lisp programs that confounded characters and
391 integers willy-nilly. These behaviors may change in the future; therefore,
392 do not rely on them. Instead, use the character-specific functions such
397 return CHARP (object) ? Qt : Qnil;
400 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
401 Convert CHARACTER into an equivalent integer.
402 The resulting integer will always be non-negative. The integers in
403 the range 0 - 255 map to characters as follows:
407 128 - 159 Control set 1
408 160 - 255 Right half of ISO-8859-1
410 If support for Mule does not exist, these are the only valid character
411 values. When Mule support exists, the values assigned to other characters
412 may vary depending on the particular version of XEmacs, the order in which
413 character sets were loaded, etc., and you should not depend on them.
417 CHECK_CHAR (character);
418 return make_int (XCHAR (character));
421 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
422 Convert integer INTEGER into the equivalent character.
423 Not all integers correspond to valid characters; use `char-int-p' to
424 determine whether this is the case. If the integer cannot be converted,
430 if (CHAR_INTP (integer))
431 return make_char (XINT (integer));
436 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
437 Return t if OBJECT is an integer that can be converted into a character.
442 return CHAR_INTP (object) ? Qt : Qnil;
445 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
446 Return t if OBJECT is a character or an integer that can be converted into one.
450 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
453 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
454 Return t if OBJECT is a character (or a char-int) or a string.
455 It is semi-hateful that we allow a char-int here, as it goes against
456 the name of this function, but it makes the most sense considering the
457 other steps we take to maintain compatibility with the old character/integer
458 confoundedness in older versions of E-Lisp.
462 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
465 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
466 Return t if OBJECT is an integer.
470 return INTP (object) ? Qt : Qnil;
473 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
474 Return t if OBJECT is an integer or a marker (editor pointer).
478 return INTP (object) || MARKERP (object) ? Qt : Qnil;
481 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
482 Return t if OBJECT is an integer or a character.
486 return INTP (object) || CHARP (object) ? Qt : Qnil;
489 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
490 Return t if OBJECT is an integer, character or a marker (editor pointer).
494 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
497 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
498 Return t if OBJECT is a nonnegative integer.
502 return NATNUMP (object) ? Qt : Qnil;
505 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
506 Return t if OBJECT is a bit (0 or 1).
510 return BITP (object) ? Qt : Qnil;
513 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
514 Return t if OBJECT is a number (floating point or integer).
518 return INT_OR_FLOATP (object) ? Qt : Qnil;
521 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
522 Return t if OBJECT is a number or a marker.
526 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
529 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
530 Return t if OBJECT is a number, character or a marker.
534 return (INT_OR_FLOATP (object) ||
540 #ifdef LISP_FLOAT_TYPE
541 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
542 Return t if OBJECT is a floating point number.
546 return FLOATP (object) ? Qt : Qnil;
548 #endif /* LISP_FLOAT_TYPE */
550 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
551 Return a symbol representing the type of OBJECT.
555 switch (XTYPE (object))
557 case Lisp_Type_Record:
558 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
560 case Lisp_Type_Char: return Qcharacter;
562 default: return Qinteger;
567 /* Extract and set components of lists */
569 DEFUN ("car", Fcar, 1, 1, 0, /*
570 Return the car of LIST. If arg is nil, return nil.
571 Error if arg is not nil and not a cons cell. See also `car-safe'.
579 else if (NILP (list))
582 list = wrong_type_argument (Qlistp, list);
586 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
587 Return the car of OBJECT if it is a cons cell, or else nil.
591 return CONSP (object) ? XCAR (object) : Qnil;
594 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
595 Return the cdr of LIST. If arg is nil, return nil.
596 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
604 else if (NILP (list))
607 list = wrong_type_argument (Qlistp, list);
611 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
612 Return the cdr of OBJECT if it is a cons cell, else nil.
616 return CONSP (object) ? XCDR (object) : Qnil;
619 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
620 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR.
624 if (!CONSP (cons_cell))
625 cons_cell = wrong_type_argument (Qconsp, cons_cell);
627 XCAR (cons_cell) = newcar;
631 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
632 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR.
636 if (!CONSP (cons_cell))
637 cons_cell = wrong_type_argument (Qconsp, cons_cell);
639 XCDR (cons_cell) = newcdr;
643 /* Find the function at the end of a chain of symbol function indirections.
645 If OBJECT is a symbol, find the end of its function chain and
646 return the value found there. If OBJECT is not a symbol, just
647 return it. If there is a cycle in the function chain, signal a
648 cyclic-function-indirection error.
650 This is like Findirect_function when VOID_FUNCTION_ERRORP is true.
651 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end
652 of the chain ends up being Qunbound. */
654 indirect_function (Lisp_Object object, int void_function_errorp)
656 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
657 Lisp_Object tortoise, hare;
660 for (hare = tortoise = object, count = 0;
662 hare = XSYMBOL (hare)->function, count++)
664 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
667 tortoise = XSYMBOL (tortoise)->function;
668 if (EQ (hare, tortoise))
669 return Fsignal (Qcyclic_function_indirection, list1 (object));
672 if (void_function_errorp && UNBOUNDP (hare))
673 return signal_void_function_error (object);
678 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
679 Return the function at the end of OBJECT's function chain.
680 If OBJECT is a symbol, follow all function indirections and return
681 the final function binding.
682 If OBJECT is not a symbol, just return it.
683 Signal a void-function error if the final symbol is unbound.
684 Signal a cyclic-function-indirection error if there is a loop in the
685 function chain of symbols.
689 return indirect_function (object, 1);
692 /* Extract and set vector and string elements */
694 DEFUN ("aref", Faref, 2, 2, 0, /*
695 Return the element of ARRAY at index INDEX.
696 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
704 if (INTP (index_)) idx = XINT (index_);
705 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
708 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
712 if (idx < 0) goto range_error;
716 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
717 return XVECTOR_DATA (array)[idx];
719 else if (BIT_VECTORP (array))
721 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
722 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
724 else if (STRINGP (array))
726 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
727 return make_char (string_char (XSTRING (array), idx));
729 #ifdef LOSING_BYTECODE
730 else if (COMPILED_FUNCTIONP (array))
732 /* Weird, gross compatibility kludge */
733 return Felt (array, index_);
738 check_losing_bytecode ("aref", array);
739 array = wrong_type_argument (Qarrayp, array);
744 args_out_of_range (array, index_);
745 return Qnil; /* not reached */
748 DEFUN ("aset", Faset, 3, 3, 0, /*
749 Store into the element of ARRAY at index INDEX the value NEWVAL.
750 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
752 (array, index_, newval))
758 if (INTP (index_)) idx = XINT (index_);
759 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
762 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
766 if (idx < 0) goto range_error;
770 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
771 XVECTOR_DATA (array)[idx] = newval;
773 else if (BIT_VECTORP (array))
775 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
777 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
779 else if (STRINGP (array))
781 CHECK_CHAR_COERCE_INT (newval);
782 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
783 set_string_char (XSTRING (array), idx, XCHAR (newval));
784 bump_string_modiff (array);
788 array = wrong_type_argument (Qarrayp, array);
795 args_out_of_range (array, index_);
796 return Qnil; /* not reached */
800 /**********************************************************************/
801 /* Arithmetic functions */
802 /**********************************************************************/
814 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
818 if (INTP (obj)) p->c.ival = XINT (obj);
819 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
820 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
821 #ifdef LISP_FLOAT_TYPE
822 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
826 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
832 number_char_or_marker_to_double (Lisp_Object obj)
835 if (INTP (obj)) return (double) XINT (obj);
836 else if (CHARP (obj)) return (double) XCHAR (obj);
837 else if (MARKERP (obj)) return (double) marker_position (obj);
838 #ifdef LISP_FLOAT_TYPE
839 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
843 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
849 integer_char_or_marker_to_int (Lisp_Object obj)
852 if (INTP (obj)) return XINT (obj);
853 else if (CHARP (obj)) return XCHAR (obj);
854 else if (MARKERP (obj)) return marker_position (obj);
857 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
862 #define ARITHCOMPARE_MANY(op) \
864 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
865 Lisp_Object *args_end = args + nargs; \
867 number_char_or_marker_to_int_or_double (*args++, p); \
869 while (args < args_end) \
871 number_char_or_marker_to_int_or_double (*args++, q); \
873 if (!((p->int_p && q->int_p) ? \
874 (p->c.ival op q->c.ival) : \
875 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
876 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
879 { /* swap */ int_or_double *r = p; p = q; q = r; } \
884 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
885 Return t if all the arguments are numerically equal.
886 The arguments may be numbers, characters or markers.
888 (int nargs, Lisp_Object *args))
890 ARITHCOMPARE_MANY (==)
893 DEFUN ("<", Flss, 1, MANY, 0, /*
894 Return t if the sequence of arguments is monotonically increasing.
895 The arguments may be numbers, characters or markers.
897 (int nargs, Lisp_Object *args))
899 ARITHCOMPARE_MANY (<)
902 DEFUN (">", Fgtr, 1, MANY, 0, /*
903 Return t if the sequence of arguments is monotonically decreasing.
904 The arguments may be numbers, characters or markers.
906 (int nargs, Lisp_Object *args))
908 ARITHCOMPARE_MANY (>)
911 DEFUN ("<=", Fleq, 1, MANY, 0, /*
912 Return t if the sequence of arguments is monotonically nondecreasing.
913 The arguments may be numbers, characters or markers.
915 (int nargs, Lisp_Object *args))
917 ARITHCOMPARE_MANY (<=)
920 DEFUN (">=", Fgeq, 1, MANY, 0, /*
921 Return t if the sequence of arguments is monotonically nonincreasing.
922 The arguments may be numbers, characters or markers.
924 (int nargs, Lisp_Object *args))
926 ARITHCOMPARE_MANY (>=)
929 DEFUN ("/=", Fneq, 1, MANY, 0, /*
930 Return t if no two arguments are numerically equal.
931 The arguments may be numbers, characters or markers.
933 (int nargs, Lisp_Object *args))
935 Lisp_Object *args_end = args + nargs;
938 /* Unlike all the other comparisons, this is an N*N algorithm.
939 We could use a hash table for nargs > 50 to make this linear. */
940 for (p = args; p < args_end; p++)
942 int_or_double iod1, iod2;
943 number_char_or_marker_to_int_or_double (*p, &iod1);
945 for (q = p + 1; q < args_end; q++)
947 number_char_or_marker_to_int_or_double (*q, &iod2);
949 if (!((iod1.int_p && iod2.int_p) ?
950 (iod1.c.ival != iod2.c.ival) :
951 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
952 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
959 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
960 Return t if NUMBER is zero.
966 return EQ (number, Qzero) ? Qt : Qnil;
967 #ifdef LISP_FLOAT_TYPE
968 else if (FLOATP (number))
969 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
970 #endif /* LISP_FLOAT_TYPE */
973 number = wrong_type_argument (Qnumberp, number);
978 /* Convert between a 32-bit value and a cons of two 16-bit values.
979 This is used to pass 32-bit integers to and from the user.
980 Use time_to_lisp() and lisp_to_time() for time values.
982 If you're thinking of using this to store a pointer into a Lisp Object
983 for internal purposes (such as when calling record_unwind_protect()),
984 try using make_opaque_ptr()/get_opaque_ptr() instead. */
986 word_to_lisp (unsigned int item)
988 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
992 lisp_to_word (Lisp_Object item)
998 Lisp_Object top = Fcar (item);
999 Lisp_Object bot = Fcdr (item);
1002 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
1007 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
1008 Convert NUMBER to a string by printing it in decimal.
1009 Uses a minus sign if negative.
1010 NUMBER may be an integer or a floating point number.
1014 char buffer[VALBITS];
1016 CHECK_INT_OR_FLOAT (number);
1018 #ifdef LISP_FLOAT_TYPE
1019 if (FLOATP (number))
1021 char pigbuf[350]; /* see comments in float_to_string */
1023 float_to_string (pigbuf, XFLOAT_DATA (number));
1024 return build_string (pigbuf);
1026 #endif /* LISP_FLOAT_TYPE */
1028 long_to_string (buffer, XINT (number));
1029 return build_string (buffer);
1033 digit_to_number (int character, int base)
1036 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1037 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
1038 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
1041 return digit >= base ? -1 : digit;
1044 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
1045 Convert STRING to a number by parsing it as a number in base BASE.
1046 This parses both integers and floating point numbers.
1047 It ignores leading spaces and tabs.
1049 If BASE is nil or omitted, base 10 is used.
1050 BASE must be an integer between 2 and 16 (inclusive).
1051 Floating point numbers always use base 10.
1058 CHECK_STRING (string);
1066 check_int_range (b, 2, 16);
1069 p = (char *) XSTRING_DATA (string);
1071 /* Skip any whitespace at the front of the number. Some versions of
1072 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1073 while (*p == ' ' || *p == '\t')
1076 #ifdef LISP_FLOAT_TYPE
1077 if (isfloat_string (p) && b == 10)
1078 return make_float (atof (p));
1079 #endif /* LISP_FLOAT_TYPE */
1083 /* Use the system-provided functions for base 10. */
1084 #if SIZEOF_EMACS_INT == SIZEOF_INT
1085 return make_int (atoi (p));
1086 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1087 return make_int (atol (p));
1088 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1089 return make_int (atoll (p));
1106 int digit = digit_to_number (*p++, b);
1111 return make_int (negative * v);
1116 DEFUN ("+", Fplus, 0, MANY, 0, /*
1117 Return sum of any number of arguments.
1118 The arguments should all be numbers, characters or markers.
1120 (int nargs, Lisp_Object *args))
1122 EMACS_INT iaccum = 0;
1123 Lisp_Object *args_end = args + nargs;
1125 while (args < args_end)
1128 number_char_or_marker_to_int_or_double (*args++, &iod);
1130 iaccum += iod.c.ival;
1133 double daccum = (double) iaccum + iod.c.dval;
1134 while (args < args_end)
1135 daccum += number_char_or_marker_to_double (*args++);
1136 return make_float (daccum);
1140 return make_int (iaccum);
1143 DEFUN ("-", Fminus, 1, MANY, 0, /*
1144 Negate number or subtract numbers, characters or markers.
1145 With one arg, negates it. With more than one arg,
1146 subtracts all but the first from the first.
1148 (int nargs, Lisp_Object *args))
1152 Lisp_Object *args_end = args + nargs;
1155 number_char_or_marker_to_int_or_double (*args++, &iod);
1157 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
1160 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
1164 while (args < args_end)
1166 number_char_or_marker_to_int_or_double (*args++, &iod);
1168 iaccum -= iod.c.ival;
1171 daccum = (double) iaccum - iod.c.dval;
1176 return make_int (iaccum);
1179 for (; args < args_end; args++)
1180 daccum -= number_char_or_marker_to_double (*args);
1181 return make_float (daccum);
1184 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1185 Return product of any number of arguments.
1186 The arguments should all be numbers, characters or markers.
1188 (int nargs, Lisp_Object *args))
1190 EMACS_INT iaccum = 1;
1191 Lisp_Object *args_end = args + nargs;
1193 while (args < args_end)
1196 number_char_or_marker_to_int_or_double (*args++, &iod);
1198 iaccum *= iod.c.ival;
1201 double daccum = (double) iaccum * iod.c.dval;
1202 while (args < args_end)
1203 daccum *= number_char_or_marker_to_double (*args++);
1204 return make_float (daccum);
1208 return make_int (iaccum);
1211 DEFUN ("/", Fquo, 1, MANY, 0, /*
1212 Return first argument divided by all the remaining arguments.
1213 The arguments must be numbers, characters or markers.
1214 With one argument, reciprocates the argument.
1216 (int nargs, Lisp_Object *args))
1220 Lisp_Object *args_end = args + nargs;
1227 number_char_or_marker_to_int_or_double (*args++, &iod);
1229 iaccum = iod.c.ival;
1232 daccum = iod.c.dval;
1237 while (args < args_end)
1239 number_char_or_marker_to_int_or_double (*args++, &iod);
1242 if (iod.c.ival == 0) goto divide_by_zero;
1243 iaccum /= iod.c.ival;
1247 if (iod.c.dval == 0) goto divide_by_zero;
1248 daccum = (double) iaccum / iod.c.dval;
1253 return make_int (iaccum);
1256 for (; args < args_end; args++)
1258 double dval = number_char_or_marker_to_double (*args);
1259 if (dval == 0) goto divide_by_zero;
1262 return make_float (daccum);
1265 Fsignal (Qarith_error, Qnil);
1266 return Qnil; /* not reached */
1269 DEFUN ("max", Fmax, 1, MANY, 0, /*
1270 Return largest of all the arguments.
1271 All arguments must be numbers, characters or markers.
1272 The value is always a number; markers and characters are converted
1275 (int nargs, Lisp_Object *args))
1279 Lisp_Object *args_end = args + nargs;
1282 number_char_or_marker_to_int_or_double (*args++, &iod);
1291 while (args < args_end)
1293 number_char_or_marker_to_int_or_double (*args++, &iod);
1296 if (imax < iod.c.ival) imax = iod.c.ival;
1300 dmax = (double) imax;
1301 if (dmax < iod.c.dval) dmax = iod.c.dval;
1306 return make_int (imax);
1309 while (args < args_end)
1311 double dval = number_char_or_marker_to_double (*args++);
1312 if (dmax < dval) dmax = dval;
1314 return make_float (dmax);
1317 DEFUN ("min", Fmin, 1, MANY, 0, /*
1318 Return smallest of all the arguments.
1319 All arguments must be numbers, characters or markers.
1320 The value is always a number; markers and characters are converted
1323 (int nargs, Lisp_Object *args))
1327 Lisp_Object *args_end = args + nargs;
1330 number_char_or_marker_to_int_or_double (*args++, &iod);
1339 while (args < args_end)
1341 number_char_or_marker_to_int_or_double (*args++, &iod);
1344 if (imin > iod.c.ival) imin = iod.c.ival;
1348 dmin = (double) imin;
1349 if (dmin > iod.c.dval) dmin = iod.c.dval;
1354 return make_int (imin);
1357 while (args < args_end)
1359 double dval = number_char_or_marker_to_double (*args++);
1360 if (dmin > dval) dmin = dval;
1362 return make_float (dmin);
1365 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1366 Return bitwise-and of all the arguments.
1367 Arguments may be integers, or markers or characters converted to integers.
1369 (int nargs, Lisp_Object *args))
1371 EMACS_INT bits = ~0;
1372 Lisp_Object *args_end = args + nargs;
1374 while (args < args_end)
1375 bits &= integer_char_or_marker_to_int (*args++);
1377 return make_int (bits);
1380 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1381 Return bitwise-or of all the arguments.
1382 Arguments may be integers, or markers or characters converted to integers.
1384 (int nargs, Lisp_Object *args))
1387 Lisp_Object *args_end = args + nargs;
1389 while (args < args_end)
1390 bits |= integer_char_or_marker_to_int (*args++);
1392 return make_int (bits);
1395 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1396 Return bitwise-exclusive-or of all the arguments.
1397 Arguments may be integers, or markers or characters converted to integers.
1399 (int nargs, Lisp_Object *args))
1402 Lisp_Object *args_end = args + nargs;
1404 while (args < args_end)
1405 bits ^= integer_char_or_marker_to_int (*args++);
1407 return make_int (bits);
1410 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1411 Return the bitwise complement of NUMBER.
1412 NUMBER may be an integer, marker or character converted to integer.
1416 return make_int (~ integer_char_or_marker_to_int (number));
1419 DEFUN ("%", Frem, 2, 2, 0, /*
1420 Return remainder of first arg divided by second.
1421 Both must be integers, characters or markers.
1425 EMACS_INT ival1 = integer_char_or_marker_to_int (number1);
1426 EMACS_INT ival2 = integer_char_or_marker_to_int (number2);
1429 Fsignal (Qarith_error, Qnil);
1431 return make_int (ival1 % ival2);
1434 /* Note, ANSI *requires* the presence of the fmod() library routine.
1435 If your system doesn't have it, complain to your vendor, because
1440 fmod (double f1, double f2)
1444 return f1 - f2 * floor (f1/f2);
1446 #endif /* ! HAVE_FMOD */
1449 DEFUN ("mod", Fmod, 2, 2, 0, /*
1451 The result falls between zero (inclusive) and Y (exclusive).
1452 Both X and Y must be numbers, characters or markers.
1453 If either argument is a float, a float will be returned.
1457 int_or_double iod1, iod2;
1458 number_char_or_marker_to_int_or_double (x, &iod1);
1459 number_char_or_marker_to_int_or_double (y, &iod2);
1461 #ifdef LISP_FLOAT_TYPE
1462 if (!iod1.int_p || !iod2.int_p)
1464 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
1465 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
1466 if (dval2 == 0) goto divide_by_zero;
1467 dval1 = fmod (dval1, dval2);
1469 /* If the "remainder" comes out with the wrong sign, fix it. */
1470 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
1473 return make_float (dval1);
1475 #endif /* LISP_FLOAT_TYPE */
1478 if (iod2.c.ival == 0) goto divide_by_zero;
1480 ival = iod1.c.ival % iod2.c.ival;
1482 /* If the "remainder" comes out with the wrong sign, fix it. */
1483 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
1484 ival += iod2.c.ival;
1486 return make_int (ival);
1490 Fsignal (Qarith_error, Qnil);
1491 return Qnil; /* not reached */
1494 DEFUN ("ash", Fash, 2, 2, 0, /*
1495 Return VALUE with its bits shifted left by COUNT.
1496 If COUNT is negative, shifting is actually to the right.
1497 In this case, the sign bit is duplicated.
1501 CHECK_INT_COERCE_CHAR (value);
1502 CONCHECK_INT (count);
1504 return make_int (XINT (count) > 0 ?
1505 XINT (value) << XINT (count) :
1506 XINT (value) >> -XINT (count));
1509 DEFUN ("lsh", Flsh, 2, 2, 0, /*
1510 Return VALUE with its bits shifted left by COUNT.
1511 If COUNT is negative, shifting is actually to the right.
1512 In this case, zeros are shifted in on the left.
1516 CHECK_INT_COERCE_CHAR (value);
1517 CONCHECK_INT (count);
1519 return make_int (XINT (count) > 0 ?
1520 XUINT (value) << XINT (count) :
1521 XUINT (value) >> -XINT (count));
1524 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1525 Return NUMBER plus one. NUMBER may be a number, character or marker.
1526 Markers and characters are converted to integers.
1532 if (INTP (number)) return make_int (XINT (number) + 1);
1533 if (CHARP (number)) return make_int (XCHAR (number) + 1);
1534 if (MARKERP (number)) return make_int (marker_position (number) + 1);
1535 #ifdef LISP_FLOAT_TYPE
1536 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1537 #endif /* LISP_FLOAT_TYPE */
1539 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1543 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1544 Return NUMBER minus one. NUMBER may be a number, character or marker.
1545 Markers and characters are converted to integers.
1551 if (INTP (number)) return make_int (XINT (number) - 1);
1552 if (CHARP (number)) return make_int (XCHAR (number) - 1);
1553 if (MARKERP (number)) return make_int (marker_position (number) - 1);
1554 #ifdef LISP_FLOAT_TYPE
1555 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1556 #endif /* LISP_FLOAT_TYPE */
1558 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1563 /************************************************************************/
1565 /************************************************************************/
1567 /* A weak list is like a normal list except that elements automatically
1568 disappear when no longer in use, i.e. when no longer GC-protected.
1569 The basic idea is that we don't mark the elements during GC, but
1570 wait for them to be marked elsewhere. If they're not marked, we
1571 remove them. This is analogous to weak hash tables; see the explanation
1572 there for more info. */
1574 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1576 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1579 mark_weak_list (Lisp_Object obj)
1581 return Qnil; /* nichts ist gemarkt */
1585 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1588 error ("printing unreadable object #<weak-list>");
1590 write_c_string ("#<weak-list ", printcharfun);
1591 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
1593 write_c_string (" ", printcharfun);
1594 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1595 write_c_string (">", printcharfun);
1599 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1601 struct weak_list *w1 = XWEAK_LIST (obj1);
1602 struct weak_list *w2 = XWEAK_LIST (obj2);
1604 return ((w1->type == w2->type) &&
1605 internal_equal (w1->list, w2->list, depth + 1));
1608 static unsigned long
1609 weak_list_hash (Lisp_Object obj, int depth)
1611 struct weak_list *w = XWEAK_LIST (obj);
1613 return HASH2 ((unsigned long) w->type,
1614 internal_hash (w->list, depth + 1));
1618 make_weak_list (enum weak_list_type type)
1621 struct weak_list *wl =
1622 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
1626 XSETWEAK_LIST (result, wl);
1627 wl->next_weak = Vall_weak_lists;
1628 Vall_weak_lists = result;
1632 static const struct lrecord_description weak_list_description[] = {
1633 { XD_LISP_OBJECT, offsetof (struct weak_list, list) },
1634 { XD_LO_LINK, offsetof (struct weak_list, next_weak) },
1638 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1639 mark_weak_list, print_weak_list,
1640 0, weak_list_equal, weak_list_hash,
1641 weak_list_description,
1644 -- we do not mark the list elements (either the elements themselves
1645 or the cons cells that hold them) in the normal marking phase.
1646 -- at the end of marking, we go through all weak lists that are
1647 marked, and mark the cons cells that hold all marked
1648 objects, and possibly parts of the objects themselves.
1649 (See alloc.c, "after-mark".)
1650 -- after that, we prune away all the cons cells that are not marked.
1652 WARNING WARNING WARNING WARNING WARNING:
1654 The code in the following two functions is *unbelievably* tricky.
1655 Don't mess with it. You'll be sorry.
1657 Linked lists just majorly suck, d'ya know?
1661 finish_marking_weak_lists (void)
1666 for (rest = Vall_weak_lists;
1668 rest = XWEAK_LIST (rest)->next_weak)
1671 enum weak_list_type type = XWEAK_LIST (rest)->type;
1673 if (! marked_p (rest))
1674 /* The weak list is probably garbage. Ignore it. */
1677 for (rest2 = XWEAK_LIST (rest)->list;
1678 /* We need to be trickier since we're inside of GC;
1679 use CONSP instead of !NILP in case of user-visible
1682 rest2 = XCDR (rest2))
1685 /* If the element is "marked" (meaning depends on the type
1686 of weak list), we need to mark the cons containing the
1687 element, and maybe the element itself (if only some part
1688 was already marked). */
1689 int need_to_mark_cons = 0;
1690 int need_to_mark_elem = 0;
1692 /* If a cons is already marked, then its car is already marked
1693 (either because of an external pointer or because of
1694 a previous call to this function), and likewise for all
1695 the rest of the elements in the list, so we can stop now. */
1696 if (marked_p (rest2))
1699 elem = XCAR (rest2);
1703 case WEAK_LIST_SIMPLE:
1704 if (marked_p (elem))
1705 need_to_mark_cons = 1;
1708 case WEAK_LIST_ASSOC:
1711 /* just leave bogus elements there */
1712 need_to_mark_cons = 1;
1713 need_to_mark_elem = 1;
1715 else if (marked_p (XCAR (elem)) &&
1716 marked_p (XCDR (elem)))
1718 need_to_mark_cons = 1;
1719 /* We still need to mark elem, because it's
1720 probably not marked. */
1721 need_to_mark_elem = 1;
1725 case WEAK_LIST_KEY_ASSOC:
1728 /* just leave bogus elements there */
1729 need_to_mark_cons = 1;
1730 need_to_mark_elem = 1;
1732 else if (marked_p (XCAR (elem)))
1734 need_to_mark_cons = 1;
1735 /* We still need to mark elem and XCDR (elem);
1736 marking elem does both */
1737 need_to_mark_elem = 1;
1741 case WEAK_LIST_VALUE_ASSOC:
1744 /* just leave bogus elements there */
1745 need_to_mark_cons = 1;
1746 need_to_mark_elem = 1;
1748 else if (marked_p (XCDR (elem)))
1750 need_to_mark_cons = 1;
1751 /* We still need to mark elem and XCAR (elem);
1752 marking elem does both */
1753 need_to_mark_elem = 1;
1757 case WEAK_LIST_FULL_ASSOC:
1760 /* just leave bogus elements there */
1761 need_to_mark_cons = 1;
1762 need_to_mark_elem = 1;
1764 else if (marked_p (XCAR (elem)) ||
1765 marked_p (XCDR (elem)))
1767 need_to_mark_cons = 1;
1768 /* We still need to mark elem and XCAR (elem);
1769 marking elem does both */
1770 need_to_mark_elem = 1;
1778 if (need_to_mark_elem && ! marked_p (elem))
1784 /* We also need to mark the cons that holds the elem or
1785 assoc-pair. We do *not* want to call (mark_object) here
1786 because that will mark the entire list; we just want to
1787 mark the cons itself.
1789 if (need_to_mark_cons)
1791 Lisp_Cons *c = XCONS (rest2);
1792 if (!CONS_MARKED_P (c))
1800 /* In case of imperfect list, need to mark the final cons
1801 because we're not removing it */
1802 if (!NILP (rest2) && ! marked_p (rest2))
1804 mark_object (rest2);
1813 prune_weak_lists (void)
1815 Lisp_Object rest, prev = Qnil;
1817 for (rest = Vall_weak_lists;
1819 rest = XWEAK_LIST (rest)->next_weak)
1821 if (! (marked_p (rest)))
1823 /* This weak list itself is garbage. Remove it from the list. */
1825 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1827 XWEAK_LIST (prev)->next_weak =
1828 XWEAK_LIST (rest)->next_weak;
1832 Lisp_Object rest2, prev2 = Qnil;
1833 Lisp_Object tortoise;
1834 int go_tortoise = 0;
1836 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1837 /* We need to be trickier since we're inside of GC;
1838 use CONSP instead of !NILP in case of user-visible
1842 /* It suffices to check the cons for marking,
1843 regardless of the type of weak list:
1845 -- if the cons is pointed to somewhere else,
1846 then it should stay around and will be marked.
1847 -- otherwise, if it should stay around, it will
1848 have been marked in finish_marking_weak_lists().
1849 -- otherwise, it's not marked and should disappear.
1851 if (! marked_p (rest2))
1855 XWEAK_LIST (rest)->list = XCDR (rest2);
1857 XCDR (prev2) = XCDR (rest2);
1858 rest2 = XCDR (rest2);
1859 /* Ouch. Circularity checking is even trickier
1860 than I thought. When we cut out a link
1861 like this, we can't advance the turtle or
1862 it'll catch up to us. Imagine that we're
1863 standing on floor tiles and moving forward --
1864 what we just did here is as if the floor
1865 tile under us just disappeared and all the
1866 ones ahead of us slid one tile towards us.
1867 In other words, we didn't move at all;
1868 if the tortoise was one step behind us
1869 previously, it still is, and therefore
1870 it must not move. */
1876 /* Implementing circularity checking is trickier here
1877 than in other places because we have to guarantee
1878 that we've processed all elements before exiting
1879 due to a circularity. (In most places, an error
1880 is issued upon encountering a circularity, so it
1881 doesn't really matter if all elements are processed.)
1882 The idea is that we process along with the hare
1883 rather than the tortoise. If at any point in
1884 our forward process we encounter the tortoise,
1885 we must have already visited the spot, so we exit.
1886 (If we process with the tortoise, we can fail to
1887 process cases where a cons points to itself, or
1888 where cons A points to cons B, which points to
1891 rest2 = XCDR (rest2);
1893 tortoise = XCDR (tortoise);
1894 go_tortoise = !go_tortoise;
1895 if (EQ (rest2, tortoise))
1905 static enum weak_list_type
1906 decode_weak_list_type (Lisp_Object symbol)
1908 CHECK_SYMBOL (symbol);
1909 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1910 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1911 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1912 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1913 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1914 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC;
1916 signal_simple_error ("Invalid weak list type", symbol);
1917 return WEAK_LIST_SIMPLE; /* not reached */
1921 encode_weak_list_type (enum weak_list_type type)
1925 case WEAK_LIST_SIMPLE: return Qsimple;
1926 case WEAK_LIST_ASSOC: return Qassoc;
1927 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1928 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1929 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc;
1934 return Qnil; /* not reached */
1937 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
1938 Return non-nil if OBJECT is a weak list.
1942 return WEAK_LISTP (object) ? Qt : Qnil;
1945 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
1946 Return a new weak list object of type TYPE.
1947 A weak list object is an object that contains a list. This list behaves
1948 like any other list except that its elements do not count towards
1949 garbage collection -- if the only pointer to an object is inside a weak
1950 list (other than pointers in similar objects such as weak hash tables),
1951 the object is garbage collected and automatically removed from the list.
1952 This is used internally, for example, to manage the list holding the
1953 children of an extent -- an extent that is unused but has a parent will
1954 still be reclaimed, and will automatically be removed from its parent's
1957 Optional argument TYPE specifies the type of the weak list, and defaults
1958 to `simple'. Recognized types are
1960 `simple' Objects in the list disappear if not pointed to.
1961 `assoc' Objects in the list disappear if they are conses
1962 and either the car or the cdr of the cons is not
1964 `key-assoc' Objects in the list disappear if they are conses
1965 and the car is not pointed to.
1966 `value-assoc' Objects in the list disappear if they are conses
1967 and the cdr is not pointed to.
1968 `full-assoc' Objects in the list disappear if they are conses
1969 and neither the car nor the cdr is pointed to.
1976 return make_weak_list (decode_weak_list_type (type));
1979 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
1980 Return the type of the given weak-list object.
1984 CHECK_WEAK_LIST (weak);
1985 return encode_weak_list_type (XWEAK_LIST (weak)->type);
1988 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
1989 Return the list contained in a weak-list object.
1993 CHECK_WEAK_LIST (weak);
1994 return XWEAK_LIST_LIST (weak);
1997 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
1998 Change the list contained in a weak-list object.
2002 CHECK_WEAK_LIST (weak);
2003 XWEAK_LIST_LIST (weak) = new_list;
2008 /************************************************************************/
2009 /* initialization */
2010 /************************************************************************/
2013 arith_error (int signo)
2015 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
2016 EMACS_UNBLOCK_SIGNAL (signo);
2017 signal_error (Qarith_error, Qnil);
2021 init_data_very_early (void)
2023 /* Don't do this if just dumping out.
2024 We don't want to call `signal' in this case
2025 so that we don't have trouble with dumping
2026 signal-delivering routines in an inconsistent state. */
2030 #endif /* CANNOT_DUMP */
2031 signal (SIGFPE, arith_error);
2033 signal (SIGEMT, arith_error);
2038 init_errors_once_early (void)
2040 DEFSYMBOL (Qerror_conditions);
2041 DEFSYMBOL (Qerror_message);
2043 /* We declare the errors here because some other deferrors depend
2044 on some of the errors below. */
2046 /* ERROR is used as a signaler for random errors for which nothing
2049 DEFERROR (Qerror, "error", Qnil);
2050 DEFERROR_STANDARD (Qquit, Qnil);
2052 DEFERROR (Qunimplemented, "Feature not yet implemented", Qerror);
2053 DEFERROR_STANDARD (Qsyntax_error, Qerror);
2054 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error);
2055 DEFERROR_STANDARD (Qlist_formation_error, Qsyntax_error);
2057 /* Generated by list traversal macros */
2058 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error);
2059 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list);
2060 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error);
2061 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list);
2063 DEFERROR_STANDARD (Qinvalid_argument, Qerror);
2064 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument);
2065 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument);
2066 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument);
2067 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument);
2068 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument);
2070 DEFERROR_STANDARD (Qinternal_error, Qerror);
2072 DEFERROR (Qinvalid_state, "Properties or values have been set incorrectly",
2074 DEFERROR (Qvoid_function, "Symbol's function definition is void",
2076 DEFERROR (Qcyclic_function_indirection,
2077 "Symbol's chain of function indirections contains a loop",
2079 DEFERROR (Qvoid_variable, "Symbol's value as variable is void",
2081 DEFERROR (Qcyclic_variable_indirection,
2082 "Symbol's chain of variable indirections contains a loop",
2085 DEFERROR (Qinvalid_operation,
2086 "Operation not allowed or error during operation", Qerror);
2087 DEFERROR (Qinvalid_change, "Attempt to set properties or values incorrectly",
2088 Qinvalid_operation);
2089 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol",
2092 DEFERROR (Qediting_error, "Invalid operation during editing",
2093 Qinvalid_operation);
2094 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error);
2095 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error);
2096 DEFERROR (Qbuffer_read_only, "Buffer is read-only", Qediting_error);
2098 DEFERROR (Qio_error, "IO Error", Qinvalid_operation);
2099 DEFERROR (Qend_of_file, "End of file or stream", Qio_error);
2101 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation);
2102 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error);
2103 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error);
2104 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error);
2105 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error);
2106 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error);
2112 INIT_LRECORD_IMPLEMENTATION (weak_list);
2115 DEFSYMBOL (Qlambda);
2117 DEFSYMBOL (Qtrue_list_p);
2120 DEFSYMBOL (Qsymbolp);
2121 DEFSYMBOL (Qintegerp);
2122 DEFSYMBOL (Qcharacterp);
2123 DEFSYMBOL (Qnatnump);
2124 DEFSYMBOL (Qstringp);
2125 DEFSYMBOL (Qarrayp);
2126 DEFSYMBOL (Qsequencep);
2127 DEFSYMBOL (Qbufferp);
2129 DEFSYMBOL_MULTIWORD_PREDICATE (Qbit_vectorp);
2130 DEFSYMBOL (Qvectorp);
2131 DEFSYMBOL (Qchar_or_string_p);
2132 DEFSYMBOL (Qmarkerp);
2133 DEFSYMBOL (Qinteger_or_marker_p);
2134 DEFSYMBOL (Qinteger_or_char_p);
2135 DEFSYMBOL (Qinteger_char_or_marker_p);
2136 DEFSYMBOL (Qnumberp);
2137 DEFSYMBOL (Qnumber_char_or_marker_p);
2139 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp);
2141 #ifdef LISP_FLOAT_TYPE
2142 DEFSYMBOL (Qfloatp);
2143 #endif /* LISP_FLOAT_TYPE */
2145 DEFSUBR (Fwrong_type_argument);
2150 Ffset (intern ("not"), intern ("null"));
2153 DEFSUBR (Ftrue_list_p);
2156 DEFSUBR (Fchar_or_string_p);
2157 DEFSUBR (Fcharacterp);
2158 DEFSUBR (Fchar_int_p);
2159 DEFSUBR (Fchar_to_int);
2160 DEFSUBR (Fint_to_char);
2161 DEFSUBR (Fchar_or_char_int_p);
2162 DEFSUBR (Fintegerp);
2163 DEFSUBR (Finteger_or_marker_p);
2164 DEFSUBR (Finteger_or_char_p);
2165 DEFSUBR (Finteger_char_or_marker_p);
2167 DEFSUBR (Fnumber_or_marker_p);
2168 DEFSUBR (Fnumber_char_or_marker_p);
2169 #ifdef LISP_FLOAT_TYPE
2171 #endif /* LISP_FLOAT_TYPE */
2174 DEFSUBR (Fkeywordp);
2178 DEFSUBR (Fbit_vector_p);
2180 DEFSUBR (Fsequencep);
2183 DEFSUBR (Fsubr_min_args);
2184 DEFSUBR (Fsubr_max_args);
2185 DEFSUBR (Fsubr_interactive);
2189 DEFSUBR (Fcar_safe);
2190 DEFSUBR (Fcdr_safe);
2193 DEFSUBR (Findirect_function);
2197 DEFSUBR (Fnumber_to_string);
2198 DEFSUBR (Fstring_to_number);
2223 DEFSUBR (Fweak_list_p);
2224 DEFSUBR (Fmake_weak_list);
2225 DEFSUBR (Fweak_list_type);
2226 DEFSUBR (Fweak_list_list);
2227 DEFSUBR (Fset_weak_list_list);
2233 /* This must not be staticpro'd */
2234 Vall_weak_lists = Qnil;
2235 dump_add_weak_object_chain (&Vall_weak_lists);
2238 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2239 If non-zero, note when your code may be suffering from char-int confoundance.
2240 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2241 etc. where an int and a char with the same value are being compared,
2242 it will issue a notice on stderr to this effect, along with a backtrace.
2243 In such situations, the result would be different in XEmacs 19 versus
2244 XEmacs 20, and you probably don't want this.
2246 Note that in order to see these notices, you have to byte compile your
2247 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2248 have its chars and ints all confounded in the byte code, making it
2249 impossible to accurately determine Ebola infection.
2252 debug_issue_ebola_notices = 0;
2254 DEFVAR_INT ("debug-ebola-backtrace-length",
2255 &debug_ebola_backtrace_length /*
2256 Length (in stack frames) of short backtrace printed out in Ebola notices.
2257 See `debug-issue-ebola-notices'.
2259 debug_ebola_backtrace_length = 32;
2261 #endif /* DEBUG_XEMACS */