1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98, 1999 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, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
35 #include "syssignal.h"
37 #ifdef LISP_FLOAT_TYPE
43 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
44 #ifndef IEEE_FLOATING_POINT
45 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
46 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
47 #define IEEE_FLOATING_POINT 1
49 #define IEEE_FLOATING_POINT 0
53 /* Work around a problem that happens because math.h on hpux 7
54 defines two static variables--which, in Emacs, are not really static,
55 because `static' is defined as nothing. The problem is that they are
56 here, in floatfns.c, and in lread.c.
57 These macros prevent the name conflict. */
58 #if defined (HPUX) && !defined (HPUX8)
59 #define _MAXLDBL data_c_maxldbl
60 #define _NMAXLDBL data_c_nmaxldbl
64 #endif /* LISP_FLOAT_TYPE */
67 extern double atof ();
70 /* Nonzero means it is an error to set a symbol whose name starts with
72 int keyword_symbols_constant_flag
;
74 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
75 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
76 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
77 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
78 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
79 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
80 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
81 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
82 Lisp_Object Qtext_read_only
;
83 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
84 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
85 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
86 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
87 Lisp_Object Qboundp
, Qfboundp
;
88 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
91 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
93 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
94 Lisp_Object Qoverflow_error
, Qunderflow_error
;
96 #ifdef LISP_FLOAT_TYPE
98 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
101 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
102 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
103 Lisp_Object Qprocess
;
104 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
105 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
107 static Lisp_Object
swap_in_symval_forwarding ();
109 Lisp_Object
set_internal ();
112 wrong_type_argument (predicate
, value
)
113 register Lisp_Object predicate
, value
;
115 register Lisp_Object tem
;
118 if (!EQ (Vmocklisp_arguments
, Qt
))
120 if (STRINGP (value
) &&
121 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
122 return Fstring_to_number (value
, Qnil
);
123 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
124 return Fnumber_to_string (value
);
127 /* If VALUE is not even a valid Lisp object, abort here
128 where we can get a backtrace showing where it came from. */
129 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
132 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
133 tem
= call1 (predicate
, value
);
142 error ("Attempt to modify read-only object");
146 args_out_of_range (a1
, a2
)
150 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
154 args_out_of_range_3 (a1
, a2
, a3
)
155 Lisp_Object a1
, a2
, a3
;
158 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
161 /* On some machines, XINT needs a temporary location.
162 Here it is, in case it is needed. */
164 int sign_extend_temp
;
166 /* On a few machines, XINT can only be done by calling this. */
169 sign_extend_lisp_int (num
)
172 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
173 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
175 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
178 /* Data type predicates */
180 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
181 "Return t if the two args are the same Lisp object.")
183 Lisp_Object obj1
, obj2
;
190 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
199 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
200 "Return a symbol representing the type of OBJECT.\n\
201 The symbol returned names the object's basic type;\n\
202 for example, (type-of 1) returns `integer'.")
206 switch (XGCTYPE (object
))
221 switch (XMISCTYPE (object
))
223 case Lisp_Misc_Marker
:
225 case Lisp_Misc_Overlay
:
227 case Lisp_Misc_Float
:
232 case Lisp_Vectorlike
:
233 if (GC_WINDOW_CONFIGURATIONP (object
))
234 return Qwindow_configuration
;
235 if (GC_PROCESSP (object
))
237 if (GC_WINDOWP (object
))
239 if (GC_SUBRP (object
))
241 if (GC_COMPILEDP (object
))
242 return Qcompiled_function
;
243 if (GC_BUFFERP (object
))
245 if (GC_CHAR_TABLE_P (object
))
247 if (GC_BOOL_VECTOR_P (object
))
249 if (GC_FRAMEP (object
))
251 if (GC_HASH_TABLE_P (object
))
255 #ifdef LISP_FLOAT_TYPE
265 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
274 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
275 "Return t if OBJECT is not a cons cell. This includes nil.")
284 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
285 "Return t if OBJECT is a list. This includes nil.")
289 if (CONSP (object
) || NILP (object
))
294 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
295 "Return t if OBJECT is not a list. Lists include nil.")
299 if (CONSP (object
) || NILP (object
))
304 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
305 "Return t if OBJECT is a symbol.")
309 if (SYMBOLP (object
))
314 /* Define this in C to avoid unnecessarily consing up the symbol
316 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
317 "Return t if OBJECT is a keyword.\n\
318 This means that it is a symbol with a print name beginning with `:'\n\
319 interned in the initial obarray.")
324 && XSYMBOL (object
)->name
->data
[0] == ':'
325 && EQ (XSYMBOL (object
)->obarray
, initial_obarray
))
330 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
331 "Return t if OBJECT is a vector.")
335 if (VECTORP (object
))
340 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
341 "Return t if OBJECT is a string.")
345 if (STRINGP (object
))
350 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
351 1, 1, 0, "Return t if OBJECT is a multibyte string.")
355 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
360 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
361 "Return t if OBJECT is a char-table.")
365 if (CHAR_TABLE_P (object
))
370 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
371 Svector_or_char_table_p
, 1, 1, 0,
372 "Return t if OBJECT is a char-table or vector.")
376 if (VECTORP (object
) || CHAR_TABLE_P (object
))
381 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
385 if (BOOL_VECTOR_P (object
))
390 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
394 if (VECTORP (object
) || STRINGP (object
)
395 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
400 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
401 "Return t if OBJECT is a sequence (list or array).")
403 register Lisp_Object object
;
405 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
406 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
411 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
415 if (BUFFERP (object
))
420 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
424 if (MARKERP (object
))
429 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
438 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
439 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
443 if (COMPILEDP (object
))
448 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
449 "Return t if OBJECT is a character (an integer) or a string.")
451 register Lisp_Object object
;
453 if (INTEGERP (object
) || STRINGP (object
))
458 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
462 if (INTEGERP (object
))
467 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
468 "Return t if OBJECT is an integer or a marker (editor pointer).")
470 register Lisp_Object object
;
472 if (MARKERP (object
) || INTEGERP (object
))
477 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
478 "Return t if OBJECT is a nonnegative integer.")
482 if (NATNUMP (object
))
487 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
488 "Return t if OBJECT is a number (floating point or integer).")
492 if (NUMBERP (object
))
498 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
499 Snumber_or_marker_p
, 1, 1, 0,
500 "Return t if OBJECT is a number or a marker.")
504 if (NUMBERP (object
) || MARKERP (object
))
509 #ifdef LISP_FLOAT_TYPE
510 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
511 "Return t if OBJECT is a floating point number.")
519 #endif /* LISP_FLOAT_TYPE */
521 /* Extract and set components of lists */
523 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
524 "Return the car of LIST. If arg is nil, return nil.\n\
525 Error if arg is not nil and not a cons cell. See also `car-safe'.")
527 register Lisp_Object list
;
533 else if (EQ (list
, Qnil
))
536 list
= wrong_type_argument (Qlistp
, list
);
540 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
541 "Return the car of OBJECT if it is a cons cell, or else nil.")
546 return XCAR (object
);
551 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
552 "Return the cdr of LIST. If arg is nil, return nil.\n\
553 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
556 register Lisp_Object list
;
562 else if (EQ (list
, Qnil
))
565 list
= wrong_type_argument (Qlistp
, list
);
569 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
570 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
575 return XCDR (object
);
580 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
581 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
583 register Lisp_Object cell
, newcar
;
586 cell
= wrong_type_argument (Qconsp
, cell
);
589 XCAR (cell
) = newcar
;
593 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
594 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
596 register Lisp_Object cell
, newcdr
;
599 cell
= wrong_type_argument (Qconsp
, cell
);
602 XCDR (cell
) = newcdr
;
606 /* Extract and set components of symbols */
608 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
610 register Lisp_Object symbol
;
612 Lisp_Object valcontents
;
613 CHECK_SYMBOL (symbol
, 0);
615 valcontents
= XSYMBOL (symbol
)->value
;
617 if (BUFFER_LOCAL_VALUEP (valcontents
)
618 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
619 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
621 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
624 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
626 register Lisp_Object symbol
;
628 CHECK_SYMBOL (symbol
, 0);
629 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
632 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
634 register Lisp_Object symbol
;
636 CHECK_SYMBOL (symbol
, 0);
637 if (NILP (symbol
) || EQ (symbol
, Qt
)
638 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
639 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
640 && keyword_symbols_constant_flag
))
641 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
642 Fset (symbol
, Qunbound
);
646 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
648 register Lisp_Object symbol
;
650 CHECK_SYMBOL (symbol
, 0);
651 if (NILP (symbol
) || EQ (symbol
, Qt
))
652 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
653 XSYMBOL (symbol
)->function
= Qunbound
;
657 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
658 "Return SYMBOL's function definition. Error if that is void.")
660 register Lisp_Object symbol
;
662 CHECK_SYMBOL (symbol
, 0);
663 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
664 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
665 return XSYMBOL (symbol
)->function
;
668 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
670 register Lisp_Object symbol
;
672 CHECK_SYMBOL (symbol
, 0);
673 return XSYMBOL (symbol
)->plist
;
676 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
678 register Lisp_Object symbol
;
680 register Lisp_Object name
;
682 CHECK_SYMBOL (symbol
, 0);
683 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
687 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
688 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
690 register Lisp_Object symbol
, definition
;
692 CHECK_SYMBOL (symbol
, 0);
693 if (NILP (symbol
) || EQ (symbol
, Qt
))
694 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
695 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
696 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
698 XSYMBOL (symbol
)->function
= definition
;
699 /* Handle automatic advice activation */
700 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
702 call2 (Qad_activate_internal
, symbol
, Qnil
);
703 definition
= XSYMBOL (symbol
)->function
;
708 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
709 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
710 Associates the function with the current load file, if any.")
712 register Lisp_Object symbol
, definition
;
714 definition
= Ffset (symbol
, definition
);
715 LOADHIST_ATTACH (symbol
);
719 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
720 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
722 register Lisp_Object symbol
, newplist
;
724 CHECK_SYMBOL (symbol
, 0);
725 XSYMBOL (symbol
)->plist
= newplist
;
730 /* Getting and setting values of symbols */
732 /* Given the raw contents of a symbol value cell,
733 return the Lisp value of the symbol.
734 This does not handle buffer-local variables; use
735 swap_in_symval_forwarding for that. */
738 do_symval_forwarding (valcontents
)
739 register Lisp_Object valcontents
;
741 register Lisp_Object val
;
743 if (MISCP (valcontents
))
744 switch (XMISCTYPE (valcontents
))
746 case Lisp_Misc_Intfwd
:
747 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
750 case Lisp_Misc_Boolfwd
:
751 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
753 case Lisp_Misc_Objfwd
:
754 return *XOBJFWD (valcontents
)->objvar
;
756 case Lisp_Misc_Buffer_Objfwd
:
757 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
758 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
760 case Lisp_Misc_Kboard_Objfwd
:
761 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
762 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
767 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
768 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
769 buffer-independent contents of the value cell: forwarded just one
770 step past the buffer-localness. */
773 store_symval_forwarding (symbol
, valcontents
, newval
)
775 register Lisp_Object valcontents
, newval
;
777 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
780 switch (XMISCTYPE (valcontents
))
782 case Lisp_Misc_Intfwd
:
783 CHECK_NUMBER (newval
, 1);
784 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
785 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
786 error ("Value out of range for variable `%s'",
787 XSYMBOL (symbol
)->name
->data
);
790 case Lisp_Misc_Boolfwd
:
791 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
794 case Lisp_Misc_Objfwd
:
795 *XOBJFWD (valcontents
)->objvar
= newval
;
798 case Lisp_Misc_Buffer_Objfwd
:
800 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
803 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
804 if (XINT (type
) == -1)
805 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
807 if (! NILP (type
) && ! NILP (newval
)
808 && XTYPE (newval
) != XINT (type
))
809 buffer_slot_type_mismatch (offset
);
811 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
815 case Lisp_Misc_Kboard_Objfwd
:
816 (*(Lisp_Object
*)((char *)current_kboard
817 + XKBOARD_OBJFWD (valcontents
)->offset
))
828 valcontents
= XSYMBOL (symbol
)->value
;
829 if (BUFFER_LOCAL_VALUEP (valcontents
)
830 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
831 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
833 XSYMBOL (symbol
)->value
= newval
;
837 /* Set up the buffer-local symbol SYMBOL for validity in the current
838 buffer. VALCONTENTS is the contents of its value cell.
839 Return the value forwarded one step past the buffer-local indicator. */
842 swap_in_symval_forwarding (symbol
, valcontents
)
843 Lisp_Object symbol
, valcontents
;
845 /* valcontents is a pointer to a struct resembling the cons
846 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
848 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
849 local_var_alist, that being the element whose car is this
850 variable. Or it can be a pointer to the
851 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
852 an element in its alist for this variable.
854 If the current buffer is not BUFFER, we store the current
855 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
856 appropriate alist element for the buffer now current and set up
857 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
858 element, and store into BUFFER.
860 Note that REALVALUE can be a forwarding pointer. */
862 register Lisp_Object tem1
;
863 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
865 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
)
866 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
868 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
870 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
871 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
872 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
873 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
876 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
877 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
879 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
881 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
884 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
886 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = tem1
;
887 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
888 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
889 store_symval_forwarding (symbol
,
890 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
893 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
896 /* Find the value of a symbol, returning Qunbound if it's not bound.
897 This is helpful for code which just wants to get a variable's value
898 if it has one, without signaling an error.
899 Note that it must not be possible to quit
900 within this function. Great care is required for this. */
903 find_symbol_value (symbol
)
906 register Lisp_Object valcontents
;
907 register Lisp_Object val
;
908 CHECK_SYMBOL (symbol
, 0);
909 valcontents
= XSYMBOL (symbol
)->value
;
911 if (BUFFER_LOCAL_VALUEP (valcontents
)
912 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
913 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
915 if (MISCP (valcontents
))
917 switch (XMISCTYPE (valcontents
))
919 case Lisp_Misc_Intfwd
:
920 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
923 case Lisp_Misc_Boolfwd
:
924 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
926 case Lisp_Misc_Objfwd
:
927 return *XOBJFWD (valcontents
)->objvar
;
929 case Lisp_Misc_Buffer_Objfwd
:
930 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
931 + (char *)current_buffer
);
933 case Lisp_Misc_Kboard_Objfwd
:
934 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
935 + (char *)current_kboard
);
942 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
943 "Return SYMBOL's value. Error if that is void.")
949 val
= find_symbol_value (symbol
);
950 if (EQ (val
, Qunbound
))
951 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
956 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
957 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
959 register Lisp_Object symbol
, newval
;
961 return set_internal (symbol
, newval
, 0);
964 /* Store the value NEWVAL into SYMBOL.
965 If BINDFLAG is zero, then if this symbol is supposed to become
966 local in every buffer where it is set, then we make it local.
967 If BINDFLAG is nonzero, we don't do that. */
970 set_internal (symbol
, newval
, bindflag
)
971 register Lisp_Object symbol
, newval
;
974 int voide
= EQ (newval
, Qunbound
);
976 register Lisp_Object valcontents
, tem1
, current_alist_element
;
978 CHECK_SYMBOL (symbol
, 0);
979 if (NILP (symbol
) || EQ (symbol
, Qt
)
980 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
981 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
982 && keyword_symbols_constant_flag
&& ! EQ (newval
, symbol
)))
983 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
984 valcontents
= XSYMBOL (symbol
)->value
;
986 if (BUFFER_OBJFWDP (valcontents
))
988 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
989 register int mask
= XINT (*((Lisp_Object
*)
990 (idx
+ (char *)&buffer_local_flags
)));
991 if (mask
> 0 && ! bindflag
)
992 current_buffer
->local_var_flags
|= mask
;
995 else if (BUFFER_LOCAL_VALUEP (valcontents
)
996 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
998 /* valcontents is actually a pointer to a struct resembling a cons,
999 with contents something like:
1000 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
1002 BUFFER is the last buffer for which this symbol's value was
1005 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
1006 local_var_alist, that being the element whose car is this
1007 variable. Or it can be a pointer to the
1008 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
1009 have an element in its alist for this variable (that is, if
1010 BUFFER sees the default value of this variable).
1012 If we want to examine or set the value and BUFFER is current,
1013 we just examine or set REALVALUE. If BUFFER is not current, we
1014 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
1015 then find the appropriate alist element for the buffer now
1016 current and set up CURRENT-ALIST-ELEMENT. Then we set
1017 REALVALUE out of that element, and store into BUFFER.
1019 If we are setting the variable and the current buffer does
1020 not have an alist entry for this variable, an alist entry is
1023 Note that REALVALUE can be a forwarding pointer. Each time
1024 it is examined or set, forwarding must be done. */
1026 /* What value are we caching right now? */
1027 current_alist_element
1028 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1030 /* If the current buffer is not the buffer whose binding is
1031 currently cached, or if it's a Lisp_Buffer_Local_Value and
1032 we're looking at the default value, the cache is invalid; we
1033 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
1034 if (current_buffer
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1035 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)
1036 || (BUFFER_LOCAL_VALUEP (valcontents
)
1037 && EQ (XCAR (current_alist_element
),
1038 current_alist_element
)))
1040 /* Write out the cached value for the old buffer; copy it
1041 back to its alist element. This works if the current
1042 buffer only sees the default value, too. */
1043 Fsetcdr (current_alist_element
,
1044 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1046 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1047 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1048 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1049 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1053 /* This buffer still sees the default value. */
1055 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1056 or if this is `let' rather than `set',
1057 make CURRENT-ALIST-ELEMENT point to itself,
1058 indicating that we're seeing the default value. */
1059 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1061 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1063 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1064 tem1
= Fassq (symbol
,
1065 XFRAME (selected_frame
)->param_alist
);
1068 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1070 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1072 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1073 give this buffer a new assoc for a local value and set
1074 CURRENT-ALIST-ELEMENT to point to that. */
1077 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1078 current_buffer
->local_var_alist
1079 = Fcons (tem1
, current_buffer
->local_var_alist
);
1083 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1084 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1087 /* Set BUFFER and FRAME for binding now loaded. */
1088 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
,
1090 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1092 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1095 /* If storing void (making the symbol void), forward only through
1096 buffer-local indicator, not through Lisp_Objfwd, etc. */
1098 store_symval_forwarding (symbol
, Qnil
, newval
);
1100 store_symval_forwarding (symbol
, valcontents
, newval
);
1105 /* Access or set a buffer-local symbol's default value. */
1107 /* Return the default value of SYMBOL, but don't check for voidness.
1108 Return Qunbound if it is void. */
1111 default_value (symbol
)
1114 register Lisp_Object valcontents
;
1116 CHECK_SYMBOL (symbol
, 0);
1117 valcontents
= XSYMBOL (symbol
)->value
;
1119 /* For a built-in buffer-local variable, get the default value
1120 rather than letting do_symval_forwarding get the current value. */
1121 if (BUFFER_OBJFWDP (valcontents
))
1123 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1125 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1126 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1129 /* Handle user-created local variables. */
1130 if (BUFFER_LOCAL_VALUEP (valcontents
)
1131 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1133 /* If var is set up for a buffer that lacks a local value for it,
1134 the current value is nominally the default value.
1135 But the current value slot may be more up to date, since
1136 ordinary setq stores just that slot. So use that. */
1137 Lisp_Object current_alist_element
, alist_element_car
;
1138 current_alist_element
1139 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1140 alist_element_car
= XCAR (current_alist_element
);
1141 if (EQ (alist_element_car
, current_alist_element
))
1142 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1144 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1146 /* For other variables, get the current value. */
1147 return do_symval_forwarding (valcontents
);
1150 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1151 "Return t if SYMBOL has a non-void default value.\n\
1152 This is the value that is seen in buffers that do not have their own values\n\
1153 for this variable.")
1157 register Lisp_Object value
;
1159 value
= default_value (symbol
);
1160 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1163 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1164 "Return SYMBOL's default value.\n\
1165 This is the value that is seen in buffers that do not have their own values\n\
1166 for this variable. The default value is meaningful for variables with\n\
1167 local bindings in certain buffers.")
1171 register Lisp_Object value
;
1173 value
= default_value (symbol
);
1174 if (EQ (value
, Qunbound
))
1175 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1179 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1180 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1181 The default value is seen in buffers that do not have their own values\n\
1182 for this variable.")
1184 Lisp_Object symbol
, value
;
1186 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1188 CHECK_SYMBOL (symbol
, 0);
1189 valcontents
= XSYMBOL (symbol
)->value
;
1191 /* Handle variables like case-fold-search that have special slots
1192 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1194 if (BUFFER_OBJFWDP (valcontents
))
1196 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1197 register struct buffer
*b
;
1198 register int mask
= XINT (*((Lisp_Object
*)
1199 (idx
+ (char *)&buffer_local_flags
)));
1201 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1203 /* If this variable is not always local in all buffers,
1204 set it in the buffers that don't nominally have a local value. */
1207 for (b
= all_buffers
; b
; b
= b
->next
)
1208 if (!(b
->local_var_flags
& mask
))
1209 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1214 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1215 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1216 return Fset (symbol
, value
);
1218 /* Store new value into the DEFAULT-VALUE slot */
1219 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1221 /* If that slot is current, we must set the REALVALUE slot too */
1222 current_alist_element
1223 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1224 alist_element_buffer
= Fcar (current_alist_element
);
1225 if (EQ (alist_element_buffer
, current_alist_element
))
1226 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1232 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1233 "Set the default value of variable VAR to VALUE.\n\
1234 VAR, the variable name, is literal (not evaluated);\n\
1235 VALUE is an expression and it is evaluated.\n\
1236 The default value of a variable is seen in buffers\n\
1237 that do not have their own values for the variable.\n\
1239 More generally, you can use multiple variables and values, as in\n\
1240 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1241 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1242 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1247 register Lisp_Object args_left
;
1248 register Lisp_Object val
, symbol
;
1249 struct gcpro gcpro1
;
1259 val
= Feval (Fcar (Fcdr (args_left
)));
1260 symbol
= Fcar (args_left
);
1261 Fset_default (symbol
, val
);
1262 args_left
= Fcdr (Fcdr (args_left
));
1264 while (!NILP (args_left
));
1270 /* Lisp functions for creating and removing buffer-local variables. */
1272 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1273 1, 1, "vMake Variable Buffer Local: ",
1274 "Make VARIABLE have a separate value for each buffer.\n\
1275 At any time, the value for the current buffer is in effect.\n\
1276 There is also a default value which is seen in any buffer which has not yet\n\
1277 set its own value.\n\
1278 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1279 for the current buffer if it was previously using the default value.\n\
1280 The function `default-value' gets the default value and `set-default' sets it.")
1282 register Lisp_Object variable
;
1284 register Lisp_Object tem
, valcontents
, newval
;
1286 CHECK_SYMBOL (variable
, 0);
1288 valcontents
= XSYMBOL (variable
)->value
;
1289 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1290 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1292 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1294 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1296 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1299 if (EQ (valcontents
, Qunbound
))
1300 XSYMBOL (variable
)->value
= Qnil
;
1301 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1303 newval
= allocate_misc ();
1304 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1305 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1306 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1307 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1308 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 1;
1309 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1310 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1311 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1312 XSYMBOL (variable
)->value
= newval
;
1316 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1317 1, 1, "vMake Local Variable: ",
1318 "Make VARIABLE have a separate value in the current buffer.\n\
1319 Other buffers will continue to share a common default value.\n\
1320 \(The buffer-local value of VARIABLE starts out as the same value\n\
1321 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1322 See also `make-variable-buffer-local'.\n\
1324 If the variable is already arranged to become local when set,\n\
1325 this function causes a local value to exist for this buffer,\n\
1326 just as setting the variable would do.\n\
1328 This function returns VARIABLE, and therefore\n\
1329 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1332 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1333 Use `make-local-hook' instead.")
1335 register Lisp_Object variable
;
1337 register Lisp_Object tem
, valcontents
;
1339 CHECK_SYMBOL (variable
, 0);
1341 valcontents
= XSYMBOL (variable
)->value
;
1342 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1343 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1345 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1347 tem
= Fboundp (variable
);
1349 /* Make sure the symbol has a local value in this particular buffer,
1350 by setting it to the same value it already has. */
1351 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1354 /* Make sure symbol is set up to hold per-buffer values */
1355 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1358 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1360 newval
= allocate_misc ();
1361 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1362 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1363 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1364 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1365 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1366 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1367 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1368 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1369 XSYMBOL (variable
)->value
= newval
;
1371 /* Make sure this buffer has its own value of symbol */
1372 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1375 /* Swap out any local binding for some other buffer, and make
1376 sure the current value is permanently recorded, if it's the
1378 find_symbol_value (variable
);
1380 current_buffer
->local_var_alist
1381 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1382 current_buffer
->local_var_alist
);
1384 /* Make sure symbol does not think it is set up for this buffer;
1385 force it to look once again for this buffer's value */
1387 Lisp_Object
*pvalbuf
;
1389 valcontents
= XSYMBOL (variable
)->value
;
1391 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1392 if (current_buffer
== XBUFFER (*pvalbuf
))
1394 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1398 /* If the symbol forwards into a C variable, then swap in the
1399 variable for this buffer immediately. If C code modifies the
1400 variable before we swap in, then that new value will clobber the
1401 default value the next time we swap. */
1402 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1403 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1404 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1409 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1410 1, 1, "vKill Local Variable: ",
1411 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1412 From now on the default value will apply in this buffer.")
1414 register Lisp_Object variable
;
1416 register Lisp_Object tem
, valcontents
;
1418 CHECK_SYMBOL (variable
, 0);
1420 valcontents
= XSYMBOL (variable
)->value
;
1422 if (BUFFER_OBJFWDP (valcontents
))
1424 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1425 register int mask
= XINT (*((Lisp_Object
*)
1426 (idx
+ (char *)&buffer_local_flags
)));
1430 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1431 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1432 current_buffer
->local_var_flags
&= ~mask
;
1437 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1438 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1441 /* Get rid of this buffer's alist element, if any */
1443 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1445 current_buffer
->local_var_alist
1446 = Fdelq (tem
, current_buffer
->local_var_alist
);
1448 /* If the symbol is set up for the current buffer, recompute its
1449 value. We have to do it now, or else forwarded objects won't
1452 Lisp_Object
*pvalbuf
;
1453 valcontents
= XSYMBOL (variable
)->value
;
1454 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1455 if (current_buffer
== XBUFFER (*pvalbuf
))
1458 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1459 find_symbol_value (variable
);
1466 /* Lisp functions for creating and removing buffer-local variables. */
1468 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1469 1, 1, "vMake Variable Frame Local: ",
1470 "Enable VARIABLE to have frame-local bindings.\n\
1471 When a frame-local binding exists in the current frame,\n\
1472 it is in effect whenever the current buffer has no buffer-local binding.\n\
1473 A frame-local binding is actual a frame parameter value;\n\
1474 thus, any given frame has a local binding for VARIABLE\n\
1475 if it has a value for the frame parameter named VARIABLE.\n\
1476 See `modify-frame-parameters'.")
1478 register Lisp_Object variable
;
1480 register Lisp_Object tem
, valcontents
, newval
;
1482 CHECK_SYMBOL (variable
, 0);
1484 valcontents
= XSYMBOL (variable
)->value
;
1485 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1486 || BUFFER_OBJFWDP (valcontents
))
1487 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1489 if (BUFFER_LOCAL_VALUEP (valcontents
)
1490 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1493 if (EQ (valcontents
, Qunbound
))
1494 XSYMBOL (variable
)->value
= Qnil
;
1495 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1497 newval
= allocate_misc ();
1498 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1499 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1500 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1501 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1502 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1503 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1504 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1505 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1506 XSYMBOL (variable
)->value
= newval
;
1510 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1512 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1513 BUFFER defaults to the current buffer.")
1515 register Lisp_Object variable
, buffer
;
1517 Lisp_Object valcontents
;
1518 register struct buffer
*buf
;
1521 buf
= current_buffer
;
1524 CHECK_BUFFER (buffer
, 0);
1525 buf
= XBUFFER (buffer
);
1528 CHECK_SYMBOL (variable
, 0);
1530 valcontents
= XSYMBOL (variable
)->value
;
1531 if (BUFFER_LOCAL_VALUEP (valcontents
)
1532 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1534 Lisp_Object tail
, elt
;
1535 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1538 if (EQ (variable
, XCAR (elt
)))
1542 if (BUFFER_OBJFWDP (valcontents
))
1544 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1545 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1546 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1552 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1554 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1555 BUFFER defaults to the current buffer.")
1557 register Lisp_Object variable
, buffer
;
1559 Lisp_Object valcontents
;
1560 register struct buffer
*buf
;
1563 buf
= current_buffer
;
1566 CHECK_BUFFER (buffer
, 0);
1567 buf
= XBUFFER (buffer
);
1570 CHECK_SYMBOL (variable
, 0);
1572 valcontents
= XSYMBOL (variable
)->value
;
1574 /* This means that make-variable-buffer-local was done. */
1575 if (BUFFER_LOCAL_VALUEP (valcontents
))
1577 /* All these slots become local if they are set. */
1578 if (BUFFER_OBJFWDP (valcontents
))
1580 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1582 Lisp_Object tail
, elt
;
1583 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1586 if (EQ (variable
, XCAR (elt
)))
1593 /* Find the function at the end of a chain of symbol function indirections. */
1595 /* If OBJECT is a symbol, find the end of its function chain and
1596 return the value found there. If OBJECT is not a symbol, just
1597 return it. If there is a cycle in the function chain, signal a
1598 cyclic-function-indirection error.
1600 This is like Findirect_function, except that it doesn't signal an
1601 error if the chain ends up unbound. */
1603 indirect_function (object
)
1604 register Lisp_Object object
;
1606 Lisp_Object tortoise
, hare
;
1608 hare
= tortoise
= object
;
1612 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1614 hare
= XSYMBOL (hare
)->function
;
1615 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1617 hare
= XSYMBOL (hare
)->function
;
1619 tortoise
= XSYMBOL (tortoise
)->function
;
1621 if (EQ (hare
, tortoise
))
1622 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1628 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1629 "Return the function at the end of OBJECT's function chain.\n\
1630 If OBJECT is a symbol, follow all function indirections and return the final\n\
1631 function binding.\n\
1632 If OBJECT is not a symbol, just return it.\n\
1633 Signal a void-function error if the final symbol is unbound.\n\
1634 Signal a cyclic-function-indirection error if there is a loop in the\n\
1635 function chain of symbols.")
1637 register Lisp_Object object
;
1641 result
= indirect_function (object
);
1643 if (EQ (result
, Qunbound
))
1644 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1648 /* Extract and set vector and string elements */
1650 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1651 "Return the element of ARRAY at index IDX.\n\
1652 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1653 or a byte-code object. IDX starts at 0.")
1655 register Lisp_Object array
;
1658 register int idxval
;
1660 CHECK_NUMBER (idx
, 1);
1661 idxval
= XINT (idx
);
1662 if (STRINGP (array
))
1666 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1667 args_out_of_range (array
, idx
);
1668 if (! STRING_MULTIBYTE (array
))
1669 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1670 idxval_byte
= string_char_to_byte (array
, idxval
);
1672 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1673 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1674 return make_number (c
);
1676 else if (BOOL_VECTOR_P (array
))
1680 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1681 args_out_of_range (array
, idx
);
1683 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1684 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1686 else if (CHAR_TABLE_P (array
))
1691 args_out_of_range (array
, idx
);
1692 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1694 /* For ASCII and 8-bit European characters, the element is
1695 stored in the top table. */
1696 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1698 val
= XCHAR_TABLE (array
)->defalt
;
1699 while (NILP (val
)) /* Follow parents until we find some value. */
1701 array
= XCHAR_TABLE (array
)->parent
;
1704 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1706 val
= XCHAR_TABLE (array
)->defalt
;
1713 Lisp_Object sub_table
;
1715 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1716 if (code
[1] < 32) code
[1] = -1;
1717 else if (code
[2] < 32) code
[2] = -1;
1719 /* Here, the possible range of CODE[0] (== charset ID) is
1720 128..MAX_CHARSET. Since the top level char table contains
1721 data for multibyte characters after 256th element, we must
1722 increment CODE[0] by 128 to get a correct index. */
1724 code
[3] = -1; /* anchor */
1726 try_parent_char_table
:
1728 for (i
= 0; code
[i
] >= 0; i
++)
1730 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1731 if (SUB_CHAR_TABLE_P (val
))
1736 val
= XCHAR_TABLE (sub_table
)->defalt
;
1739 array
= XCHAR_TABLE (array
)->parent
;
1741 goto try_parent_char_table
;
1746 /* Here, VAL is a sub char table. We try the default value
1748 val
= XCHAR_TABLE (val
)->defalt
;
1751 array
= XCHAR_TABLE (array
)->parent
;
1753 goto try_parent_char_table
;
1761 if (VECTORP (array
))
1762 size
= XVECTOR (array
)->size
;
1763 else if (COMPILEDP (array
))
1764 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1766 wrong_type_argument (Qarrayp
, array
);
1768 if (idxval
< 0 || idxval
>= size
)
1769 args_out_of_range (array
, idx
);
1770 return XVECTOR (array
)->contents
[idxval
];
1774 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1775 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1776 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1778 (array
, idx
, newelt
)
1779 register Lisp_Object array
;
1780 Lisp_Object idx
, newelt
;
1782 register int idxval
;
1784 CHECK_NUMBER (idx
, 1);
1785 idxval
= XINT (idx
);
1786 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1787 && ! CHAR_TABLE_P (array
))
1788 array
= wrong_type_argument (Qarrayp
, array
);
1789 CHECK_IMPURE (array
);
1791 if (VECTORP (array
))
1793 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1794 args_out_of_range (array
, idx
);
1795 XVECTOR (array
)->contents
[idxval
] = newelt
;
1797 else if (BOOL_VECTOR_P (array
))
1801 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1802 args_out_of_range (array
, idx
);
1804 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1806 if (! NILP (newelt
))
1807 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1809 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1810 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1812 else if (CHAR_TABLE_P (array
))
1815 args_out_of_range (array
, idx
);
1816 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1817 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1823 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1824 if (code
[1] < 32) code
[1] = -1;
1825 else if (code
[2] < 32) code
[2] = -1;
1827 /* See the comment of the corresponding part in Faref. */
1829 code
[3] = -1; /* anchor */
1830 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1832 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1833 if (SUB_CHAR_TABLE_P (val
))
1839 /* VAL is a leaf. Create a sub char table with the
1840 default value VAL or XCHAR_TABLE (array)->defalt
1841 and look into it. */
1843 temp
= make_sub_char_table (NILP (val
)
1844 ? XCHAR_TABLE (array
)->defalt
1846 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1850 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1853 else if (STRING_MULTIBYTE (array
))
1855 int idxval_byte
, new_len
, actual_len
;
1857 unsigned char *p
, workbuf
[MAX_MULTIBYTE_LENGTH
], *str
= workbuf
;
1859 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1860 args_out_of_range (array
, idx
);
1862 idxval_byte
= string_char_to_byte (array
, idxval
);
1863 p
= &XSTRING (array
)->data
[idxval_byte
];
1865 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1866 CHECK_NUMBER (newelt
, 2);
1867 new_len
= CHAR_STRING (XINT (newelt
), str
);
1868 if (actual_len
!= new_len
)
1869 error ("Attempt to change byte length of a string");
1871 /* We can't accept a change causing byte combining. */
1872 if (!ASCII_BYTE_P (*str
)
1873 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1874 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1875 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1876 > idxval_byte
- prev_byte
))
1877 || (idxval
< XSTRING (array
)->size
- 1
1878 && !CHAR_HEAD_P (p
[actual_len
])
1879 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1880 error ("Attempt to change char length of a string");
1886 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1887 args_out_of_range (array
, idx
);
1888 CHECK_NUMBER (newelt
, 2);
1889 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1895 /* Arithmetic functions */
1897 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1900 arithcompare (num1
, num2
, comparison
)
1901 Lisp_Object num1
, num2
;
1902 enum comparison comparison
;
1907 #ifdef LISP_FLOAT_TYPE
1908 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1909 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1911 if (FLOATP (num1
) || FLOATP (num2
))
1914 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1915 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1918 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1919 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1920 #endif /* LISP_FLOAT_TYPE */
1925 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1930 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1935 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1940 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1945 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1950 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1959 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1960 "Return t if two args, both numbers or markers, are equal.")
1962 register Lisp_Object num1
, num2
;
1964 return arithcompare (num1
, num2
, equal
);
1967 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1968 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1970 register Lisp_Object num1
, num2
;
1972 return arithcompare (num1
, num2
, less
);
1975 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1976 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1978 register Lisp_Object num1
, num2
;
1980 return arithcompare (num1
, num2
, grtr
);
1983 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1984 "Return t if first arg is less than or equal to second arg.\n\
1985 Both must be numbers or markers.")
1987 register Lisp_Object num1
, num2
;
1989 return arithcompare (num1
, num2
, less_or_equal
);
1992 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1993 "Return t if first arg is greater than or equal to second arg.\n\
1994 Both must be numbers or markers.")
1996 register Lisp_Object num1
, num2
;
1998 return arithcompare (num1
, num2
, grtr_or_equal
);
2001 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2002 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
2004 register Lisp_Object num1
, num2
;
2006 return arithcompare (num1
, num2
, notequal
);
2009 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2011 register Lisp_Object number
;
2013 #ifdef LISP_FLOAT_TYPE
2014 CHECK_NUMBER_OR_FLOAT (number
, 0);
2016 if (FLOATP (number
))
2018 if (XFLOAT_DATA (number
) == 0.0)
2023 CHECK_NUMBER (number
, 0);
2024 #endif /* LISP_FLOAT_TYPE */
2031 /* Convert between long values and pairs of Lisp integers. */
2037 unsigned int top
= i
>> 16;
2038 unsigned int bot
= i
& 0xFFFF;
2040 return make_number (bot
);
2041 if (top
== (unsigned long)-1 >> 16)
2042 return Fcons (make_number (-1), make_number (bot
));
2043 return Fcons (make_number (top
), make_number (bot
));
2050 Lisp_Object top
, bot
;
2057 return ((XINT (top
) << 16) | XINT (bot
));
2060 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2061 "Convert NUMBER to a string by printing it in decimal.\n\
2062 Uses a minus sign if negative.\n\
2063 NUMBER may be an integer or a floating point number.")
2067 char buffer
[VALBITS
];
2069 #ifndef LISP_FLOAT_TYPE
2070 CHECK_NUMBER (number
, 0);
2072 CHECK_NUMBER_OR_FLOAT (number
, 0);
2074 if (FLOATP (number
))
2076 char pigbuf
[350]; /* see comments in float_to_string */
2078 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2079 return build_string (pigbuf
);
2081 #endif /* LISP_FLOAT_TYPE */
2083 if (sizeof (int) == sizeof (EMACS_INT
))
2084 sprintf (buffer
, "%d", XINT (number
));
2085 else if (sizeof (long) == sizeof (EMACS_INT
))
2086 sprintf (buffer
, "%ld", (long) XINT (number
));
2089 return build_string (buffer
);
2093 digit_to_number (character
, base
)
2094 int character
, base
;
2098 if (character
>= '0' && character
<= '9')
2099 digit
= character
- '0';
2100 else if (character
>= 'a' && character
<= 'z')
2101 digit
= character
- 'a' + 10;
2102 else if (character
>= 'A' && character
<= 'Z')
2103 digit
= character
- 'A' + 10;
2113 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2114 "Convert STRING to a number by parsing it as a decimal number.\n\
2115 This parses both integers and floating point numbers.\n\
2116 It ignores leading spaces and tabs.\n\
2118 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2119 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2120 If the base used is not 10, floating point is not recognized.")
2122 register Lisp_Object string
, base
;
2124 register unsigned char *p
;
2125 register int b
, v
= 0;
2128 CHECK_STRING (string
, 0);
2134 CHECK_NUMBER (base
, 1);
2136 if (b
< 2 || b
> 16)
2137 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2140 p
= XSTRING (string
)->data
;
2142 /* Skip any whitespace at the front of the number. Some versions of
2143 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2144 while (*p
== ' ' || *p
== '\t')
2155 #ifdef LISP_FLOAT_TYPE
2156 if (isfloat_string (p
) && b
== 10)
2157 return make_float (negative
* atof (p
));
2158 #endif /* LISP_FLOAT_TYPE */
2162 int digit
= digit_to_number (*p
++, b
);
2168 return make_number (negative
* v
);
2173 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2175 extern Lisp_Object
float_arith_driver ();
2176 extern Lisp_Object
fmod_float ();
2179 arith_driver (code
, nargs
, args
)
2182 register Lisp_Object
*args
;
2184 register Lisp_Object val
;
2185 register int argnum
;
2186 register EMACS_INT accum
;
2187 register EMACS_INT next
;
2189 switch (SWITCH_ENUM_CAST (code
))
2202 for (argnum
= 0; argnum
< nargs
; argnum
++)
2204 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2205 #ifdef LISP_FLOAT_TYPE
2206 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2208 if (FLOATP (val
)) /* time to do serious math */
2209 return (float_arith_driver ((double) accum
, argnum
, code
,
2212 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2213 #endif /* LISP_FLOAT_TYPE */
2214 args
[argnum
] = val
; /* runs into a compiler bug. */
2215 next
= XINT (args
[argnum
]);
2216 switch (SWITCH_ENUM_CAST (code
))
2218 case Aadd
: accum
+= next
; break;
2220 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2222 case Amult
: accum
*= next
; break;
2224 if (!argnum
) accum
= next
;
2228 Fsignal (Qarith_error
, Qnil
);
2232 case Alogand
: accum
&= next
; break;
2233 case Alogior
: accum
|= next
; break;
2234 case Alogxor
: accum
^= next
; break;
2235 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2236 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2240 XSETINT (val
, accum
);
2245 #define isnan(x) ((x) != (x))
2247 #ifdef LISP_FLOAT_TYPE
2250 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2252 register int argnum
;
2255 register Lisp_Object
*args
;
2257 register Lisp_Object val
;
2260 for (; argnum
< nargs
; argnum
++)
2262 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2263 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2267 next
= XFLOAT_DATA (val
);
2271 args
[argnum
] = val
; /* runs into a compiler bug. */
2272 next
= XINT (args
[argnum
]);
2274 switch (SWITCH_ENUM_CAST (code
))
2280 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2290 if (! IEEE_FLOATING_POINT
&& next
== 0)
2291 Fsignal (Qarith_error
, Qnil
);
2298 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2300 if (!argnum
|| isnan (next
) || next
> accum
)
2304 if (!argnum
|| isnan (next
) || next
< accum
)
2310 return make_float (accum
);
2312 #endif /* LISP_FLOAT_TYPE */
2314 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2315 "Return sum of any number of arguments, which are numbers or markers.")
2320 return arith_driver (Aadd
, nargs
, args
);
2323 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2324 "Negate number or subtract numbers or markers.\n\
2325 With one arg, negates it. With more than one arg,\n\
2326 subtracts all but the first from the first.")
2331 return arith_driver (Asub
, nargs
, args
);
2334 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2335 "Returns product of any number of arguments, which are numbers or markers.")
2340 return arith_driver (Amult
, nargs
, args
);
2343 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2344 "Returns first argument divided by all the remaining arguments.\n\
2345 The arguments must be numbers or markers.")
2350 return arith_driver (Adiv
, nargs
, args
);
2353 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2354 "Returns remainder of X divided by Y.\n\
2355 Both must be integers or markers.")
2357 register Lisp_Object x
, y
;
2361 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2362 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2364 if (XFASTINT (y
) == 0)
2365 Fsignal (Qarith_error
, Qnil
);
2367 XSETINT (val
, XINT (x
) % XINT (y
));
2381 /* If the magnitude of the result exceeds that of the divisor, or
2382 the sign of the result does not agree with that of the dividend,
2383 iterate with the reduced value. This does not yield a
2384 particularly accurate result, but at least it will be in the
2385 range promised by fmod. */
2387 r
-= f2
* floor (r
/ f2
);
2388 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2392 #endif /* ! HAVE_FMOD */
2394 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2395 "Returns X modulo Y.\n\
2396 The result falls between zero (inclusive) and Y (exclusive).\n\
2397 Both X and Y must be numbers or markers.")
2399 register Lisp_Object x
, y
;
2404 #ifdef LISP_FLOAT_TYPE
2405 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2406 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2408 if (FLOATP (x
) || FLOATP (y
))
2409 return fmod_float (x
, y
);
2411 #else /* not LISP_FLOAT_TYPE */
2412 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2413 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2414 #endif /* not LISP_FLOAT_TYPE */
2420 Fsignal (Qarith_error
, Qnil
);
2424 /* If the "remainder" comes out with the wrong sign, fix it. */
2425 if (i2
< 0 ? i1
> 0 : i1
< 0)
2432 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2433 "Return largest of all the arguments (which must be numbers or markers).\n\
2434 The value is always a number; markers are converted to numbers.")
2439 return arith_driver (Amax
, nargs
, args
);
2442 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2443 "Return smallest of all the arguments (which must be numbers or markers).\n\
2444 The value is always a number; markers are converted to numbers.")
2449 return arith_driver (Amin
, nargs
, args
);
2452 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2453 "Return bitwise-and of all the arguments.\n\
2454 Arguments may be integers, or markers converted to integers.")
2459 return arith_driver (Alogand
, nargs
, args
);
2462 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2463 "Return bitwise-or of all the arguments.\n\
2464 Arguments may be integers, or markers converted to integers.")
2469 return arith_driver (Alogior
, nargs
, args
);
2472 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2473 "Return bitwise-exclusive-or of all the arguments.\n\
2474 Arguments may be integers, or markers converted to integers.")
2479 return arith_driver (Alogxor
, nargs
, args
);
2482 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2483 "Return VALUE with its bits shifted left by COUNT.\n\
2484 If COUNT is negative, shifting is actually to the right.\n\
2485 In this case, the sign bit is duplicated.")
2487 register Lisp_Object value
, count
;
2489 register Lisp_Object val
;
2491 CHECK_NUMBER (value
, 0);
2492 CHECK_NUMBER (count
, 1);
2494 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2496 else if (XINT (count
) > 0)
2497 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2498 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2499 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2501 XSETINT (val
, XINT (value
) >> -XINT (count
));
2505 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2506 "Return VALUE with its bits shifted left by COUNT.\n\
2507 If COUNT is negative, shifting is actually to the right.\n\
2508 In this case, zeros are shifted in on the left.")
2510 register Lisp_Object value
, count
;
2512 register Lisp_Object val
;
2514 CHECK_NUMBER (value
, 0);
2515 CHECK_NUMBER (count
, 1);
2517 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2519 else if (XINT (count
) > 0)
2520 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2521 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2524 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2528 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2529 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2530 Markers are converted to integers.")
2532 register Lisp_Object number
;
2534 #ifdef LISP_FLOAT_TYPE
2535 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2537 if (FLOATP (number
))
2538 return (make_float (1.0 + XFLOAT_DATA (number
)));
2540 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2541 #endif /* LISP_FLOAT_TYPE */
2543 XSETINT (number
, XINT (number
) + 1);
2547 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2548 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2549 Markers are converted to integers.")
2551 register Lisp_Object number
;
2553 #ifdef LISP_FLOAT_TYPE
2554 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2556 if (FLOATP (number
))
2557 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2559 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2560 #endif /* LISP_FLOAT_TYPE */
2562 XSETINT (number
, XINT (number
) - 1);
2566 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2567 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2569 register Lisp_Object number
;
2571 CHECK_NUMBER (number
, 0);
2572 XSETINT (number
, ~XINT (number
));
2579 Lisp_Object error_tail
, arith_tail
;
2581 Qquote
= intern ("quote");
2582 Qlambda
= intern ("lambda");
2583 Qsubr
= intern ("subr");
2584 Qerror_conditions
= intern ("error-conditions");
2585 Qerror_message
= intern ("error-message");
2586 Qtop_level
= intern ("top-level");
2588 Qerror
= intern ("error");
2589 Qquit
= intern ("quit");
2590 Qwrong_type_argument
= intern ("wrong-type-argument");
2591 Qargs_out_of_range
= intern ("args-out-of-range");
2592 Qvoid_function
= intern ("void-function");
2593 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2594 Qvoid_variable
= intern ("void-variable");
2595 Qsetting_constant
= intern ("setting-constant");
2596 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2598 Qinvalid_function
= intern ("invalid-function");
2599 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2600 Qno_catch
= intern ("no-catch");
2601 Qend_of_file
= intern ("end-of-file");
2602 Qarith_error
= intern ("arith-error");
2603 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2604 Qend_of_buffer
= intern ("end-of-buffer");
2605 Qbuffer_read_only
= intern ("buffer-read-only");
2606 Qtext_read_only
= intern ("text-read-only");
2607 Qmark_inactive
= intern ("mark-inactive");
2609 Qlistp
= intern ("listp");
2610 Qconsp
= intern ("consp");
2611 Qsymbolp
= intern ("symbolp");
2612 Qkeywordp
= intern ("keywordp");
2613 Qintegerp
= intern ("integerp");
2614 Qnatnump
= intern ("natnump");
2615 Qwholenump
= intern ("wholenump");
2616 Qstringp
= intern ("stringp");
2617 Qarrayp
= intern ("arrayp");
2618 Qsequencep
= intern ("sequencep");
2619 Qbufferp
= intern ("bufferp");
2620 Qvectorp
= intern ("vectorp");
2621 Qchar_or_string_p
= intern ("char-or-string-p");
2622 Qmarkerp
= intern ("markerp");
2623 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2624 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2625 Qboundp
= intern ("boundp");
2626 Qfboundp
= intern ("fboundp");
2628 #ifdef LISP_FLOAT_TYPE
2629 Qfloatp
= intern ("floatp");
2630 Qnumberp
= intern ("numberp");
2631 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2632 #endif /* LISP_FLOAT_TYPE */
2634 Qchar_table_p
= intern ("char-table-p");
2635 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2637 Qcdr
= intern ("cdr");
2639 /* Handle automatic advice activation */
2640 Qad_advice_info
= intern ("ad-advice-info");
2641 Qad_activate_internal
= intern ("ad-activate-internal");
2643 error_tail
= Fcons (Qerror
, Qnil
);
2645 /* ERROR is used as a signaler for random errors for which nothing else is right */
2647 Fput (Qerror
, Qerror_conditions
,
2649 Fput (Qerror
, Qerror_message
,
2650 build_string ("error"));
2652 Fput (Qquit
, Qerror_conditions
,
2653 Fcons (Qquit
, Qnil
));
2654 Fput (Qquit
, Qerror_message
,
2655 build_string ("Quit"));
2657 Fput (Qwrong_type_argument
, Qerror_conditions
,
2658 Fcons (Qwrong_type_argument
, error_tail
));
2659 Fput (Qwrong_type_argument
, Qerror_message
,
2660 build_string ("Wrong type argument"));
2662 Fput (Qargs_out_of_range
, Qerror_conditions
,
2663 Fcons (Qargs_out_of_range
, error_tail
));
2664 Fput (Qargs_out_of_range
, Qerror_message
,
2665 build_string ("Args out of range"));
2667 Fput (Qvoid_function
, Qerror_conditions
,
2668 Fcons (Qvoid_function
, error_tail
));
2669 Fput (Qvoid_function
, Qerror_message
,
2670 build_string ("Symbol's function definition is void"));
2672 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2673 Fcons (Qcyclic_function_indirection
, error_tail
));
2674 Fput (Qcyclic_function_indirection
, Qerror_message
,
2675 build_string ("Symbol's chain of function indirections contains a loop"));
2677 Fput (Qvoid_variable
, Qerror_conditions
,
2678 Fcons (Qvoid_variable
, error_tail
));
2679 Fput (Qvoid_variable
, Qerror_message
,
2680 build_string ("Symbol's value as variable is void"));
2682 Fput (Qsetting_constant
, Qerror_conditions
,
2683 Fcons (Qsetting_constant
, error_tail
));
2684 Fput (Qsetting_constant
, Qerror_message
,
2685 build_string ("Attempt to set a constant symbol"));
2687 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2688 Fcons (Qinvalid_read_syntax
, error_tail
));
2689 Fput (Qinvalid_read_syntax
, Qerror_message
,
2690 build_string ("Invalid read syntax"));
2692 Fput (Qinvalid_function
, Qerror_conditions
,
2693 Fcons (Qinvalid_function
, error_tail
));
2694 Fput (Qinvalid_function
, Qerror_message
,
2695 build_string ("Invalid function"));
2697 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2698 Fcons (Qwrong_number_of_arguments
, error_tail
));
2699 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2700 build_string ("Wrong number of arguments"));
2702 Fput (Qno_catch
, Qerror_conditions
,
2703 Fcons (Qno_catch
, error_tail
));
2704 Fput (Qno_catch
, Qerror_message
,
2705 build_string ("No catch for tag"));
2707 Fput (Qend_of_file
, Qerror_conditions
,
2708 Fcons (Qend_of_file
, error_tail
));
2709 Fput (Qend_of_file
, Qerror_message
,
2710 build_string ("End of file during parsing"));
2712 arith_tail
= Fcons (Qarith_error
, error_tail
);
2713 Fput (Qarith_error
, Qerror_conditions
,
2715 Fput (Qarith_error
, Qerror_message
,
2716 build_string ("Arithmetic error"));
2718 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2719 Fcons (Qbeginning_of_buffer
, error_tail
));
2720 Fput (Qbeginning_of_buffer
, Qerror_message
,
2721 build_string ("Beginning of buffer"));
2723 Fput (Qend_of_buffer
, Qerror_conditions
,
2724 Fcons (Qend_of_buffer
, error_tail
));
2725 Fput (Qend_of_buffer
, Qerror_message
,
2726 build_string ("End of buffer"));
2728 Fput (Qbuffer_read_only
, Qerror_conditions
,
2729 Fcons (Qbuffer_read_only
, error_tail
));
2730 Fput (Qbuffer_read_only
, Qerror_message
,
2731 build_string ("Buffer is read-only"));
2733 Fput (Qtext_read_only
, Qerror_conditions
,
2734 Fcons (Qtext_read_only
, error_tail
));
2735 Fput (Qtext_read_only
, Qerror_message
,
2736 build_string ("Text is read-only"));
2738 #ifdef LISP_FLOAT_TYPE
2739 Qrange_error
= intern ("range-error");
2740 Qdomain_error
= intern ("domain-error");
2741 Qsingularity_error
= intern ("singularity-error");
2742 Qoverflow_error
= intern ("overflow-error");
2743 Qunderflow_error
= intern ("underflow-error");
2745 Fput (Qdomain_error
, Qerror_conditions
,
2746 Fcons (Qdomain_error
, arith_tail
));
2747 Fput (Qdomain_error
, Qerror_message
,
2748 build_string ("Arithmetic domain error"));
2750 Fput (Qrange_error
, Qerror_conditions
,
2751 Fcons (Qrange_error
, arith_tail
));
2752 Fput (Qrange_error
, Qerror_message
,
2753 build_string ("Arithmetic range error"));
2755 Fput (Qsingularity_error
, Qerror_conditions
,
2756 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2757 Fput (Qsingularity_error
, Qerror_message
,
2758 build_string ("Arithmetic singularity error"));
2760 Fput (Qoverflow_error
, Qerror_conditions
,
2761 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2762 Fput (Qoverflow_error
, Qerror_message
,
2763 build_string ("Arithmetic overflow error"));
2765 Fput (Qunderflow_error
, Qerror_conditions
,
2766 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2767 Fput (Qunderflow_error
, Qerror_message
,
2768 build_string ("Arithmetic underflow error"));
2770 staticpro (&Qrange_error
);
2771 staticpro (&Qdomain_error
);
2772 staticpro (&Qsingularity_error
);
2773 staticpro (&Qoverflow_error
);
2774 staticpro (&Qunderflow_error
);
2775 #endif /* LISP_FLOAT_TYPE */
2779 staticpro (&Qquote
);
2780 staticpro (&Qlambda
);
2782 staticpro (&Qunbound
);
2783 staticpro (&Qerror_conditions
);
2784 staticpro (&Qerror_message
);
2785 staticpro (&Qtop_level
);
2787 staticpro (&Qerror
);
2789 staticpro (&Qwrong_type_argument
);
2790 staticpro (&Qargs_out_of_range
);
2791 staticpro (&Qvoid_function
);
2792 staticpro (&Qcyclic_function_indirection
);
2793 staticpro (&Qvoid_variable
);
2794 staticpro (&Qsetting_constant
);
2795 staticpro (&Qinvalid_read_syntax
);
2796 staticpro (&Qwrong_number_of_arguments
);
2797 staticpro (&Qinvalid_function
);
2798 staticpro (&Qno_catch
);
2799 staticpro (&Qend_of_file
);
2800 staticpro (&Qarith_error
);
2801 staticpro (&Qbeginning_of_buffer
);
2802 staticpro (&Qend_of_buffer
);
2803 staticpro (&Qbuffer_read_only
);
2804 staticpro (&Qtext_read_only
);
2805 staticpro (&Qmark_inactive
);
2807 staticpro (&Qlistp
);
2808 staticpro (&Qconsp
);
2809 staticpro (&Qsymbolp
);
2810 staticpro (&Qkeywordp
);
2811 staticpro (&Qintegerp
);
2812 staticpro (&Qnatnump
);
2813 staticpro (&Qwholenump
);
2814 staticpro (&Qstringp
);
2815 staticpro (&Qarrayp
);
2816 staticpro (&Qsequencep
);
2817 staticpro (&Qbufferp
);
2818 staticpro (&Qvectorp
);
2819 staticpro (&Qchar_or_string_p
);
2820 staticpro (&Qmarkerp
);
2821 staticpro (&Qbuffer_or_string_p
);
2822 staticpro (&Qinteger_or_marker_p
);
2823 #ifdef LISP_FLOAT_TYPE
2824 staticpro (&Qfloatp
);
2825 staticpro (&Qnumberp
);
2826 staticpro (&Qnumber_or_marker_p
);
2827 #endif /* LISP_FLOAT_TYPE */
2828 staticpro (&Qchar_table_p
);
2829 staticpro (&Qvector_or_char_table_p
);
2831 staticpro (&Qboundp
);
2832 staticpro (&Qfboundp
);
2834 staticpro (&Qad_advice_info
);
2835 staticpro (&Qad_activate_internal
);
2837 /* Types that type-of returns. */
2838 Qinteger
= intern ("integer");
2839 Qsymbol
= intern ("symbol");
2840 Qstring
= intern ("string");
2841 Qcons
= intern ("cons");
2842 Qmarker
= intern ("marker");
2843 Qoverlay
= intern ("overlay");
2844 Qfloat
= intern ("float");
2845 Qwindow_configuration
= intern ("window-configuration");
2846 Qprocess
= intern ("process");
2847 Qwindow
= intern ("window");
2848 /* Qsubr = intern ("subr"); */
2849 Qcompiled_function
= intern ("compiled-function");
2850 Qbuffer
= intern ("buffer");
2851 Qframe
= intern ("frame");
2852 Qvector
= intern ("vector");
2853 Qchar_table
= intern ("char-table");
2854 Qbool_vector
= intern ("bool-vector");
2855 Qhash_table
= intern ("hash-table");
2857 staticpro (&Qinteger
);
2858 staticpro (&Qsymbol
);
2859 staticpro (&Qstring
);
2861 staticpro (&Qmarker
);
2862 staticpro (&Qoverlay
);
2863 staticpro (&Qfloat
);
2864 staticpro (&Qwindow_configuration
);
2865 staticpro (&Qprocess
);
2866 staticpro (&Qwindow
);
2867 /* staticpro (&Qsubr); */
2868 staticpro (&Qcompiled_function
);
2869 staticpro (&Qbuffer
);
2870 staticpro (&Qframe
);
2871 staticpro (&Qvector
);
2872 staticpro (&Qchar_table
);
2873 staticpro (&Qbool_vector
);
2874 staticpro (&Qhash_table
);
2876 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2877 "Non-nil means it is an error to set a keyword symbol.\n\
2878 A keyword symbol is a symbol whose name starts with a colon (`:').");
2879 keyword_symbols_constant_flag
= 1;
2883 defsubr (&Stype_of
);
2888 defsubr (&Sintegerp
);
2889 defsubr (&Sinteger_or_marker_p
);
2890 defsubr (&Snumberp
);
2891 defsubr (&Snumber_or_marker_p
);
2892 #ifdef LISP_FLOAT_TYPE
2894 #endif /* LISP_FLOAT_TYPE */
2895 defsubr (&Snatnump
);
2896 defsubr (&Ssymbolp
);
2897 defsubr (&Skeywordp
);
2898 defsubr (&Sstringp
);
2899 defsubr (&Smultibyte_string_p
);
2900 defsubr (&Svectorp
);
2901 defsubr (&Schar_table_p
);
2902 defsubr (&Svector_or_char_table_p
);
2903 defsubr (&Sbool_vector_p
);
2905 defsubr (&Ssequencep
);
2906 defsubr (&Sbufferp
);
2907 defsubr (&Smarkerp
);
2909 defsubr (&Sbyte_code_function_p
);
2910 defsubr (&Schar_or_string_p
);
2913 defsubr (&Scar_safe
);
2914 defsubr (&Scdr_safe
);
2917 defsubr (&Ssymbol_function
);
2918 defsubr (&Sindirect_function
);
2919 defsubr (&Ssymbol_plist
);
2920 defsubr (&Ssymbol_name
);
2921 defsubr (&Smakunbound
);
2922 defsubr (&Sfmakunbound
);
2924 defsubr (&Sfboundp
);
2926 defsubr (&Sdefalias
);
2927 defsubr (&Ssetplist
);
2928 defsubr (&Ssymbol_value
);
2930 defsubr (&Sdefault_boundp
);
2931 defsubr (&Sdefault_value
);
2932 defsubr (&Sset_default
);
2933 defsubr (&Ssetq_default
);
2934 defsubr (&Smake_variable_buffer_local
);
2935 defsubr (&Smake_local_variable
);
2936 defsubr (&Skill_local_variable
);
2937 defsubr (&Smake_variable_frame_local
);
2938 defsubr (&Slocal_variable_p
);
2939 defsubr (&Slocal_variable_if_set_p
);
2942 defsubr (&Snumber_to_string
);
2943 defsubr (&Sstring_to_number
);
2944 defsubr (&Seqlsign
);
2968 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2975 #if defined(USG) && !defined(POSIX_SIGNALS)
2976 /* USG systems forget handlers when they are used;
2977 must reestablish each time */
2978 signal (signo
, arith_error
);
2981 /* VMS systems are like USG. */
2982 signal (signo
, arith_error
);
2986 #else /* not BSD4_1 */
2987 sigsetmask (SIGEMPTYMASK
);
2988 #endif /* not BSD4_1 */
2990 Fsignal (Qarith_error
, Qnil
);
2996 /* Don't do this if just dumping out.
2997 We don't want to call `signal' in this case
2998 so that we don't have trouble with dumping
2999 signal-delivering routines in an inconsistent state. */
3003 #endif /* CANNOT_DUMP */
3004 signal (SIGFPE
, arith_error
);
3007 signal (SIGEMT
, arith_error
);