1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
32 #include "syssignal.h"
34 #ifdef LISP_FLOAT_TYPE
40 /* Work around a problem that happens because math.h on hpux 7
41 defines two static variables--which, in Emacs, are not really static,
42 because `static' is defined as nothing. The problem is that they are
43 here, in floatfns.c, and in lread.c.
44 These macros prevent the name conflict. */
45 #if defined (HPUX) && !defined (HPUX8)
46 #define _MAXLDBL data_c_maxldbl
47 #define _NMAXLDBL data_c_nmaxldbl
51 #endif /* LISP_FLOAT_TYPE */
54 extern double atof ();
57 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
58 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
59 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
60 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
66 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
67 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
68 Lisp_Object Qbuffer_or_string_p
;
69 Lisp_Object Qboundp
, Qfboundp
;
70 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
73 Lisp_Object Qad_advice_info
, Qad_activate
;
75 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
76 Lisp_Object Qoverflow_error
, Qunderflow_error
;
78 #ifdef LISP_FLOAT_TYPE
80 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
83 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
84 static Lisp_Object Qfloat
, Qwindow_configuration
, Qprocess
, Qwindow
;
85 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
86 static Lisp_Object Qchar_table
, Qbool_vector
;
88 static Lisp_Object
swap_in_symval_forwarding ();
91 wrong_type_argument (predicate
, value
)
92 register Lisp_Object predicate
, value
;
94 register Lisp_Object tem
;
97 if (!EQ (Vmocklisp_arguments
, Qt
))
99 if (STRINGP (value
) &&
100 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
101 return Fstring_to_number (value
);
102 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
103 return Fnumber_to_string (value
);
106 /* If VALUE is not even a valid Lisp object, abort here
107 where we can get a backtrace showing where it came from. */
108 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
111 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
112 tem
= call1 (predicate
, value
);
120 error ("Attempt to modify read-only object");
124 args_out_of_range (a1
, a2
)
128 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
132 args_out_of_range_3 (a1
, a2
, a3
)
133 Lisp_Object a1
, a2
, a3
;
136 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
143 register Lisp_Object val
;
148 /* On some machines, XINT needs a temporary location.
149 Here it is, in case it is needed. */
151 int sign_extend_temp
;
153 /* On a few machines, XINT can only be done by calling this. */
156 sign_extend_lisp_int (num
)
159 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
160 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
162 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
165 /* Data type predicates */
167 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
168 "T if the two args are the same Lisp object.")
170 Lisp_Object obj1
, obj2
;
177 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
186 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
187 "Return a symbol representing the type of OBJECT.\n\
188 The symbol returned names the object's basic type;\n\
189 for example, (type-of 1) returns `integer'.")
193 switch (XGCTYPE (object
))
208 switch (XMISCTYPE (object
))
210 case Lisp_Misc_Marker
:
212 case Lisp_Misc_Overlay
:
214 case Lisp_Misc_Float
:
219 case Lisp_Vectorlike
:
220 if (GC_WINDOW_CONFIGURATIONP (object
))
221 return Qwindow_configuration
;
222 if (GC_PROCESSP (object
))
224 if (GC_WINDOWP (object
))
226 if (GC_SUBRP (object
))
228 if (GC_COMPILEDP (object
))
229 return Qcompiled_function
;
230 if (GC_BUFFERP (object
))
232 if (GC_CHAR_TABLE_P (object
))
234 if (GC_BOOL_VECTOR_P (object
))
238 if (GC_FRAMEP (object
))
243 #ifdef LISP_FLOAT_TYPE
253 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
262 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
271 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
275 if (CONSP (object
) || NILP (object
))
280 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
293 if (SYMBOLP (object
))
298 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
302 if (VECTORP (object
))
307 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
311 if (STRINGP (object
))
316 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0, "T if OBJECT is a char-table.")
320 if (CHAR_TABLE_P (object
))
325 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
326 Svector_or_char_table_p
, 1, 1, 0,
327 "T if OBJECT is a char-table or vector.")
331 if (VECTORP (object
) || CHAR_TABLE_P (object
))
336 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "T if OBJECT is a bool-vector.")
340 if (BOOL_VECTOR_P (object
))
345 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
349 if (VECTORP (object
) || STRINGP (object
))
354 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
355 "T if OBJECT is a sequence (list or array).")
357 register Lisp_Object object
;
359 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
360 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
365 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
369 if (BUFFERP (object
))
374 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
378 if (MARKERP (object
))
383 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
392 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
393 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
397 if (COMPILEDP (object
))
402 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
403 "T if OBJECT is a character (an integer) or a string.")
405 register Lisp_Object object
;
407 if (INTEGERP (object
) || STRINGP (object
))
412 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
416 if (INTEGERP (object
))
421 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
422 "T if OBJECT is an integer or a marker (editor pointer).")
424 register Lisp_Object object
;
426 if (MARKERP (object
) || INTEGERP (object
))
431 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
432 "T if OBJECT is a nonnegative integer.")
436 if (NATNUMP (object
))
441 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
442 "T if OBJECT is a number (floating point or integer).")
446 if (NUMBERP (object
))
452 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
453 Snumber_or_marker_p
, 1, 1, 0,
454 "T if OBJECT is a number or a marker.")
458 if (NUMBERP (object
) || MARKERP (object
))
463 #ifdef LISP_FLOAT_TYPE
464 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
465 "T if OBJECT is a floating point number.")
473 #endif /* LISP_FLOAT_TYPE */
475 /* Extract and set components of lists */
477 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
478 "Return the car of LIST. If arg is nil, return nil.\n\
479 Error if arg is not nil and not a cons cell. See also `car-safe'.")
481 register Lisp_Object list
;
486 return XCONS (list
)->car
;
487 else if (EQ (list
, Qnil
))
490 list
= wrong_type_argument (Qlistp
, list
);
494 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
495 "Return the car of OBJECT if it is a cons cell, or else nil.")
500 return XCONS (object
)->car
;
505 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
506 "Return the cdr of LIST. If arg is nil, return nil.\n\
507 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
510 register Lisp_Object list
;
515 return XCONS (list
)->cdr
;
516 else if (EQ (list
, Qnil
))
519 list
= wrong_type_argument (Qlistp
, list
);
523 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
524 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
529 return XCONS (object
)->cdr
;
534 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
535 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
537 register Lisp_Object cell
, newcar
;
540 cell
= wrong_type_argument (Qconsp
, cell
);
543 XCONS (cell
)->car
= newcar
;
547 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
548 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
550 register Lisp_Object cell
, newcdr
;
553 cell
= wrong_type_argument (Qconsp
, cell
);
556 XCONS (cell
)->cdr
= newcdr
;
560 /* Extract and set components of symbols */
562 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
564 register Lisp_Object sym
;
566 Lisp_Object valcontents
;
567 CHECK_SYMBOL (sym
, 0);
569 valcontents
= XSYMBOL (sym
)->value
;
571 if (BUFFER_LOCAL_VALUEP (valcontents
)
572 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
573 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
575 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
578 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
580 register Lisp_Object sym
;
582 CHECK_SYMBOL (sym
, 0);
583 return (EQ (XSYMBOL (sym
)->function
, Qunbound
) ? Qnil
: Qt
);
586 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
588 register Lisp_Object sym
;
590 CHECK_SYMBOL (sym
, 0);
591 if (NILP (sym
) || EQ (sym
, Qt
))
592 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
593 Fset (sym
, Qunbound
);
597 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
599 register Lisp_Object sym
;
601 CHECK_SYMBOL (sym
, 0);
602 if (NILP (sym
) || EQ (sym
, Qt
))
603 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
604 XSYMBOL (sym
)->function
= Qunbound
;
608 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
609 "Return SYMBOL's function definition. Error if that is void.")
611 register Lisp_Object symbol
;
613 CHECK_SYMBOL (symbol
, 0);
614 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
615 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
616 return XSYMBOL (symbol
)->function
;
619 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
621 register Lisp_Object sym
;
623 CHECK_SYMBOL (sym
, 0);
624 return XSYMBOL (sym
)->plist
;
627 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
629 register Lisp_Object sym
;
631 register Lisp_Object name
;
633 CHECK_SYMBOL (sym
, 0);
634 XSETSTRING (name
, XSYMBOL (sym
)->name
);
638 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
639 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
641 register Lisp_Object sym
, newdef
;
643 CHECK_SYMBOL (sym
, 0);
644 if (NILP (sym
) || EQ (sym
, Qt
))
645 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
646 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
647 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
649 XSYMBOL (sym
)->function
= newdef
;
650 /* Handle automatic advice activation */
651 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
653 call2 (Qad_activate
, sym
, Qnil
);
654 newdef
= XSYMBOL (sym
)->function
;
659 /* This name should be removed once it is eliminated from elsewhere. */
661 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
662 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
663 Associates the function with the current load file, if any.")
665 register Lisp_Object sym
, newdef
;
667 CHECK_SYMBOL (sym
, 0);
668 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
669 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
671 XSYMBOL (sym
)->function
= newdef
;
672 /* Handle automatic advice activation */
673 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
675 call2 (Qad_activate
, sym
, Qnil
);
676 newdef
= XSYMBOL (sym
)->function
;
678 LOADHIST_ATTACH (sym
);
682 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
683 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
684 Associates the function with the current load file, if any.")
686 register Lisp_Object sym
, newdef
;
688 CHECK_SYMBOL (sym
, 0);
689 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
690 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
692 XSYMBOL (sym
)->function
= newdef
;
693 /* Handle automatic advice activation */
694 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
696 call2 (Qad_activate
, sym
, Qnil
);
697 newdef
= XSYMBOL (sym
)->function
;
699 LOADHIST_ATTACH (sym
);
703 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
704 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
706 register Lisp_Object sym
, newplist
;
708 CHECK_SYMBOL (sym
, 0);
709 XSYMBOL (sym
)->plist
= newplist
;
714 /* Getting and setting values of symbols */
716 /* Given the raw contents of a symbol value cell,
717 return the Lisp value of the symbol.
718 This does not handle buffer-local variables; use
719 swap_in_symval_forwarding for that. */
722 do_symval_forwarding (valcontents
)
723 register Lisp_Object valcontents
;
725 register Lisp_Object val
;
727 if (MISCP (valcontents
))
728 switch (XMISCTYPE (valcontents
))
730 case Lisp_Misc_Intfwd
:
731 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
734 case Lisp_Misc_Boolfwd
:
735 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
737 case Lisp_Misc_Objfwd
:
738 return *XOBJFWD (valcontents
)->objvar
;
740 case Lisp_Misc_Buffer_Objfwd
:
741 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
742 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
744 case Lisp_Misc_Kboard_Objfwd
:
745 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
746 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
751 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
752 of SYM. If SYM is buffer-local, VALCONTENTS should be the
753 buffer-independent contents of the value cell: forwarded just one
754 step past the buffer-localness. */
757 store_symval_forwarding (sym
, valcontents
, newval
)
759 register Lisp_Object valcontents
, newval
;
761 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
764 switch (XMISCTYPE (valcontents
))
766 case Lisp_Misc_Intfwd
:
767 CHECK_NUMBER (newval
, 1);
768 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
769 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
770 error ("Value out of range for variable `%s'",
771 XSYMBOL (sym
)->name
->data
);
774 case Lisp_Misc_Boolfwd
:
775 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
778 case Lisp_Misc_Objfwd
:
779 *XOBJFWD (valcontents
)->objvar
= newval
;
782 case Lisp_Misc_Buffer_Objfwd
:
784 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
787 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
788 if (! NILP (type
) && ! NILP (newval
)
789 && XTYPE (newval
) != XINT (type
))
790 buffer_slot_type_mismatch (offset
);
792 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
796 case Lisp_Misc_Kboard_Objfwd
:
797 (*(Lisp_Object
*)((char *)current_kboard
798 + XKBOARD_OBJFWD (valcontents
)->offset
))
809 valcontents
= XSYMBOL (sym
)->value
;
810 if (BUFFER_LOCAL_VALUEP (valcontents
)
811 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
812 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
814 XSYMBOL (sym
)->value
= newval
;
818 /* Set up the buffer-local symbol SYM for validity in the current
819 buffer. VALCONTENTS is the contents of its value cell.
820 Return the value forwarded one step past the buffer-local indicator. */
823 swap_in_symval_forwarding (sym
, valcontents
)
824 Lisp_Object sym
, valcontents
;
826 /* valcontents is a pointer to a struct resembling the cons
827 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
829 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
830 local_var_alist, that being the element whose car is this
831 variable. Or it can be a pointer to the
832 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
833 an element in its alist for this variable.
835 If the current buffer is not BUFFER, we store the current
836 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
837 appropriate alist element for the buffer now current and set up
838 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
839 element, and store into BUFFER.
841 Note that REALVALUE can be a forwarding pointer. */
843 register Lisp_Object tem1
;
844 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
846 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
848 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
850 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
851 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
853 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
854 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
855 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
857 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
860 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
863 /* Find the value of a symbol, returning Qunbound if it's not bound.
864 This is helpful for code which just wants to get a variable's value
865 if it has one, without signalling an error.
866 Note that it must not be possible to quit
867 within this function. Great care is required for this. */
870 find_symbol_value (sym
)
873 register Lisp_Object valcontents
, tem1
;
874 register Lisp_Object val
;
875 CHECK_SYMBOL (sym
, 0);
876 valcontents
= XSYMBOL (sym
)->value
;
878 if (BUFFER_LOCAL_VALUEP (valcontents
)
879 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
880 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
882 if (MISCP (valcontents
))
884 switch (XMISCTYPE (valcontents
))
886 case Lisp_Misc_Intfwd
:
887 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
890 case Lisp_Misc_Boolfwd
:
891 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
893 case Lisp_Misc_Objfwd
:
894 return *XOBJFWD (valcontents
)->objvar
;
896 case Lisp_Misc_Buffer_Objfwd
:
897 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
898 + (char *)current_buffer
);
900 case Lisp_Misc_Kboard_Objfwd
:
901 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
902 + (char *)current_kboard
);
909 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
910 "Return SYMBOL's value. Error if that is void.")
916 val
= find_symbol_value (sym
);
917 if (EQ (val
, Qunbound
))
918 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
923 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
924 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
926 register Lisp_Object sym
, newval
;
928 int voide
= EQ (newval
, Qunbound
);
930 register Lisp_Object valcontents
, tem1
, current_alist_element
;
932 CHECK_SYMBOL (sym
, 0);
933 if (NILP (sym
) || EQ (sym
, Qt
))
934 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
935 valcontents
= XSYMBOL (sym
)->value
;
937 if (BUFFER_OBJFWDP (valcontents
))
939 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
940 register int mask
= XINT (*((Lisp_Object
*)
941 (idx
+ (char *)&buffer_local_flags
)));
943 current_buffer
->local_var_flags
|= mask
;
946 else if (BUFFER_LOCAL_VALUEP (valcontents
)
947 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
949 /* valcontents is actually a pointer to a struct resembling a cons,
950 with contents something like:
951 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
953 BUFFER is the last buffer for which this symbol's value was
956 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
957 local_var_alist, that being the element whose car is this
958 variable. Or it can be a pointer to the
959 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
960 have an element in its alist for this variable (that is, if
961 BUFFER sees the default value of this variable).
963 If we want to examine or set the value and BUFFER is current,
964 we just examine or set REALVALUE. If BUFFER is not current, we
965 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
966 then find the appropriate alist element for the buffer now
967 current and set up CURRENT-ALIST-ELEMENT. Then we set
968 REALVALUE out of that element, and store into BUFFER.
970 If we are setting the variable and the current buffer does
971 not have an alist entry for this variable, an alist entry is
974 Note that REALVALUE can be a forwarding pointer. Each time
975 it is examined or set, forwarding must be done. */
977 /* What value are we caching right now? */
978 current_alist_element
=
979 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
981 /* If the current buffer is not the buffer whose binding is
982 currently cached, or if it's a Lisp_Buffer_Local_Value and
983 we're looking at the default value, the cache is invalid; we
984 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
986 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
987 || (BUFFER_LOCAL_VALUEP (valcontents
)
988 && EQ (XCONS (current_alist_element
)->car
,
989 current_alist_element
)))
991 /* Write out the cached value for the old buffer; copy it
992 back to its alist element. This works if the current
993 buffer only sees the default value, too. */
994 Fsetcdr (current_alist_element
,
995 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
997 /* Find the new value for CURRENT-ALIST-ELEMENT. */
998 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
1001 /* This buffer still sees the default value. */
1003 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1004 make CURRENT-ALIST-ELEMENT point to itself,
1005 indicating that we're seeing the default value. */
1006 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1007 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1009 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
1010 new assoc for a local value and set
1011 CURRENT-ALIST-ELEMENT to point to that. */
1014 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
1015 current_buffer
->local_var_alist
=
1016 Fcons (tem1
, current_buffer
->local_var_alist
);
1019 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1020 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
1023 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1024 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
1027 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1030 /* If storing void (making the symbol void), forward only through
1031 buffer-local indicator, not through Lisp_Objfwd, etc. */
1033 store_symval_forwarding (sym
, Qnil
, newval
);
1035 store_symval_forwarding (sym
, valcontents
, newval
);
1040 /* Access or set a buffer-local symbol's default value. */
1042 /* Return the default value of SYM, but don't check for voidness.
1043 Return Qunbound if it is void. */
1049 register Lisp_Object valcontents
;
1051 CHECK_SYMBOL (sym
, 0);
1052 valcontents
= XSYMBOL (sym
)->value
;
1054 /* For a built-in buffer-local variable, get the default value
1055 rather than letting do_symval_forwarding get the current value. */
1056 if (BUFFER_OBJFWDP (valcontents
))
1058 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1060 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1061 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1064 /* Handle user-created local variables. */
1065 if (BUFFER_LOCAL_VALUEP (valcontents
)
1066 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1068 /* If var is set up for a buffer that lacks a local value for it,
1069 the current value is nominally the default value.
1070 But the current value slot may be more up to date, since
1071 ordinary setq stores just that slot. So use that. */
1072 Lisp_Object current_alist_element
, alist_element_car
;
1073 current_alist_element
1074 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1075 alist_element_car
= XCONS (current_alist_element
)->car
;
1076 if (EQ (alist_element_car
, current_alist_element
))
1077 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1079 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1081 /* For other variables, get the current value. */
1082 return do_symval_forwarding (valcontents
);
1085 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1086 "Return T if SYMBOL has a non-void default value.\n\
1087 This is the value that is seen in buffers that do not have their own values\n\
1088 for this variable.")
1092 register Lisp_Object value
;
1094 value
= default_value (sym
);
1095 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1098 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1099 "Return SYMBOL's default value.\n\
1100 This is the value that is seen in buffers that do not have their own values\n\
1101 for this variable. The default value is meaningful for variables with\n\
1102 local bindings in certain buffers.")
1106 register Lisp_Object value
;
1108 value
= default_value (sym
);
1109 if (EQ (value
, Qunbound
))
1110 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1114 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1115 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1116 The default value is seen in buffers that do not have their own values\n\
1117 for this variable.")
1119 Lisp_Object sym
, value
;
1121 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1123 CHECK_SYMBOL (sym
, 0);
1124 valcontents
= XSYMBOL (sym
)->value
;
1126 /* Handle variables like case-fold-search that have special slots
1127 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1129 if (BUFFER_OBJFWDP (valcontents
))
1131 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1132 register struct buffer
*b
;
1133 register int mask
= XINT (*((Lisp_Object
*)
1134 (idx
+ (char *)&buffer_local_flags
)));
1138 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1139 for (b
= all_buffers
; b
; b
= b
->next
)
1140 if (!(b
->local_var_flags
& mask
))
1141 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1146 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1147 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1148 return Fset (sym
, value
);
1150 /* Store new value into the DEFAULT-VALUE slot */
1151 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1153 /* If that slot is current, we must set the REALVALUE slot too */
1154 current_alist_element
1155 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1156 alist_element_buffer
= Fcar (current_alist_element
);
1157 if (EQ (alist_element_buffer
, current_alist_element
))
1158 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1164 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1165 "Set the default value of variable VAR to VALUE.\n\
1166 VAR, the variable name, is literal (not evaluated);\n\
1167 VALUE is an expression and it is evaluated.\n\
1168 The default value of a variable is seen in buffers\n\
1169 that do not have their own values for the variable.\n\
1171 More generally, you can use multiple variables and values, as in\n\
1172 (setq-default SYM VALUE SYM VALUE...)\n\
1173 This sets each SYM's default value to the corresponding VALUE.\n\
1174 The VALUE for the Nth SYM can refer to the new default values\n\
1179 register Lisp_Object args_left
;
1180 register Lisp_Object val
, sym
;
1181 struct gcpro gcpro1
;
1191 val
= Feval (Fcar (Fcdr (args_left
)));
1192 sym
= Fcar (args_left
);
1193 Fset_default (sym
, val
);
1194 args_left
= Fcdr (Fcdr (args_left
));
1196 while (!NILP (args_left
));
1202 /* Lisp functions for creating and removing buffer-local variables. */
1204 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1205 1, 1, "vMake Variable Buffer Local: ",
1206 "Make VARIABLE have a separate value for each buffer.\n\
1207 At any time, the value for the current buffer is in effect.\n\
1208 There is also a default value which is seen in any buffer which has not yet\n\
1209 set its own value.\n\
1210 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1211 for the current buffer if it was previously using the default value.\n\
1212 The function `default-value' gets the default value and `set-default' sets it.")
1214 register Lisp_Object sym
;
1216 register Lisp_Object tem
, valcontents
, newval
;
1218 CHECK_SYMBOL (sym
, 0);
1220 valcontents
= XSYMBOL (sym
)->value
;
1221 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1222 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1224 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1226 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1228 XMISCTYPE (XSYMBOL (sym
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1231 if (EQ (valcontents
, Qunbound
))
1232 XSYMBOL (sym
)->value
= Qnil
;
1233 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1234 XCONS (tem
)->car
= tem
;
1235 newval
= allocate_misc ();
1236 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1237 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1238 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1239 XSYMBOL (sym
)->value
= newval
;
1243 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1244 1, 1, "vMake Local Variable: ",
1245 "Make VARIABLE have a separate value in the current buffer.\n\
1246 Other buffers will continue to share a common default value.\n\
1247 \(The buffer-local value of VARIABLE starts out as the same value\n\
1248 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1249 See also `make-variable-buffer-local'.\n\n\
1250 If the variable is already arranged to become local when set,\n\
1251 this function causes a local value to exist for this buffer,\n\
1252 just as setting the variable would do.\n\
1254 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1255 Use `make-local-hook' instead.")
1257 register Lisp_Object sym
;
1259 register Lisp_Object tem
, valcontents
;
1261 CHECK_SYMBOL (sym
, 0);
1263 valcontents
= XSYMBOL (sym
)->value
;
1264 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1265 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1267 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1269 tem
= Fboundp (sym
);
1271 /* Make sure the symbol has a local value in this particular buffer,
1272 by setting it to the same value it already has. */
1273 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1276 /* Make sure sym is set up to hold per-buffer values */
1277 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1280 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1281 XCONS (tem
)->car
= tem
;
1282 newval
= allocate_misc ();
1283 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1284 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1285 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1286 XSYMBOL (sym
)->value
= newval
;
1288 /* Make sure this buffer has its own value of sym */
1289 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1292 /* Swap out any local binding for some other buffer, and make
1293 sure the current value is permanently recorded, if it's the
1295 find_symbol_value (sym
);
1297 current_buffer
->local_var_alist
1298 = Fcons (Fcons (sym
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1299 current_buffer
->local_var_alist
);
1301 /* Make sure symbol does not think it is set up for this buffer;
1302 force it to look once again for this buffer's value */
1304 Lisp_Object
*pvalbuf
;
1306 valcontents
= XSYMBOL (sym
)->value
;
1308 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1309 if (current_buffer
== XBUFFER (*pvalbuf
))
1314 /* If the symbol forwards into a C variable, then swap in the
1315 variable for this buffer immediately. If C code modifies the
1316 variable before we swap in, then that new value will clobber the
1317 default value the next time we swap. */
1318 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->car
;
1319 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1320 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1325 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1326 1, 1, "vKill Local Variable: ",
1327 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1328 From now on the default value will apply in this buffer.")
1330 register Lisp_Object sym
;
1332 register Lisp_Object tem
, valcontents
;
1334 CHECK_SYMBOL (sym
, 0);
1336 valcontents
= XSYMBOL (sym
)->value
;
1338 if (BUFFER_OBJFWDP (valcontents
))
1340 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1341 register int mask
= XINT (*((Lisp_Object
*)
1342 (idx
+ (char *)&buffer_local_flags
)));
1346 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1347 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1348 current_buffer
->local_var_flags
&= ~mask
;
1353 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1354 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1357 /* Get rid of this buffer's alist element, if any */
1359 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1361 current_buffer
->local_var_alist
1362 = Fdelq (tem
, current_buffer
->local_var_alist
);
1364 /* Make sure symbol does not think it is set up for this buffer;
1365 force it to look once again for this buffer's value */
1367 Lisp_Object
*pvalbuf
;
1368 valcontents
= XSYMBOL (sym
)->value
;
1369 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1370 if (current_buffer
== XBUFFER (*pvalbuf
))
1377 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1379 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1380 BUFFER defaults to the current buffer.")
1382 register Lisp_Object sym
, buffer
;
1384 Lisp_Object valcontents
;
1385 register struct buffer
*buf
;
1388 buf
= current_buffer
;
1391 CHECK_BUFFER (buffer
, 0);
1392 buf
= XBUFFER (buffer
);
1395 CHECK_SYMBOL (sym
, 0);
1397 valcontents
= XSYMBOL (sym
)->value
;
1398 if (BUFFER_LOCAL_VALUEP (valcontents
)
1399 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1401 Lisp_Object tail
, elt
;
1402 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1404 elt
= XCONS (tail
)->car
;
1405 if (EQ (sym
, XCONS (elt
)->car
))
1409 if (BUFFER_OBJFWDP (valcontents
))
1411 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1412 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1413 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1419 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1421 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1422 BUFFER defaults to the current buffer.")
1424 register Lisp_Object sym
, buffer
;
1426 Lisp_Object valcontents
;
1427 register struct buffer
*buf
;
1430 buf
= current_buffer
;
1433 CHECK_BUFFER (buffer
, 0);
1434 buf
= XBUFFER (buffer
);
1437 CHECK_SYMBOL (sym
, 0);
1439 valcontents
= XSYMBOL (sym
)->value
;
1441 /* This means that make-variable-buffer-local was done. */
1442 if (BUFFER_LOCAL_VALUEP (valcontents
))
1444 /* All these slots become local if they are set. */
1445 if (BUFFER_OBJFWDP (valcontents
))
1447 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1449 Lisp_Object tail
, elt
;
1450 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1452 elt
= XCONS (tail
)->car
;
1453 if (EQ (sym
, XCONS (elt
)->car
))
1460 /* Find the function at the end of a chain of symbol function indirections. */
1462 /* If OBJECT is a symbol, find the end of its function chain and
1463 return the value found there. If OBJECT is not a symbol, just
1464 return it. If there is a cycle in the function chain, signal a
1465 cyclic-function-indirection error.
1467 This is like Findirect_function, except that it doesn't signal an
1468 error if the chain ends up unbound. */
1470 indirect_function (object
)
1471 register Lisp_Object object
;
1473 Lisp_Object tortoise
, hare
;
1475 hare
= tortoise
= object
;
1479 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1481 hare
= XSYMBOL (hare
)->function
;
1482 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1484 hare
= XSYMBOL (hare
)->function
;
1486 tortoise
= XSYMBOL (tortoise
)->function
;
1488 if (EQ (hare
, tortoise
))
1489 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1495 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1496 "Return the function at the end of OBJECT's function chain.\n\
1497 If OBJECT is a symbol, follow all function indirections and return the final\n\
1498 function binding.\n\
1499 If OBJECT is not a symbol, just return it.\n\
1500 Signal a void-function error if the final symbol is unbound.\n\
1501 Signal a cyclic-function-indirection error if there is a loop in the\n\
1502 function chain of symbols.")
1504 register Lisp_Object object
;
1508 result
= indirect_function (object
);
1510 if (EQ (result
, Qunbound
))
1511 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1515 /* Extract and set vector and string elements */
1517 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1518 "Return the element of ARRAY at index INDEX.\n\
1519 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1520 or a byte-code object. INDEX starts at 0.")
1522 register Lisp_Object array
;
1525 register int idxval
;
1527 CHECK_NUMBER (idx
, 1);
1528 idxval
= XINT (idx
);
1529 if (STRINGP (array
))
1532 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1533 args_out_of_range (array
, idx
);
1534 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1537 else if (BOOL_VECTOR_P (array
))
1541 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1542 args_out_of_range (array
, idx
);
1544 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1545 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1547 else if (CHAR_TABLE_P (array
))
1552 args_out_of_range (array
, idx
);
1554 if ((unsigned) idxval
>= CHAR_TABLE_ORDINARY_SLOTS
)
1555 args_out_of_range (array
, idx
);
1556 return val
= XCHAR_TABLE (array
)->contents
[idxval
];
1558 if ((unsigned) idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1559 val
= XCHAR_TABLE (array
)->data
[idxval
];
1563 unsigned char c1
, c2
;
1564 Lisp_Object val
, temp
;
1566 BREAKUP_NON_ASCII_CHAR (idxval
, charset
, c1
, c2
);
1568 try_parent_char_table
:
1569 val
= XCHAR_TABLE (array
)->contents
[charset
];
1570 if (c1
== 0 || !CHAR_TABLE_P (val
))
1573 temp
= XCHAR_TABLE (val
)->contents
[c1
];
1575 val
= XCHAR_TABLE (val
)->defalt
;
1579 if (NILP (val
) && !NILP (XCHAR_TABLE (array
)->parent
))
1581 array
= XCHAR_TABLE (array
)->parent
;
1582 goto try_parent_char_table
;
1586 if (c2
== 0 || !CHAR_TABLE_P (val
))
1589 temp
= XCHAR_TABLE (val
)->contents
[c2
];
1591 val
= XCHAR_TABLE (val
)->defalt
;
1595 if (NILP (val
) && !NILP (XCHAR_TABLE (array
)->parent
))
1597 array
= XCHAR_TABLE (array
)->parent
;
1598 goto try_parent_char_table
;
1608 if (VECTORP (array
))
1609 size
= XVECTOR (array
)->size
;
1610 else if (COMPILEDP (array
))
1611 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1613 wrong_type_argument (Qarrayp
, array
);
1615 if (idxval
< 0 || idxval
>= size
)
1616 args_out_of_range (array
, idx
);
1617 return XVECTOR (array
)->contents
[idxval
];
1621 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1622 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1623 ARRAY may be a vector or a string. IDX starts at 0.")
1624 (array
, idx
, newelt
)
1625 register Lisp_Object array
;
1626 Lisp_Object idx
, newelt
;
1628 register int idxval
;
1630 CHECK_NUMBER (idx
, 1);
1631 idxval
= XINT (idx
);
1632 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1633 && ! CHAR_TABLE_P (array
))
1634 array
= wrong_type_argument (Qarrayp
, array
);
1635 CHECK_IMPURE (array
);
1637 if (VECTORP (array
))
1639 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1640 args_out_of_range (array
, idx
);
1641 XVECTOR (array
)->contents
[idxval
] = newelt
;
1643 else if (BOOL_VECTOR_P (array
))
1647 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1648 args_out_of_range (array
, idx
);
1650 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1652 if (! NILP (newelt
))
1653 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1655 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1656 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1658 else if (CHAR_TABLE_P (array
))
1663 args_out_of_range (array
, idx
);
1665 if (idxval
>= CHAR_TABLE_ORDINARY_SLOTS
)
1666 args_out_of_range (array
, idx
);
1667 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1670 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1671 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1675 unsigned char c1
, c2
;
1676 Lisp_Object val
, val2
;
1678 BREAKUP_NON_ASCII_CHAR (idxval
, charset
, c1
, c2
);
1681 return XCHAR_TABLE (array
)->contents
[charset
] = newelt
;
1683 val
= XCHAR_TABLE (array
)->contents
[charset
];
1684 if (!CHAR_TABLE_P (val
))
1685 XCHAR_TABLE (array
)->contents
[charset
]
1686 = val
= Fmake_char_table (Qnil
);
1689 return XCHAR_TABLE (val
)->contents
[c1
] = newelt
;
1691 val2
= XCHAR_TABLE (val
)->contents
[c2
];
1692 if (!CHAR_TABLE_P (val2
))
1693 XCHAR_TABLE (val
)->contents
[charset
]
1694 = val2
= Fmake_char_table (Qnil
);
1696 return XCHAR_TABLE (val2
)->contents
[c2
] = newelt
;
1702 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1703 args_out_of_range (array
, idx
);
1704 CHECK_NUMBER (newelt
, 2);
1705 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1711 /* Arithmetic functions */
1713 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1716 arithcompare (num1
, num2
, comparison
)
1717 Lisp_Object num1
, num2
;
1718 enum comparison comparison
;
1723 #ifdef LISP_FLOAT_TYPE
1724 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1725 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1727 if (FLOATP (num1
) || FLOATP (num2
))
1730 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1731 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1734 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1735 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1736 #endif /* LISP_FLOAT_TYPE */
1741 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1746 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1751 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1756 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1761 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1766 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1775 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1776 "T if two args, both numbers or markers, are equal.")
1778 register Lisp_Object num1
, num2
;
1780 return arithcompare (num1
, num2
, equal
);
1783 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1784 "T if first arg is less than second arg. Both must be numbers or markers.")
1786 register Lisp_Object num1
, num2
;
1788 return arithcompare (num1
, num2
, less
);
1791 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1792 "T if first arg is greater than second arg. Both must be numbers or markers.")
1794 register Lisp_Object num1
, num2
;
1796 return arithcompare (num1
, num2
, grtr
);
1799 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1800 "T if first arg is less than or equal to second arg.\n\
1801 Both must be numbers or markers.")
1803 register Lisp_Object num1
, num2
;
1805 return arithcompare (num1
, num2
, less_or_equal
);
1808 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1809 "T if first arg is greater than or equal to second arg.\n\
1810 Both must be numbers or markers.")
1812 register Lisp_Object num1
, num2
;
1814 return arithcompare (num1
, num2
, grtr_or_equal
);
1817 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1818 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1820 register Lisp_Object num1
, num2
;
1822 return arithcompare (num1
, num2
, notequal
);
1825 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1827 register Lisp_Object num
;
1829 #ifdef LISP_FLOAT_TYPE
1830 CHECK_NUMBER_OR_FLOAT (num
, 0);
1834 if (XFLOAT(num
)->data
== 0.0)
1839 CHECK_NUMBER (num
, 0);
1840 #endif /* LISP_FLOAT_TYPE */
1847 /* Convert between long values and pairs of Lisp integers. */
1853 unsigned int top
= i
>> 16;
1854 unsigned int bot
= i
& 0xFFFF;
1856 return make_number (bot
);
1857 if (top
== (unsigned long)-1 >> 16)
1858 return Fcons (make_number (-1), make_number (bot
));
1859 return Fcons (make_number (top
), make_number (bot
));
1866 Lisp_Object top
, bot
;
1869 top
= XCONS (c
)->car
;
1870 bot
= XCONS (c
)->cdr
;
1872 bot
= XCONS (bot
)->car
;
1873 return ((XINT (top
) << 16) | XINT (bot
));
1876 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1877 "Convert NUM to a string by printing it in decimal.\n\
1878 Uses a minus sign if negative.\n\
1879 NUM may be an integer or a floating point number.")
1883 char buffer
[VALBITS
];
1885 #ifndef LISP_FLOAT_TYPE
1886 CHECK_NUMBER (num
, 0);
1888 CHECK_NUMBER_OR_FLOAT (num
, 0);
1892 char pigbuf
[350]; /* see comments in float_to_string */
1894 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1895 return build_string (pigbuf
);
1897 #endif /* LISP_FLOAT_TYPE */
1899 if (sizeof (int) == sizeof (EMACS_INT
))
1900 sprintf (buffer
, "%d", XINT (num
));
1901 else if (sizeof (long) == sizeof (EMACS_INT
))
1902 sprintf (buffer
, "%ld", XINT (num
));
1905 return build_string (buffer
);
1908 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1909 "Convert STRING to a number by parsing it as a decimal number.\n\
1910 This parses both integers and floating point numbers.\n\
1911 It ignores leading spaces and tabs.")
1913 register Lisp_Object str
;
1918 CHECK_STRING (str
, 0);
1920 p
= XSTRING (str
)->data
;
1922 /* Skip any whitespace at the front of the number. Some versions of
1923 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1924 while (*p
== ' ' || *p
== '\t')
1927 #ifdef LISP_FLOAT_TYPE
1928 if (isfloat_string (p
))
1929 return make_float (atof (p
));
1930 #endif /* LISP_FLOAT_TYPE */
1932 if (sizeof (int) == sizeof (EMACS_INT
))
1933 XSETINT (value
, atoi (p
));
1934 else if (sizeof (long) == sizeof (EMACS_INT
))
1935 XSETINT (value
, atol (p
));
1942 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1944 extern Lisp_Object
float_arith_driver ();
1947 arith_driver (code
, nargs
, args
)
1950 register Lisp_Object
*args
;
1952 register Lisp_Object val
;
1953 register int argnum
;
1954 register EMACS_INT accum
;
1955 register EMACS_INT next
;
1957 switch (SWITCH_ENUM_CAST (code
))
1970 for (argnum
= 0; argnum
< nargs
; argnum
++)
1972 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1973 #ifdef LISP_FLOAT_TYPE
1974 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1976 if (FLOATP (val
)) /* time to do serious math */
1977 return (float_arith_driver ((double) accum
, argnum
, code
,
1980 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1981 #endif /* LISP_FLOAT_TYPE */
1982 args
[argnum
] = val
; /* runs into a compiler bug. */
1983 next
= XINT (args
[argnum
]);
1984 switch (SWITCH_ENUM_CAST (code
))
1986 case Aadd
: accum
+= next
; break;
1988 if (!argnum
&& nargs
!= 1)
1992 case Amult
: accum
*= next
; break;
1994 if (!argnum
) accum
= next
;
1998 Fsignal (Qarith_error
, Qnil
);
2002 case Alogand
: accum
&= next
; break;
2003 case Alogior
: accum
|= next
; break;
2004 case Alogxor
: accum
^= next
; break;
2005 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2006 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2010 XSETINT (val
, accum
);
2014 #ifdef LISP_FLOAT_TYPE
2017 #define isnan(x) ((x) != (x))
2020 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2022 register int argnum
;
2025 register Lisp_Object
*args
;
2027 register Lisp_Object val
;
2030 for (; argnum
< nargs
; argnum
++)
2032 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2033 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2037 next
= XFLOAT (val
)->data
;
2041 args
[argnum
] = val
; /* runs into a compiler bug. */
2042 next
= XINT (args
[argnum
]);
2044 switch (SWITCH_ENUM_CAST (code
))
2050 if (!argnum
&& nargs
!= 1)
2063 Fsignal (Qarith_error
, Qnil
);
2070 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2072 if (!argnum
|| isnan (next
) || next
> accum
)
2076 if (!argnum
|| isnan (next
) || next
< accum
)
2082 return make_float (accum
);
2084 #endif /* LISP_FLOAT_TYPE */
2086 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2087 "Return sum of any number of arguments, which are numbers or markers.")
2092 return arith_driver (Aadd
, nargs
, args
);
2095 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2096 "Negate number or subtract numbers or markers.\n\
2097 With one arg, negates it. With more than one arg,\n\
2098 subtracts all but the first from the first.")
2103 return arith_driver (Asub
, nargs
, args
);
2106 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2107 "Returns product of any number of arguments, which are numbers or markers.")
2112 return arith_driver (Amult
, nargs
, args
);
2115 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2116 "Returns first argument divided by all the remaining arguments.\n\
2117 The arguments must be numbers or markers.")
2122 return arith_driver (Adiv
, nargs
, args
);
2125 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2126 "Returns remainder of first arg divided by second.\n\
2127 Both must be integers or markers.")
2129 register Lisp_Object num1
, num2
;
2133 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
2134 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
2136 if (XFASTINT (num2
) == 0)
2137 Fsignal (Qarith_error
, Qnil
);
2139 XSETINT (val
, XINT (num1
) % XINT (num2
));
2150 return (f1
- f2
* floor (f1
/f2
));
2152 #endif /* ! HAVE_FMOD */
2154 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2155 "Returns X modulo Y.\n\
2156 The result falls between zero (inclusive) and Y (exclusive).\n\
2157 Both X and Y must be numbers or markers.")
2159 register Lisp_Object num1
, num2
;
2164 #ifdef LISP_FLOAT_TYPE
2165 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
2166 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
2168 if (FLOATP (num1
) || FLOATP (num2
))
2172 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
2173 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
2175 Fsignal (Qarith_error
, Qnil
);
2178 /* If the "remainder" comes out with the wrong sign, fix it. */
2179 if (f2
< 0 ? f1
> 0 : f1
< 0)
2181 return (make_float (f1
));
2183 #else /* not LISP_FLOAT_TYPE */
2184 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
2185 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
2186 #endif /* not LISP_FLOAT_TYPE */
2192 Fsignal (Qarith_error
, Qnil
);
2196 /* If the "remainder" comes out with the wrong sign, fix it. */
2197 if (i2
< 0 ? i1
> 0 : i1
< 0)
2204 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2205 "Return largest of all the arguments (which must be numbers or markers).\n\
2206 The value is always a number; markers are converted to numbers.")
2211 return arith_driver (Amax
, nargs
, args
);
2214 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2215 "Return smallest of all the arguments (which must be numbers or markers).\n\
2216 The value is always a number; markers are converted to numbers.")
2221 return arith_driver (Amin
, nargs
, args
);
2224 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2225 "Return bitwise-and of all the arguments.\n\
2226 Arguments may be integers, or markers converted to integers.")
2231 return arith_driver (Alogand
, nargs
, args
);
2234 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2235 "Return bitwise-or of all the arguments.\n\
2236 Arguments may be integers, or markers converted to integers.")
2241 return arith_driver (Alogior
, nargs
, args
);
2244 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2245 "Return bitwise-exclusive-or of all the arguments.\n\
2246 Arguments may be integers, or markers converted to integers.")
2251 return arith_driver (Alogxor
, nargs
, args
);
2254 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2255 "Return VALUE with its bits shifted left by COUNT.\n\
2256 If COUNT is negative, shifting is actually to the right.\n\
2257 In this case, the sign bit is duplicated.")
2259 register Lisp_Object value
, count
;
2261 register Lisp_Object val
;
2263 CHECK_NUMBER (value
, 0);
2264 CHECK_NUMBER (count
, 1);
2266 if (XINT (count
) > 0)
2267 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2269 XSETINT (val
, XINT (value
) >> -XINT (count
));
2273 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2274 "Return VALUE with its bits shifted left by COUNT.\n\
2275 If COUNT is negative, shifting is actually to the right.\n\
2276 In this case, zeros are shifted in on the left.")
2278 register Lisp_Object value
, count
;
2280 register Lisp_Object val
;
2282 CHECK_NUMBER (value
, 0);
2283 CHECK_NUMBER (count
, 1);
2285 if (XINT (count
) > 0)
2286 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2288 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2292 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2293 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2294 Markers are converted to integers.")
2296 register Lisp_Object num
;
2298 #ifdef LISP_FLOAT_TYPE
2299 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2302 return (make_float (1.0 + XFLOAT (num
)->data
));
2304 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2305 #endif /* LISP_FLOAT_TYPE */
2307 XSETINT (num
, XINT (num
) + 1);
2311 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2312 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2313 Markers are converted to integers.")
2315 register Lisp_Object num
;
2317 #ifdef LISP_FLOAT_TYPE
2318 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2321 return (make_float (-1.0 + XFLOAT (num
)->data
));
2323 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2324 #endif /* LISP_FLOAT_TYPE */
2326 XSETINT (num
, XINT (num
) - 1);
2330 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2331 "Return the bitwise complement of ARG. ARG must be an integer.")
2333 register Lisp_Object num
;
2335 CHECK_NUMBER (num
, 0);
2336 XSETINT (num
, ~XINT (num
));
2343 Lisp_Object error_tail
, arith_tail
;
2345 Qquote
= intern ("quote");
2346 Qlambda
= intern ("lambda");
2347 Qsubr
= intern ("subr");
2348 Qerror_conditions
= intern ("error-conditions");
2349 Qerror_message
= intern ("error-message");
2350 Qtop_level
= intern ("top-level");
2352 Qerror
= intern ("error");
2353 Qquit
= intern ("quit");
2354 Qwrong_type_argument
= intern ("wrong-type-argument");
2355 Qargs_out_of_range
= intern ("args-out-of-range");
2356 Qvoid_function
= intern ("void-function");
2357 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2358 Qvoid_variable
= intern ("void-variable");
2359 Qsetting_constant
= intern ("setting-constant");
2360 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2362 Qinvalid_function
= intern ("invalid-function");
2363 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2364 Qno_catch
= intern ("no-catch");
2365 Qend_of_file
= intern ("end-of-file");
2366 Qarith_error
= intern ("arith-error");
2367 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2368 Qend_of_buffer
= intern ("end-of-buffer");
2369 Qbuffer_read_only
= intern ("buffer-read-only");
2370 Qmark_inactive
= intern ("mark-inactive");
2372 Qlistp
= intern ("listp");
2373 Qconsp
= intern ("consp");
2374 Qsymbolp
= intern ("symbolp");
2375 Qintegerp
= intern ("integerp");
2376 Qnatnump
= intern ("natnump");
2377 Qwholenump
= intern ("wholenump");
2378 Qstringp
= intern ("stringp");
2379 Qarrayp
= intern ("arrayp");
2380 Qsequencep
= intern ("sequencep");
2381 Qbufferp
= intern ("bufferp");
2382 Qvectorp
= intern ("vectorp");
2383 Qchar_or_string_p
= intern ("char-or-string-p");
2384 Qmarkerp
= intern ("markerp");
2385 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2386 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2387 Qboundp
= intern ("boundp");
2388 Qfboundp
= intern ("fboundp");
2390 #ifdef LISP_FLOAT_TYPE
2391 Qfloatp
= intern ("floatp");
2392 Qnumberp
= intern ("numberp");
2393 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2394 #endif /* LISP_FLOAT_TYPE */
2396 Qchar_table_p
= intern ("char-table-p");
2397 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2399 Qcdr
= intern ("cdr");
2401 /* Handle automatic advice activation */
2402 Qad_advice_info
= intern ("ad-advice-info");
2403 Qad_activate
= intern ("ad-activate");
2405 error_tail
= Fcons (Qerror
, Qnil
);
2407 /* ERROR is used as a signaler for random errors for which nothing else is right */
2409 Fput (Qerror
, Qerror_conditions
,
2411 Fput (Qerror
, Qerror_message
,
2412 build_string ("error"));
2414 Fput (Qquit
, Qerror_conditions
,
2415 Fcons (Qquit
, Qnil
));
2416 Fput (Qquit
, Qerror_message
,
2417 build_string ("Quit"));
2419 Fput (Qwrong_type_argument
, Qerror_conditions
,
2420 Fcons (Qwrong_type_argument
, error_tail
));
2421 Fput (Qwrong_type_argument
, Qerror_message
,
2422 build_string ("Wrong type argument"));
2424 Fput (Qargs_out_of_range
, Qerror_conditions
,
2425 Fcons (Qargs_out_of_range
, error_tail
));
2426 Fput (Qargs_out_of_range
, Qerror_message
,
2427 build_string ("Args out of range"));
2429 Fput (Qvoid_function
, Qerror_conditions
,
2430 Fcons (Qvoid_function
, error_tail
));
2431 Fput (Qvoid_function
, Qerror_message
,
2432 build_string ("Symbol's function definition is void"));
2434 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2435 Fcons (Qcyclic_function_indirection
, error_tail
));
2436 Fput (Qcyclic_function_indirection
, Qerror_message
,
2437 build_string ("Symbol's chain of function indirections contains a loop"));
2439 Fput (Qvoid_variable
, Qerror_conditions
,
2440 Fcons (Qvoid_variable
, error_tail
));
2441 Fput (Qvoid_variable
, Qerror_message
,
2442 build_string ("Symbol's value as variable is void"));
2444 Fput (Qsetting_constant
, Qerror_conditions
,
2445 Fcons (Qsetting_constant
, error_tail
));
2446 Fput (Qsetting_constant
, Qerror_message
,
2447 build_string ("Attempt to set a constant symbol"));
2449 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2450 Fcons (Qinvalid_read_syntax
, error_tail
));
2451 Fput (Qinvalid_read_syntax
, Qerror_message
,
2452 build_string ("Invalid read syntax"));
2454 Fput (Qinvalid_function
, Qerror_conditions
,
2455 Fcons (Qinvalid_function
, error_tail
));
2456 Fput (Qinvalid_function
, Qerror_message
,
2457 build_string ("Invalid function"));
2459 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2460 Fcons (Qwrong_number_of_arguments
, error_tail
));
2461 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2462 build_string ("Wrong number of arguments"));
2464 Fput (Qno_catch
, Qerror_conditions
,
2465 Fcons (Qno_catch
, error_tail
));
2466 Fput (Qno_catch
, Qerror_message
,
2467 build_string ("No catch for tag"));
2469 Fput (Qend_of_file
, Qerror_conditions
,
2470 Fcons (Qend_of_file
, error_tail
));
2471 Fput (Qend_of_file
, Qerror_message
,
2472 build_string ("End of file during parsing"));
2474 arith_tail
= Fcons (Qarith_error
, error_tail
);
2475 Fput (Qarith_error
, Qerror_conditions
,
2477 Fput (Qarith_error
, Qerror_message
,
2478 build_string ("Arithmetic error"));
2480 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2481 Fcons (Qbeginning_of_buffer
, error_tail
));
2482 Fput (Qbeginning_of_buffer
, Qerror_message
,
2483 build_string ("Beginning of buffer"));
2485 Fput (Qend_of_buffer
, Qerror_conditions
,
2486 Fcons (Qend_of_buffer
, error_tail
));
2487 Fput (Qend_of_buffer
, Qerror_message
,
2488 build_string ("End of buffer"));
2490 Fput (Qbuffer_read_only
, Qerror_conditions
,
2491 Fcons (Qbuffer_read_only
, error_tail
));
2492 Fput (Qbuffer_read_only
, Qerror_message
,
2493 build_string ("Buffer is read-only"));
2495 #ifdef LISP_FLOAT_TYPE
2496 Qrange_error
= intern ("range-error");
2497 Qdomain_error
= intern ("domain-error");
2498 Qsingularity_error
= intern ("singularity-error");
2499 Qoverflow_error
= intern ("overflow-error");
2500 Qunderflow_error
= intern ("underflow-error");
2502 Fput (Qdomain_error
, Qerror_conditions
,
2503 Fcons (Qdomain_error
, arith_tail
));
2504 Fput (Qdomain_error
, Qerror_message
,
2505 build_string ("Arithmetic domain error"));
2507 Fput (Qrange_error
, Qerror_conditions
,
2508 Fcons (Qrange_error
, arith_tail
));
2509 Fput (Qrange_error
, Qerror_message
,
2510 build_string ("Arithmetic range error"));
2512 Fput (Qsingularity_error
, Qerror_conditions
,
2513 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2514 Fput (Qsingularity_error
, Qerror_message
,
2515 build_string ("Arithmetic singularity error"));
2517 Fput (Qoverflow_error
, Qerror_conditions
,
2518 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2519 Fput (Qoverflow_error
, Qerror_message
,
2520 build_string ("Arithmetic overflow error"));
2522 Fput (Qunderflow_error
, Qerror_conditions
,
2523 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2524 Fput (Qunderflow_error
, Qerror_message
,
2525 build_string ("Arithmetic underflow error"));
2527 staticpro (&Qrange_error
);
2528 staticpro (&Qdomain_error
);
2529 staticpro (&Qsingularity_error
);
2530 staticpro (&Qoverflow_error
);
2531 staticpro (&Qunderflow_error
);
2532 #endif /* LISP_FLOAT_TYPE */
2536 staticpro (&Qquote
);
2537 staticpro (&Qlambda
);
2539 staticpro (&Qunbound
);
2540 staticpro (&Qerror_conditions
);
2541 staticpro (&Qerror_message
);
2542 staticpro (&Qtop_level
);
2544 staticpro (&Qerror
);
2546 staticpro (&Qwrong_type_argument
);
2547 staticpro (&Qargs_out_of_range
);
2548 staticpro (&Qvoid_function
);
2549 staticpro (&Qcyclic_function_indirection
);
2550 staticpro (&Qvoid_variable
);
2551 staticpro (&Qsetting_constant
);
2552 staticpro (&Qinvalid_read_syntax
);
2553 staticpro (&Qwrong_number_of_arguments
);
2554 staticpro (&Qinvalid_function
);
2555 staticpro (&Qno_catch
);
2556 staticpro (&Qend_of_file
);
2557 staticpro (&Qarith_error
);
2558 staticpro (&Qbeginning_of_buffer
);
2559 staticpro (&Qend_of_buffer
);
2560 staticpro (&Qbuffer_read_only
);
2561 staticpro (&Qmark_inactive
);
2563 staticpro (&Qlistp
);
2564 staticpro (&Qconsp
);
2565 staticpro (&Qsymbolp
);
2566 staticpro (&Qintegerp
);
2567 staticpro (&Qnatnump
);
2568 staticpro (&Qwholenump
);
2569 staticpro (&Qstringp
);
2570 staticpro (&Qarrayp
);
2571 staticpro (&Qsequencep
);
2572 staticpro (&Qbufferp
);
2573 staticpro (&Qvectorp
);
2574 staticpro (&Qchar_or_string_p
);
2575 staticpro (&Qmarkerp
);
2576 staticpro (&Qbuffer_or_string_p
);
2577 staticpro (&Qinteger_or_marker_p
);
2578 #ifdef LISP_FLOAT_TYPE
2579 staticpro (&Qfloatp
);
2580 staticpro (&Qnumberp
);
2581 staticpro (&Qnumber_or_marker_p
);
2582 #endif /* LISP_FLOAT_TYPE */
2583 staticpro (&Qchar_table_p
);
2584 staticpro (&Qvector_or_char_table_p
);
2586 staticpro (&Qboundp
);
2587 staticpro (&Qfboundp
);
2589 staticpro (&Qad_advice_info
);
2590 staticpro (&Qad_activate
);
2592 /* Types that type-of returns. */
2593 Qinteger
= intern ("integer");
2594 Qsymbol
= intern ("symbol");
2595 Qstring
= intern ("string");
2596 Qcons
= intern ("cons");
2597 Qmarker
= intern ("marker");
2598 Qoverlay
= intern ("overlay");
2599 Qfloat
= intern ("float");
2600 Qwindow_configuration
= intern ("window-configuration");
2601 Qprocess
= intern ("process");
2602 Qwindow
= intern ("window");
2603 /* Qsubr = intern ("subr"); */
2604 Qcompiled_function
= intern ("compiled-function");
2605 Qbuffer
= intern ("buffer");
2606 Qframe
= intern ("frame");
2607 Qvector
= intern ("vector");
2608 Qchar_table
= intern ("char-table");
2609 Qbool_vector
= intern ("bool-vector");
2611 staticpro (&Qinteger
);
2612 staticpro (&Qsymbol
);
2613 staticpro (&Qstring
);
2615 staticpro (&Qmarker
);
2616 staticpro (&Qoverlay
);
2617 staticpro (&Qfloat
);
2618 staticpro (&Qwindow_configuration
);
2619 staticpro (&Qprocess
);
2620 staticpro (&Qwindow
);
2621 /* staticpro (&Qsubr); */
2622 staticpro (&Qcompiled_function
);
2623 staticpro (&Qbuffer
);
2624 staticpro (&Qframe
);
2625 staticpro (&Qvector
);
2626 staticpro (&Qchar_table
);
2627 staticpro (&Qbool_vector
);
2631 defsubr (&Stype_of
);
2636 defsubr (&Sintegerp
);
2637 defsubr (&Sinteger_or_marker_p
);
2638 defsubr (&Snumberp
);
2639 defsubr (&Snumber_or_marker_p
);
2640 #ifdef LISP_FLOAT_TYPE
2642 #endif /* LISP_FLOAT_TYPE */
2643 defsubr (&Snatnump
);
2644 defsubr (&Ssymbolp
);
2645 defsubr (&Sstringp
);
2646 defsubr (&Svectorp
);
2647 defsubr (&Schar_table_p
);
2648 defsubr (&Svector_or_char_table_p
);
2649 defsubr (&Sbool_vector_p
);
2651 defsubr (&Ssequencep
);
2652 defsubr (&Sbufferp
);
2653 defsubr (&Smarkerp
);
2655 defsubr (&Sbyte_code_function_p
);
2656 defsubr (&Schar_or_string_p
);
2659 defsubr (&Scar_safe
);
2660 defsubr (&Scdr_safe
);
2663 defsubr (&Ssymbol_function
);
2664 defsubr (&Sindirect_function
);
2665 defsubr (&Ssymbol_plist
);
2666 defsubr (&Ssymbol_name
);
2667 defsubr (&Smakunbound
);
2668 defsubr (&Sfmakunbound
);
2670 defsubr (&Sfboundp
);
2672 defsubr (&Sdefalias
);
2673 defsubr (&Sdefine_function
);
2674 defsubr (&Ssetplist
);
2675 defsubr (&Ssymbol_value
);
2677 defsubr (&Sdefault_boundp
);
2678 defsubr (&Sdefault_value
);
2679 defsubr (&Sset_default
);
2680 defsubr (&Ssetq_default
);
2681 defsubr (&Smake_variable_buffer_local
);
2682 defsubr (&Smake_local_variable
);
2683 defsubr (&Skill_local_variable
);
2684 defsubr (&Slocal_variable_p
);
2685 defsubr (&Slocal_variable_if_set_p
);
2688 defsubr (&Snumber_to_string
);
2689 defsubr (&Sstring_to_number
);
2690 defsubr (&Seqlsign
);
2714 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2722 /* USG systems forget handlers when they are used;
2723 must reestablish each time */
2724 signal (signo
, arith_error
);
2727 /* VMS systems are like USG. */
2728 signal (signo
, arith_error
);
2732 #else /* not BSD4_1 */
2733 sigsetmask (SIGEMPTYMASK
);
2734 #endif /* not BSD4_1 */
2736 Fsignal (Qarith_error
, Qnil
);
2741 /* Don't do this if just dumping out.
2742 We don't want to call `signal' in this case
2743 so that we don't have trouble with dumping
2744 signal-delivering routines in an inconsistent state. */
2748 #endif /* CANNOT_DUMP */
2749 signal (SIGFPE
, arith_error
);
2752 signal (SIGEMT
, arith_error
);