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
;
87 static Lisp_Object
swap_in_symval_forwarding ();
90 wrong_type_argument (predicate
, value
)
91 register Lisp_Object predicate
, value
;
93 register Lisp_Object tem
;
96 if (!EQ (Vmocklisp_arguments
, Qt
))
98 if (STRINGP (value
) &&
99 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
100 return Fstring_to_number (value
);
101 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
102 return Fnumber_to_string (value
);
105 /* If VALUE is not even a valid Lisp object, abort here
106 where we can get a backtrace showing where it came from. */
107 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
110 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
111 tem
= call1 (predicate
, value
);
119 error ("Attempt to modify read-only object");
123 args_out_of_range (a1
, a2
)
127 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
131 args_out_of_range_3 (a1
, a2
, a3
)
132 Lisp_Object a1
, a2
, a3
;
135 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
142 register Lisp_Object val
;
147 /* On some machines, XINT needs a temporary location.
148 Here it is, in case it is needed. */
150 int sign_extend_temp
;
152 /* On a few machines, XINT can only be done by calling this. */
155 sign_extend_lisp_int (num
)
158 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
159 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
161 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
164 /* Data type predicates */
166 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
167 "T if the two args are the same Lisp object.")
169 Lisp_Object obj1
, obj2
;
176 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
185 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
186 "Return a symbol representing the type of OBJECT.\n\
187 The symbol returned names the object's basic type;\n\
188 for example, (type-of 1) returns `integer'.")
192 switch (XGCTYPE (object
))
207 switch (XMISCTYPE (object
))
209 case Lisp_Misc_Marker
:
211 case Lisp_Misc_Overlay
:
213 case Lisp_Misc_Float
:
218 case Lisp_Vectorlike
:
219 if (GC_WINDOW_CONFIGURATIONP (object
))
220 return Qwindow_configuration
;
221 if (GC_PROCESSP (object
))
223 if (GC_WINDOWP (object
))
225 if (GC_SUBRP (object
))
227 if (GC_COMPILEDP (object
))
228 return Qcompiled_function
;
229 if (GC_BUFFERP (object
))
233 if (GC_FRAMEP (object
))
238 #ifdef LISP_FLOAT_TYPE
248 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
257 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
266 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
270 if (CONSP (object
) || NILP (object
))
275 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
279 if (CONSP (object
) || NILP (object
))
284 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
288 if (SYMBOLP (object
))
293 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
297 if (VECTORP (object
))
302 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
306 if (STRINGP (object
))
311 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0, "T if OBJECT is a char-table.")
315 if (CHAR_TABLE_P (object
))
320 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
321 Svector_or_char_table_p
, 1, 1, 0,
322 "T if OBJECT is a char-table or vector.")
326 if (VECTORP (object
) || CHAR_TABLE_P (object
))
331 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "T if OBJECT is a bool-vector.")
335 if (BOOL_VECTOR_P (object
))
340 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
344 if (VECTORP (object
) || STRINGP (object
))
349 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
350 "T if OBJECT is a sequence (list or array).")
352 register Lisp_Object object
;
354 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
355 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
360 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
364 if (BUFFERP (object
))
369 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
373 if (MARKERP (object
))
378 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
387 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
388 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
392 if (COMPILEDP (object
))
397 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
398 "T if OBJECT is a character (an integer) or a string.")
400 register Lisp_Object object
;
402 if (INTEGERP (object
) || STRINGP (object
))
407 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
411 if (INTEGERP (object
))
416 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
417 "T if OBJECT is an integer or a marker (editor pointer).")
419 register Lisp_Object object
;
421 if (MARKERP (object
) || INTEGERP (object
))
426 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
427 "T if OBJECT is a nonnegative integer.")
431 if (NATNUMP (object
))
436 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
437 "T if OBJECT is a number (floating point or integer).")
441 if (NUMBERP (object
))
447 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
448 Snumber_or_marker_p
, 1, 1, 0,
449 "T if OBJECT is a number or a marker.")
453 if (NUMBERP (object
) || MARKERP (object
))
458 #ifdef LISP_FLOAT_TYPE
459 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
460 "T if OBJECT is a floating point number.")
468 #endif /* LISP_FLOAT_TYPE */
470 /* Extract and set components of lists */
472 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
473 "Return the car of LIST. If arg is nil, return nil.\n\
474 Error if arg is not nil and not a cons cell. See also `car-safe'.")
476 register Lisp_Object list
;
481 return XCONS (list
)->car
;
482 else if (EQ (list
, Qnil
))
485 list
= wrong_type_argument (Qlistp
, list
);
489 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
490 "Return the car of OBJECT if it is a cons cell, or else nil.")
495 return XCONS (object
)->car
;
500 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
501 "Return the cdr of LIST. If arg is nil, return nil.\n\
502 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
505 register Lisp_Object list
;
510 return XCONS (list
)->cdr
;
511 else if (EQ (list
, Qnil
))
514 list
= wrong_type_argument (Qlistp
, list
);
518 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
519 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
524 return XCONS (object
)->cdr
;
529 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
530 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
532 register Lisp_Object cell
, newcar
;
535 cell
= wrong_type_argument (Qconsp
, cell
);
538 XCONS (cell
)->car
= newcar
;
542 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
543 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
545 register Lisp_Object cell
, newcdr
;
548 cell
= wrong_type_argument (Qconsp
, cell
);
551 XCONS (cell
)->cdr
= newcdr
;
555 /* Extract and set components of symbols */
557 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
559 register Lisp_Object sym
;
561 Lisp_Object valcontents
;
562 CHECK_SYMBOL (sym
, 0);
564 valcontents
= XSYMBOL (sym
)->value
;
566 if (BUFFER_LOCAL_VALUEP (valcontents
)
567 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
568 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
570 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
573 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
575 register Lisp_Object sym
;
577 CHECK_SYMBOL (sym
, 0);
578 return (EQ (XSYMBOL (sym
)->function
, Qunbound
) ? Qnil
: Qt
);
581 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
583 register Lisp_Object sym
;
585 CHECK_SYMBOL (sym
, 0);
586 if (NILP (sym
) || EQ (sym
, Qt
))
587 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
588 Fset (sym
, Qunbound
);
592 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
594 register Lisp_Object sym
;
596 CHECK_SYMBOL (sym
, 0);
597 if (NILP (sym
) || EQ (sym
, Qt
))
598 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
599 XSYMBOL (sym
)->function
= Qunbound
;
603 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
604 "Return SYMBOL's function definition. Error if that is void.")
606 register Lisp_Object symbol
;
608 CHECK_SYMBOL (symbol
, 0);
609 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
610 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
611 return XSYMBOL (symbol
)->function
;
614 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
616 register Lisp_Object sym
;
618 CHECK_SYMBOL (sym
, 0);
619 return XSYMBOL (sym
)->plist
;
622 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
624 register Lisp_Object sym
;
626 register Lisp_Object name
;
628 CHECK_SYMBOL (sym
, 0);
629 XSETSTRING (name
, XSYMBOL (sym
)->name
);
633 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
634 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
636 register Lisp_Object sym
, newdef
;
638 CHECK_SYMBOL (sym
, 0);
639 if (NILP (sym
) || EQ (sym
, Qt
))
640 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
641 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
642 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
644 XSYMBOL (sym
)->function
= newdef
;
645 /* Handle automatic advice activation */
646 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
648 call2 (Qad_activate
, sym
, Qnil
);
649 newdef
= XSYMBOL (sym
)->function
;
654 /* This name should be removed once it is eliminated from elsewhere. */
656 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
657 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
658 Associates the function with the current load file, if any.")
660 register Lisp_Object sym
, newdef
;
662 CHECK_SYMBOL (sym
, 0);
663 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
664 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
666 XSYMBOL (sym
)->function
= newdef
;
667 /* Handle automatic advice activation */
668 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
670 call2 (Qad_activate
, sym
, Qnil
);
671 newdef
= XSYMBOL (sym
)->function
;
673 LOADHIST_ATTACH (sym
);
677 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
678 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
679 Associates the function with the current load file, if any.")
681 register Lisp_Object sym
, newdef
;
683 CHECK_SYMBOL (sym
, 0);
684 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
685 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
687 XSYMBOL (sym
)->function
= newdef
;
688 /* Handle automatic advice activation */
689 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
691 call2 (Qad_activate
, sym
, Qnil
);
692 newdef
= XSYMBOL (sym
)->function
;
694 LOADHIST_ATTACH (sym
);
698 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
699 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
701 register Lisp_Object sym
, newplist
;
703 CHECK_SYMBOL (sym
, 0);
704 XSYMBOL (sym
)->plist
= newplist
;
709 /* Getting and setting values of symbols */
711 /* Given the raw contents of a symbol value cell,
712 return the Lisp value of the symbol.
713 This does not handle buffer-local variables; use
714 swap_in_symval_forwarding for that. */
717 do_symval_forwarding (valcontents
)
718 register Lisp_Object valcontents
;
720 register Lisp_Object val
;
722 if (MISCP (valcontents
))
723 switch (XMISCTYPE (valcontents
))
725 case Lisp_Misc_Intfwd
:
726 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
729 case Lisp_Misc_Boolfwd
:
730 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
732 case Lisp_Misc_Objfwd
:
733 return *XOBJFWD (valcontents
)->objvar
;
735 case Lisp_Misc_Buffer_Objfwd
:
736 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
737 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
739 case Lisp_Misc_Kboard_Objfwd
:
740 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
741 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
746 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
747 of SYM. If SYM is buffer-local, VALCONTENTS should be the
748 buffer-independent contents of the value cell: forwarded just one
749 step past the buffer-localness. */
752 store_symval_forwarding (sym
, valcontents
, newval
)
754 register Lisp_Object valcontents
, newval
;
756 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
759 switch (XMISCTYPE (valcontents
))
761 case Lisp_Misc_Intfwd
:
762 CHECK_NUMBER (newval
, 1);
763 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
764 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
765 error ("Value out of range for variable `%s'",
766 XSYMBOL (sym
)->name
->data
);
769 case Lisp_Misc_Boolfwd
:
770 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
773 case Lisp_Misc_Objfwd
:
774 *XOBJFWD (valcontents
)->objvar
= newval
;
777 case Lisp_Misc_Buffer_Objfwd
:
779 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
782 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
783 if (! NILP (type
) && ! NILP (newval
)
784 && XTYPE (newval
) != XINT (type
))
785 buffer_slot_type_mismatch (offset
);
787 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
791 case Lisp_Misc_Kboard_Objfwd
:
792 (*(Lisp_Object
*)((char *)current_kboard
793 + XKBOARD_OBJFWD (valcontents
)->offset
))
804 valcontents
= XSYMBOL (sym
)->value
;
805 if (BUFFER_LOCAL_VALUEP (valcontents
)
806 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
807 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
809 XSYMBOL (sym
)->value
= newval
;
813 /* Set up the buffer-local symbol SYM for validity in the current
814 buffer. VALCONTENTS is the contents of its value cell.
815 Return the value forwarded one step past the buffer-local indicator. */
818 swap_in_symval_forwarding (sym
, valcontents
)
819 Lisp_Object sym
, valcontents
;
821 /* valcontents is a pointer to a struct resembling the cons
822 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
824 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
825 local_var_alist, that being the element whose car is this
826 variable. Or it can be a pointer to the
827 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
828 an element in its alist for this variable.
830 If the current buffer is not BUFFER, we store the current
831 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
832 appropriate alist element for the buffer now current and set up
833 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
834 element, and store into BUFFER.
836 Note that REALVALUE can be a forwarding pointer. */
838 register Lisp_Object tem1
;
839 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
841 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
843 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
845 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
846 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
848 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
849 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
850 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
852 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
855 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
858 /* Find the value of a symbol, returning Qunbound if it's not bound.
859 This is helpful for code which just wants to get a variable's value
860 if it has one, without signalling an error.
861 Note that it must not be possible to quit
862 within this function. Great care is required for this. */
865 find_symbol_value (sym
)
868 register Lisp_Object valcontents
, tem1
;
869 register Lisp_Object val
;
870 CHECK_SYMBOL (sym
, 0);
871 valcontents
= XSYMBOL (sym
)->value
;
873 if (BUFFER_LOCAL_VALUEP (valcontents
)
874 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
875 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
877 if (MISCP (valcontents
))
879 switch (XMISCTYPE (valcontents
))
881 case Lisp_Misc_Intfwd
:
882 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
885 case Lisp_Misc_Boolfwd
:
886 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
888 case Lisp_Misc_Objfwd
:
889 return *XOBJFWD (valcontents
)->objvar
;
891 case Lisp_Misc_Buffer_Objfwd
:
892 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
893 + (char *)current_buffer
);
895 case Lisp_Misc_Kboard_Objfwd
:
896 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
897 + (char *)current_kboard
);
904 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
905 "Return SYMBOL's value. Error if that is void.")
911 val
= find_symbol_value (sym
);
912 if (EQ (val
, Qunbound
))
913 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
918 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
919 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
921 register Lisp_Object sym
, newval
;
923 int voide
= EQ (newval
, Qunbound
);
925 register Lisp_Object valcontents
, tem1
, current_alist_element
;
927 CHECK_SYMBOL (sym
, 0);
928 if (NILP (sym
) || EQ (sym
, Qt
))
929 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
930 valcontents
= XSYMBOL (sym
)->value
;
932 if (BUFFER_OBJFWDP (valcontents
))
934 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
935 register int mask
= XINT (*((Lisp_Object
*)
936 (idx
+ (char *)&buffer_local_flags
)));
938 current_buffer
->local_var_flags
|= mask
;
941 else if (BUFFER_LOCAL_VALUEP (valcontents
)
942 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
944 /* valcontents is actually a pointer to a struct resembling a cons,
945 with contents something like:
946 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
948 BUFFER is the last buffer for which this symbol's value was
951 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
952 local_var_alist, that being the element whose car is this
953 variable. Or it can be a pointer to the
954 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
955 have an element in its alist for this variable (that is, if
956 BUFFER sees the default value of this variable).
958 If we want to examine or set the value and BUFFER is current,
959 we just examine or set REALVALUE. If BUFFER is not current, we
960 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
961 then find the appropriate alist element for the buffer now
962 current and set up CURRENT-ALIST-ELEMENT. Then we set
963 REALVALUE out of that element, and store into BUFFER.
965 If we are setting the variable and the current buffer does
966 not have an alist entry for this variable, an alist entry is
969 Note that REALVALUE can be a forwarding pointer. Each time
970 it is examined or set, forwarding must be done. */
972 /* What value are we caching right now? */
973 current_alist_element
=
974 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
976 /* If the current buffer is not the buffer whose binding is
977 currently cached, or if it's a Lisp_Buffer_Local_Value and
978 we're looking at the default value, the cache is invalid; we
979 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
981 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
982 || (BUFFER_LOCAL_VALUEP (valcontents
)
983 && EQ (XCONS (current_alist_element
)->car
,
984 current_alist_element
)))
986 /* Write out the cached value for the old buffer; copy it
987 back to its alist element. This works if the current
988 buffer only sees the default value, too. */
989 Fsetcdr (current_alist_element
,
990 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
992 /* Find the new value for CURRENT-ALIST-ELEMENT. */
993 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
996 /* This buffer still sees the default value. */
998 /* If the variable is a Lisp_Some_Buffer_Local_Value,
999 make CURRENT-ALIST-ELEMENT point to itself,
1000 indicating that we're seeing the default value. */
1001 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1002 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1004 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
1005 new assoc for a local value and set
1006 CURRENT-ALIST-ELEMENT to point to that. */
1009 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
1010 current_buffer
->local_var_alist
=
1011 Fcons (tem1
, current_buffer
->local_var_alist
);
1014 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1015 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
1018 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1019 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
1022 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1025 /* If storing void (making the symbol void), forward only through
1026 buffer-local indicator, not through Lisp_Objfwd, etc. */
1028 store_symval_forwarding (sym
, Qnil
, newval
);
1030 store_symval_forwarding (sym
, valcontents
, newval
);
1035 /* Access or set a buffer-local symbol's default value. */
1037 /* Return the default value of SYM, but don't check for voidness.
1038 Return Qunbound if it is void. */
1044 register Lisp_Object valcontents
;
1046 CHECK_SYMBOL (sym
, 0);
1047 valcontents
= XSYMBOL (sym
)->value
;
1049 /* For a built-in buffer-local variable, get the default value
1050 rather than letting do_symval_forwarding get the current value. */
1051 if (BUFFER_OBJFWDP (valcontents
))
1053 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1055 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1056 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1059 /* Handle user-created local variables. */
1060 if (BUFFER_LOCAL_VALUEP (valcontents
)
1061 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1063 /* If var is set up for a buffer that lacks a local value for it,
1064 the current value is nominally the default value.
1065 But the current value slot may be more up to date, since
1066 ordinary setq stores just that slot. So use that. */
1067 Lisp_Object current_alist_element
, alist_element_car
;
1068 current_alist_element
1069 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1070 alist_element_car
= XCONS (current_alist_element
)->car
;
1071 if (EQ (alist_element_car
, current_alist_element
))
1072 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1074 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1076 /* For other variables, get the current value. */
1077 return do_symval_forwarding (valcontents
);
1080 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1081 "Return T if SYMBOL has a non-void default value.\n\
1082 This is the value that is seen in buffers that do not have their own values\n\
1083 for this variable.")
1087 register Lisp_Object value
;
1089 value
= default_value (sym
);
1090 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1093 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1094 "Return SYMBOL's default value.\n\
1095 This is the value that is seen in buffers that do not have their own values\n\
1096 for this variable. The default value is meaningful for variables with\n\
1097 local bindings in certain buffers.")
1101 register Lisp_Object value
;
1103 value
= default_value (sym
);
1104 if (EQ (value
, Qunbound
))
1105 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1109 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1110 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1111 The default value is seen in buffers that do not have their own values\n\
1112 for this variable.")
1114 Lisp_Object sym
, value
;
1116 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1118 CHECK_SYMBOL (sym
, 0);
1119 valcontents
= XSYMBOL (sym
)->value
;
1121 /* Handle variables like case-fold-search that have special slots
1122 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1124 if (BUFFER_OBJFWDP (valcontents
))
1126 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1127 register struct buffer
*b
;
1128 register int mask
= XINT (*((Lisp_Object
*)
1129 (idx
+ (char *)&buffer_local_flags
)));
1133 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1134 for (b
= all_buffers
; b
; b
= b
->next
)
1135 if (!(b
->local_var_flags
& mask
))
1136 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1141 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1142 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1143 return Fset (sym
, value
);
1145 /* Store new value into the DEFAULT-VALUE slot */
1146 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1148 /* If that slot is current, we must set the REALVALUE slot too */
1149 current_alist_element
1150 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1151 alist_element_buffer
= Fcar (current_alist_element
);
1152 if (EQ (alist_element_buffer
, current_alist_element
))
1153 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1159 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1160 "Set the default value of variable VAR to VALUE.\n\
1161 VAR, the variable name, is literal (not evaluated);\n\
1162 VALUE is an expression and it is evaluated.\n\
1163 The default value of a variable is seen in buffers\n\
1164 that do not have their own values for the variable.\n\
1166 More generally, you can use multiple variables and values, as in\n\
1167 (setq-default SYM VALUE SYM VALUE...)\n\
1168 This sets each SYM's default value to the corresponding VALUE.\n\
1169 The VALUE for the Nth SYM can refer to the new default values\n\
1174 register Lisp_Object args_left
;
1175 register Lisp_Object val
, sym
;
1176 struct gcpro gcpro1
;
1186 val
= Feval (Fcar (Fcdr (args_left
)));
1187 sym
= Fcar (args_left
);
1188 Fset_default (sym
, val
);
1189 args_left
= Fcdr (Fcdr (args_left
));
1191 while (!NILP (args_left
));
1197 /* Lisp functions for creating and removing buffer-local variables. */
1199 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1200 1, 1, "vMake Variable Buffer Local: ",
1201 "Make VARIABLE have a separate value for each buffer.\n\
1202 At any time, the value for the current buffer is in effect.\n\
1203 There is also a default value which is seen in any buffer which has not yet\n\
1204 set its own value.\n\
1205 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1206 for the current buffer if it was previously using the default value.\n\
1207 The function `default-value' gets the default value and `set-default' sets it.")
1209 register Lisp_Object sym
;
1211 register Lisp_Object tem
, valcontents
, newval
;
1213 CHECK_SYMBOL (sym
, 0);
1215 valcontents
= XSYMBOL (sym
)->value
;
1216 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1217 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1219 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1221 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1223 XMISCTYPE (XSYMBOL (sym
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1226 if (EQ (valcontents
, Qunbound
))
1227 XSYMBOL (sym
)->value
= Qnil
;
1228 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1229 XCONS (tem
)->car
= tem
;
1230 newval
= allocate_misc ();
1231 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1232 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1233 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1234 XSYMBOL (sym
)->value
= newval
;
1238 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1239 1, 1, "vMake Local Variable: ",
1240 "Make VARIABLE have a separate value in the current buffer.\n\
1241 Other buffers will continue to share a common default value.\n\
1242 \(The buffer-local value of VARIABLE starts out as the same value\n\
1243 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1244 See also `make-variable-buffer-local'.\n\n\
1245 If the variable is already arranged to become local when set,\n\
1246 this function causes a local value to exist for this buffer,\n\
1247 just as setting the variable would do.\n\
1249 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1250 Use `make-local-hook' instead.")
1252 register Lisp_Object sym
;
1254 register Lisp_Object tem
, valcontents
;
1256 CHECK_SYMBOL (sym
, 0);
1258 valcontents
= XSYMBOL (sym
)->value
;
1259 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1260 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1262 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1264 tem
= Fboundp (sym
);
1266 /* Make sure the symbol has a local value in this particular buffer,
1267 by setting it to the same value it already has. */
1268 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1271 /* Make sure sym is set up to hold per-buffer values */
1272 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1275 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1276 XCONS (tem
)->car
= tem
;
1277 newval
= allocate_misc ();
1278 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1279 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1280 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1281 XSYMBOL (sym
)->value
= newval
;
1283 /* Make sure this buffer has its own value of sym */
1284 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1287 current_buffer
->local_var_alist
1288 = Fcons (Fcons (sym
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1289 current_buffer
->local_var_alist
);
1291 /* Make sure symbol does not think it is set up for this buffer;
1292 force it to look once again for this buffer's value */
1294 Lisp_Object
*pvalbuf
;
1295 valcontents
= XSYMBOL (sym
)->value
;
1296 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1297 if (current_buffer
== XBUFFER (*pvalbuf
))
1302 /* If the symbol forwards into a C variable, then swap in the
1303 variable for this buffer immediately. If C code modifies the
1304 variable before we swap in, then that new value will clobber the
1305 default value the next time we swap. */
1306 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->car
;
1307 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1308 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1313 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1314 1, 1, "vKill Local Variable: ",
1315 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1316 From now on the default value will apply in this buffer.")
1318 register Lisp_Object sym
;
1320 register Lisp_Object tem
, valcontents
;
1322 CHECK_SYMBOL (sym
, 0);
1324 valcontents
= XSYMBOL (sym
)->value
;
1326 if (BUFFER_OBJFWDP (valcontents
))
1328 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1329 register int mask
= XINT (*((Lisp_Object
*)
1330 (idx
+ (char *)&buffer_local_flags
)));
1334 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1335 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1336 current_buffer
->local_var_flags
&= ~mask
;
1341 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1342 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1345 /* Get rid of this buffer's alist element, if any */
1347 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1349 current_buffer
->local_var_alist
1350 = Fdelq (tem
, current_buffer
->local_var_alist
);
1352 /* Make sure symbol does not think it is set up for this buffer;
1353 force it to look once again for this buffer's value */
1355 Lisp_Object
*pvalbuf
;
1356 valcontents
= XSYMBOL (sym
)->value
;
1357 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1358 if (current_buffer
== XBUFFER (*pvalbuf
))
1365 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1367 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1368 BUFFER defaults to the current buffer.")
1370 register Lisp_Object sym
, buffer
;
1372 Lisp_Object valcontents
;
1373 register struct buffer
*buf
;
1376 buf
= current_buffer
;
1379 CHECK_BUFFER (buffer
, 0);
1380 buf
= XBUFFER (buffer
);
1383 CHECK_SYMBOL (sym
, 0);
1385 valcontents
= XSYMBOL (sym
)->value
;
1386 if (BUFFER_LOCAL_VALUEP (valcontents
)
1387 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1389 Lisp_Object tail
, elt
;
1390 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1392 elt
= XCONS (tail
)->car
;
1393 if (EQ (sym
, XCONS (elt
)->car
))
1397 if (BUFFER_OBJFWDP (valcontents
))
1399 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1400 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1401 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1407 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1409 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1410 BUFFER defaults to the current buffer.")
1412 register Lisp_Object sym
, buffer
;
1414 Lisp_Object valcontents
;
1415 register struct buffer
*buf
;
1418 buf
= current_buffer
;
1421 CHECK_BUFFER (buffer
, 0);
1422 buf
= XBUFFER (buffer
);
1425 CHECK_SYMBOL (sym
, 0);
1427 valcontents
= XSYMBOL (sym
)->value
;
1429 /* This means that make-variable-buffer-local was done. */
1430 if (BUFFER_LOCAL_VALUEP (valcontents
))
1432 /* All these slots become local if they are set. */
1433 if (BUFFER_OBJFWDP (valcontents
))
1435 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1437 Lisp_Object tail
, elt
;
1438 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1440 elt
= XCONS (tail
)->car
;
1441 if (EQ (sym
, XCONS (elt
)->car
))
1448 /* Find the function at the end of a chain of symbol function indirections. */
1450 /* If OBJECT is a symbol, find the end of its function chain and
1451 return the value found there. If OBJECT is not a symbol, just
1452 return it. If there is a cycle in the function chain, signal a
1453 cyclic-function-indirection error.
1455 This is like Findirect_function, except that it doesn't signal an
1456 error if the chain ends up unbound. */
1458 indirect_function (object
)
1459 register Lisp_Object object
;
1461 Lisp_Object tortoise
, hare
;
1463 hare
= tortoise
= object
;
1467 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1469 hare
= XSYMBOL (hare
)->function
;
1470 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1472 hare
= XSYMBOL (hare
)->function
;
1474 tortoise
= XSYMBOL (tortoise
)->function
;
1476 if (EQ (hare
, tortoise
))
1477 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1483 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1484 "Return the function at the end of OBJECT's function chain.\n\
1485 If OBJECT is a symbol, follow all function indirections and return the final\n\
1486 function binding.\n\
1487 If OBJECT is not a symbol, just return it.\n\
1488 Signal a void-function error if the final symbol is unbound.\n\
1489 Signal a cyclic-function-indirection error if there is a loop in the\n\
1490 function chain of symbols.")
1492 register Lisp_Object object
;
1496 result
= indirect_function (object
);
1498 if (EQ (result
, Qunbound
))
1499 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1503 /* Extract and set vector and string elements */
1505 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1506 "Return the element of ARRAY at index INDEX.\n\
1507 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1508 or a byte-code object. INDEX starts at 0.")
1510 register Lisp_Object array
;
1513 register int idxval
;
1515 CHECK_NUMBER (idx
, 1);
1516 idxval
= XINT (idx
);
1517 if (STRINGP (array
))
1520 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1521 args_out_of_range (array
, idx
);
1522 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1525 else if (BOOL_VECTOR_P (array
))
1529 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1530 args_out_of_range (array
, idx
);
1532 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1533 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1535 else if (CHAR_TABLE_P (array
))
1540 args_out_of_range (array
, idx
);
1542 if ((unsigned) idxval
>= CHAR_TABLE_ORDINARY_SLOTS
)
1543 args_out_of_range (array
, idx
);
1544 return val
= XCHAR_TABLE (array
)->contents
[idxval
];
1546 if ((unsigned) idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1547 val
= XCHAR_TABLE (array
)->data
[idxval
];
1551 unsigned char c1
, c2
;
1552 Lisp_Object val
, temp
;
1554 BREAKUP_NON_ASCII_CHAR (idxval
, charset
, c1
, c2
);
1556 try_parent_char_table
:
1557 val
= XCHAR_TABLE (array
)->contents
[charset
];
1558 if (c1
== 0 || !CHAR_TABLE_P (val
))
1561 temp
= XCHAR_TABLE (val
)->contents
[c1
];
1563 val
= XCHAR_TABLE (val
)->defalt
;
1567 if (NILP (val
) && !NILP (XCHAR_TABLE (array
)->parent
))
1569 array
= XCHAR_TABLE (array
)->parent
;
1570 goto try_parent_char_table
;
1574 if (c2
== 0 || !CHAR_TABLE_P (val
))
1577 temp
= XCHAR_TABLE (val
)->contents
[c2
];
1579 val
= XCHAR_TABLE (val
)->defalt
;
1583 if (NILP (val
) && !NILP (XCHAR_TABLE (array
)->parent
))
1585 array
= XCHAR_TABLE (array
)->parent
;
1586 goto try_parent_char_table
;
1596 if (VECTORP (array
))
1597 size
= XVECTOR (array
)->size
;
1598 else if (COMPILEDP (array
))
1599 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1601 wrong_type_argument (Qarrayp
, array
);
1603 if (idxval
< 0 || idxval
>= size
)
1604 args_out_of_range (array
, idx
);
1605 return XVECTOR (array
)->contents
[idxval
];
1609 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1610 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1611 ARRAY may be a vector or a string. IDX starts at 0.")
1612 (array
, idx
, newelt
)
1613 register Lisp_Object array
;
1614 Lisp_Object idx
, newelt
;
1616 register int idxval
;
1618 CHECK_NUMBER (idx
, 1);
1619 idxval
= XINT (idx
);
1620 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1621 && ! CHAR_TABLE_P (array
))
1622 array
= wrong_type_argument (Qarrayp
, array
);
1623 CHECK_IMPURE (array
);
1625 if (VECTORP (array
))
1627 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1628 args_out_of_range (array
, idx
);
1629 XVECTOR (array
)->contents
[idxval
] = newelt
;
1631 else if (BOOL_VECTOR_P (array
))
1635 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1636 args_out_of_range (array
, idx
);
1638 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1640 if (! NILP (newelt
))
1641 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1643 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1644 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1646 else if (CHAR_TABLE_P (array
))
1651 args_out_of_range (array
, idx
);
1653 if (idxval
>= CHAR_TABLE_ORDINARY_SLOTS
)
1654 args_out_of_range (array
, idx
);
1655 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1658 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1659 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1663 unsigned char c1
, c2
;
1664 Lisp_Object val
, val2
;
1666 BREAKUP_NON_ASCII_CHAR (idxval
, charset
, c1
, c2
);
1669 return XCHAR_TABLE (array
)->contents
[charset
] = newelt
;
1671 val
= XCHAR_TABLE (array
)->contents
[charset
];
1672 if (!CHAR_TABLE_P (val
))
1673 XCHAR_TABLE (array
)->contents
[charset
]
1674 = val
= Fmake_char_table (Qnil
);
1677 return XCHAR_TABLE (val
)->contents
[c1
] = newelt
;
1679 val2
= XCHAR_TABLE (val
)->contents
[c2
];
1680 if (!CHAR_TABLE_P (val2
))
1681 XCHAR_TABLE (val
)->contents
[charset
]
1682 = val2
= Fmake_char_table (Qnil
);
1684 return XCHAR_TABLE (val2
)->contents
[c2
] = newelt
;
1690 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1691 args_out_of_range (array
, idx
);
1692 CHECK_NUMBER (newelt
, 2);
1693 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1699 /* Arithmetic functions */
1701 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1704 arithcompare (num1
, num2
, comparison
)
1705 Lisp_Object num1
, num2
;
1706 enum comparison comparison
;
1711 #ifdef LISP_FLOAT_TYPE
1712 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1713 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1715 if (FLOATP (num1
) || FLOATP (num2
))
1718 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1719 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1722 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1723 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1724 #endif /* LISP_FLOAT_TYPE */
1729 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1734 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1739 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1744 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1749 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1754 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1763 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1764 "T if two args, both numbers or markers, are equal.")
1766 register Lisp_Object num1
, num2
;
1768 return arithcompare (num1
, num2
, equal
);
1771 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1772 "T if first arg is less than second arg. Both must be numbers or markers.")
1774 register Lisp_Object num1
, num2
;
1776 return arithcompare (num1
, num2
, less
);
1779 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1780 "T if first arg is greater than second arg. Both must be numbers or markers.")
1782 register Lisp_Object num1
, num2
;
1784 return arithcompare (num1
, num2
, grtr
);
1787 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1788 "T if first arg is less than or equal to second arg.\n\
1789 Both must be numbers or markers.")
1791 register Lisp_Object num1
, num2
;
1793 return arithcompare (num1
, num2
, less_or_equal
);
1796 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1797 "T if first arg is greater than or equal to second arg.\n\
1798 Both must be numbers or markers.")
1800 register Lisp_Object num1
, num2
;
1802 return arithcompare (num1
, num2
, grtr_or_equal
);
1805 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1806 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1808 register Lisp_Object num1
, num2
;
1810 return arithcompare (num1
, num2
, notequal
);
1813 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1815 register Lisp_Object num
;
1817 #ifdef LISP_FLOAT_TYPE
1818 CHECK_NUMBER_OR_FLOAT (num
, 0);
1822 if (XFLOAT(num
)->data
== 0.0)
1827 CHECK_NUMBER (num
, 0);
1828 #endif /* LISP_FLOAT_TYPE */
1835 /* Convert between long values and pairs of Lisp integers. */
1841 unsigned int top
= i
>> 16;
1842 unsigned int bot
= i
& 0xFFFF;
1844 return make_number (bot
);
1845 if (top
== (unsigned long)-1 >> 16)
1846 return Fcons (make_number (-1), make_number (bot
));
1847 return Fcons (make_number (top
), make_number (bot
));
1854 Lisp_Object top
, bot
;
1857 top
= XCONS (c
)->car
;
1858 bot
= XCONS (c
)->cdr
;
1860 bot
= XCONS (bot
)->car
;
1861 return ((XINT (top
) << 16) | XINT (bot
));
1864 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1865 "Convert NUM to a string by printing it in decimal.\n\
1866 Uses a minus sign if negative.\n\
1867 NUM may be an integer or a floating point number.")
1871 char buffer
[VALBITS
];
1873 #ifndef LISP_FLOAT_TYPE
1874 CHECK_NUMBER (num
, 0);
1876 CHECK_NUMBER_OR_FLOAT (num
, 0);
1880 char pigbuf
[350]; /* see comments in float_to_string */
1882 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1883 return build_string (pigbuf
);
1885 #endif /* LISP_FLOAT_TYPE */
1887 if (sizeof (int) == sizeof (EMACS_INT
))
1888 sprintf (buffer
, "%d", XINT (num
));
1889 else if (sizeof (long) == sizeof (EMACS_INT
))
1890 sprintf (buffer
, "%ld", XINT (num
));
1893 return build_string (buffer
);
1896 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1897 "Convert STRING to a number by parsing it as a decimal number.\n\
1898 This parses both integers and floating point numbers.\n\
1899 It ignores leading spaces and tabs.")
1901 register Lisp_Object str
;
1906 CHECK_STRING (str
, 0);
1908 p
= XSTRING (str
)->data
;
1910 /* Skip any whitespace at the front of the number. Some versions of
1911 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1912 while (*p
== ' ' || *p
== '\t')
1915 #ifdef LISP_FLOAT_TYPE
1916 if (isfloat_string (p
))
1917 return make_float (atof (p
));
1918 #endif /* LISP_FLOAT_TYPE */
1920 if (sizeof (int) == sizeof (EMACS_INT
))
1921 XSETINT (value
, atoi (p
));
1922 else if (sizeof (long) == sizeof (EMACS_INT
))
1923 XSETINT (value
, atol (p
));
1930 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1932 extern Lisp_Object
float_arith_driver ();
1935 arith_driver (code
, nargs
, args
)
1938 register Lisp_Object
*args
;
1940 register Lisp_Object val
;
1941 register int argnum
;
1942 register EMACS_INT accum
;
1943 register EMACS_INT next
;
1945 switch (SWITCH_ENUM_CAST (code
))
1958 for (argnum
= 0; argnum
< nargs
; argnum
++)
1960 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1961 #ifdef LISP_FLOAT_TYPE
1962 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1964 if (FLOATP (val
)) /* time to do serious math */
1965 return (float_arith_driver ((double) accum
, argnum
, code
,
1968 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1969 #endif /* LISP_FLOAT_TYPE */
1970 args
[argnum
] = val
; /* runs into a compiler bug. */
1971 next
= XINT (args
[argnum
]);
1972 switch (SWITCH_ENUM_CAST (code
))
1974 case Aadd
: accum
+= next
; break;
1976 if (!argnum
&& nargs
!= 1)
1980 case Amult
: accum
*= next
; break;
1982 if (!argnum
) accum
= next
;
1986 Fsignal (Qarith_error
, Qnil
);
1990 case Alogand
: accum
&= next
; break;
1991 case Alogior
: accum
|= next
; break;
1992 case Alogxor
: accum
^= next
; break;
1993 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1994 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1998 XSETINT (val
, accum
);
2002 #ifdef LISP_FLOAT_TYPE
2005 #define isnan(x) ((x) != (x))
2008 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2010 register int argnum
;
2013 register Lisp_Object
*args
;
2015 register Lisp_Object val
;
2018 for (; argnum
< nargs
; argnum
++)
2020 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2021 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2025 next
= XFLOAT (val
)->data
;
2029 args
[argnum
] = val
; /* runs into a compiler bug. */
2030 next
= XINT (args
[argnum
]);
2032 switch (SWITCH_ENUM_CAST (code
))
2038 if (!argnum
&& nargs
!= 1)
2051 Fsignal (Qarith_error
, Qnil
);
2058 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2060 if (!argnum
|| isnan (next
) || next
> accum
)
2064 if (!argnum
|| isnan (next
) || next
< accum
)
2070 return make_float (accum
);
2072 #endif /* LISP_FLOAT_TYPE */
2074 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2075 "Return sum of any number of arguments, which are numbers or markers.")
2080 return arith_driver (Aadd
, nargs
, args
);
2083 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2084 "Negate number or subtract numbers or markers.\n\
2085 With one arg, negates it. With more than one arg,\n\
2086 subtracts all but the first from the first.")
2091 return arith_driver (Asub
, nargs
, args
);
2094 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2095 "Returns product of any number of arguments, which are numbers or markers.")
2100 return arith_driver (Amult
, nargs
, args
);
2103 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2104 "Returns first argument divided by all the remaining arguments.\n\
2105 The arguments must be numbers or markers.")
2110 return arith_driver (Adiv
, nargs
, args
);
2113 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2114 "Returns remainder of first arg divided by second.\n\
2115 Both must be integers or markers.")
2117 register Lisp_Object num1
, num2
;
2121 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
2122 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
2124 if (XFASTINT (num2
) == 0)
2125 Fsignal (Qarith_error
, Qnil
);
2127 XSETINT (val
, XINT (num1
) % XINT (num2
));
2138 return (f1
- f2
* floor (f1
/f2
));
2140 #endif /* ! HAVE_FMOD */
2142 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2143 "Returns X modulo Y.\n\
2144 The result falls between zero (inclusive) and Y (exclusive).\n\
2145 Both X and Y must be numbers or markers.")
2147 register Lisp_Object num1
, num2
;
2152 #ifdef LISP_FLOAT_TYPE
2153 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
2154 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
2156 if (FLOATP (num1
) || FLOATP (num2
))
2160 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
2161 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
2163 Fsignal (Qarith_error
, Qnil
);
2166 /* If the "remainder" comes out with the wrong sign, fix it. */
2167 if (f2
< 0 ? f1
> 0 : f1
< 0)
2169 return (make_float (f1
));
2171 #else /* not LISP_FLOAT_TYPE */
2172 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
2173 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
2174 #endif /* not LISP_FLOAT_TYPE */
2180 Fsignal (Qarith_error
, Qnil
);
2184 /* If the "remainder" comes out with the wrong sign, fix it. */
2185 if (i2
< 0 ? i1
> 0 : i1
< 0)
2192 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2193 "Return largest of all the arguments (which must be numbers or markers).\n\
2194 The value is always a number; markers are converted to numbers.")
2199 return arith_driver (Amax
, nargs
, args
);
2202 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2203 "Return smallest of all the arguments (which must be numbers or markers).\n\
2204 The value is always a number; markers are converted to numbers.")
2209 return arith_driver (Amin
, nargs
, args
);
2212 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2213 "Return bitwise-and of all the arguments.\n\
2214 Arguments may be integers, or markers converted to integers.")
2219 return arith_driver (Alogand
, nargs
, args
);
2222 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2223 "Return bitwise-or of all the arguments.\n\
2224 Arguments may be integers, or markers converted to integers.")
2229 return arith_driver (Alogior
, nargs
, args
);
2232 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2233 "Return bitwise-exclusive-or of all the arguments.\n\
2234 Arguments may be integers, or markers converted to integers.")
2239 return arith_driver (Alogxor
, nargs
, args
);
2242 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2243 "Return VALUE with its bits shifted left by COUNT.\n\
2244 If COUNT is negative, shifting is actually to the right.\n\
2245 In this case, the sign bit is duplicated.")
2247 register Lisp_Object value
, count
;
2249 register Lisp_Object val
;
2251 CHECK_NUMBER (value
, 0);
2252 CHECK_NUMBER (count
, 1);
2254 if (XINT (count
) > 0)
2255 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2257 XSETINT (val
, XINT (value
) >> -XINT (count
));
2261 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2262 "Return VALUE with its bits shifted left by COUNT.\n\
2263 If COUNT is negative, shifting is actually to the right.\n\
2264 In this case, zeros are shifted in on the left.")
2266 register Lisp_Object value
, count
;
2268 register Lisp_Object val
;
2270 CHECK_NUMBER (value
, 0);
2271 CHECK_NUMBER (count
, 1);
2273 if (XINT (count
) > 0)
2274 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2276 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2280 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2281 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2282 Markers are converted to integers.")
2284 register Lisp_Object num
;
2286 #ifdef LISP_FLOAT_TYPE
2287 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2290 return (make_float (1.0 + XFLOAT (num
)->data
));
2292 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2293 #endif /* LISP_FLOAT_TYPE */
2295 XSETINT (num
, XINT (num
) + 1);
2299 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2300 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2301 Markers are converted to integers.")
2303 register Lisp_Object num
;
2305 #ifdef LISP_FLOAT_TYPE
2306 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2309 return (make_float (-1.0 + XFLOAT (num
)->data
));
2311 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2312 #endif /* LISP_FLOAT_TYPE */
2314 XSETINT (num
, XINT (num
) - 1);
2318 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2319 "Return the bitwise complement of ARG. ARG must be an integer.")
2321 register Lisp_Object num
;
2323 CHECK_NUMBER (num
, 0);
2324 XSETINT (num
, ~XINT (num
));
2331 Lisp_Object error_tail
, arith_tail
;
2333 Qquote
= intern ("quote");
2334 Qlambda
= intern ("lambda");
2335 Qsubr
= intern ("subr");
2336 Qerror_conditions
= intern ("error-conditions");
2337 Qerror_message
= intern ("error-message");
2338 Qtop_level
= intern ("top-level");
2340 Qerror
= intern ("error");
2341 Qquit
= intern ("quit");
2342 Qwrong_type_argument
= intern ("wrong-type-argument");
2343 Qargs_out_of_range
= intern ("args-out-of-range");
2344 Qvoid_function
= intern ("void-function");
2345 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2346 Qvoid_variable
= intern ("void-variable");
2347 Qsetting_constant
= intern ("setting-constant");
2348 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2350 Qinvalid_function
= intern ("invalid-function");
2351 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2352 Qno_catch
= intern ("no-catch");
2353 Qend_of_file
= intern ("end-of-file");
2354 Qarith_error
= intern ("arith-error");
2355 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2356 Qend_of_buffer
= intern ("end-of-buffer");
2357 Qbuffer_read_only
= intern ("buffer-read-only");
2358 Qmark_inactive
= intern ("mark-inactive");
2360 Qlistp
= intern ("listp");
2361 Qconsp
= intern ("consp");
2362 Qsymbolp
= intern ("symbolp");
2363 Qintegerp
= intern ("integerp");
2364 Qnatnump
= intern ("natnump");
2365 Qwholenump
= intern ("wholenump");
2366 Qstringp
= intern ("stringp");
2367 Qarrayp
= intern ("arrayp");
2368 Qsequencep
= intern ("sequencep");
2369 Qbufferp
= intern ("bufferp");
2370 Qvectorp
= intern ("vectorp");
2371 Qchar_or_string_p
= intern ("char-or-string-p");
2372 Qmarkerp
= intern ("markerp");
2373 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2374 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2375 Qboundp
= intern ("boundp");
2376 Qfboundp
= intern ("fboundp");
2378 #ifdef LISP_FLOAT_TYPE
2379 Qfloatp
= intern ("floatp");
2380 Qnumberp
= intern ("numberp");
2381 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2382 #endif /* LISP_FLOAT_TYPE */
2384 Qchar_table_p
= intern ("char-table-p");
2385 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2387 Qcdr
= intern ("cdr");
2389 /* Handle automatic advice activation */
2390 Qad_advice_info
= intern ("ad-advice-info");
2391 Qad_activate
= intern ("ad-activate");
2393 error_tail
= Fcons (Qerror
, Qnil
);
2395 /* ERROR is used as a signaler for random errors for which nothing else is right */
2397 Fput (Qerror
, Qerror_conditions
,
2399 Fput (Qerror
, Qerror_message
,
2400 build_string ("error"));
2402 Fput (Qquit
, Qerror_conditions
,
2403 Fcons (Qquit
, Qnil
));
2404 Fput (Qquit
, Qerror_message
,
2405 build_string ("Quit"));
2407 Fput (Qwrong_type_argument
, Qerror_conditions
,
2408 Fcons (Qwrong_type_argument
, error_tail
));
2409 Fput (Qwrong_type_argument
, Qerror_message
,
2410 build_string ("Wrong type argument"));
2412 Fput (Qargs_out_of_range
, Qerror_conditions
,
2413 Fcons (Qargs_out_of_range
, error_tail
));
2414 Fput (Qargs_out_of_range
, Qerror_message
,
2415 build_string ("Args out of range"));
2417 Fput (Qvoid_function
, Qerror_conditions
,
2418 Fcons (Qvoid_function
, error_tail
));
2419 Fput (Qvoid_function
, Qerror_message
,
2420 build_string ("Symbol's function definition is void"));
2422 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2423 Fcons (Qcyclic_function_indirection
, error_tail
));
2424 Fput (Qcyclic_function_indirection
, Qerror_message
,
2425 build_string ("Symbol's chain of function indirections contains a loop"));
2427 Fput (Qvoid_variable
, Qerror_conditions
,
2428 Fcons (Qvoid_variable
, error_tail
));
2429 Fput (Qvoid_variable
, Qerror_message
,
2430 build_string ("Symbol's value as variable is void"));
2432 Fput (Qsetting_constant
, Qerror_conditions
,
2433 Fcons (Qsetting_constant
, error_tail
));
2434 Fput (Qsetting_constant
, Qerror_message
,
2435 build_string ("Attempt to set a constant symbol"));
2437 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2438 Fcons (Qinvalid_read_syntax
, error_tail
));
2439 Fput (Qinvalid_read_syntax
, Qerror_message
,
2440 build_string ("Invalid read syntax"));
2442 Fput (Qinvalid_function
, Qerror_conditions
,
2443 Fcons (Qinvalid_function
, error_tail
));
2444 Fput (Qinvalid_function
, Qerror_message
,
2445 build_string ("Invalid function"));
2447 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2448 Fcons (Qwrong_number_of_arguments
, error_tail
));
2449 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2450 build_string ("Wrong number of arguments"));
2452 Fput (Qno_catch
, Qerror_conditions
,
2453 Fcons (Qno_catch
, error_tail
));
2454 Fput (Qno_catch
, Qerror_message
,
2455 build_string ("No catch for tag"));
2457 Fput (Qend_of_file
, Qerror_conditions
,
2458 Fcons (Qend_of_file
, error_tail
));
2459 Fput (Qend_of_file
, Qerror_message
,
2460 build_string ("End of file during parsing"));
2462 arith_tail
= Fcons (Qarith_error
, error_tail
);
2463 Fput (Qarith_error
, Qerror_conditions
,
2465 Fput (Qarith_error
, Qerror_message
,
2466 build_string ("Arithmetic error"));
2468 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2469 Fcons (Qbeginning_of_buffer
, error_tail
));
2470 Fput (Qbeginning_of_buffer
, Qerror_message
,
2471 build_string ("Beginning of buffer"));
2473 Fput (Qend_of_buffer
, Qerror_conditions
,
2474 Fcons (Qend_of_buffer
, error_tail
));
2475 Fput (Qend_of_buffer
, Qerror_message
,
2476 build_string ("End of buffer"));
2478 Fput (Qbuffer_read_only
, Qerror_conditions
,
2479 Fcons (Qbuffer_read_only
, error_tail
));
2480 Fput (Qbuffer_read_only
, Qerror_message
,
2481 build_string ("Buffer is read-only"));
2483 #ifdef LISP_FLOAT_TYPE
2484 Qrange_error
= intern ("range-error");
2485 Qdomain_error
= intern ("domain-error");
2486 Qsingularity_error
= intern ("singularity-error");
2487 Qoverflow_error
= intern ("overflow-error");
2488 Qunderflow_error
= intern ("underflow-error");
2490 Fput (Qdomain_error
, Qerror_conditions
,
2491 Fcons (Qdomain_error
, arith_tail
));
2492 Fput (Qdomain_error
, Qerror_message
,
2493 build_string ("Arithmetic domain error"));
2495 Fput (Qrange_error
, Qerror_conditions
,
2496 Fcons (Qrange_error
, arith_tail
));
2497 Fput (Qrange_error
, Qerror_message
,
2498 build_string ("Arithmetic range error"));
2500 Fput (Qsingularity_error
, Qerror_conditions
,
2501 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2502 Fput (Qsingularity_error
, Qerror_message
,
2503 build_string ("Arithmetic singularity error"));
2505 Fput (Qoverflow_error
, Qerror_conditions
,
2506 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2507 Fput (Qoverflow_error
, Qerror_message
,
2508 build_string ("Arithmetic overflow error"));
2510 Fput (Qunderflow_error
, Qerror_conditions
,
2511 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2512 Fput (Qunderflow_error
, Qerror_message
,
2513 build_string ("Arithmetic underflow error"));
2515 staticpro (&Qrange_error
);
2516 staticpro (&Qdomain_error
);
2517 staticpro (&Qsingularity_error
);
2518 staticpro (&Qoverflow_error
);
2519 staticpro (&Qunderflow_error
);
2520 #endif /* LISP_FLOAT_TYPE */
2524 staticpro (&Qquote
);
2525 staticpro (&Qlambda
);
2527 staticpro (&Qunbound
);
2528 staticpro (&Qerror_conditions
);
2529 staticpro (&Qerror_message
);
2530 staticpro (&Qtop_level
);
2532 staticpro (&Qerror
);
2534 staticpro (&Qwrong_type_argument
);
2535 staticpro (&Qargs_out_of_range
);
2536 staticpro (&Qvoid_function
);
2537 staticpro (&Qcyclic_function_indirection
);
2538 staticpro (&Qvoid_variable
);
2539 staticpro (&Qsetting_constant
);
2540 staticpro (&Qinvalid_read_syntax
);
2541 staticpro (&Qwrong_number_of_arguments
);
2542 staticpro (&Qinvalid_function
);
2543 staticpro (&Qno_catch
);
2544 staticpro (&Qend_of_file
);
2545 staticpro (&Qarith_error
);
2546 staticpro (&Qbeginning_of_buffer
);
2547 staticpro (&Qend_of_buffer
);
2548 staticpro (&Qbuffer_read_only
);
2549 staticpro (&Qmark_inactive
);
2551 staticpro (&Qlistp
);
2552 staticpro (&Qconsp
);
2553 staticpro (&Qsymbolp
);
2554 staticpro (&Qintegerp
);
2555 staticpro (&Qnatnump
);
2556 staticpro (&Qwholenump
);
2557 staticpro (&Qstringp
);
2558 staticpro (&Qarrayp
);
2559 staticpro (&Qsequencep
);
2560 staticpro (&Qbufferp
);
2561 staticpro (&Qvectorp
);
2562 staticpro (&Qchar_or_string_p
);
2563 staticpro (&Qmarkerp
);
2564 staticpro (&Qbuffer_or_string_p
);
2565 staticpro (&Qinteger_or_marker_p
);
2566 #ifdef LISP_FLOAT_TYPE
2567 staticpro (&Qfloatp
);
2568 staticpro (&Qnumberp
);
2569 staticpro (&Qnumber_or_marker_p
);
2570 #endif /* LISP_FLOAT_TYPE */
2571 staticpro (&Qchar_table_p
);
2572 staticpro (&Qvector_or_char_table_p
);
2574 staticpro (&Qboundp
);
2575 staticpro (&Qfboundp
);
2577 staticpro (&Qad_advice_info
);
2578 staticpro (&Qad_activate
);
2580 /* Types that type-of returns. */
2581 Qinteger
= intern ("integer");
2582 Qsymbol
= intern ("symbol");
2583 Qstring
= intern ("string");
2584 Qcons
= intern ("cons");
2585 Qmarker
= intern ("marker");
2586 Qoverlay
= intern ("overlay");
2587 Qfloat
= intern ("float");
2588 Qwindow_configuration
= intern ("window-configuration");
2589 Qprocess
= intern ("process");
2590 Qwindow
= intern ("window");
2591 /* Qsubr = intern ("subr"); */
2592 Qcompiled_function
= intern ("compiled-function");
2593 Qbuffer
= intern ("buffer");
2594 Qframe
= intern ("frame");
2595 Qvector
= intern ("vector");
2597 staticpro (&Qinteger
);
2598 staticpro (&Qsymbol
);
2599 staticpro (&Qstring
);
2601 staticpro (&Qmarker
);
2602 staticpro (&Qoverlay
);
2603 staticpro (&Qfloat
);
2604 staticpro (&Qwindow_configuration
);
2605 staticpro (&Qprocess
);
2606 staticpro (&Qwindow
);
2607 /* staticpro (&Qsubr); */
2608 staticpro (&Qcompiled_function
);
2609 staticpro (&Qbuffer
);
2610 staticpro (&Qframe
);
2611 staticpro (&Qvector
);
2615 defsubr (&Stype_of
);
2620 defsubr (&Sintegerp
);
2621 defsubr (&Sinteger_or_marker_p
);
2622 defsubr (&Snumberp
);
2623 defsubr (&Snumber_or_marker_p
);
2624 #ifdef LISP_FLOAT_TYPE
2626 #endif /* LISP_FLOAT_TYPE */
2627 defsubr (&Snatnump
);
2628 defsubr (&Ssymbolp
);
2629 defsubr (&Sstringp
);
2630 defsubr (&Svectorp
);
2631 defsubr (&Schar_table_p
);
2632 defsubr (&Svector_or_char_table_p
);
2633 defsubr (&Sbool_vector_p
);
2635 defsubr (&Ssequencep
);
2636 defsubr (&Sbufferp
);
2637 defsubr (&Smarkerp
);
2639 defsubr (&Sbyte_code_function_p
);
2640 defsubr (&Schar_or_string_p
);
2643 defsubr (&Scar_safe
);
2644 defsubr (&Scdr_safe
);
2647 defsubr (&Ssymbol_function
);
2648 defsubr (&Sindirect_function
);
2649 defsubr (&Ssymbol_plist
);
2650 defsubr (&Ssymbol_name
);
2651 defsubr (&Smakunbound
);
2652 defsubr (&Sfmakunbound
);
2654 defsubr (&Sfboundp
);
2656 defsubr (&Sdefalias
);
2657 defsubr (&Sdefine_function
);
2658 defsubr (&Ssetplist
);
2659 defsubr (&Ssymbol_value
);
2661 defsubr (&Sdefault_boundp
);
2662 defsubr (&Sdefault_value
);
2663 defsubr (&Sset_default
);
2664 defsubr (&Ssetq_default
);
2665 defsubr (&Smake_variable_buffer_local
);
2666 defsubr (&Smake_local_variable
);
2667 defsubr (&Skill_local_variable
);
2668 defsubr (&Slocal_variable_p
);
2669 defsubr (&Slocal_variable_if_set_p
);
2672 defsubr (&Snumber_to_string
);
2673 defsubr (&Sstring_to_number
);
2674 defsubr (&Seqlsign
);
2698 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2706 /* USG systems forget handlers when they are used;
2707 must reestablish each time */
2708 signal (signo
, arith_error
);
2711 /* VMS systems are like USG. */
2712 signal (signo
, arith_error
);
2716 #else /* not BSD4_1 */
2717 sigsetmask (SIGEMPTYMASK
);
2718 #endif /* not BSD4_1 */
2720 Fsignal (Qarith_error
, Qnil
);
2725 /* Don't do this if just dumping out.
2726 We don't want to call `signal' in this case
2727 so that we don't have trouble with dumping
2728 signal-delivering routines in an inconsistent state. */
2732 #endif /* CANNOT_DUMP */
2733 signal (SIGFPE
, arith_error
);
2736 signal (SIGEMT
, arith_error
);