1 /* Primitive operations on Lisp data types for XEmacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995
3 Free Software Foundation, Inc.
4 Copyright (C) 2000 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
26 /* This file has been Mule-ized. */
33 #include "syssignal.h"
35 #ifdef LISP_FLOAT_TYPE
36 /* Need to define a differentiating symbol -- see sysfloat.h */
37 # define THIS_FILENAME data_c
38 # include "sysfloat.h"
39 #endif /* LISP_FLOAT_TYPE */
41 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
42 Lisp_Object Qerror_conditions, Qerror_message;
43 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
44 Lisp_Object Qlist_formation_error;
45 Lisp_Object Qmalformed_list, Qmalformed_property_list;
46 Lisp_Object Qcircular_list, Qcircular_property_list;
47 Lisp_Object Qinvalid_argument, Qwrong_type_argument, Qargs_out_of_range;
48 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch;
49 Lisp_Object Qinternal_error, Qinvalid_state;
50 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
51 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
52 Lisp_Object Qinvalid_operation, Qinvalid_change;
53 Lisp_Object Qsetting_constant;
54 Lisp_Object Qediting_error;
55 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
56 Lisp_Object Qio_error, Qend_of_file;
57 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
58 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
59 Lisp_Object Qintegerp, Qnatnump, Qsymbolp;
60 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
61 Lisp_Object Qconsp, Qsubrp;
62 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
63 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
64 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
65 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
66 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
72 int debug_issue_ebola_notices;
74 Fixnum debug_ebola_backtrace_length;
77 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
79 if (debug_issue_ebola_notices
80 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
82 /* #### It would be really nice if this were a proper warning
83 instead of brain-dead print to Qexternal_debugging_output. */
84 write_c_string ("Comparison between integer and character is constant nil (",
85 Qexternal_debugging_output);
86 Fprinc (obj1, Qexternal_debugging_output);
87 write_c_string (" and ", Qexternal_debugging_output);
88 Fprinc (obj2, Qexternal_debugging_output);
89 write_c_string (")\n", Qexternal_debugging_output);
90 debug_short_backtrace (debug_ebola_backtrace_length);
92 return EQ (obj1, obj2);
95 #endif /* DEBUG_XEMACS */
100 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
102 /* This function can GC */
103 REGISTER Lisp_Object tem;
106 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
107 tem = call1 (predicate, value);
114 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
116 signal_error (Qwrong_type_argument, list2 (predicate, value));
119 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
120 Signal an error until the correct type value is given by the user.
121 This function loops, signalling a continuable `wrong-type-argument' error
122 with PREDICATE and VALUE as the data associated with the error and then
123 calling PREDICATE on the returned value, until the value gotten satisfies
124 PREDICATE. At that point, the gotten value is returned.
128 return wrong_type_argument (predicate, value);
132 c_write_error (Lisp_Object obj)
134 signal_simple_error ("Attempt to modify read-only object (c)", obj);
138 lisp_write_error (Lisp_Object obj)
140 signal_simple_error ("Attempt to modify read-only object (lisp)", obj);
144 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
146 signal_error (Qargs_out_of_range, list2 (a1, a2));
150 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
152 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
156 check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max)
158 if (val < min || val > max)
159 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
162 /* On some machines, XINT needs a temporary location.
163 Here it is, in case it is needed. */
165 EMACS_INT sign_extend_temp;
167 /* On a few machines, XINT can only be done by calling this. */
168 /* XEmacs: only used by m/convex.h */
169 EMACS_INT sign_extend_lisp_int (EMACS_INT num);
171 sign_extend_lisp_int (EMACS_INT num)
173 if (num & (1L << (INT_VALBITS - 1)))
174 return num | ((-1L) << INT_VALBITS);
176 return num & (EMACS_INT) ((1UL << INT_VALBITS) - 1);
180 /* Data type predicates */
182 DEFUN ("eq", Feq, 2, 2, 0, /*
183 Return t if the two args are the same Lisp object.
187 return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil;
190 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
191 Return t if the two args are (in most cases) the same Lisp object.
193 Special kludge: A character is considered `old-eq' to its equivalent integer
194 even though they are not the same object and are in fact of different
195 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
196 preserve byte-code compatibility with v19. This kludge is known as the
197 \"char-int confoundance disease\" and appears in a number of other
198 functions with `old-foo' equivalents.
200 Do not use this function!
205 return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
208 DEFUN ("null", Fnull, 1, 1, 0, /*
209 Return t if OBJECT is nil.
213 return NILP (object) ? Qt : Qnil;
216 DEFUN ("consp", Fconsp, 1, 1, 0, /*
217 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
221 return CONSP (object) ? Qt : Qnil;
224 DEFUN ("atom", Fatom, 1, 1, 0, /*
225 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
229 return CONSP (object) ? Qnil : Qt;
232 DEFUN ("listp", Flistp, 1, 1, 0, /*
233 Return t if OBJECT is a list. `nil' is a list.
237 return LISTP (object) ? Qt : Qnil;
240 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
241 Return t if OBJECT is not a list. `nil' is a list.
245 return LISTP (object) ? Qnil : Qt;
248 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
249 Return t if OBJECT is an acyclic, nil-terminated (ie, not dotted), list.
253 return TRUE_LIST_P (object) ? Qt : Qnil;
256 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
257 Return t if OBJECT is a symbol.
261 return SYMBOLP (object) ? Qt : Qnil;
264 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
265 Return t if OBJECT is a keyword.
269 return KEYWORDP (object) ? Qt : Qnil;
272 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
273 Return t if OBJECT is a vector.
277 return VECTORP (object) ? Qt : Qnil;
280 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
281 Return t if OBJECT is a bit vector.
285 return BIT_VECTORP (object) ? Qt : Qnil;
288 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
289 Return t if OBJECT is a string.
293 return STRINGP (object) ? Qt : Qnil;
296 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
297 Return t if OBJECT is an array (string, vector, or bit vector).
301 return (VECTORP (object) ||
303 BIT_VECTORP (object))
307 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
308 Return t if OBJECT is a sequence (list or array).
312 return (LISTP (object) ||
315 BIT_VECTORP (object))
319 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
320 Return t if OBJECT is a marker (editor pointer).
324 return MARKERP (object) ? Qt : Qnil;
327 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
328 Return t if OBJECT is a built-in function.
332 return SUBRP (object) ? Qt : Qnil;
335 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
336 Return minimum number of args built-in function SUBR may be called with.
341 return make_int (XSUBR (subr)->min_args);
344 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
345 Return maximum number of args built-in function SUBR may be called with,
346 or nil if it takes an arbitrary number of arguments or is a special form.
352 nargs = XSUBR (subr)->max_args;
353 if (nargs == MANY || nargs == UNEVALLED)
356 return make_int (nargs);
359 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
360 Return the interactive spec of the subr object SUBR, or nil.
361 If non-nil, the return value will be a list whose first element is
362 `interactive' and whose second element is the interactive spec.
368 prompt = XSUBR (subr)->prompt;
369 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
373 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
374 Return t if OBJECT is a character.
375 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
376 Any character can be converted into an equivalent integer using
377 `char-int'. To convert the other way, use `int-char'; however,
378 only some integers can be converted into characters. Such an integer
379 is called a `char-int'; see `char-int-p'.
381 Some functions that work on integers (e.g. the comparison functions
382 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
383 accept characters and implicitly convert them into integers. In
384 general, functions that work on characters also accept char-ints and
385 implicitly convert them into characters. WARNING: Neither of these
386 behaviors is very desirable, and they are maintained for backward
387 compatibility with old E-Lisp programs that confounded characters and
388 integers willy-nilly. These behaviors may change in the future; therefore,
389 do not rely on them. Instead, use the character-specific functions such
394 return CHARP (object) ? Qt : Qnil;
397 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
398 Convert CHARACTER into an equivalent integer.
399 The resulting integer will always be non-negative. The integers in
400 the range 0 - 255 map to characters as follows:
404 128 - 159 Control set 1
405 160 - 255 Right half of ISO-8859-1
407 If support for Mule does not exist, these are the only valid character
408 values. When Mule support exists, the values assigned to other characters
409 may vary depending on the particular version of XEmacs, the order in which
410 character sets were loaded, etc., and you should not depend on them.
414 CHECK_CHAR (character);
415 return make_int (XCHAR (character));
418 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
419 Convert integer INTEGER into the equivalent character.
420 Not all integers correspond to valid characters; use `char-int-p' to
421 determine whether this is the case. If the integer cannot be converted,
427 if (CHAR_INTP (integer))
428 return make_char (XINT (integer));
433 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
434 Return t if OBJECT is an integer that can be converted into a character.
439 return CHAR_INTP (object) ? Qt : Qnil;
442 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
443 Return t if OBJECT is a character or an integer that can be converted into one.
447 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
450 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
451 Return t if OBJECT is a character (or a char-int) or a string.
452 It is semi-hateful that we allow a char-int here, as it goes against
453 the name of this function, but it makes the most sense considering the
454 other steps we take to maintain compatibility with the old character/integer
455 confoundedness in older versions of E-Lisp.
459 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
462 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
463 Return t if OBJECT is an integer.
467 return INTP (object) ? Qt : Qnil;
470 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
471 Return t if OBJECT is an integer or a marker (editor pointer).
475 return INTP (object) || MARKERP (object) ? Qt : Qnil;
478 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
479 Return t if OBJECT is an integer or a character.
483 return INTP (object) || CHARP (object) ? Qt : Qnil;
486 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
487 Return t if OBJECT is an integer, character or a marker (editor pointer).
491 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
494 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
495 Return t if OBJECT is a nonnegative integer.
499 return NATNUMP (object) ? Qt : Qnil;
502 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
503 Return t if OBJECT is a bit (0 or 1).
507 return BITP (object) ? Qt : Qnil;
510 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
511 Return t if OBJECT is a number (floating point or integer).
515 return INT_OR_FLOATP (object) ? Qt : Qnil;
518 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
519 Return t if OBJECT is a number or a marker.
523 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
526 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
527 Return t if OBJECT is a number, character or a marker.
531 return (INT_OR_FLOATP (object) ||
537 #ifdef LISP_FLOAT_TYPE
538 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
539 Return t if OBJECT is a floating point number.
543 return FLOATP (object) ? Qt : Qnil;
545 #endif /* LISP_FLOAT_TYPE */
547 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
548 Return a symbol representing the type of OBJECT.
552 switch (XTYPE (object))
554 case Lisp_Type_Record:
555 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
557 case Lisp_Type_Char: return Qcharacter;
559 default: return Qinteger;
564 /* Extract and set components of lists */
566 DEFUN ("car", Fcar, 1, 1, 0, /*
567 Return the car of LIST. If arg is nil, return nil.
568 Error if arg is not nil and not a cons cell. See also `car-safe'.
576 else if (NILP (list))
579 list = wrong_type_argument (Qlistp, list);
583 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
584 Return the car of OBJECT if it is a cons cell, or else nil.
588 return CONSP (object) ? XCAR (object) : Qnil;
591 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
592 Return the cdr of LIST. If arg is nil, return nil.
593 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
601 else if (NILP (list))
604 list = wrong_type_argument (Qlistp, list);
608 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
609 Return the cdr of OBJECT if it is a cons cell, else nil.
613 return CONSP (object) ? XCDR (object) : Qnil;
616 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
617 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR.
621 if (!CONSP (cons_cell))
622 cons_cell = wrong_type_argument (Qconsp, cons_cell);
624 XCAR (cons_cell) = newcar;
628 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
629 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR.
633 if (!CONSP (cons_cell))
634 cons_cell = wrong_type_argument (Qconsp, cons_cell);
636 XCDR (cons_cell) = newcdr;
640 /* Find the function at the end of a chain of symbol function indirections.
642 If OBJECT is a symbol, find the end of its function chain and
643 return the value found there. If OBJECT is not a symbol, just
644 return it. If there is a cycle in the function chain, signal a
645 cyclic-function-indirection error.
647 This is like Findirect_function when VOID_FUNCTION_ERRORP is true.
648 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end
649 of the chain ends up being Qunbound. */
651 indirect_function (Lisp_Object object, int void_function_errorp)
653 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
654 Lisp_Object tortoise, hare;
657 for (hare = tortoise = object, count = 0;
659 hare = XSYMBOL (hare)->function, count++)
661 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
664 tortoise = XSYMBOL (tortoise)->function;
665 if (EQ (hare, tortoise))
666 return Fsignal (Qcyclic_function_indirection, list1 (object));
669 if (void_function_errorp && UNBOUNDP (hare))
670 return signal_void_function_error (object);
675 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
676 Return the function at the end of OBJECT's function chain.
677 If OBJECT is a symbol, follow all function indirections and return
678 the final function binding.
679 If OBJECT is not a symbol, just return it.
680 Signal a void-function error if the final symbol is unbound.
681 Signal a cyclic-function-indirection error if there is a loop in the
682 function chain of symbols.
686 return indirect_function (object, 1);
689 /* Extract and set vector and string elements */
691 DEFUN ("aref", Faref, 2, 2, 0, /*
692 Return the element of ARRAY at index INDEX.
693 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
701 if (INTP (index_)) idx = XINT (index_);
702 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
705 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
709 if (idx < 0) goto range_error;
713 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
714 return XVECTOR_DATA (array)[idx];
716 else if (BIT_VECTORP (array))
718 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
719 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
721 else if (STRINGP (array))
723 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
724 return make_char (string_char (XSTRING (array), idx));
726 #ifdef LOSING_BYTECODE
727 else if (COMPILED_FUNCTIONP (array))
729 /* Weird, gross compatibility kludge */
730 return Felt (array, index_);
735 check_losing_bytecode ("aref", array);
736 array = wrong_type_argument (Qarrayp, array);
741 args_out_of_range (array, index_);
742 return Qnil; /* not reached */
745 DEFUN ("aset", Faset, 3, 3, 0, /*
746 Store into the element of ARRAY at index INDEX the value NEWVAL.
747 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
749 (array, index_, newval))
755 if (INTP (index_)) idx = XINT (index_);
756 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
759 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
763 if (idx < 0) goto range_error;
767 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
768 XVECTOR_DATA (array)[idx] = newval;
770 else if (BIT_VECTORP (array))
772 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
774 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
776 else if (STRINGP (array))
778 CHECK_CHAR_COERCE_INT (newval);
779 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
780 set_string_char (XSTRING (array), idx, XCHAR (newval));
781 bump_string_modiff (array);
785 array = wrong_type_argument (Qarrayp, array);
792 args_out_of_range (array, index_);
793 return Qnil; /* not reached */
797 /**********************************************************************/
798 /* Arithmetic functions */
799 /**********************************************************************/
811 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
815 if (INTP (obj)) p->c.ival = XINT (obj);
816 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
817 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
818 #ifdef LISP_FLOAT_TYPE
819 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
823 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
829 number_char_or_marker_to_double (Lisp_Object obj)
832 if (INTP (obj)) return (double) XINT (obj);
833 else if (CHARP (obj)) return (double) XCHAR (obj);
834 else if (MARKERP (obj)) return (double) marker_position (obj);
835 #ifdef LISP_FLOAT_TYPE
836 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
840 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
846 integer_char_or_marker_to_int (Lisp_Object obj)
849 if (INTP (obj)) return XINT (obj);
850 else if (CHARP (obj)) return XCHAR (obj);
851 else if (MARKERP (obj)) return marker_position (obj);
854 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
859 #define ARITHCOMPARE_MANY(op) \
861 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
862 Lisp_Object *args_end = args + nargs; \
864 number_char_or_marker_to_int_or_double (*args++, p); \
866 while (args < args_end) \
868 number_char_or_marker_to_int_or_double (*args++, q); \
870 if (!((p->int_p && q->int_p) ? \
871 (p->c.ival op q->c.ival) : \
872 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
873 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
876 { /* swap */ int_or_double *r = p; p = q; q = r; } \
881 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
882 Return t if all the arguments are numerically equal.
883 The arguments may be numbers, characters or markers.
885 (int nargs, Lisp_Object *args))
887 ARITHCOMPARE_MANY (==)
890 DEFUN ("<", Flss, 1, MANY, 0, /*
891 Return t if the sequence of arguments is monotonically increasing.
892 The arguments may be numbers, characters or markers.
894 (int nargs, Lisp_Object *args))
896 ARITHCOMPARE_MANY (<)
899 DEFUN (">", Fgtr, 1, MANY, 0, /*
900 Return t if the sequence of arguments is monotonically decreasing.
901 The arguments may be numbers, characters or markers.
903 (int nargs, Lisp_Object *args))
905 ARITHCOMPARE_MANY (>)
908 DEFUN ("<=", Fleq, 1, MANY, 0, /*
909 Return t if the sequence of arguments is monotonically nondecreasing.
910 The arguments may be numbers, characters or markers.
912 (int nargs, Lisp_Object *args))
914 ARITHCOMPARE_MANY (<=)
917 DEFUN (">=", Fgeq, 1, MANY, 0, /*
918 Return t if the sequence of arguments is monotonically nonincreasing.
919 The arguments may be numbers, characters or markers.
921 (int nargs, Lisp_Object *args))
923 ARITHCOMPARE_MANY (>=)
926 DEFUN ("/=", Fneq, 1, MANY, 0, /*
927 Return t if no two arguments are numerically equal.
928 The arguments may be numbers, characters or markers.
930 (int nargs, Lisp_Object *args))
932 Lisp_Object *args_end = args + nargs;
935 /* Unlike all the other comparisons, this is an N*N algorithm.
936 We could use a hash table for nargs > 50 to make this linear. */
937 for (p = args; p < args_end; p++)
939 int_or_double iod1, iod2;
940 number_char_or_marker_to_int_or_double (*p, &iod1);
942 for (q = p + 1; q < args_end; q++)
944 number_char_or_marker_to_int_or_double (*q, &iod2);
946 if (!((iod1.int_p && iod2.int_p) ?
947 (iod1.c.ival != iod2.c.ival) :
948 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
949 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
956 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
957 Return t if NUMBER is zero.
963 return EQ (number, Qzero) ? Qt : Qnil;
964 #ifdef LISP_FLOAT_TYPE
965 else if (FLOATP (number))
966 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
967 #endif /* LISP_FLOAT_TYPE */
970 number = wrong_type_argument (Qnumberp, number);
975 /* Convert between a 32-bit value and a cons of two 16-bit values.
976 This is used to pass 32-bit integers to and from the user.
977 Use time_to_lisp() and lisp_to_time() for time values.
979 If you're thinking of using this to store a pointer into a Lisp Object
980 for internal purposes (such as when calling record_unwind_protect()),
981 try using make_opaque_ptr()/get_opaque_ptr() instead. */
983 word_to_lisp (unsigned int item)
985 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
989 lisp_to_word (Lisp_Object item)
995 Lisp_Object top = Fcar (item);
996 Lisp_Object bot = Fcdr (item);
999 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
1004 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
1005 Convert NUMBER to a string by printing it in decimal.
1006 Uses a minus sign if negative.
1007 NUMBER may be an integer or a floating point number.
1011 char buffer[VALBITS];
1013 CHECK_INT_OR_FLOAT (number);
1015 #ifdef LISP_FLOAT_TYPE
1016 if (FLOATP (number))
1018 char pigbuf[350]; /* see comments in float_to_string */
1020 float_to_string (pigbuf, XFLOAT_DATA (number));
1021 return build_string (pigbuf);
1023 #endif /* LISP_FLOAT_TYPE */
1025 long_to_string (buffer, XINT (number));
1026 return build_string (buffer);
1030 digit_to_number (int character, int base)
1033 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1034 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
1035 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
1038 return digit >= base ? -1 : digit;
1041 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
1042 Convert STRING to a number by parsing it as a number in base BASE.
1043 This parses both integers and floating point numbers.
1044 It ignores leading spaces and tabs.
1046 If BASE is nil or omitted, base 10 is used.
1047 BASE must be an integer between 2 and 16 (inclusive).
1048 Floating point numbers always use base 10.
1055 CHECK_STRING (string);
1063 check_int_range (b, 2, 16);
1066 p = (char *) XSTRING_DATA (string);
1068 /* Skip any whitespace at the front of the number. Some versions of
1069 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1070 while (*p == ' ' || *p == '\t')
1073 #ifdef LISP_FLOAT_TYPE
1074 if (isfloat_string (p) && b == 10)
1075 return make_float (atof (p));
1076 #endif /* LISP_FLOAT_TYPE */
1080 /* Use the system-provided functions for base 10. */
1081 #if SIZEOF_EMACS_INT == SIZEOF_INT
1082 return make_int (atoi (p));
1083 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1084 return make_int (atol (p));
1085 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1086 return make_int (atoll (p));
1103 int digit = digit_to_number (*p++, b);
1108 return make_int (negative * v);
1113 DEFUN ("+", Fplus, 0, MANY, 0, /*
1114 Return sum of any number of arguments.
1115 The arguments should all be numbers, characters or markers.
1117 (int nargs, Lisp_Object *args))
1119 EMACS_INT iaccum = 0;
1120 Lisp_Object *args_end = args + nargs;
1122 while (args < args_end)
1125 number_char_or_marker_to_int_or_double (*args++, &iod);
1127 iaccum += iod.c.ival;
1130 double daccum = (double) iaccum + iod.c.dval;
1131 while (args < args_end)
1132 daccum += number_char_or_marker_to_double (*args++);
1133 return make_float (daccum);
1137 return make_int (iaccum);
1140 DEFUN ("-", Fminus, 1, MANY, 0, /*
1141 Negate number or subtract numbers, characters or markers.
1142 With one arg, negates it. With more than one arg,
1143 subtracts all but the first from the first.
1145 (int nargs, Lisp_Object *args))
1149 Lisp_Object *args_end = args + nargs;
1152 number_char_or_marker_to_int_or_double (*args++, &iod);
1154 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
1157 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
1161 while (args < args_end)
1163 number_char_or_marker_to_int_or_double (*args++, &iod);
1165 iaccum -= iod.c.ival;
1168 daccum = (double) iaccum - iod.c.dval;
1173 return make_int (iaccum);
1176 for (; args < args_end; args++)
1177 daccum -= number_char_or_marker_to_double (*args);
1178 return make_float (daccum);
1181 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1182 Return product of any number of arguments.
1183 The arguments should all be numbers, characters or markers.
1185 (int nargs, Lisp_Object *args))
1187 EMACS_INT iaccum = 1;
1188 Lisp_Object *args_end = args + nargs;
1190 while (args < args_end)
1193 number_char_or_marker_to_int_or_double (*args++, &iod);
1195 iaccum *= iod.c.ival;
1198 double daccum = (double) iaccum * iod.c.dval;
1199 while (args < args_end)
1200 daccum *= number_char_or_marker_to_double (*args++);
1201 return make_float (daccum);
1205 return make_int (iaccum);
1208 DEFUN ("/", Fquo, 1, MANY, 0, /*
1209 Return first argument divided by all the remaining arguments.
1210 The arguments must be numbers, characters or markers.
1211 With one argument, reciprocates the argument.
1213 (int nargs, Lisp_Object *args))
1217 Lisp_Object *args_end = args + nargs;
1224 number_char_or_marker_to_int_or_double (*args++, &iod);
1226 iaccum = iod.c.ival;
1229 daccum = iod.c.dval;
1234 while (args < args_end)
1236 number_char_or_marker_to_int_or_double (*args++, &iod);
1239 if (iod.c.ival == 0) goto divide_by_zero;
1240 iaccum /= iod.c.ival;
1244 if (iod.c.dval == 0) goto divide_by_zero;
1245 daccum = (double) iaccum / iod.c.dval;
1250 return make_int (iaccum);
1253 for (; args < args_end; args++)
1255 double dval = number_char_or_marker_to_double (*args);
1256 if (dval == 0) goto divide_by_zero;
1259 return make_float (daccum);
1262 Fsignal (Qarith_error, Qnil);
1263 return Qnil; /* not reached */
1266 DEFUN ("max", Fmax, 1, MANY, 0, /*
1267 Return largest of all the arguments.
1268 All arguments must be numbers, characters or markers.
1269 The value is always a number; markers and characters are converted
1272 (int nargs, Lisp_Object *args))
1276 Lisp_Object *args_end = args + nargs;
1279 number_char_or_marker_to_int_or_double (*args++, &iod);
1288 while (args < args_end)
1290 number_char_or_marker_to_int_or_double (*args++, &iod);
1293 if (imax < iod.c.ival) imax = iod.c.ival;
1297 dmax = (double) imax;
1298 if (dmax < iod.c.dval) dmax = iod.c.dval;
1303 return make_int (imax);
1306 while (args < args_end)
1308 double dval = number_char_or_marker_to_double (*args++);
1309 if (dmax < dval) dmax = dval;
1311 return make_float (dmax);
1314 DEFUN ("min", Fmin, 1, MANY, 0, /*
1315 Return smallest of all the arguments.
1316 All arguments must be numbers, characters or markers.
1317 The value is always a number; markers and characters are converted
1320 (int nargs, Lisp_Object *args))
1324 Lisp_Object *args_end = args + nargs;
1327 number_char_or_marker_to_int_or_double (*args++, &iod);
1336 while (args < args_end)
1338 number_char_or_marker_to_int_or_double (*args++, &iod);
1341 if (imin > iod.c.ival) imin = iod.c.ival;
1345 dmin = (double) imin;
1346 if (dmin > iod.c.dval) dmin = iod.c.dval;
1351 return make_int (imin);
1354 while (args < args_end)
1356 double dval = number_char_or_marker_to_double (*args++);
1357 if (dmin > dval) dmin = dval;
1359 return make_float (dmin);
1362 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1363 Return bitwise-and of all the arguments.
1364 Arguments may be integers, or markers or characters converted to integers.
1366 (int nargs, Lisp_Object *args))
1368 EMACS_INT bits = ~0;
1369 Lisp_Object *args_end = args + nargs;
1371 while (args < args_end)
1372 bits &= integer_char_or_marker_to_int (*args++);
1374 return make_int (bits);
1377 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1378 Return bitwise-or of all the arguments.
1379 Arguments may be integers, or markers or characters converted to integers.
1381 (int nargs, Lisp_Object *args))
1384 Lisp_Object *args_end = args + nargs;
1386 while (args < args_end)
1387 bits |= integer_char_or_marker_to_int (*args++);
1389 return make_int (bits);
1392 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1393 Return bitwise-exclusive-or of all the arguments.
1394 Arguments may be integers, or markers or characters converted to integers.
1396 (int nargs, Lisp_Object *args))
1399 Lisp_Object *args_end = args + nargs;
1401 while (args < args_end)
1402 bits ^= integer_char_or_marker_to_int (*args++);
1404 return make_int (bits);
1407 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1408 Return the bitwise complement of NUMBER.
1409 NUMBER may be an integer, marker or character converted to integer.
1413 return make_int (~ integer_char_or_marker_to_int (number));
1416 DEFUN ("%", Frem, 2, 2, 0, /*
1417 Return remainder of first arg divided by second.
1418 Both must be integers, characters or markers.
1422 EMACS_INT ival1 = integer_char_or_marker_to_int (number1);
1423 EMACS_INT ival2 = integer_char_or_marker_to_int (number2);
1426 Fsignal (Qarith_error, Qnil);
1428 return make_int (ival1 % ival2);
1431 /* Note, ANSI *requires* the presence of the fmod() library routine.
1432 If your system doesn't have it, complain to your vendor, because
1437 fmod (double f1, double f2)
1441 return f1 - f2 * floor (f1/f2);
1443 #endif /* ! HAVE_FMOD */
1446 DEFUN ("mod", Fmod, 2, 2, 0, /*
1448 The result falls between zero (inclusive) and Y (exclusive).
1449 Both X and Y must be numbers, characters or markers.
1450 If either argument is a float, a float will be returned.
1454 int_or_double iod1, iod2;
1455 number_char_or_marker_to_int_or_double (x, &iod1);
1456 number_char_or_marker_to_int_or_double (y, &iod2);
1458 #ifdef LISP_FLOAT_TYPE
1459 if (!iod1.int_p || !iod2.int_p)
1461 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
1462 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
1463 if (dval2 == 0) goto divide_by_zero;
1464 dval1 = fmod (dval1, dval2);
1466 /* If the "remainder" comes out with the wrong sign, fix it. */
1467 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
1470 return make_float (dval1);
1472 #endif /* LISP_FLOAT_TYPE */
1475 if (iod2.c.ival == 0) goto divide_by_zero;
1477 ival = iod1.c.ival % iod2.c.ival;
1479 /* If the "remainder" comes out with the wrong sign, fix it. */
1480 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
1481 ival += iod2.c.ival;
1483 return make_int (ival);
1487 Fsignal (Qarith_error, Qnil);
1488 return Qnil; /* not reached */
1491 DEFUN ("ash", Fash, 2, 2, 0, /*
1492 Return VALUE with its bits shifted left by COUNT.
1493 If COUNT is negative, shifting is actually to the right.
1494 In this case, the sign bit is duplicated.
1498 CHECK_INT_COERCE_CHAR (value);
1499 CONCHECK_INT (count);
1501 return make_int (XINT (count) > 0 ?
1502 XINT (value) << XINT (count) :
1503 XINT (value) >> -XINT (count));
1506 DEFUN ("lsh", Flsh, 2, 2, 0, /*
1507 Return VALUE with its bits shifted left by COUNT.
1508 If COUNT is negative, shifting is actually to the right.
1509 In this case, zeros are shifted in on the left.
1513 CHECK_INT_COERCE_CHAR (value);
1514 CONCHECK_INT (count);
1516 return make_int (XINT (count) > 0 ?
1517 XUINT (value) << XINT (count) :
1518 XUINT (value) >> -XINT (count));
1521 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1522 Return NUMBER plus one. NUMBER may be a number, character or marker.
1523 Markers and characters are converted to integers.
1529 if (INTP (number)) return make_int (XINT (number) + 1);
1530 if (CHARP (number)) return make_int (XCHAR (number) + 1);
1531 if (MARKERP (number)) return make_int (marker_position (number) + 1);
1532 #ifdef LISP_FLOAT_TYPE
1533 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1534 #endif /* LISP_FLOAT_TYPE */
1536 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1540 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1541 Return NUMBER minus one. NUMBER may be a number, character or marker.
1542 Markers and characters are converted to integers.
1548 if (INTP (number)) return make_int (XINT (number) - 1);
1549 if (CHARP (number)) return make_int (XCHAR (number) - 1);
1550 if (MARKERP (number)) return make_int (marker_position (number) - 1);
1551 #ifdef LISP_FLOAT_TYPE
1552 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1553 #endif /* LISP_FLOAT_TYPE */
1555 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1560 /************************************************************************/
1562 /************************************************************************/
1564 /* A weak list is like a normal list except that elements automatically
1565 disappear when no longer in use, i.e. when no longer GC-protected.
1566 The basic idea is that we don't mark the elements during GC, but
1567 wait for them to be marked elsewhere. If they're not marked, we
1568 remove them. This is analogous to weak hash tables; see the explanation
1569 there for more info. */
1571 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1573 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1576 mark_weak_list (Lisp_Object obj)
1578 return Qnil; /* nichts ist gemarkt */
1582 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1585 error ("printing unreadable object #<weak-list>");
1587 write_c_string ("#<weak-list ", printcharfun);
1588 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
1590 write_c_string (" ", printcharfun);
1591 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1592 write_c_string (">", printcharfun);
1596 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1598 struct weak_list *w1 = XWEAK_LIST (obj1);
1599 struct weak_list *w2 = XWEAK_LIST (obj2);
1601 return ((w1->type == w2->type) &&
1602 internal_equal (w1->list, w2->list, depth + 1));
1605 static unsigned long
1606 weak_list_hash (Lisp_Object obj, int depth)
1608 struct weak_list *w = XWEAK_LIST (obj);
1610 return HASH2 ((unsigned long) w->type,
1611 internal_hash (w->list, depth + 1));
1615 make_weak_list (enum weak_list_type type)
1618 struct weak_list *wl =
1619 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
1623 XSETWEAK_LIST (result, wl);
1624 wl->next_weak = Vall_weak_lists;
1625 Vall_weak_lists = result;
1629 static const struct lrecord_description weak_list_description[] = {
1630 { XD_LISP_OBJECT, offsetof (struct weak_list, list) },
1631 { XD_LO_LINK, offsetof (struct weak_list, next_weak) },
1635 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1636 mark_weak_list, print_weak_list,
1637 0, weak_list_equal, weak_list_hash,
1638 weak_list_description,
1641 -- we do not mark the list elements (either the elements themselves
1642 or the cons cells that hold them) in the normal marking phase.
1643 -- at the end of marking, we go through all weak lists that are
1644 marked, and mark the cons cells that hold all marked
1645 objects, and possibly parts of the objects themselves.
1646 (See alloc.c, "after-mark".)
1647 -- after that, we prune away all the cons cells that are not marked.
1649 WARNING WARNING WARNING WARNING WARNING:
1651 The code in the following two functions is *unbelievably* tricky.
1652 Don't mess with it. You'll be sorry.
1654 Linked lists just majorly suck, d'ya know?
1658 finish_marking_weak_lists (void)
1663 for (rest = Vall_weak_lists;
1665 rest = XWEAK_LIST (rest)->next_weak)
1668 enum weak_list_type type = XWEAK_LIST (rest)->type;
1670 if (! marked_p (rest))
1671 /* The weak list is probably garbage. Ignore it. */
1674 for (rest2 = XWEAK_LIST (rest)->list;
1675 /* We need to be trickier since we're inside of GC;
1676 use CONSP instead of !NILP in case of user-visible
1679 rest2 = XCDR (rest2))
1682 /* If the element is "marked" (meaning depends on the type
1683 of weak list), we need to mark the cons containing the
1684 element, and maybe the element itself (if only some part
1685 was already marked). */
1686 int need_to_mark_cons = 0;
1687 int need_to_mark_elem = 0;
1689 /* If a cons is already marked, then its car is already marked
1690 (either because of an external pointer or because of
1691 a previous call to this function), and likewise for all
1692 the rest of the elements in the list, so we can stop now. */
1693 if (marked_p (rest2))
1696 elem = XCAR (rest2);
1700 case WEAK_LIST_SIMPLE:
1701 if (marked_p (elem))
1702 need_to_mark_cons = 1;
1705 case WEAK_LIST_ASSOC:
1708 /* just leave bogus elements there */
1709 need_to_mark_cons = 1;
1710 need_to_mark_elem = 1;
1712 else if (marked_p (XCAR (elem)) &&
1713 marked_p (XCDR (elem)))
1715 need_to_mark_cons = 1;
1716 /* We still need to mark elem, because it's
1717 probably not marked. */
1718 need_to_mark_elem = 1;
1722 case WEAK_LIST_KEY_ASSOC:
1725 /* just leave bogus elements there */
1726 need_to_mark_cons = 1;
1727 need_to_mark_elem = 1;
1729 else if (marked_p (XCAR (elem)))
1731 need_to_mark_cons = 1;
1732 /* We still need to mark elem and XCDR (elem);
1733 marking elem does both */
1734 need_to_mark_elem = 1;
1738 case WEAK_LIST_VALUE_ASSOC:
1741 /* just leave bogus elements there */
1742 need_to_mark_cons = 1;
1743 need_to_mark_elem = 1;
1745 else if (marked_p (XCDR (elem)))
1747 need_to_mark_cons = 1;
1748 /* We still need to mark elem and XCAR (elem);
1749 marking elem does both */
1750 need_to_mark_elem = 1;
1754 case WEAK_LIST_FULL_ASSOC:
1757 /* just leave bogus elements there */
1758 need_to_mark_cons = 1;
1759 need_to_mark_elem = 1;
1761 else if (marked_p (XCAR (elem)) ||
1762 marked_p (XCDR (elem)))
1764 need_to_mark_cons = 1;
1765 /* We still need to mark elem and XCAR (elem);
1766 marking elem does both */
1767 need_to_mark_elem = 1;
1775 if (need_to_mark_elem && ! marked_p (elem))
1781 /* We also need to mark the cons that holds the elem or
1782 assoc-pair. We do *not* want to call (mark_object) here
1783 because that will mark the entire list; we just want to
1784 mark the cons itself.
1786 if (need_to_mark_cons)
1788 Lisp_Cons *c = XCONS (rest2);
1789 if (!CONS_MARKED_P (c))
1797 /* In case of imperfect list, need to mark the final cons
1798 because we're not removing it */
1799 if (!NILP (rest2) && ! marked_p (rest2))
1801 mark_object (rest2);
1810 prune_weak_lists (void)
1812 Lisp_Object rest, prev = Qnil;
1814 for (rest = Vall_weak_lists;
1816 rest = XWEAK_LIST (rest)->next_weak)
1818 if (! (marked_p (rest)))
1820 /* This weak list itself is garbage. Remove it from the list. */
1822 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1824 XWEAK_LIST (prev)->next_weak =
1825 XWEAK_LIST (rest)->next_weak;
1829 Lisp_Object rest2, prev2 = Qnil;
1830 Lisp_Object tortoise;
1831 int go_tortoise = 0;
1833 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1834 /* We need to be trickier since we're inside of GC;
1835 use CONSP instead of !NILP in case of user-visible
1839 /* It suffices to check the cons for marking,
1840 regardless of the type of weak list:
1842 -- if the cons is pointed to somewhere else,
1843 then it should stay around and will be marked.
1844 -- otherwise, if it should stay around, it will
1845 have been marked in finish_marking_weak_lists().
1846 -- otherwise, it's not marked and should disappear.
1848 if (! marked_p (rest2))
1852 XWEAK_LIST (rest)->list = XCDR (rest2);
1854 XCDR (prev2) = XCDR (rest2);
1855 rest2 = XCDR (rest2);
1856 /* Ouch. Circularity checking is even trickier
1857 than I thought. When we cut out a link
1858 like this, we can't advance the turtle or
1859 it'll catch up to us. Imagine that we're
1860 standing on floor tiles and moving forward --
1861 what we just did here is as if the floor
1862 tile under us just disappeared and all the
1863 ones ahead of us slid one tile towards us.
1864 In other words, we didn't move at all;
1865 if the tortoise was one step behind us
1866 previously, it still is, and therefore
1867 it must not move. */
1873 /* Implementing circularity checking is trickier here
1874 than in other places because we have to guarantee
1875 that we've processed all elements before exiting
1876 due to a circularity. (In most places, an error
1877 is issued upon encountering a circularity, so it
1878 doesn't really matter if all elements are processed.)
1879 The idea is that we process along with the hare
1880 rather than the tortoise. If at any point in
1881 our forward process we encounter the tortoise,
1882 we must have already visited the spot, so we exit.
1883 (If we process with the tortoise, we can fail to
1884 process cases where a cons points to itself, or
1885 where cons A points to cons B, which points to
1888 rest2 = XCDR (rest2);
1890 tortoise = XCDR (tortoise);
1891 go_tortoise = !go_tortoise;
1892 if (EQ (rest2, tortoise))
1902 static enum weak_list_type
1903 decode_weak_list_type (Lisp_Object symbol)
1905 CHECK_SYMBOL (symbol);
1906 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1907 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1908 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1909 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1910 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1911 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC;
1913 signal_simple_error ("Invalid weak list type", symbol);
1914 return WEAK_LIST_SIMPLE; /* not reached */
1918 encode_weak_list_type (enum weak_list_type type)
1922 case WEAK_LIST_SIMPLE: return Qsimple;
1923 case WEAK_LIST_ASSOC: return Qassoc;
1924 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1925 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1926 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc;
1931 return Qnil; /* not reached */
1934 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
1935 Return non-nil if OBJECT is a weak list.
1939 return WEAK_LISTP (object) ? Qt : Qnil;
1942 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
1943 Return a new weak list object of type TYPE.
1944 A weak list object is an object that contains a list. This list behaves
1945 like any other list except that its elements do not count towards
1946 garbage collection -- if the only pointer to an object is inside a weak
1947 list (other than pointers in similar objects such as weak hash tables),
1948 the object is garbage collected and automatically removed from the list.
1949 This is used internally, for example, to manage the list holding the
1950 children of an extent -- an extent that is unused but has a parent will
1951 still be reclaimed, and will automatically be removed from its parent's
1954 Optional argument TYPE specifies the type of the weak list, and defaults
1955 to `simple'. Recognized types are
1957 `simple' Objects in the list disappear if not pointed to.
1958 `assoc' Objects in the list disappear if they are conses
1959 and either the car or the cdr of the cons is not
1961 `key-assoc' Objects in the list disappear if they are conses
1962 and the car is not pointed to.
1963 `value-assoc' Objects in the list disappear if they are conses
1964 and the cdr is not pointed to.
1965 `full-assoc' Objects in the list disappear if they are conses
1966 and neither the car nor the cdr is pointed to.
1973 return make_weak_list (decode_weak_list_type (type));
1976 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
1977 Return the type of the given weak-list object.
1981 CHECK_WEAK_LIST (weak);
1982 return encode_weak_list_type (XWEAK_LIST (weak)->type);
1985 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
1986 Return the list contained in a weak-list object.
1990 CHECK_WEAK_LIST (weak);
1991 return XWEAK_LIST_LIST (weak);
1994 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
1995 Change the list contained in a weak-list object.
1999 CHECK_WEAK_LIST (weak);
2000 XWEAK_LIST_LIST (weak) = new_list;
2005 /************************************************************************/
2006 /* initialization */
2007 /************************************************************************/
2010 arith_error (int signo)
2012 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
2013 EMACS_UNBLOCK_SIGNAL (signo);
2014 signal_error (Qarith_error, Qnil);
2018 init_data_very_early (void)
2020 /* Don't do this if just dumping out.
2021 We don't want to call `signal' in this case
2022 so that we don't have trouble with dumping
2023 signal-delivering routines in an inconsistent state. */
2027 #endif /* CANNOT_DUMP */
2028 signal (SIGFPE, arith_error);
2030 signal (SIGEMT, arith_error);
2035 init_errors_once_early (void)
2037 DEFSYMBOL (Qerror_conditions);
2038 DEFSYMBOL (Qerror_message);
2040 /* We declare the errors here because some other deferrors depend
2041 on some of the errors below. */
2043 /* ERROR is used as a signaler for random errors for which nothing
2046 DEFERROR (Qerror, "error", Qnil);
2047 DEFERROR_STANDARD (Qquit, Qnil);
2049 DEFERROR (Qunimplemented, "Feature not yet implemented", Qerror);
2050 DEFERROR_STANDARD (Qsyntax_error, Qerror);
2051 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error);
2052 DEFERROR_STANDARD (Qlist_formation_error, Qsyntax_error);
2054 /* Generated by list traversal macros */
2055 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error);
2056 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list);
2057 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error);
2058 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list);
2060 DEFERROR_STANDARD (Qinvalid_argument, Qerror);
2061 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument);
2062 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument);
2063 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument);
2064 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument);
2065 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument);
2067 DEFERROR_STANDARD (Qinternal_error, Qerror);
2069 DEFERROR (Qinvalid_state, "Properties or values have been set incorrectly",
2071 DEFERROR (Qvoid_function, "Symbol's function definition is void",
2073 DEFERROR (Qcyclic_function_indirection,
2074 "Symbol's chain of function indirections contains a loop",
2076 DEFERROR (Qvoid_variable, "Symbol's value as variable is void",
2078 DEFERROR (Qcyclic_variable_indirection,
2079 "Symbol's chain of variable indirections contains a loop",
2082 DEFERROR (Qinvalid_operation,
2083 "Operation not allowed or error during operation", Qerror);
2084 DEFERROR (Qinvalid_change, "Attempt to set properties or values incorrectly",
2085 Qinvalid_operation);
2086 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol",
2089 DEFERROR (Qediting_error, "Invalid operation during editing",
2090 Qinvalid_operation);
2091 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error);
2092 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error);
2093 DEFERROR (Qbuffer_read_only, "Buffer is read-only", Qediting_error);
2095 DEFERROR (Qio_error, "IO Error", Qinvalid_operation);
2096 DEFERROR (Qend_of_file, "End of file or stream", Qio_error);
2098 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation);
2099 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error);
2100 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error);
2101 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error);
2102 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error);
2103 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error);
2109 INIT_LRECORD_IMPLEMENTATION (weak_list);
2112 DEFSYMBOL (Qlambda);
2114 DEFSYMBOL (Qtrue_list_p);
2117 DEFSYMBOL (Qsymbolp);
2118 DEFSYMBOL (Qintegerp);
2119 DEFSYMBOL (Qcharacterp);
2120 DEFSYMBOL (Qnatnump);
2121 DEFSYMBOL (Qstringp);
2122 DEFSYMBOL (Qarrayp);
2123 DEFSYMBOL (Qsequencep);
2124 DEFSYMBOL (Qbufferp);
2126 DEFSYMBOL_MULTIWORD_PREDICATE (Qbit_vectorp);
2127 DEFSYMBOL (Qvectorp);
2128 DEFSYMBOL (Qchar_or_string_p);
2129 DEFSYMBOL (Qmarkerp);
2130 DEFSYMBOL (Qinteger_or_marker_p);
2131 DEFSYMBOL (Qinteger_or_char_p);
2132 DEFSYMBOL (Qinteger_char_or_marker_p);
2133 DEFSYMBOL (Qnumberp);
2134 DEFSYMBOL (Qnumber_char_or_marker_p);
2136 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp);
2138 #ifdef LISP_FLOAT_TYPE
2139 DEFSYMBOL (Qfloatp);
2140 #endif /* LISP_FLOAT_TYPE */
2142 DEFSUBR (Fwrong_type_argument);
2147 Ffset (intern ("not"), intern ("null"));
2150 DEFSUBR (Ftrue_list_p);
2153 DEFSUBR (Fchar_or_string_p);
2154 DEFSUBR (Fcharacterp);
2155 DEFSUBR (Fchar_int_p);
2156 DEFSUBR (Fchar_to_int);
2157 DEFSUBR (Fint_to_char);
2158 DEFSUBR (Fchar_or_char_int_p);
2159 DEFSUBR (Fintegerp);
2160 DEFSUBR (Finteger_or_marker_p);
2161 DEFSUBR (Finteger_or_char_p);
2162 DEFSUBR (Finteger_char_or_marker_p);
2164 DEFSUBR (Fnumber_or_marker_p);
2165 DEFSUBR (Fnumber_char_or_marker_p);
2166 #ifdef LISP_FLOAT_TYPE
2168 #endif /* LISP_FLOAT_TYPE */
2171 DEFSUBR (Fkeywordp);
2175 DEFSUBR (Fbit_vector_p);
2177 DEFSUBR (Fsequencep);
2180 DEFSUBR (Fsubr_min_args);
2181 DEFSUBR (Fsubr_max_args);
2182 DEFSUBR (Fsubr_interactive);
2186 DEFSUBR (Fcar_safe);
2187 DEFSUBR (Fcdr_safe);
2190 DEFSUBR (Findirect_function);
2194 DEFSUBR (Fnumber_to_string);
2195 DEFSUBR (Fstring_to_number);
2220 DEFSUBR (Fweak_list_p);
2221 DEFSUBR (Fmake_weak_list);
2222 DEFSUBR (Fweak_list_type);
2223 DEFSUBR (Fweak_list_list);
2224 DEFSUBR (Fset_weak_list_list);
2230 /* This must not be staticpro'd */
2231 Vall_weak_lists = Qnil;
2232 dump_add_weak_object_chain (&Vall_weak_lists);
2235 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2236 If non-zero, note when your code may be suffering from char-int confoundance.
2237 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2238 etc. where an int and a char with the same value are being compared,
2239 it will issue a notice on stderr to this effect, along with a backtrace.
2240 In such situations, the result would be different in XEmacs 19 versus
2241 XEmacs 20, and you probably don't want this.
2243 Note that in order to see these notices, you have to byte compile your
2244 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2245 have its chars and ints all confounded in the byte code, making it
2246 impossible to accurately determine Ebola infection.
2249 debug_issue_ebola_notices = 0;
2251 DEFVAR_INT ("debug-ebola-backtrace-length",
2252 &debug_ebola_backtrace_length /*
2253 Length (in stack frames) of short backtrace printed out in Ebola notices.
2254 See `debug-issue-ebola-notices'.
2256 debug_ebola_backtrace_length = 32;
2258 #endif /* DEBUG_XEMACS */