1 /* Primitive operations on Lisp data types for XEmacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995
3 Free Software Foundation, Inc.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
25 /* This file has been Mule-ized. */
32 #include "syssignal.h"
34 #ifdef LISP_FLOAT_TYPE
35 /* Need to define a differentiating symbol -- see sysfloat.h */
36 # define THIS_FILENAME data_c
37 # include "sysfloat.h"
38 #endif /* LISP_FLOAT_TYPE */
40 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
41 Lisp_Object Qerror_conditions, Qerror_message;
42 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
43 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
44 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
45 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
46 Lisp_Object Qmalformed_list, Qmalformed_property_list;
47 Lisp_Object Qcircular_list, Qcircular_property_list;
48 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
49 Lisp_Object Qio_error, Qend_of_file;
50 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
51 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
52 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
53 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp;
54 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
55 Lisp_Object Qconsp, Qsubrp, Qcompiled_functionp;
56 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
57 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
58 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
59 Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p;
60 Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore;
62 #ifdef LISP_FLOAT_TYPE
68 int debug_issue_ebola_notices;
70 int debug_ebola_backtrace_length;
73 /*#ifndef LRECORD_SYMBOL*/
74 #include "backtrace.h"
78 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
80 if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1)))
81 && (debug_issue_ebola_notices >= 2
82 || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2)))
84 stderr_out("Comparison between integer and character is constant nil (");
85 Fprinc (obj1, Qexternal_debugging_output);
87 Fprinc (obj2, Qexternal_debugging_output);
89 debug_short_backtrace (debug_ebola_backtrace_length);
91 return EQ (obj1, obj2);
94 #endif /* DEBUG_XEMACS */
99 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
101 /* This function can GC */
102 REGISTER Lisp_Object tem;
105 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
106 tem = call1 (predicate, value);
113 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
115 signal_error (Qwrong_type_argument, list2 (predicate, value));
118 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
119 Signal an error until the correct type value is given by the user.
120 This function loops, signalling a continuable `wrong-type-argument' error
121 with PREDICATE and VALUE as the data associated with the error and then
122 calling PREDICATE on the returned value, until the value gotten satisfies
123 PREDICATE. At that point, the gotten value is returned.
127 return wrong_type_argument (predicate, value);
131 pure_write_error (Lisp_Object obj)
133 signal_simple_error ("Attempt to modify read-only object", obj);
137 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
139 signal_error (Qargs_out_of_range, list2 (a1, a2));
143 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
145 signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
149 check_int_range (int val, int min, int max)
151 if (val < min || val > max)
152 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
155 /* On some machines, XINT needs a temporary location.
156 Here it is, in case it is needed. */
158 EMACS_INT sign_extend_temp;
160 /* On a few machines, XINT can only be done by calling this. */
161 /* XEmacs: only used by m/convex.h */
162 int sign_extend_lisp_int (EMACS_INT num);
164 sign_extend_lisp_int (EMACS_INT num)
166 if (num & (1L << (VALBITS - 1)))
167 return num | ((-1L) << VALBITS);
169 return num & ((1L << VALBITS) - 1);
173 /* Data type predicates */
175 DEFUN ("eq", Feq, 2, 2, 0, /*
176 Return t if the two args are the same Lisp object.
180 return EQ_WITH_EBOLA_NOTICE (obj1, obj2) ? Qt : Qnil;
183 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
184 Return t if the two args are (in most cases) the same Lisp object.
186 Special kludge: A character is considered `old-eq' to its equivalent integer
187 even though they are not the same object and are in fact of different
188 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
189 preserve byte-code compatibility with v19. This kludge is known as the
190 \"char-int confoundance disease\" and appears in a number of other
191 functions with `old-foo' equivalents.
193 Do not use this function!
198 return HACKEQ_UNSAFE (obj1, obj2) ? Qt : Qnil;
201 DEFUN ("null", Fnull, 1, 1, 0, /*
202 Return t if OBJECT is nil.
206 return NILP (object) ? Qt : Qnil;
209 DEFUN ("consp", Fconsp, 1, 1, 0, /*
210 Return t if OBJECT is a cons cell.
214 return CONSP (object) ? Qt : Qnil;
217 DEFUN ("atom", Fatom, 1, 1, 0, /*
218 Return t if OBJECT is not a cons cell. Atoms include nil.
222 return CONSP (object) ? Qnil : Qt;
225 DEFUN ("listp", Flistp, 1, 1, 0, /*
226 Return t if OBJECT is a list. Lists includes nil.
230 return LISTP (object) ? Qt : Qnil;
233 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
234 Return t if OBJECT is not a list. Lists include nil.
238 return LISTP (object) ? Qnil : Qt;
241 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
242 Return t if OBJECT is a non-dotted, i.e. nil-terminated, list.
246 return TRUE_LIST_P (object) ? Qt : Qnil;
249 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
250 Return t if OBJECT is a symbol.
254 return SYMBOLP (object) ? Qt : Qnil;
257 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
258 Return t if OBJECT is a keyword.
262 return KEYWORDP (object) ? Qt : Qnil;
265 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
266 REturn t if OBJECT is a vector.
270 return VECTORP (object) ? Qt : Qnil;
273 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
274 Return t if OBJECT is a bit vector.
278 return BIT_VECTORP (object) ? Qt : Qnil;
281 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
282 Return t if OBJECT is a string.
286 return STRINGP (object) ? Qt : Qnil;
289 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
290 Return t if OBJECT is an array (string, vector, or bit vector).
294 return (VECTORP (object) ||
296 BIT_VECTORP (object))
300 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
301 Return t if OBJECT is a sequence (list or array).
305 return (CONSP (object) ||
309 BIT_VECTORP (object))
313 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
314 Return t if OBJECT is a marker (editor pointer).
318 return MARKERP (object) ? Qt : Qnil;
321 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
322 Return t if OBJECT is a built-in function.
326 return SUBRP (object) ? Qt : Qnil;
329 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
330 Return minimum number of args built-in function SUBR may be called with.
335 return make_int (XSUBR (subr)->min_args);
338 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
339 Return maximum number of args built-in function SUBR may be called with,
340 or nil if it takes an arbitrary number of arguments or is a special form.
346 nargs = XSUBR (subr)->max_args;
347 if (nargs == MANY || nargs == UNEVALLED)
350 return make_int (nargs);
353 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
354 Return the interactive spec of the subr object, or nil.
355 If non-nil, the return value will be a list whose first element is
356 `interactive' and whose second element is the interactive spec.
362 prompt = XSUBR (subr)->prompt;
363 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
366 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
367 Return t if OBJECT is a byte-compiled function object.
371 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
375 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
376 Return t if OBJECT is a character.
377 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
378 Any character can be converted into an equivalent integer using
379 `char-int'. To convert the other way, use `int-char'; however,
380 only some integers can be converted into characters. Such an integer
381 is called a `char-int'; see `char-int-p'.
383 Some functions that work on integers (e.g. the comparison functions
384 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
385 accept characters and implicitly convert them into integers. In
386 general, functions that work on characters also accept char-ints and
387 implicitly convert them into characters. WARNING: Neither of these
388 behaviors is very desirable, and they are maintained for backward
389 compatibility with old E-Lisp programs that confounded characters and
390 integers willy-nilly. These behaviors may change in the future; therefore,
391 do not rely on them. Instead, use the character-specific functions such
396 return CHARP (object) ? Qt : Qnil;
399 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
400 Convert a character into an equivalent integer.
401 The resulting integer will always be non-negative. The integers in
402 the range 0 - 255 map to characters as follows:
406 128 - 159 Control set 1
407 160 - 255 Right half of ISO-8859-1
409 If support for Mule does not exist, these are the only valid character
410 values. When Mule support exists, the values assigned to other characters
411 may vary depending on the particular version of XEmacs, the order in which
412 character sets were loaded, etc., and you should not depend on them.
417 return make_int (XCHAR (ch));
420 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
421 Convert an integer into the equivalent character.
422 Not all integers correspond to valid characters; use `char-int-p' to
423 determine whether this is the case. If the integer cannot be converted,
429 if (CHAR_INTP (integer))
430 return make_char (XINT (integer));
435 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
436 Return t if OBJECT is an integer that can be converted into a character.
441 return CHAR_INTP (object) ? Qt : Qnil;
444 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
445 Return t if OBJECT is a character or an integer that can be converted into one.
449 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
452 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
453 Return t if OBJECT is a character (or a char-int) or a string.
454 It is semi-hateful that we allow a char-int here, as it goes against
455 the name of this function, but it makes the most sense considering the
456 other steps we take to maintain compatibility with the old character/integer
457 confoundedness in older versions of E-Lisp.
461 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
464 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
465 Return t if OBJECT is an integer.
469 return INTP (object) ? Qt : Qnil;
472 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
473 Return t if OBJECT is an integer or a marker (editor pointer).
477 return INTP (object) || MARKERP (object) ? Qt : Qnil;
480 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
481 Return t if OBJECT is an integer or a character.
485 return INTP (object) || CHARP (object) ? Qt : Qnil;
488 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
489 Return t if OBJECT is an integer, character or a marker (editor pointer).
493 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
496 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
497 Return t if OBJECT is a nonnegative integer.
501 return NATNUMP (object) ? Qt : Qnil;
504 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
505 Return t if OBJECT is a bit (0 or 1).
509 return BITP (object) ? Qt : Qnil;
512 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
513 Return t if OBJECT is a number (floating point or integer).
517 return INT_OR_FLOATP (object) ? Qt : Qnil;
520 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
521 Return t if OBJECT is a number or a marker.
525 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
528 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
529 Return t if OBJECT is a number, character or a marker.
533 return (INT_OR_FLOATP (object) ||
539 #ifdef LISP_FLOAT_TYPE
540 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
541 Return t if OBJECT is a floating point number.
545 return FLOATP (object) ? Qt : Qnil;
547 #endif /* LISP_FLOAT_TYPE */
549 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
550 Return a symbol representing the type of OBJECT.
554 if (CONSP (object)) return Qcons;
555 if (SYMBOLP (object)) return Qsymbol;
556 if (KEYWORDP (object)) return Qkeyword;
557 if (INTP (object)) return Qinteger;
558 if (CHARP (object)) return Qcharacter;
559 if (STRINGP (object)) return Qstring;
560 if (VECTORP (object)) return Qvector;
562 assert (LRECORDP (object));
563 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
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 CONSCELL to be NEWCAR. Return NEWCAR.
624 if (!CONSP (conscell))
625 conscell = wrong_type_argument (Qconsp, conscell);
627 CHECK_IMPURE (conscell);
628 XCAR (conscell) = newcar;
632 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
633 Set the cdr of CONSCELL to be NEWCDR. Return NEWCDR.
637 if (!CONSP (conscell))
638 conscell = wrong_type_argument (Qconsp, conscell);
640 CHECK_IMPURE (conscell);
641 XCDR (conscell) = newcdr;
645 /* Find the function at the end of a chain of symbol function indirections. */
647 /* If OBJECT is a symbol, find the end of its function chain and
648 return the value found there. If OBJECT is not a symbol, just
649 return it. If there is a cycle in the function chain, signal a
650 cyclic-function-indirection error.
652 This is like Findirect_function, except that it doesn't signal an
653 error if the chain ends up unbound. */
655 indirect_function (Lisp_Object object, int errorp)
657 Lisp_Object tortoise = object;
658 Lisp_Object hare = object;
662 if (!SYMBOLP (hare) || UNBOUNDP (hare))
664 hare = XSYMBOL (hare)->function;
665 if (!SYMBOLP (hare) || UNBOUNDP (hare))
667 hare = XSYMBOL (hare)->function;
669 tortoise = XSYMBOL (tortoise)->function;
671 if (EQ (hare, tortoise))
672 return Fsignal (Qcyclic_function_indirection, list1 (object));
675 if (UNBOUNDP (hare) && errorp)
676 return Fsignal (Qvoid_function, list1 (object));
680 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
681 Return the function at the end of OBJECT's function chain.
682 If OBJECT is a symbol, follow all function indirections and return
683 the final function binding.
684 If OBJECT is not a symbol, just return it.
685 Signal a void-function error if the final symbol is unbound.
686 Signal a cyclic-function-indirection error if there is a loop in the
687 function chain of symbols.
691 return indirect_function (object, 1);
694 /* Extract and set vector and string elements */
696 DEFUN ("aref", Faref, 2, 2, 0, /*
697 Return the element of ARRAY at index INDEX.
698 ARRAY may be a vector, bit vector, string, or byte-code object.
706 CHECK_INT_COERCE_CHAR (idx); /* yuck! */
711 args_out_of_range (array, idx);
715 if (idxval >= XVECTOR_LENGTH (array)) goto lose;
716 return XVECTOR_DATA (array)[idxval];
718 else if (BIT_VECTORP (array))
720 if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose;
721 return make_int (bit_vector_bit (XBIT_VECTOR (array), idxval));
723 else if (STRINGP (array))
725 if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose;
726 return make_char (string_char (XSTRING (array), idxval));
728 #ifdef LOSING_BYTECODE
729 else if (COMPILED_FUNCTIONP (array))
731 /* Weird, gross compatibility kludge */
732 return Felt (array, idx);
737 check_losing_bytecode ("aref", array);
738 array = wrong_type_argument (Qarrayp, array);
743 DEFUN ("aset", Faset, 3, 3, 0, /*
744 Store into the element of ARRAY at index IDX the value NEWVAL.
745 ARRAY may be a vector, bit vector, or string. IDX starts at 0.
747 (array, idx, newval))
751 CHECK_INT_COERCE_CHAR (idx); /* yuck! */
752 if (!VECTORP (array) && !BIT_VECTORP (array) && !STRINGP (array))
753 array = wrong_type_argument (Qarrayp, array);
759 args_out_of_range (array, idx);
761 CHECK_IMPURE (array);
765 if (idxval >= XVECTOR_LENGTH (array)) goto lose;
766 XVECTOR_DATA (array)[idxval] = newval;
768 else if (BIT_VECTORP (array))
770 if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose;
772 set_bit_vector_bit (XBIT_VECTOR (array), idxval, !ZEROP (newval));
776 CHECK_CHAR_COERCE_INT (newval);
777 if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose;
778 set_string_char (XSTRING (array), idxval, XCHAR (newval));
779 bump_string_modiff (array);
786 /**********************************************************************/
787 /* Compiled-function objects */
788 /**********************************************************************/
790 /* The compiled_function->doc_and_interactive slot uses the minimal
791 number of conses, based on compiled_function->flags; it may take
792 any of the following forms:
799 (interactive . domain)
800 (doc . (interactive . domain))
803 /* Caller must check flags.interactivep first */
805 compiled_function_interactive (struct Lisp_Compiled_Function *b)
807 assert (b->flags.interactivep);
808 if (b->flags.documentationp && b->flags.domainp)
809 return XCAR (XCDR (b->doc_and_interactive));
810 else if (b->flags.documentationp)
811 return XCDR (b->doc_and_interactive);
812 else if (b->flags.domainp)
813 return XCAR (b->doc_and_interactive);
815 /* if all else fails... */
816 return b->doc_and_interactive;
819 /* Caller need not check flags.documentationp first */
821 compiled_function_documentation (struct Lisp_Compiled_Function *b)
823 if (! b->flags.documentationp)
825 else if (b->flags.interactivep && b->flags.domainp)
826 return XCAR (b->doc_and_interactive);
827 else if (b->flags.interactivep)
828 return XCAR (b->doc_and_interactive);
829 else if (b->flags.domainp)
830 return XCAR (b->doc_and_interactive);
832 return b->doc_and_interactive;
835 /* Caller need not check flags.domainp first */
837 compiled_function_domain (struct Lisp_Compiled_Function *b)
839 if (! b->flags.domainp)
841 else if (b->flags.documentationp && b->flags.interactivep)
842 return XCDR (XCDR (b->doc_and_interactive));
843 else if (b->flags.documentationp)
844 return XCDR (b->doc_and_interactive);
845 else if (b->flags.interactivep)
846 return XCDR (b->doc_and_interactive);
848 return b->doc_and_interactive;
851 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
854 compiled_function_annotation (struct Lisp_Compiled_Function *b)
861 /* used only by Snarf-documentation; there must be doc already. */
863 set_compiled_function_documentation (struct Lisp_Compiled_Function *b,
866 assert (b->flags.documentationp);
867 assert (INTP (new) || STRINGP (new));
869 if (b->flags.interactivep && b->flags.domainp)
870 XCAR (b->doc_and_interactive) = new;
871 else if (b->flags.interactivep)
872 XCAR (b->doc_and_interactive) = new;
873 else if (b->flags.domainp)
874 XCAR (b->doc_and_interactive) = new;
876 b->doc_and_interactive = new;
879 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
880 Return the byte-opcode string of the compiled-function object.
884 CHECK_COMPILED_FUNCTION (function);
885 return XCOMPILED_FUNCTION (function)->bytecodes;
888 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
889 Return the constants vector of the compiled-function object.
893 CHECK_COMPILED_FUNCTION (function);
894 return XCOMPILED_FUNCTION (function)->constants;
897 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
898 Return the max stack depth of the compiled-function object.
902 CHECK_COMPILED_FUNCTION (function);
903 return make_int (XCOMPILED_FUNCTION (function)->maxdepth);
906 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
907 Return the argument list of the compiled-function object.
911 CHECK_COMPILED_FUNCTION (function);
912 return XCOMPILED_FUNCTION (function)->arglist;
915 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
916 Return the interactive spec of the compiled-function object, or nil.
917 If non-nil, the return value will be a list whose first element is
918 `interactive' and whose second element is the interactive spec.
922 CHECK_COMPILED_FUNCTION (function);
923 return XCOMPILED_FUNCTION (function)->flags.interactivep
924 ? list2 (Qinteractive,
925 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
929 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
930 Return the doc string of the compiled-function object, if available.
931 Functions that had their doc strings snarfed into the DOC file will have
932 an integer returned instead of a string.
936 CHECK_COMPILED_FUNCTION (function);
937 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
940 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
942 /* Remove the `xx' if you wish to restore this feature */
943 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
944 Return the annotation of the compiled-function object, or nil.
945 The annotation is a piece of information indicating where this
946 compiled-function object came from. Generally this will be
947 a symbol naming a function; or a string naming a file, if the
948 compiled-function object was not defined in a function; or nil,
949 if the compiled-function object was not created as a result of
954 CHECK_COMPILED_FUNCTION (function);
955 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
958 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
960 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
961 Return the domain of the compiled-function object, or nil.
962 This is only meaningful if I18N3 was enabled when emacs was compiled.
966 CHECK_COMPILED_FUNCTION (function);
967 return XCOMPILED_FUNCTION (function)->flags.domainp
968 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
973 /**********************************************************************/
974 /* Arithmetic functions */
975 /**********************************************************************/
978 arithcompare (Lisp_Object num1, Lisp_Object num2,
979 enum arith_comparison comparison)
981 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num1);
982 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num2);
984 #ifdef LISP_FLOAT_TYPE
985 if (FLOATP (num1) || FLOATP (num2))
987 double f1 = FLOATP (num1) ? float_data (XFLOAT (num1)) : XINT (num1);
988 double f2 = FLOATP (num2) ? float_data (XFLOAT (num2)) : XINT (num2);
992 case arith_equal: return f1 == f2 ? Qt : Qnil;
993 case arith_notequal: return f1 != f2 ? Qt : Qnil;
994 case arith_less: return f1 < f2 ? Qt : Qnil;
995 case arith_less_or_equal: return f1 <= f2 ? Qt : Qnil;
996 case arith_grtr: return f1 > f2 ? Qt : Qnil;
997 case arith_grtr_or_equal: return f1 >= f2 ? Qt : Qnil;
1000 #endif /* LISP_FLOAT_TYPE */
1004 case arith_equal: return XINT (num1) == XINT (num2) ? Qt : Qnil;
1005 case arith_notequal: return XINT (num1) != XINT (num2) ? Qt : Qnil;
1006 case arith_less: return XINT (num1) < XINT (num2) ? Qt : Qnil;
1007 case arith_less_or_equal: return XINT (num1) <= XINT (num2) ? Qt : Qnil;
1008 case arith_grtr: return XINT (num1) > XINT (num2) ? Qt : Qnil;
1009 case arith_grtr_or_equal: return XINT (num1) >= XINT (num2) ? Qt : Qnil;
1013 return Qnil; /* suppress compiler warning */
1017 arithcompare_many (enum arith_comparison comparison,
1018 int nargs, Lisp_Object *args)
1020 for (; --nargs > 0; args++)
1021 if (NILP (arithcompare (*args, *(args + 1), comparison)))
1027 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
1028 Return t if all the arguments are numerically equal.
1029 The arguments may be numbers, characters or markers.
1031 (int nargs, Lisp_Object *args))
1033 return arithcompare_many (arith_equal, nargs, args);
1036 DEFUN ("<", Flss, 1, MANY, 0, /*
1037 Return t if the sequence of arguments is monotonically increasing.
1038 The arguments may be numbers, characters or markers.
1040 (int nargs, Lisp_Object *args))
1042 return arithcompare_many (arith_less, nargs, args);
1045 DEFUN (">", Fgtr, 1, MANY, 0, /*
1046 Return t if the sequence of arguments is monotonically decreasing.
1047 The arguments may be numbers, characters or markers.
1049 (int nargs, Lisp_Object *args))
1051 return arithcompare_many (arith_grtr, nargs, args);
1054 DEFUN ("<=", Fleq, 1, MANY, 0, /*
1055 Return t if the sequence of arguments is monotonically nondecreasing.
1056 The arguments may be numbers, characters or markers.
1058 (int nargs, Lisp_Object *args))
1060 return arithcompare_many (arith_less_or_equal, nargs, args);
1063 DEFUN (">=", Fgeq, 1, MANY, 0, /*
1064 Return t if the sequence of arguments is monotonically nonincreasing.
1065 The arguments may be numbers, characters or markers.
1067 (int nargs, Lisp_Object *args))
1069 return arithcompare_many (arith_grtr_or_equal, nargs, args);
1072 DEFUN ("/=", Fneq, 1, MANY, 0, /*
1073 Return t if no two arguments are numerically equal.
1074 The arguments may be numbers, characters or markers.
1076 (int nargs, Lisp_Object *args))
1078 return arithcompare_many (arith_notequal, nargs, args);
1081 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
1082 Return t if NUMBER is zero.
1086 CHECK_INT_OR_FLOAT (number);
1088 #ifdef LISP_FLOAT_TYPE
1089 if (FLOATP (number))
1090 return float_data (XFLOAT (number)) == 0.0 ? Qt : Qnil;
1091 #endif /* LISP_FLOAT_TYPE */
1093 return EQ (number, Qzero) ? Qt : Qnil;
1096 /* Convert between a 32-bit value and a cons of two 16-bit values.
1097 This is used to pass 32-bit integers to and from the user.
1098 Use time_to_lisp() and lisp_to_time() for time values.
1100 If you're thinking of using this to store a pointer into a Lisp Object
1101 for internal purposes (such as when calling record_unwind_protect()),
1102 try using make_opaque_ptr()/get_opaque_ptr() instead. */
1104 word_to_lisp (unsigned int item)
1106 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
1110 lisp_to_word (Lisp_Object item)
1116 Lisp_Object top = Fcar (item);
1117 Lisp_Object bot = Fcdr (item);
1120 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
1125 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
1126 Convert NUM to a string by printing it in decimal.
1127 Uses a minus sign if negative.
1128 NUM may be an integer or a floating point number.
1132 char buffer[VALBITS];
1134 CHECK_INT_OR_FLOAT (num);
1136 #ifdef LISP_FLOAT_TYPE
1139 char pigbuf[350]; /* see comments in float_to_string */
1141 float_to_string (pigbuf, float_data (XFLOAT (num)));
1142 return build_string (pigbuf);
1144 #endif /* LISP_FLOAT_TYPE */
1146 long_to_string (buffer, XINT (num));
1147 return build_string (buffer);
1151 digit_to_number (int character, int base)
1154 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1155 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
1156 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
1159 return digit >= base ? -1 : digit;
1162 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
1163 Convert STRING to a number by parsing it as a decimal number.
1164 This parses both integers and floating point numbers.
1165 It ignores leading spaces and tabs.
1167 If BASE, interpret STRING as a number in that base. If BASE isn't
1168 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
1169 Floating point numbers always use base 10.
1176 CHECK_STRING (string);
1184 check_int_range (b, 2, 16);
1187 p = (char *) XSTRING_DATA (string);
1189 /* Skip any whitespace at the front of the number. Some versions of
1190 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1191 while (*p == ' ' || *p == '\t')
1194 #ifdef LISP_FLOAT_TYPE
1195 if (isfloat_string (p))
1196 return make_float (atof (p));
1197 #endif /* LISP_FLOAT_TYPE */
1201 /* Use the system-provided functions for base 10. */
1202 #if SIZEOF_EMACS_INT == SIZEOF_INT
1203 return make_int (atoi (p));
1204 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1205 return make_int (atol (p));
1206 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1207 return make_int (atoll (p));
1212 int digit, negative = 1;
1224 digit = digit_to_number (*p++, b);
1229 return make_int (negative * v);
1234 { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
1237 #ifdef LISP_FLOAT_TYPE
1239 float_arith_driver (double accum, int argnum, enum arithop code, int nargs,
1242 REGISTER Lisp_Object val;
1245 for (; argnum < nargs; argnum++)
1247 /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
1249 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
1253 next = float_data (XFLOAT (val));
1257 args[argnum] = val; /* runs into a compiler bug. */
1258 next = XINT (args[argnum]);
1266 if (!argnum && nargs != 1)
1279 Fsignal (Qarith_error, Qnil);
1286 return wrong_type_argument (Qinteger_char_or_marker_p, val);
1288 if (!argnum || isnan (next) || next > accum)
1292 if (!argnum || isnan (next) || next < accum)
1298 return make_float (accum);
1300 #endif /* LISP_FLOAT_TYPE */
1303 arith_driver (enum arithop code, int nargs, Lisp_Object *args)
1306 REGISTER int argnum;
1307 REGISTER EMACS_INT accum = 0;
1308 REGISTER EMACS_INT next;
1329 for (argnum = 0; argnum < nargs; argnum++)
1331 /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
1333 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
1335 #ifdef LISP_FLOAT_TYPE
1336 if (FLOATP (val)) /* time to do serious math */
1337 return float_arith_driver ((double) accum, argnum, code,
1339 #endif /* LISP_FLOAT_TYPE */
1340 args[argnum] = val; /* runs into a compiler bug. */
1341 next = XINT (args[argnum]);
1344 case Aadd: accum += next; break;
1346 if (!argnum && nargs != 1)
1350 case Amult: accum *= next; break;
1352 if (!argnum) accum = next;
1356 Fsignal (Qarith_error, Qnil);
1360 case Alogand: accum &= next; break;
1361 case Alogior: accum |= next; break;
1362 case Alogxor: accum ^= next; break;
1363 case Amax: if (!argnum || next > accum) accum = next; break;
1364 case Amin: if (!argnum || next < accum) accum = next; break;
1368 XSETINT (val, accum);
1372 DEFUN ("+", Fplus, 0, MANY, 0, /*
1373 Return sum of any number of arguments.
1374 The arguments should all be numbers, characters or markers.
1376 (int nargs, Lisp_Object *args))
1378 return arith_driver (Aadd, nargs, args);
1381 DEFUN ("-", Fminus, 0, MANY, 0, /*
1382 Negate number or subtract numbers, characters or markers.
1383 With one arg, negates it. With more than one arg,
1384 subtracts all but the first from the first.
1386 (int nargs, Lisp_Object *args))
1388 return arith_driver (Asub, nargs, args);
1391 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1392 Return product of any number of arguments.
1393 The arguments should all be numbers, characters or markers.
1395 (int nargs, Lisp_Object *args))
1397 return arith_driver (Amult, nargs, args);
1400 DEFUN ("/", Fquo, 2, MANY, 0, /*
1401 Return first argument divided by all the remaining arguments.
1402 The arguments must be numbers, characters or markers.
1404 (int nargs, Lisp_Object *args))
1406 return arith_driver (Adiv, nargs, args);
1409 DEFUN ("%", Frem, 2, 2, 0, /*
1410 Return remainder of first arg divided by second.
1411 Both must be integers, characters or markers.
1415 CHECK_INT_COERCE_CHAR_OR_MARKER (num1);
1416 CHECK_INT_COERCE_CHAR_OR_MARKER (num2);
1419 Fsignal (Qarith_error, Qnil);
1421 return make_int (XINT (num1) % XINT (num2));
1424 /* Note, ANSI *requires* the presence of the fmod() library routine.
1425 If your system doesn't have it, complain to your vendor, because
1430 fmod (double f1, double f2)
1434 return f1 - f2 * floor (f1/f2);
1436 #endif /* ! HAVE_FMOD */
1439 DEFUN ("mod", Fmod, 2, 2, 0, /*
1441 The result falls between zero (inclusive) and Y (exclusive).
1442 Both X and Y must be numbers, characters or markers.
1443 If either argument is a float, a float will be returned.
1449 #ifdef LISP_FLOAT_TYPE
1450 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x);
1451 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y);
1453 if (FLOATP (x) || FLOATP (y))
1457 f1 = ((FLOATP (x)) ? float_data (XFLOAT (x)) : XINT (x));
1458 f2 = ((FLOATP (y)) ? float_data (XFLOAT (y)) : XINT (y));
1460 Fsignal (Qarith_error, Qnil);
1464 /* If the "remainder" comes out with the wrong sign, fix it. */
1465 if (f2 < 0 ? f1 > 0 : f1 < 0)
1467 return make_float (f1);
1469 #else /* not LISP_FLOAT_TYPE */
1470 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x);
1471 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y);
1472 #endif /* not LISP_FLOAT_TYPE */
1478 Fsignal (Qarith_error, Qnil);
1482 /* If the "remainder" comes out with the wrong sign, fix it. */
1483 if (i2 < 0 ? i1 > 0 : i1 < 0)
1486 return make_int (i1);
1490 DEFUN ("max", Fmax, 1, MANY, 0, /*
1491 Return largest of all the arguments.
1492 All arguments must be numbers, characters or markers.
1493 The value is always a number; markers and characters are converted
1496 (int nargs, Lisp_Object *args))
1498 return arith_driver (Amax, nargs, args);
1501 DEFUN ("min", Fmin, 1, MANY, 0, /*
1502 Return smallest of all the arguments.
1503 All arguments must be numbers, characters or markers.
1504 The value is always a number; markers and characters are converted
1507 (int nargs, Lisp_Object *args))
1509 return arith_driver (Amin, nargs, args);
1512 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1513 Return bitwise-and of all the arguments.
1514 Arguments may be integers, or markers or characters converted to integers.
1516 (int nargs, Lisp_Object *args))
1518 return arith_driver (Alogand, nargs, args);
1521 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1522 Return bitwise-or of all the arguments.
1523 Arguments may be integers, or markers or characters converted to integers.
1525 (int nargs, Lisp_Object *args))
1527 return arith_driver (Alogior, nargs, args);
1530 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1531 Return bitwise-exclusive-or of all the arguments.
1532 Arguments may be integers, or markers or characters converted to integers.
1534 (int nargs, Lisp_Object *args))
1536 return arith_driver (Alogxor, nargs, args);
1539 DEFUN ("ash", Fash, 2, 2, 0, /*
1540 Return VALUE with its bits shifted left by COUNT.
1541 If COUNT is negative, shifting is actually to the right.
1542 In this case, the sign bit is duplicated.
1546 CHECK_INT_COERCE_CHAR (value);
1549 return make_int (XINT (count) > 0 ?
1550 XINT (value) << XINT (count) :
1551 XINT (value) >> -XINT (count));
1554 DEFUN ("lsh", Flsh, 2, 2, 0, /*
1555 Return VALUE with its bits shifted left by COUNT.
1556 If COUNT is negative, shifting is actually to the right.
1557 In this case, zeros are shifted in on the left.
1561 CHECK_INT_COERCE_CHAR (value);
1564 return make_int (XINT (count) > 0 ?
1565 XUINT (value) << XINT (count) :
1566 XUINT (value) >> -XINT (count));
1569 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1570 Return NUMBER plus one. NUMBER may be a number or a marker.
1571 Markers and characters are converted to integers.
1575 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
1577 #ifdef LISP_FLOAT_TYPE
1578 if (FLOATP (number))
1579 return make_float (1.0 + float_data (XFLOAT (number)));
1580 #endif /* LISP_FLOAT_TYPE */
1582 return make_int (XINT (number) + 1);
1585 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1586 Return NUMBER minus one. NUMBER may be a number or a marker.
1587 Markers and characters are converted to integers.
1591 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
1593 #ifdef LISP_FLOAT_TYPE
1594 if (FLOATP (number))
1595 return make_float (-1.0 + (float_data (XFLOAT (number))));
1596 #endif /* LISP_FLOAT_TYPE */
1598 return make_int (XINT (number) - 1);
1601 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1602 Return the bitwise complement of NUMBER. NUMBER must be an integer.
1607 return make_int (~XINT (number));
1611 /************************************************************************/
1613 /************************************************************************/
1615 /* A weak list is like a normal list except that elements automatically
1616 disappear when no longer in use, i.e. when no longer GC-protected.
1617 The basic idea is that we don't mark the elements during GC, but
1618 wait for them to be marked elsewhere. If they're not marked, we
1619 remove them. This is analogous to weak hashtables; see the explanation
1620 there for more info. */
1622 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1624 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1627 mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
1629 return Qnil; /* nichts ist gemarkt */
1633 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1636 error ("printing unreadable object #<weak-list>");
1638 write_c_string ("#<weak-list ", printcharfun);
1639 print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
1641 write_c_string (" ", printcharfun);
1642 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1643 write_c_string (">", printcharfun);
1647 weak_list_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1649 struct weak_list *w1 = XWEAK_LIST (o1);
1650 struct weak_list *w2 = XWEAK_LIST (o2);
1652 return ((w1->type == w2->type) &&
1653 internal_equal (w1->list, w2->list, depth + 1));
1656 static unsigned long
1657 weak_list_hash (Lisp_Object obj, int depth)
1659 struct weak_list *w = XWEAK_LIST (obj);
1661 return HASH2 ((unsigned long) w->type,
1662 internal_hash (w->list, depth + 1));
1666 make_weak_list (enum weak_list_type type)
1669 struct weak_list *wl =
1670 alloc_lcrecord_type (struct weak_list, lrecord_weak_list);
1674 XSETWEAK_LIST (result, wl);
1675 wl->next_weak = Vall_weak_lists;
1676 Vall_weak_lists = result;
1680 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
1681 mark_weak_list, print_weak_list,
1682 0, weak_list_equal, weak_list_hash,
1685 -- we do not mark the list elements (either the elements themselves
1686 or the cons cells that hold them) in the normal marking phase.
1687 -- at the end of marking, we go through all weak lists that are
1688 marked, and mark the cons cells that hold all marked
1689 objects, and possibly parts of the objects themselves.
1690 (See alloc.c, "after-mark".)
1691 -- after that, we prune away all the cons cells that are not marked.
1693 WARNING WARNING WARNING WARNING WARNING:
1695 The code in the following two functions is *unbelievably* tricky.
1696 Don't mess with it. You'll be sorry.
1698 Linked lists just majorly suck, d'ya know?
1702 finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object),
1703 void (*markobj) (Lisp_Object))
1708 for (rest = Vall_weak_lists;
1710 rest = XWEAK_LIST (rest)->next_weak)
1713 enum weak_list_type type = XWEAK_LIST (rest)->type;
1715 if (! ((*obj_marked_p) (rest)))
1716 /* The weak list is probably garbage. Ignore it. */
1719 for (rest2 = XWEAK_LIST (rest)->list;
1720 /* We need to be trickier since we're inside of GC;
1721 use CONSP instead of !NILP in case of user-visible
1724 rest2 = XCDR (rest2))
1727 /* If the element is "marked" (meaning depends on the type
1728 of weak list), we need to mark the cons containing the
1729 element, and maybe the element itself (if only some part
1730 was already marked). */
1731 int need_to_mark_cons = 0;
1732 int need_to_mark_elem = 0;
1734 /* If a cons is already marked, then its car is already marked
1735 (either because of an external pointer or because of
1736 a previous call to this function), and likewise for all
1737 the rest of the elements in the list, so we can stop now. */
1738 if ((*obj_marked_p) (rest2))
1741 elem = XCAR (rest2);
1745 case WEAK_LIST_SIMPLE:
1746 if ((*obj_marked_p) (elem))
1747 need_to_mark_cons = 1;
1750 case WEAK_LIST_ASSOC:
1751 if (!GC_CONSP (elem))
1753 /* just leave bogus elements there */
1754 need_to_mark_cons = 1;
1755 need_to_mark_elem = 1;
1757 else if ((*obj_marked_p) (XCAR (elem)) &&
1758 (*obj_marked_p) (XCDR (elem)))
1760 need_to_mark_cons = 1;
1761 /* We still need to mark elem, because it's
1762 probably not marked. */
1763 need_to_mark_elem = 1;
1767 case WEAK_LIST_KEY_ASSOC:
1768 if (!GC_CONSP (elem))
1770 /* just leave bogus elements there */
1771 need_to_mark_cons = 1;
1772 need_to_mark_elem = 1;
1774 else if ((*obj_marked_p) (XCAR (elem)))
1776 need_to_mark_cons = 1;
1777 /* We still need to mark elem and XCDR (elem);
1778 marking elem does both */
1779 need_to_mark_elem = 1;
1783 case WEAK_LIST_VALUE_ASSOC:
1784 if (!GC_CONSP (elem))
1786 /* just leave bogus elements there */
1787 need_to_mark_cons = 1;
1788 need_to_mark_elem = 1;
1790 else if ((*obj_marked_p) (XCDR (elem)))
1792 need_to_mark_cons = 1;
1793 /* We still need to mark elem and XCAR (elem);
1794 marking elem does both */
1795 need_to_mark_elem = 1;
1803 if (need_to_mark_elem && ! (*obj_marked_p) (elem))
1809 /* We also need to mark the cons that holds the elem or
1810 assoc-pair. We do *not* want to call (markobj) here
1811 because that will mark the entire list; we just want to
1812 mark the cons itself.
1814 if (need_to_mark_cons)
1816 struct Lisp_Cons *ptr = XCONS (rest2);
1817 if (!CONS_MARKED_P (ptr))
1825 /* In case of imperfect list, need to mark the final cons
1826 because we're not removing it */
1827 if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2))
1838 prune_weak_lists (int (*obj_marked_p) (Lisp_Object))
1840 Lisp_Object rest, prev = Qnil;
1842 for (rest = Vall_weak_lists;
1844 rest = XWEAK_LIST (rest)->next_weak)
1846 if (! ((*obj_marked_p) (rest)))
1848 /* This weak list itself is garbage. Remove it from the list. */
1850 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1852 XWEAK_LIST (prev)->next_weak =
1853 XWEAK_LIST (rest)->next_weak;
1857 Lisp_Object rest2, prev2 = Qnil;
1858 Lisp_Object tortoise;
1859 int go_tortoise = 0;
1861 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
1862 /* We need to be trickier since we're inside of GC;
1863 use CONSP instead of !NILP in case of user-visible
1867 /* It suffices to check the cons for marking,
1868 regardless of the type of weak list:
1870 -- if the cons is pointed to somewhere else,
1871 then it should stay around and will be marked.
1872 -- otherwise, if it should stay around, it will
1873 have been marked in finish_marking_weak_lists().
1874 -- otherwise, it's not marked and should disappear.
1876 if (!(*obj_marked_p) (rest2))
1879 if (GC_NILP (prev2))
1880 XWEAK_LIST (rest)->list = XCDR (rest2);
1882 XCDR (prev2) = XCDR (rest2);
1883 rest2 = XCDR (rest2);
1884 /* Ouch. Circularity checking is even trickier
1885 than I thought. When we cut out a link
1886 like this, we can't advance the turtle or
1887 it'll catch up to us. Imagine that we're
1888 standing on floor tiles and moving forward --
1889 what we just did here is as if the floor
1890 tile under us just disappeared and all the
1891 ones ahead of us slid one tile towards us.
1892 In other words, we didn't move at all;
1893 if the tortoise was one step behind us
1894 previously, it still is, and therefore
1895 it must not move. */
1901 /* Implementing circularity checking is trickier here
1902 than in other places because we have to guarantee
1903 that we've processed all elements before exiting
1904 due to a circularity. (In most places, an error
1905 is issued upon encountering a circularity, so it
1906 doesn't really matter if all elements are processed.)
1907 The idea is that we process along with the hare
1908 rather than the tortoise. If at any point in
1909 our forward process we encounter the tortoise,
1910 we must have already visited the spot, so we exit.
1911 (If we process with the tortoise, we can fail to
1912 process cases where a cons points to itself, or
1913 where cons A points to cons B, which points to
1916 rest2 = XCDR (rest2);
1918 tortoise = XCDR (tortoise);
1919 go_tortoise = !go_tortoise;
1920 if (GC_EQ (rest2, tortoise))
1930 static enum weak_list_type
1931 decode_weak_list_type (Lisp_Object symbol)
1933 CHECK_SYMBOL (symbol);
1934 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
1935 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
1936 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
1937 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
1938 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
1940 signal_simple_error ("Invalid weak list type", symbol);
1941 return WEAK_LIST_SIMPLE; /* not reached */
1945 encode_weak_list_type (enum weak_list_type type)
1949 case WEAK_LIST_SIMPLE: return Qsimple;
1950 case WEAK_LIST_ASSOC: return Qassoc;
1951 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
1952 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
1957 return Qnil; /* not reached */
1960 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
1961 Return non-nil if OBJECT is a weak list.
1965 return WEAK_LISTP (object) ? Qt : Qnil;
1968 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
1969 Return a new weak list object of type TYPE.
1970 A weak list object is an object that contains a list. This list behaves
1971 like any other list except that its elements do not count towards
1972 garbage collection -- if the only pointer to an object in inside a weak
1973 list (other than pointers in similar objects such as weak hash tables),
1974 the object is garbage collected and automatically removed from the list.
1975 This is used internally, for example, to manage the list holding the
1976 children of an extent -- an extent that is unused but has a parent will
1977 still be reclaimed, and will automatically be removed from its parent's
1980 Optional argument TYPE specifies the type of the weak list, and defaults
1981 to `simple'. Recognized types are
1983 `simple' Objects in the list disappear if not pointed to.
1984 `assoc' Objects in the list disappear if they are conses
1985 and either the car or the cdr of the cons is not
1987 `key-assoc' Objects in the list disappear if they are conses
1988 and the car is not pointed to.
1989 `value-assoc' Objects in the list disappear if they are conses
1990 and the cdr is not pointed to.
1997 return make_weak_list (decode_weak_list_type (type));
2000 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
2001 Return the type of the given weak-list object.
2005 CHECK_WEAK_LIST (weak);
2006 return encode_weak_list_type (XWEAK_LIST (weak)->type);
2009 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
2010 Return the list contained in a weak-list object.
2014 CHECK_WEAK_LIST (weak);
2015 return XWEAK_LIST_LIST (weak);
2018 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
2019 Change the list contained in a weak-list object.
2023 CHECK_WEAK_LIST (weak);
2024 XWEAK_LIST_LIST (weak) = new_list;
2029 /************************************************************************/
2030 /* initialization */
2031 /************************************************************************/
2034 arith_error (int signo)
2036 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
2037 EMACS_UNBLOCK_SIGNAL (signo);
2038 signal_error (Qarith_error, Qnil);
2042 init_data_very_early (void)
2044 /* Don't do this if just dumping out.
2045 We don't want to call `signal' in this case
2046 so that we don't have trouble with dumping
2047 signal-delivering routines in an inconsistent state. */
2051 #endif /* CANNOT_DUMP */
2052 signal (SIGFPE, arith_error);
2054 signal (SIGEMT, arith_error);
2059 init_errors_once_early (void)
2061 defsymbol (&Qerror_conditions, "error-conditions");
2062 defsymbol (&Qerror_message, "error-message");
2064 /* We declare the errors here because some other deferrors depend
2065 on some of the errors below. */
2067 /* ERROR is used as a signaler for random errors for which nothing
2070 deferror (&Qerror, "error", "error", Qnil);
2071 deferror (&Qquit, "quit", "Quit", Qnil);
2073 deferror (&Qwrong_type_argument, "wrong-type-argument",
2074 "Wrong type argument", Qerror);
2075 deferror (&Qargs_out_of_range, "args-out-of-range", "Args out of range",
2077 deferror (&Qvoid_function, "void-function",
2078 "Symbol's function definition is void", Qerror);
2079 deferror (&Qcyclic_function_indirection, "cyclic-function-indirection",
2080 "Symbol's chain of function indirections contains a loop", Qerror);
2081 deferror (&Qvoid_variable, "void-variable",
2082 "Symbol's value as variable is void", Qerror);
2083 deferror (&Qcyclic_variable_indirection, "cyclic-variable-indirection",
2084 "Symbol's chain of variable indirections contains a loop", Qerror);
2085 deferror (&Qsetting_constant, "setting-constant",
2086 "Attempt to set a constant symbol", Qerror);
2087 deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
2088 "Invalid read syntax", Qerror);
2089 deferror (&Qmalformed_list, "malformed-list",
2090 "Malformed list", Qerror);
2091 deferror (&Qmalformed_property_list, "malformed-property-list",
2092 "Malformed property list", Qerror);
2093 deferror (&Qcircular_list, "circular-list",
2094 "Circular list", Qerror);
2095 deferror (&Qcircular_property_list, "circular-property-list",
2096 "Circular property list", Qerror);
2097 deferror (&Qinvalid_function, "invalid-function", "Invalid function",
2099 deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
2100 "Wrong number of arguments", Qerror);
2101 deferror (&Qno_catch, "no-catch", "No catch for tag",
2103 deferror (&Qbeginning_of_buffer, "beginning-of-buffer",
2104 "Beginning of buffer", Qerror);
2105 deferror (&Qend_of_buffer, "end-of-buffer", "End of buffer", Qerror);
2106 deferror (&Qbuffer_read_only, "buffer-read-only", "Buffer is read-only",
2109 deferror (&Qio_error, "io-error", "IO Error", Qerror);
2110 deferror (&Qend_of_file, "end-of-file", "End of stream", Qio_error);
2112 deferror (&Qarith_error, "arith-error", "Arithmetic error", Qerror);
2113 deferror (&Qrange_error, "range-error", "Arithmetic range error",
2115 deferror (&Qdomain_error, "domain-error", "Arithmetic domain error",
2117 deferror (&Qsingularity_error, "singularity-error",
2118 "Arithmetic singularity error", Qdomain_error);
2119 deferror (&Qoverflow_error, "overflow-error",
2120 "Arithmetic overflow error", Qdomain_error);
2121 deferror (&Qunderflow_error, "underflow-error",
2122 "Arithmetic underflow error", Qdomain_error);
2128 defsymbol (&Qcons, "cons");
2129 defsymbol (&Qkeyword, "keyword");
2130 defsymbol (&Qquote, "quote");
2131 defsymbol (&Qlambda, "lambda");
2132 defsymbol (&Qignore, "ignore");
2133 defsymbol (&Qlistp, "listp");
2134 defsymbol (&Qtrue_list_p, "true-list-p");
2135 defsymbol (&Qconsp, "consp");
2136 defsymbol (&Qsubrp, "subrp");
2137 defsymbol (&Qsymbolp, "symbolp");
2138 defsymbol (&Qkeywordp, "keywordp");
2139 defsymbol (&Qintegerp, "integerp");
2140 defsymbol (&Qcharacterp, "characterp");
2141 defsymbol (&Qnatnump, "natnump");
2142 defsymbol (&Qstringp, "stringp");
2143 defsymbol (&Qarrayp, "arrayp");
2144 defsymbol (&Qsequencep, "sequencep");
2145 defsymbol (&Qbufferp, "bufferp");
2146 defsymbol (&Qbitp, "bitp");
2147 defsymbol (&Qbit_vectorp, "bit-vector-p");
2148 defsymbol (&Qvectorp, "vectorp");
2149 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2150 defsymbol (&Qchar_or_string_p, "char-or-string-p");
2151 defsymbol (&Qmarkerp, "markerp");
2152 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
2153 defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
2154 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
2155 defsymbol (&Qnumberp, "numberp");
2156 defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
2157 defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p");
2158 defsymbol (&Qcdr, "cdr");
2159 defsymbol (&Qweak_listp, "weak-list-p");
2161 #ifdef LISP_FLOAT_TYPE
2162 defsymbol (&Qfloatp, "floatp");
2163 #endif /* LISP_FLOAT_TYPE */
2165 DEFSUBR (Fwrong_type_argument);
2172 DEFSUBR (Ftrue_list_p);
2175 DEFSUBR (Fchar_or_string_p);
2176 DEFSUBR (Fcharacterp);
2177 DEFSUBR (Fchar_int_p);
2178 DEFSUBR (Fchar_to_int);
2179 DEFSUBR (Fint_to_char);
2180 DEFSUBR (Fchar_or_char_int_p);
2181 DEFSUBR (Fintegerp);
2182 DEFSUBR (Finteger_or_marker_p);
2183 DEFSUBR (Finteger_or_char_p);
2184 DEFSUBR (Finteger_char_or_marker_p);
2186 DEFSUBR (Fnumber_or_marker_p);
2187 DEFSUBR (Fnumber_char_or_marker_p);
2188 #ifdef LISP_FLOAT_TYPE
2190 #endif /* LISP_FLOAT_TYPE */
2193 DEFSUBR (Fkeywordp);
2197 DEFSUBR (Fbit_vector_p);
2199 DEFSUBR (Fsequencep);
2202 DEFSUBR (Fsubr_min_args);
2203 DEFSUBR (Fsubr_max_args);
2204 DEFSUBR (Fsubr_interactive);
2205 DEFSUBR (Fcompiled_function_p);
2209 DEFSUBR (Fcar_safe);
2210 DEFSUBR (Fcdr_safe);
2213 DEFSUBR (Findirect_function);
2217 DEFSUBR (Fcompiled_function_instructions);
2218 DEFSUBR (Fcompiled_function_constants);
2219 DEFSUBR (Fcompiled_function_stack_depth);
2220 DEFSUBR (Fcompiled_function_arglist);
2221 DEFSUBR (Fcompiled_function_interactive);
2222 DEFSUBR (Fcompiled_function_doc_string);
2223 DEFSUBR (Fcompiled_function_domain);
2224 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2225 DEFSUBR (Fcompiled_function_annotation);
2228 DEFSUBR (Fnumber_to_string);
2229 DEFSUBR (Fstring_to_number);
2254 DEFSUBR (Fweak_list_p);
2255 DEFSUBR (Fmake_weak_list);
2256 DEFSUBR (Fweak_list_type);
2257 DEFSUBR (Fweak_list_list);
2258 DEFSUBR (Fset_weak_list_list);
2264 /* This must not be staticpro'd */
2265 Vall_weak_lists = Qnil;
2268 DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2269 If non-nil, note when your code may be suffering from char-int confoundance.
2270 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2271 etc. where a int and a char with the same value are being compared,
2272 it will issue a notice on stderr to this effect, along with a backtrace.
2273 In such situations, the result would be different in XEmacs 19 versus
2274 XEmacs 20, and you probably don't want this.
2276 Note that in order to see these notices, you have to byte compile your
2277 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
2278 have its chars and ints all confounded in the byte code, making it
2279 impossible to accurately determine Ebola infection.
2282 debug_issue_ebola_notices = 2; /* #### temporary hack */
2284 DEFVAR_INT ("debug-ebola-backtrace-length",
2285 &debug_ebola_backtrace_length /*
2286 Length (in stack frames) of short backtrace printed out in Ebola notices.
2287 See `debug-issue-ebola-notices'.
2289 debug_ebola_backtrace_length = 32;
2291 #endif /* DEBUG_XEMACS */