1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97, 1998 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
44 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
45 #ifndef IEEE_FLOATING_POINT
46 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
47 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
48 #define IEEE_FLOATING_POINT 1
50 #define IEEE_FLOATING_POINT 0
54 /* Work around a problem that happens because math.h on hpux 7
55 defines two static variables--which, in Emacs, are not really static,
56 because `static' is defined as nothing. The problem is that they are
57 here, in floatfns.c, and in lread.c.
58 These macros prevent the name conflict. */
59 #if defined (HPUX) && !defined (HPUX8)
60 #define _MAXLDBL data_c_maxldbl
61 #define _NMAXLDBL data_c_nmaxldbl
65 #endif /* LISP_FLOAT_TYPE */
68 extern double atof ();
71 /* Nonzero means it is an error to set a symbol whose name starts with
73 int keyword_symbols_constant_flag
;
75 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
76 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
77 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
78 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
79 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
80 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
81 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
82 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_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
;
87 Lisp_Object Qboundp
, Qfboundp
;
88 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
91 Lisp_Object Qad_advice_info
, Qad_activate
;
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
;
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
))
253 #ifdef LISP_FLOAT_TYPE
263 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
272 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
273 "Return t if OBJECT is not a cons cell. This includes nil.")
282 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
283 "Return t if OBJECT is a list. This includes nil.")
287 if (CONSP (object
) || NILP (object
))
292 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
293 "Return t if OBJECT is not a list. Lists include nil.")
297 if (CONSP (object
) || NILP (object
))
302 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
303 "Return t if OBJECT is a symbol.")
307 if (SYMBOLP (object
))
312 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
313 "Return t if OBJECT is a vector.")
317 if (VECTORP (object
))
322 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
323 "Return t if OBJECT is a string.")
327 if (STRINGP (object
))
332 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
333 1, 1, 0, "Return t if OBJECT is a multibyte string.")
337 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
342 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
343 "Return t if OBJECT is a char-table.")
347 if (CHAR_TABLE_P (object
))
352 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
353 Svector_or_char_table_p
, 1, 1, 0,
354 "Return t if OBJECT is a char-table or vector.")
358 if (VECTORP (object
) || CHAR_TABLE_P (object
))
363 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
367 if (BOOL_VECTOR_P (object
))
372 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
376 if (VECTORP (object
) || STRINGP (object
)
377 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
382 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
383 "Return t if OBJECT is a sequence (list or array).")
385 register Lisp_Object object
;
387 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
388 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
393 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
397 if (BUFFERP (object
))
402 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
406 if (MARKERP (object
))
411 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
420 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
421 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
425 if (COMPILEDP (object
))
430 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
431 "Return t if OBJECT is a character (an integer) or a string.")
433 register Lisp_Object object
;
435 if (INTEGERP (object
) || STRINGP (object
))
440 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
444 if (INTEGERP (object
))
449 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
450 "Return t if OBJECT is an integer or a marker (editor pointer).")
452 register Lisp_Object object
;
454 if (MARKERP (object
) || INTEGERP (object
))
459 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
460 "Return t if OBJECT is a nonnegative integer.")
464 if (NATNUMP (object
))
469 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
470 "Return t if OBJECT is a number (floating point or integer).")
474 if (NUMBERP (object
))
480 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
481 Snumber_or_marker_p
, 1, 1, 0,
482 "Return t if OBJECT is a number or a marker.")
486 if (NUMBERP (object
) || MARKERP (object
))
491 #ifdef LISP_FLOAT_TYPE
492 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
493 "Return t if OBJECT is a floating point number.")
501 #endif /* LISP_FLOAT_TYPE */
503 /* Extract and set components of lists */
505 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
506 "Return the car of LIST. If arg is nil, return nil.\n\
507 Error if arg is not nil and not a cons cell. See also `car-safe'.")
509 register Lisp_Object list
;
514 return XCONS (list
)->car
;
515 else if (EQ (list
, Qnil
))
518 list
= wrong_type_argument (Qlistp
, list
);
522 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
523 "Return the car of OBJECT if it is a cons cell, or else nil.")
528 return XCONS (object
)->car
;
533 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
534 "Return the cdr of LIST. If arg is nil, return nil.\n\
535 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
538 register Lisp_Object list
;
543 return XCONS (list
)->cdr
;
544 else if (EQ (list
, Qnil
))
547 list
= wrong_type_argument (Qlistp
, list
);
551 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
552 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
557 return XCONS (object
)->cdr
;
562 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
563 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
565 register Lisp_Object cell
, newcar
;
568 cell
= wrong_type_argument (Qconsp
, cell
);
571 XCONS (cell
)->car
= newcar
;
575 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
576 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
578 register Lisp_Object cell
, newcdr
;
581 cell
= wrong_type_argument (Qconsp
, cell
);
584 XCONS (cell
)->cdr
= newcdr
;
588 /* Extract and set components of symbols */
590 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
592 register Lisp_Object symbol
;
594 Lisp_Object valcontents
;
595 CHECK_SYMBOL (symbol
, 0);
597 valcontents
= XSYMBOL (symbol
)->value
;
599 if (BUFFER_LOCAL_VALUEP (valcontents
)
600 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
601 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
603 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
606 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
608 register Lisp_Object symbol
;
610 CHECK_SYMBOL (symbol
, 0);
611 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
614 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
616 register Lisp_Object symbol
;
618 CHECK_SYMBOL (symbol
, 0);
619 if (NILP (symbol
) || EQ (symbol
, Qt
)
620 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
621 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
622 && keyword_symbols_constant_flag
))
623 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
624 Fset (symbol
, Qunbound
);
628 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
630 register Lisp_Object symbol
;
632 CHECK_SYMBOL (symbol
, 0);
633 if (NILP (symbol
) || EQ (symbol
, Qt
))
634 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
635 XSYMBOL (symbol
)->function
= Qunbound
;
639 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
640 "Return SYMBOL's function definition. Error if that is void.")
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
, 0);
645 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
646 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
647 return XSYMBOL (symbol
)->function
;
650 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
652 register Lisp_Object symbol
;
654 CHECK_SYMBOL (symbol
, 0);
655 return XSYMBOL (symbol
)->plist
;
658 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
660 register Lisp_Object symbol
;
662 register Lisp_Object name
;
664 CHECK_SYMBOL (symbol
, 0);
665 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
669 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
670 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
672 register Lisp_Object symbol
, definition
;
674 CHECK_SYMBOL (symbol
, 0);
675 if (NILP (symbol
) || EQ (symbol
, Qt
))
676 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
677 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
678 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
680 XSYMBOL (symbol
)->function
= definition
;
681 /* Handle automatic advice activation */
682 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
684 call2 (Qad_activate
, symbol
, Qnil
);
685 definition
= XSYMBOL (symbol
)->function
;
690 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
691 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
692 Associates the function with the current load file, if any.")
694 register Lisp_Object symbol
, definition
;
696 definition
= Ffset (symbol
, definition
);
697 LOADHIST_ATTACH (symbol
);
701 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
702 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
704 register Lisp_Object symbol
, newplist
;
706 CHECK_SYMBOL (symbol
, 0);
707 XSYMBOL (symbol
)->plist
= newplist
;
712 /* Getting and setting values of symbols */
714 /* Given the raw contents of a symbol value cell,
715 return the Lisp value of the symbol.
716 This does not handle buffer-local variables; use
717 swap_in_symval_forwarding for that. */
720 do_symval_forwarding (valcontents
)
721 register Lisp_Object valcontents
;
723 register Lisp_Object val
;
725 if (MISCP (valcontents
))
726 switch (XMISCTYPE (valcontents
))
728 case Lisp_Misc_Intfwd
:
729 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
732 case Lisp_Misc_Boolfwd
:
733 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
735 case Lisp_Misc_Objfwd
:
736 return *XOBJFWD (valcontents
)->objvar
;
738 case Lisp_Misc_Buffer_Objfwd
:
739 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
740 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
742 case Lisp_Misc_Kboard_Objfwd
:
743 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
744 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
749 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
750 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
751 buffer-independent contents of the value cell: forwarded just one
752 step past the buffer-localness. */
755 store_symval_forwarding (symbol
, valcontents
, newval
)
757 register Lisp_Object valcontents
, newval
;
759 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
762 switch (XMISCTYPE (valcontents
))
764 case Lisp_Misc_Intfwd
:
765 CHECK_NUMBER (newval
, 1);
766 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
767 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
768 error ("Value out of range for variable `%s'",
769 XSYMBOL (symbol
)->name
->data
);
772 case Lisp_Misc_Boolfwd
:
773 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
776 case Lisp_Misc_Objfwd
:
777 *XOBJFWD (valcontents
)->objvar
= newval
;
780 case Lisp_Misc_Buffer_Objfwd
:
782 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
785 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
786 if (XINT (type
) == -1)
787 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
789 if (! NILP (type
) && ! NILP (newval
)
790 && XTYPE (newval
) != XINT (type
))
791 buffer_slot_type_mismatch (offset
);
793 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
797 case Lisp_Misc_Kboard_Objfwd
:
798 (*(Lisp_Object
*)((char *)current_kboard
799 + XKBOARD_OBJFWD (valcontents
)->offset
))
810 valcontents
= XSYMBOL (symbol
)->value
;
811 if (BUFFER_LOCAL_VALUEP (valcontents
)
812 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
813 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
815 XSYMBOL (symbol
)->value
= newval
;
819 /* Set up the buffer-local symbol SYMBOL for validity in the current
820 buffer. VALCONTENTS is the contents of its value cell.
821 Return the value forwarded one step past the buffer-local indicator. */
824 swap_in_symval_forwarding (symbol
, valcontents
)
825 Lisp_Object symbol
, valcontents
;
827 /* valcontents is a pointer to a struct resembling the cons
828 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
830 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
831 local_var_alist, that being the element whose car is this
832 variable. Or it can be a pointer to the
833 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
834 an element in its alist for this variable.
836 If the current buffer is not BUFFER, we store the current
837 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
838 appropriate alist element for the buffer now current and set up
839 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
840 element, and store into BUFFER.
842 Note that REALVALUE can be a forwarding pointer. */
844 register Lisp_Object tem1
;
845 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
847 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
)
848 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
850 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
852 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
853 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
854 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
855 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
858 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
859 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
861 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
863 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
866 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
868 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
= tem1
;
869 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
870 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
871 store_symval_forwarding (symbol
,
872 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
875 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
878 /* Find the value of a symbol, returning Qunbound if it's not bound.
879 This is helpful for code which just wants to get a variable's value
880 if it has one, without signaling an error.
881 Note that it must not be possible to quit
882 within this function. Great care is required for this. */
885 find_symbol_value (symbol
)
888 register Lisp_Object valcontents
, tem1
;
889 register Lisp_Object val
;
890 CHECK_SYMBOL (symbol
, 0);
891 valcontents
= XSYMBOL (symbol
)->value
;
893 if (BUFFER_LOCAL_VALUEP (valcontents
)
894 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
895 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
897 if (MISCP (valcontents
))
899 switch (XMISCTYPE (valcontents
))
901 case Lisp_Misc_Intfwd
:
902 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
905 case Lisp_Misc_Boolfwd
:
906 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
908 case Lisp_Misc_Objfwd
:
909 return *XOBJFWD (valcontents
)->objvar
;
911 case Lisp_Misc_Buffer_Objfwd
:
912 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
913 + (char *)current_buffer
);
915 case Lisp_Misc_Kboard_Objfwd
:
916 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
917 + (char *)current_kboard
);
924 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
925 "Return SYMBOL's value. Error if that is void.")
931 val
= find_symbol_value (symbol
);
932 if (EQ (val
, Qunbound
))
933 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
938 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
939 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
941 register Lisp_Object symbol
, newval
;
943 return set_internal (symbol
, newval
, 0);
946 /* Store the value NEWVAL into SYMBOL.
947 If BINDFLAG is zero, then if this symbol is supposed to become
948 local in every buffer where it is set, then we make it local.
949 If BINDFLAG is nonzero, we don't do that. */
952 set_internal (symbol
, newval
, bindflag
)
953 register Lisp_Object symbol
, newval
;
956 int voide
= EQ (newval
, Qunbound
);
958 register Lisp_Object valcontents
, tem1
, current_alist_element
;
960 CHECK_SYMBOL (symbol
, 0);
961 if (NILP (symbol
) || EQ (symbol
, Qt
)
962 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
963 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
964 && keyword_symbols_constant_flag
&& ! EQ (newval
, symbol
)))
965 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
966 valcontents
= XSYMBOL (symbol
)->value
;
968 if (BUFFER_OBJFWDP (valcontents
))
970 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
971 register int mask
= XINT (*((Lisp_Object
*)
972 (idx
+ (char *)&buffer_local_flags
)));
973 if (mask
> 0 && ! bindflag
)
974 current_buffer
->local_var_flags
|= mask
;
977 else if (BUFFER_LOCAL_VALUEP (valcontents
)
978 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
980 /* valcontents is actually a pointer to a struct resembling a cons,
981 with contents something like:
982 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
984 BUFFER is the last buffer for which this symbol's value was
987 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
988 local_var_alist, that being the element whose car is this
989 variable. Or it can be a pointer to the
990 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
991 have an element in its alist for this variable (that is, if
992 BUFFER sees the default value of this variable).
994 If we want to examine or set the value and BUFFER is current,
995 we just examine or set REALVALUE. If BUFFER is not current, we
996 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
997 then find the appropriate alist element for the buffer now
998 current and set up CURRENT-ALIST-ELEMENT. Then we set
999 REALVALUE out of that element, and store into BUFFER.
1001 If we are setting the variable and the current buffer does
1002 not have an alist entry for this variable, an alist entry is
1005 Note that REALVALUE can be a forwarding pointer. Each time
1006 it is examined or set, forwarding must be done. */
1008 /* What value are we caching right now? */
1009 current_alist_element
1010 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1012 /* If the current buffer is not the buffer whose binding is
1013 currently cached, or if it's a Lisp_Buffer_Local_Value and
1014 we're looking at the default value, the cache is invalid; we
1015 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
1016 if (current_buffer
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1017 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)
1018 || (BUFFER_LOCAL_VALUEP (valcontents
)
1019 && EQ (XCONS (current_alist_element
)->car
,
1020 current_alist_element
)))
1022 /* Write out the cached value for the old buffer; copy it
1023 back to its alist element. This works if the current
1024 buffer only sees the default value, too. */
1025 Fsetcdr (current_alist_element
,
1026 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1028 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1029 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1030 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1031 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1035 /* This buffer still sees the default value. */
1037 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1038 or if this is `let' rather than `set',
1039 make CURRENT-ALIST-ELEMENT point to itself,
1040 indicating that we're seeing the default value. */
1041 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1043 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1045 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1046 tem1
= Fassq (symbol
,
1047 XFRAME (selected_frame
)->param_alist
);
1050 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1052 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1054 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1055 give this buffer a new assoc for a local value and set
1056 CURRENT-ALIST-ELEMENT to point to that. */
1059 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1060 current_buffer
->local_var_alist
1061 = Fcons (tem1
, current_buffer
->local_var_alist
);
1065 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1066 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
1069 /* Set BUFFER and FRAME for binding now loaded. */
1070 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
,
1072 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1074 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1077 /* If storing void (making the symbol void), forward only through
1078 buffer-local indicator, not through Lisp_Objfwd, etc. */
1080 store_symval_forwarding (symbol
, Qnil
, newval
);
1082 store_symval_forwarding (symbol
, valcontents
, newval
);
1087 /* Access or set a buffer-local symbol's default value. */
1089 /* Return the default value of SYMBOL, but don't check for voidness.
1090 Return Qunbound if it is void. */
1093 default_value (symbol
)
1096 register Lisp_Object valcontents
;
1098 CHECK_SYMBOL (symbol
, 0);
1099 valcontents
= XSYMBOL (symbol
)->value
;
1101 /* For a built-in buffer-local variable, get the default value
1102 rather than letting do_symval_forwarding get the current value. */
1103 if (BUFFER_OBJFWDP (valcontents
))
1105 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1107 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1108 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1111 /* Handle user-created local variables. */
1112 if (BUFFER_LOCAL_VALUEP (valcontents
)
1113 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1115 /* If var is set up for a buffer that lacks a local value for it,
1116 the current value is nominally the default value.
1117 But the current value slot may be more up to date, since
1118 ordinary setq stores just that slot. So use that. */
1119 Lisp_Object current_alist_element
, alist_element_car
;
1120 current_alist_element
1121 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1122 alist_element_car
= XCONS (current_alist_element
)->car
;
1123 if (EQ (alist_element_car
, current_alist_element
))
1124 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1126 return XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1128 /* For other variables, get the current value. */
1129 return do_symval_forwarding (valcontents
);
1132 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1133 "Return t if SYMBOL has a non-void default value.\n\
1134 This is the value that is seen in buffers that do not have their own values\n\
1135 for this variable.")
1139 register Lisp_Object value
;
1141 value
= default_value (symbol
);
1142 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1145 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1146 "Return SYMBOL's default value.\n\
1147 This is the value that is seen in buffers that do not have their own values\n\
1148 for this variable. The default value is meaningful for variables with\n\
1149 local bindings in certain buffers.")
1153 register Lisp_Object value
;
1155 value
= default_value (symbol
);
1156 if (EQ (value
, Qunbound
))
1157 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1161 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1162 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1163 The default value is seen in buffers that do not have their own values\n\
1164 for this variable.")
1166 Lisp_Object symbol
, value
;
1168 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1170 CHECK_SYMBOL (symbol
, 0);
1171 valcontents
= XSYMBOL (symbol
)->value
;
1173 /* Handle variables like case-fold-search that have special slots
1174 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1176 if (BUFFER_OBJFWDP (valcontents
))
1178 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1179 register struct buffer
*b
;
1180 register int mask
= XINT (*((Lisp_Object
*)
1181 (idx
+ (char *)&buffer_local_flags
)));
1183 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1185 /* If this variable is not always local in all buffers,
1186 set it in the buffers that don't nominally have a local value. */
1189 for (b
= all_buffers
; b
; b
= b
->next
)
1190 if (!(b
->local_var_flags
& mask
))
1191 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1196 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1197 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1198 return Fset (symbol
, value
);
1200 /* Store new value into the DEFAULT-VALUE slot */
1201 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
= value
;
1203 /* If that slot is current, we must set the REALVALUE slot too */
1204 current_alist_element
1205 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1206 alist_element_buffer
= Fcar (current_alist_element
);
1207 if (EQ (alist_element_buffer
, current_alist_element
))
1208 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1214 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1215 "Set the default value of variable VAR to VALUE.\n\
1216 VAR, the variable name, is literal (not evaluated);\n\
1217 VALUE is an expression and it is evaluated.\n\
1218 The default value of a variable is seen in buffers\n\
1219 that do not have their own values for the variable.\n\
1221 More generally, you can use multiple variables and values, as in\n\
1222 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1223 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1224 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1229 register Lisp_Object args_left
;
1230 register Lisp_Object val
, symbol
;
1231 struct gcpro gcpro1
;
1241 val
= Feval (Fcar (Fcdr (args_left
)));
1242 symbol
= Fcar (args_left
);
1243 Fset_default (symbol
, val
);
1244 args_left
= Fcdr (Fcdr (args_left
));
1246 while (!NILP (args_left
));
1252 /* Lisp functions for creating and removing buffer-local variables. */
1254 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1255 1, 1, "vMake Variable Buffer Local: ",
1256 "Make VARIABLE have a separate value for each buffer.\n\
1257 At any time, the value for the current buffer is in effect.\n\
1258 There is also a default value which is seen in any buffer which has not yet\n\
1259 set its own value.\n\
1260 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1261 for the current buffer if it was previously using the default value.\n\
1262 The function `default-value' gets the default value and `set-default' sets it.")
1264 register Lisp_Object variable
;
1266 register Lisp_Object tem
, valcontents
, newval
;
1268 CHECK_SYMBOL (variable
, 0);
1270 valcontents
= XSYMBOL (variable
)->value
;
1271 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1272 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1274 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1276 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1278 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1281 if (EQ (valcontents
, Qunbound
))
1282 XSYMBOL (variable
)->value
= Qnil
;
1283 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1284 XCONS (tem
)->car
= tem
;
1285 newval
= allocate_misc ();
1286 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1287 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1288 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1289 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1290 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 1;
1291 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1292 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1293 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1294 XSYMBOL (variable
)->value
= newval
;
1298 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1299 1, 1, "vMake Local Variable: ",
1300 "Make VARIABLE have a separate value in the current buffer.\n\
1301 Other buffers will continue to share a common default value.\n\
1302 \(The buffer-local value of VARIABLE starts out as the same value\n\
1303 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1304 See also `make-variable-buffer-local'.\n\
1306 If the variable is already arranged to become local when set,\n\
1307 this function causes a local value to exist for this buffer,\n\
1308 just as setting the variable would do.\n\
1310 This function returns VARIABLE, and therefore\n\
1311 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1314 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1315 Use `make-local-hook' instead.")
1317 register Lisp_Object variable
;
1319 register Lisp_Object tem
, valcontents
;
1321 CHECK_SYMBOL (variable
, 0);
1323 valcontents
= XSYMBOL (variable
)->value
;
1324 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1325 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1327 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1329 tem
= Fboundp (variable
);
1331 /* Make sure the symbol has a local value in this particular buffer,
1332 by setting it to the same value it already has. */
1333 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1336 /* Make sure symbol is set up to hold per-buffer values */
1337 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1340 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1341 XCONS (tem
)->car
= tem
;
1342 newval
= allocate_misc ();
1343 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1344 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1345 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1346 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1347 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1348 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1349 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1350 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1351 XSYMBOL (variable
)->value
= newval
;
1353 /* Make sure this buffer has its own value of symbol */
1354 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1357 /* Swap out any local binding for some other buffer, and make
1358 sure the current value is permanently recorded, if it's the
1360 find_symbol_value (variable
);
1362 current_buffer
->local_var_alist
1363 = Fcons (Fcons (variable
, XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
),
1364 current_buffer
->local_var_alist
);
1366 /* Make sure symbol does not think it is set up for this buffer;
1367 force it to look once again for this buffer's value */
1369 Lisp_Object
*pvalbuf
;
1371 valcontents
= XSYMBOL (variable
)->value
;
1373 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1374 if (current_buffer
== XBUFFER (*pvalbuf
))
1376 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1380 /* If the symbol forwards into a C variable, then swap in the
1381 variable for this buffer immediately. If C code modifies the
1382 variable before we swap in, then that new value will clobber the
1383 default value the next time we swap. */
1384 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1385 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1386 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1391 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1392 1, 1, "vKill Local Variable: ",
1393 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1394 From now on the default value will apply in this buffer.")
1396 register Lisp_Object variable
;
1398 register Lisp_Object tem
, valcontents
;
1400 CHECK_SYMBOL (variable
, 0);
1402 valcontents
= XSYMBOL (variable
)->value
;
1404 if (BUFFER_OBJFWDP (valcontents
))
1406 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1407 register int mask
= XINT (*((Lisp_Object
*)
1408 (idx
+ (char *)&buffer_local_flags
)));
1412 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1413 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1414 current_buffer
->local_var_flags
&= ~mask
;
1419 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1420 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1423 /* Get rid of this buffer's alist element, if any */
1425 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1427 current_buffer
->local_var_alist
1428 = Fdelq (tem
, current_buffer
->local_var_alist
);
1430 /* If the symbol is set up for the current buffer, recompute its
1431 value. We have to do it now, or else forwarded objects won't
1434 Lisp_Object
*pvalbuf
;
1435 valcontents
= XSYMBOL (variable
)->value
;
1436 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1437 if (current_buffer
== XBUFFER (*pvalbuf
))
1440 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1441 find_symbol_value (variable
);
1448 /* Lisp functions for creating and removing buffer-local variables. */
1450 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1451 1, 1, "vMake Variable Frame Local: ",
1452 "Enable VARIABLE to have frame-local bindings.\n\
1453 When a frame-local binding exists in the current frame,\n\
1454 it is in effect whenever the current buffer has no buffer-local binding.\n\
1455 A frame-local binding is actual a frame parameter value;\n\
1456 thus, any given frame has a local binding for VARIABLE\n\
1457 if it has a value for the frame parameter named VARIABLE.\n\
1458 See `modify-frame-parameters'.")
1460 register Lisp_Object variable
;
1462 register Lisp_Object tem
, valcontents
, newval
;
1464 CHECK_SYMBOL (variable
, 0);
1466 valcontents
= XSYMBOL (variable
)->value
;
1467 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1468 || BUFFER_OBJFWDP (valcontents
))
1469 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1471 if (BUFFER_LOCAL_VALUEP (valcontents
)
1472 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1475 if (EQ (valcontents
, Qunbound
))
1476 XSYMBOL (variable
)->value
= Qnil
;
1477 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1478 XCONS (tem
)->car
= tem
;
1479 newval
= allocate_misc ();
1480 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1481 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1482 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1483 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1484 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1485 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1486 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1487 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1488 XSYMBOL (variable
)->value
= newval
;
1492 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1494 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1495 BUFFER defaults to the current buffer.")
1497 register Lisp_Object variable
, buffer
;
1499 Lisp_Object valcontents
;
1500 register struct buffer
*buf
;
1503 buf
= current_buffer
;
1506 CHECK_BUFFER (buffer
, 0);
1507 buf
= XBUFFER (buffer
);
1510 CHECK_SYMBOL (variable
, 0);
1512 valcontents
= XSYMBOL (variable
)->value
;
1513 if (BUFFER_LOCAL_VALUEP (valcontents
)
1514 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1516 Lisp_Object tail
, elt
;
1517 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1519 elt
= XCONS (tail
)->car
;
1520 if (EQ (variable
, XCONS (elt
)->car
))
1524 if (BUFFER_OBJFWDP (valcontents
))
1526 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1527 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1528 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1534 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1536 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1537 BUFFER defaults to the current buffer.")
1539 register Lisp_Object variable
, buffer
;
1541 Lisp_Object valcontents
;
1542 register struct buffer
*buf
;
1545 buf
= current_buffer
;
1548 CHECK_BUFFER (buffer
, 0);
1549 buf
= XBUFFER (buffer
);
1552 CHECK_SYMBOL (variable
, 0);
1554 valcontents
= XSYMBOL (variable
)->value
;
1556 /* This means that make-variable-buffer-local was done. */
1557 if (BUFFER_LOCAL_VALUEP (valcontents
))
1559 /* All these slots become local if they are set. */
1560 if (BUFFER_OBJFWDP (valcontents
))
1562 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1564 Lisp_Object tail
, elt
;
1565 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1567 elt
= XCONS (tail
)->car
;
1568 if (EQ (variable
, XCONS (elt
)->car
))
1575 /* Find the function at the end of a chain of symbol function indirections. */
1577 /* If OBJECT is a symbol, find the end of its function chain and
1578 return the value found there. If OBJECT is not a symbol, just
1579 return it. If there is a cycle in the function chain, signal a
1580 cyclic-function-indirection error.
1582 This is like Findirect_function, except that it doesn't signal an
1583 error if the chain ends up unbound. */
1585 indirect_function (object
)
1586 register Lisp_Object object
;
1588 Lisp_Object tortoise
, hare
;
1590 hare
= tortoise
= object
;
1594 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1596 hare
= XSYMBOL (hare
)->function
;
1597 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1599 hare
= XSYMBOL (hare
)->function
;
1601 tortoise
= XSYMBOL (tortoise
)->function
;
1603 if (EQ (hare
, tortoise
))
1604 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1610 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1611 "Return the function at the end of OBJECT's function chain.\n\
1612 If OBJECT is a symbol, follow all function indirections and return the final\n\
1613 function binding.\n\
1614 If OBJECT is not a symbol, just return it.\n\
1615 Signal a void-function error if the final symbol is unbound.\n\
1616 Signal a cyclic-function-indirection error if there is a loop in the\n\
1617 function chain of symbols.")
1619 register Lisp_Object object
;
1623 result
= indirect_function (object
);
1625 if (EQ (result
, Qunbound
))
1626 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1630 /* Extract and set vector and string elements */
1632 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1633 "Return the element of ARRAY at index IDX.\n\
1634 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1635 or a byte-code object. IDX starts at 0.")
1637 register Lisp_Object array
;
1640 register int idxval
;
1642 CHECK_NUMBER (idx
, 1);
1643 idxval
= XINT (idx
);
1644 if (STRINGP (array
))
1649 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1650 args_out_of_range (array
, idx
);
1651 if (! STRING_MULTIBYTE (array
))
1652 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1653 idxval_byte
= string_char_to_byte (array
, idxval
);
1655 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1656 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1657 return make_number (c
);
1659 else if (BOOL_VECTOR_P (array
))
1663 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1664 args_out_of_range (array
, idx
);
1666 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1667 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1669 else if (CHAR_TABLE_P (array
))
1674 args_out_of_range (array
, idx
);
1675 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1677 /* For ASCII and 8-bit European characters, the element is
1678 stored in the top table. */
1679 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1681 val
= XCHAR_TABLE (array
)->defalt
;
1682 while (NILP (val
)) /* Follow parents until we find some value. */
1684 array
= XCHAR_TABLE (array
)->parent
;
1687 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1689 val
= XCHAR_TABLE (array
)->defalt
;
1696 Lisp_Object sub_table
;
1698 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1699 if (code
[0] != CHARSET_COMPOSITION
)
1701 if (code
[1] < 32) code
[1] = -1;
1702 else if (code
[2] < 32) code
[2] = -1;
1704 /* Here, the possible range of CODE[0] (== charset ID) is
1705 128..MAX_CHARSET. Since the top level char table contains
1706 data for multibyte characters after 256th element, we must
1707 increment CODE[0] by 128 to get a correct index. */
1709 code
[3] = -1; /* anchor */
1711 try_parent_char_table
:
1713 for (i
= 0; code
[i
] >= 0; i
++)
1715 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1716 if (SUB_CHAR_TABLE_P (val
))
1721 val
= XCHAR_TABLE (sub_table
)->defalt
;
1724 array
= XCHAR_TABLE (array
)->parent
;
1726 goto try_parent_char_table
;
1731 /* Here, VAL is a sub char table. We try the default value
1733 val
= XCHAR_TABLE (val
)->defalt
;
1736 array
= XCHAR_TABLE (array
)->parent
;
1738 goto try_parent_char_table
;
1746 if (VECTORP (array
))
1747 size
= XVECTOR (array
)->size
;
1748 else if (COMPILEDP (array
))
1749 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1751 wrong_type_argument (Qarrayp
, array
);
1753 if (idxval
< 0 || idxval
>= size
)
1754 args_out_of_range (array
, idx
);
1755 return XVECTOR (array
)->contents
[idxval
];
1759 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1760 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1761 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1763 (array
, idx
, newelt
)
1764 register Lisp_Object array
;
1765 Lisp_Object idx
, newelt
;
1767 register int idxval
;
1769 CHECK_NUMBER (idx
, 1);
1770 idxval
= XINT (idx
);
1771 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1772 && ! CHAR_TABLE_P (array
))
1773 array
= wrong_type_argument (Qarrayp
, array
);
1774 CHECK_IMPURE (array
);
1776 if (VECTORP (array
))
1778 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1779 args_out_of_range (array
, idx
);
1780 XVECTOR (array
)->contents
[idxval
] = newelt
;
1782 else if (BOOL_VECTOR_P (array
))
1786 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1787 args_out_of_range (array
, idx
);
1789 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1791 if (! NILP (newelt
))
1792 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1794 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1795 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1797 else if (CHAR_TABLE_P (array
))
1802 args_out_of_range (array
, idx
);
1803 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1804 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1810 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1811 if (code
[0] != CHARSET_COMPOSITION
)
1813 if (code
[1] < 32) code
[1] = -1;
1814 else if (code
[2] < 32) code
[2] = -1;
1816 /* See the comment of the corresponding part in Faref. */
1818 code
[3] = -1; /* anchor */
1819 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1821 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1822 if (SUB_CHAR_TABLE_P (val
))
1828 /* VAL is a leaf. Create a sub char table with the
1829 default value VAL or XCHAR_TABLE (array)->defalt
1830 and look into it. */
1832 temp
= make_sub_char_table (NILP (val
)
1833 ? XCHAR_TABLE (array
)->defalt
1835 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1839 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1842 else if (STRING_MULTIBYTE (array
))
1844 int c
, idxval_byte
, new_len
, actual_len
;
1846 unsigned char *p
, workbuf
[4], *str
;
1848 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1849 args_out_of_range (array
, idx
);
1851 idxval_byte
= string_char_to_byte (array
, idxval
);
1852 p
= &XSTRING (array
)->data
[idxval_byte
];
1854 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1855 CHECK_NUMBER (newelt
, 2);
1856 new_len
= CHAR_STRING (XINT (newelt
), workbuf
, str
);
1857 if (actual_len
!= new_len
)
1858 error ("Attempt to change byte length of a string");
1860 /* We can't accept a change causing byte combining. */
1861 if (!ASCII_BYTE_P (*str
)
1862 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1863 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1864 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1865 > idxval_byte
- prev_byte
))
1866 || (idxval
< XSTRING (array
)->size
- 1
1867 && !CHAR_HEAD_P (p
[actual_len
])
1868 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1869 error ("Attempt to change char length of a string");
1875 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1876 args_out_of_range (array
, idx
);
1877 CHECK_NUMBER (newelt
, 2);
1878 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1884 /* Arithmetic functions */
1886 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1889 arithcompare (num1
, num2
, comparison
)
1890 Lisp_Object num1
, num2
;
1891 enum comparison comparison
;
1896 #ifdef LISP_FLOAT_TYPE
1897 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1898 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1900 if (FLOATP (num1
) || FLOATP (num2
))
1903 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1904 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1907 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1908 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1909 #endif /* LISP_FLOAT_TYPE */
1914 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1919 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1924 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1929 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1934 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1939 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1948 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1949 "Return t if two args, both numbers or markers, are equal.")
1951 register Lisp_Object num1
, num2
;
1953 return arithcompare (num1
, num2
, equal
);
1956 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1957 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1959 register Lisp_Object num1
, num2
;
1961 return arithcompare (num1
, num2
, less
);
1964 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1965 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1967 register Lisp_Object num1
, num2
;
1969 return arithcompare (num1
, num2
, grtr
);
1972 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1973 "Return t if first arg is less than or equal to second arg.\n\
1974 Both must be numbers or markers.")
1976 register Lisp_Object num1
, num2
;
1978 return arithcompare (num1
, num2
, less_or_equal
);
1981 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1982 "Return t if first arg is greater than or equal to second arg.\n\
1983 Both must be numbers or markers.")
1985 register Lisp_Object num1
, num2
;
1987 return arithcompare (num1
, num2
, grtr_or_equal
);
1990 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1991 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1993 register Lisp_Object num1
, num2
;
1995 return arithcompare (num1
, num2
, notequal
);
1998 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2000 register Lisp_Object number
;
2002 #ifdef LISP_FLOAT_TYPE
2003 CHECK_NUMBER_OR_FLOAT (number
, 0);
2005 if (FLOATP (number
))
2007 if (XFLOAT(number
)->data
== 0.0)
2012 CHECK_NUMBER (number
, 0);
2013 #endif /* LISP_FLOAT_TYPE */
2020 /* Convert between long values and pairs of Lisp integers. */
2026 unsigned int top
= i
>> 16;
2027 unsigned int bot
= i
& 0xFFFF;
2029 return make_number (bot
);
2030 if (top
== (unsigned long)-1 >> 16)
2031 return Fcons (make_number (-1), make_number (bot
));
2032 return Fcons (make_number (top
), make_number (bot
));
2039 Lisp_Object top
, bot
;
2042 top
= XCONS (c
)->car
;
2043 bot
= XCONS (c
)->cdr
;
2045 bot
= XCONS (bot
)->car
;
2046 return ((XINT (top
) << 16) | XINT (bot
));
2049 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2050 "Convert NUMBER to a string by printing it in decimal.\n\
2051 Uses a minus sign if negative.\n\
2052 NUMBER may be an integer or a floating point number.")
2056 char buffer
[VALBITS
];
2058 #ifndef LISP_FLOAT_TYPE
2059 CHECK_NUMBER (number
, 0);
2061 CHECK_NUMBER_OR_FLOAT (number
, 0);
2063 if (FLOATP (number
))
2065 char pigbuf
[350]; /* see comments in float_to_string */
2067 float_to_string (pigbuf
, XFLOAT(number
)->data
);
2068 return build_string (pigbuf
);
2070 #endif /* LISP_FLOAT_TYPE */
2072 if (sizeof (int) == sizeof (EMACS_INT
))
2073 sprintf (buffer
, "%d", XINT (number
));
2074 else if (sizeof (long) == sizeof (EMACS_INT
))
2075 sprintf (buffer
, "%ld", XINT (number
));
2078 return build_string (buffer
);
2082 digit_to_number (character
, base
)
2083 int character
, base
;
2087 if (character
>= '0' && character
<= '9')
2088 digit
= character
- '0';
2089 else if (character
>= 'a' && character
<= 'z')
2090 digit
= character
- 'a' + 10;
2091 else if (character
>= 'A' && character
<= 'Z')
2092 digit
= character
- 'A' + 10;
2102 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2103 "Convert STRING to a number by parsing it as a decimal number.\n\
2104 This parses both integers and floating point numbers.\n\
2105 It ignores leading spaces and tabs.\n\
2107 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2108 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2109 If the base used is not 10, floating point is not recognized.")
2111 register Lisp_Object string
, base
;
2113 register unsigned char *p
;
2114 register int b
, digit
, v
= 0;
2117 CHECK_STRING (string
, 0);
2123 CHECK_NUMBER (base
, 1);
2125 if (b
< 2 || b
> 16)
2126 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2129 p
= XSTRING (string
)->data
;
2131 /* Skip any whitespace at the front of the number. Some versions of
2132 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2133 while (*p
== ' ' || *p
== '\t')
2144 #ifdef LISP_FLOAT_TYPE
2145 if (isfloat_string (p
) && b
== 10)
2146 return make_float (negative
* atof (p
));
2147 #endif /* LISP_FLOAT_TYPE */
2151 int digit
= digit_to_number (*p
++, b
);
2157 return make_number (negative
* v
);
2162 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2164 extern Lisp_Object
float_arith_driver ();
2165 extern Lisp_Object
fmod_float ();
2168 arith_driver (code
, nargs
, args
)
2171 register Lisp_Object
*args
;
2173 register Lisp_Object val
;
2174 register int argnum
;
2175 register EMACS_INT accum
;
2176 register EMACS_INT next
;
2178 switch (SWITCH_ENUM_CAST (code
))
2191 for (argnum
= 0; argnum
< nargs
; argnum
++)
2193 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2194 #ifdef LISP_FLOAT_TYPE
2195 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2197 if (FLOATP (val
)) /* time to do serious math */
2198 return (float_arith_driver ((double) accum
, argnum
, code
,
2201 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2202 #endif /* LISP_FLOAT_TYPE */
2203 args
[argnum
] = val
; /* runs into a compiler bug. */
2204 next
= XINT (args
[argnum
]);
2205 switch (SWITCH_ENUM_CAST (code
))
2207 case Aadd
: accum
+= next
; break;
2209 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2211 case Amult
: accum
*= next
; break;
2213 if (!argnum
) accum
= next
;
2217 Fsignal (Qarith_error
, Qnil
);
2221 case Alogand
: accum
&= next
; break;
2222 case Alogior
: accum
|= next
; break;
2223 case Alogxor
: accum
^= next
; break;
2224 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2225 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2229 XSETINT (val
, accum
);
2234 #define isnan(x) ((x) != (x))
2236 #ifdef LISP_FLOAT_TYPE
2239 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2241 register int argnum
;
2244 register Lisp_Object
*args
;
2246 register Lisp_Object val
;
2249 for (; argnum
< nargs
; argnum
++)
2251 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2252 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2256 next
= XFLOAT (val
)->data
;
2260 args
[argnum
] = val
; /* runs into a compiler bug. */
2261 next
= XINT (args
[argnum
]);
2263 switch (SWITCH_ENUM_CAST (code
))
2269 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2279 if (! IEEE_FLOATING_POINT
&& next
== 0)
2280 Fsignal (Qarith_error
, Qnil
);
2287 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2289 if (!argnum
|| isnan (next
) || next
> accum
)
2293 if (!argnum
|| isnan (next
) || next
< accum
)
2299 return make_float (accum
);
2301 #endif /* LISP_FLOAT_TYPE */
2303 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2304 "Return sum of any number of arguments, which are numbers or markers.")
2309 return arith_driver (Aadd
, nargs
, args
);
2312 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2313 "Negate number or subtract numbers or markers.\n\
2314 With one arg, negates it. With more than one arg,\n\
2315 subtracts all but the first from the first.")
2320 return arith_driver (Asub
, nargs
, args
);
2323 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2324 "Returns product of any number of arguments, which are numbers or markers.")
2329 return arith_driver (Amult
, nargs
, args
);
2332 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2333 "Returns first argument divided by all the remaining arguments.\n\
2334 The arguments must be numbers or markers.")
2339 return arith_driver (Adiv
, nargs
, args
);
2342 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2343 "Returns remainder of X divided by Y.\n\
2344 Both must be integers or markers.")
2346 register Lisp_Object x
, y
;
2350 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2351 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2353 if (XFASTINT (y
) == 0)
2354 Fsignal (Qarith_error
, Qnil
);
2356 XSETINT (val
, XINT (x
) % XINT (y
));
2370 /* If the magnitude of the result exceeds that of the divisor, or
2371 the sign of the result does not agree with that of the dividend,
2372 iterate with the reduced value. This does not yield a
2373 particularly accurate result, but at least it will be in the
2374 range promised by fmod. */
2376 r
-= f2
* floor (r
/ f2
);
2377 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2381 #endif /* ! HAVE_FMOD */
2383 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2384 "Returns X modulo Y.\n\
2385 The result falls between zero (inclusive) and Y (exclusive).\n\
2386 Both X and Y must be numbers or markers.")
2388 register Lisp_Object x
, y
;
2393 #ifdef LISP_FLOAT_TYPE
2394 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2395 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2397 if (FLOATP (x
) || FLOATP (y
))
2398 return fmod_float (x
, y
);
2400 #else /* not LISP_FLOAT_TYPE */
2401 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2402 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2403 #endif /* not LISP_FLOAT_TYPE */
2409 Fsignal (Qarith_error
, Qnil
);
2413 /* If the "remainder" comes out with the wrong sign, fix it. */
2414 if (i2
< 0 ? i1
> 0 : i1
< 0)
2421 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2422 "Return largest of all the arguments (which must be numbers or markers).\n\
2423 The value is always a number; markers are converted to numbers.")
2428 return arith_driver (Amax
, nargs
, args
);
2431 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2432 "Return smallest of all the arguments (which must be numbers or markers).\n\
2433 The value is always a number; markers are converted to numbers.")
2438 return arith_driver (Amin
, nargs
, args
);
2441 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2442 "Return bitwise-and of all the arguments.\n\
2443 Arguments may be integers, or markers converted to integers.")
2448 return arith_driver (Alogand
, nargs
, args
);
2451 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2452 "Return bitwise-or of all the arguments.\n\
2453 Arguments may be integers, or markers converted to integers.")
2458 return arith_driver (Alogior
, nargs
, args
);
2461 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2462 "Return bitwise-exclusive-or of all the arguments.\n\
2463 Arguments may be integers, or markers converted to integers.")
2468 return arith_driver (Alogxor
, nargs
, args
);
2471 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2472 "Return VALUE with its bits shifted left by COUNT.\n\
2473 If COUNT is negative, shifting is actually to the right.\n\
2474 In this case, the sign bit is duplicated.")
2476 register Lisp_Object value
, count
;
2478 register Lisp_Object val
;
2480 CHECK_NUMBER (value
, 0);
2481 CHECK_NUMBER (count
, 1);
2483 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2485 else if (XINT (count
) > 0)
2486 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2487 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2488 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2490 XSETINT (val
, XINT (value
) >> -XINT (count
));
2494 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2495 "Return VALUE with its bits shifted left by COUNT.\n\
2496 If COUNT is negative, shifting is actually to the right.\n\
2497 In this case, zeros are shifted in on the left.")
2499 register Lisp_Object value
, count
;
2501 register Lisp_Object val
;
2503 CHECK_NUMBER (value
, 0);
2504 CHECK_NUMBER (count
, 1);
2506 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2508 else if (XINT (count
) > 0)
2509 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2510 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2513 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2517 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2518 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2519 Markers are converted to integers.")
2521 register Lisp_Object number
;
2523 #ifdef LISP_FLOAT_TYPE
2524 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2526 if (FLOATP (number
))
2527 return (make_float (1.0 + XFLOAT (number
)->data
));
2529 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2530 #endif /* LISP_FLOAT_TYPE */
2532 XSETINT (number
, XINT (number
) + 1);
2536 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2537 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2538 Markers are converted to integers.")
2540 register Lisp_Object number
;
2542 #ifdef LISP_FLOAT_TYPE
2543 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2545 if (FLOATP (number
))
2546 return (make_float (-1.0 + XFLOAT (number
)->data
));
2548 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2549 #endif /* LISP_FLOAT_TYPE */
2551 XSETINT (number
, XINT (number
) - 1);
2555 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2556 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2558 register Lisp_Object number
;
2560 CHECK_NUMBER (number
, 0);
2561 XSETINT (number
, ~XINT (number
));
2568 Lisp_Object error_tail
, arith_tail
;
2570 Qquote
= intern ("quote");
2571 Qlambda
= intern ("lambda");
2572 Qsubr
= intern ("subr");
2573 Qerror_conditions
= intern ("error-conditions");
2574 Qerror_message
= intern ("error-message");
2575 Qtop_level
= intern ("top-level");
2577 Qerror
= intern ("error");
2578 Qquit
= intern ("quit");
2579 Qwrong_type_argument
= intern ("wrong-type-argument");
2580 Qargs_out_of_range
= intern ("args-out-of-range");
2581 Qvoid_function
= intern ("void-function");
2582 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2583 Qvoid_variable
= intern ("void-variable");
2584 Qsetting_constant
= intern ("setting-constant");
2585 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2587 Qinvalid_function
= intern ("invalid-function");
2588 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2589 Qno_catch
= intern ("no-catch");
2590 Qend_of_file
= intern ("end-of-file");
2591 Qarith_error
= intern ("arith-error");
2592 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2593 Qend_of_buffer
= intern ("end-of-buffer");
2594 Qbuffer_read_only
= intern ("buffer-read-only");
2595 Qmark_inactive
= intern ("mark-inactive");
2597 Qlistp
= intern ("listp");
2598 Qconsp
= intern ("consp");
2599 Qsymbolp
= intern ("symbolp");
2600 Qintegerp
= intern ("integerp");
2601 Qnatnump
= intern ("natnump");
2602 Qwholenump
= intern ("wholenump");
2603 Qstringp
= intern ("stringp");
2604 Qarrayp
= intern ("arrayp");
2605 Qsequencep
= intern ("sequencep");
2606 Qbufferp
= intern ("bufferp");
2607 Qvectorp
= intern ("vectorp");
2608 Qchar_or_string_p
= intern ("char-or-string-p");
2609 Qmarkerp
= intern ("markerp");
2610 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2611 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2612 Qboundp
= intern ("boundp");
2613 Qfboundp
= intern ("fboundp");
2615 #ifdef LISP_FLOAT_TYPE
2616 Qfloatp
= intern ("floatp");
2617 Qnumberp
= intern ("numberp");
2618 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2619 #endif /* LISP_FLOAT_TYPE */
2621 Qchar_table_p
= intern ("char-table-p");
2622 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2624 Qcdr
= intern ("cdr");
2626 /* Handle automatic advice activation */
2627 Qad_advice_info
= intern ("ad-advice-info");
2628 Qad_activate
= intern ("ad-activate");
2630 error_tail
= Fcons (Qerror
, Qnil
);
2632 /* ERROR is used as a signaler for random errors for which nothing else is right */
2634 Fput (Qerror
, Qerror_conditions
,
2636 Fput (Qerror
, Qerror_message
,
2637 build_string ("error"));
2639 Fput (Qquit
, Qerror_conditions
,
2640 Fcons (Qquit
, Qnil
));
2641 Fput (Qquit
, Qerror_message
,
2642 build_string ("Quit"));
2644 Fput (Qwrong_type_argument
, Qerror_conditions
,
2645 Fcons (Qwrong_type_argument
, error_tail
));
2646 Fput (Qwrong_type_argument
, Qerror_message
,
2647 build_string ("Wrong type argument"));
2649 Fput (Qargs_out_of_range
, Qerror_conditions
,
2650 Fcons (Qargs_out_of_range
, error_tail
));
2651 Fput (Qargs_out_of_range
, Qerror_message
,
2652 build_string ("Args out of range"));
2654 Fput (Qvoid_function
, Qerror_conditions
,
2655 Fcons (Qvoid_function
, error_tail
));
2656 Fput (Qvoid_function
, Qerror_message
,
2657 build_string ("Symbol's function definition is void"));
2659 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2660 Fcons (Qcyclic_function_indirection
, error_tail
));
2661 Fput (Qcyclic_function_indirection
, Qerror_message
,
2662 build_string ("Symbol's chain of function indirections contains a loop"));
2664 Fput (Qvoid_variable
, Qerror_conditions
,
2665 Fcons (Qvoid_variable
, error_tail
));
2666 Fput (Qvoid_variable
, Qerror_message
,
2667 build_string ("Symbol's value as variable is void"));
2669 Fput (Qsetting_constant
, Qerror_conditions
,
2670 Fcons (Qsetting_constant
, error_tail
));
2671 Fput (Qsetting_constant
, Qerror_message
,
2672 build_string ("Attempt to set a constant symbol"));
2674 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2675 Fcons (Qinvalid_read_syntax
, error_tail
));
2676 Fput (Qinvalid_read_syntax
, Qerror_message
,
2677 build_string ("Invalid read syntax"));
2679 Fput (Qinvalid_function
, Qerror_conditions
,
2680 Fcons (Qinvalid_function
, error_tail
));
2681 Fput (Qinvalid_function
, Qerror_message
,
2682 build_string ("Invalid function"));
2684 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2685 Fcons (Qwrong_number_of_arguments
, error_tail
));
2686 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2687 build_string ("Wrong number of arguments"));
2689 Fput (Qno_catch
, Qerror_conditions
,
2690 Fcons (Qno_catch
, error_tail
));
2691 Fput (Qno_catch
, Qerror_message
,
2692 build_string ("No catch for tag"));
2694 Fput (Qend_of_file
, Qerror_conditions
,
2695 Fcons (Qend_of_file
, error_tail
));
2696 Fput (Qend_of_file
, Qerror_message
,
2697 build_string ("End of file during parsing"));
2699 arith_tail
= Fcons (Qarith_error
, error_tail
);
2700 Fput (Qarith_error
, Qerror_conditions
,
2702 Fput (Qarith_error
, Qerror_message
,
2703 build_string ("Arithmetic error"));
2705 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2706 Fcons (Qbeginning_of_buffer
, error_tail
));
2707 Fput (Qbeginning_of_buffer
, Qerror_message
,
2708 build_string ("Beginning of buffer"));
2710 Fput (Qend_of_buffer
, Qerror_conditions
,
2711 Fcons (Qend_of_buffer
, error_tail
));
2712 Fput (Qend_of_buffer
, Qerror_message
,
2713 build_string ("End of buffer"));
2715 Fput (Qbuffer_read_only
, Qerror_conditions
,
2716 Fcons (Qbuffer_read_only
, error_tail
));
2717 Fput (Qbuffer_read_only
, Qerror_message
,
2718 build_string ("Buffer is read-only"));
2720 #ifdef LISP_FLOAT_TYPE
2721 Qrange_error
= intern ("range-error");
2722 Qdomain_error
= intern ("domain-error");
2723 Qsingularity_error
= intern ("singularity-error");
2724 Qoverflow_error
= intern ("overflow-error");
2725 Qunderflow_error
= intern ("underflow-error");
2727 Fput (Qdomain_error
, Qerror_conditions
,
2728 Fcons (Qdomain_error
, arith_tail
));
2729 Fput (Qdomain_error
, Qerror_message
,
2730 build_string ("Arithmetic domain error"));
2732 Fput (Qrange_error
, Qerror_conditions
,
2733 Fcons (Qrange_error
, arith_tail
));
2734 Fput (Qrange_error
, Qerror_message
,
2735 build_string ("Arithmetic range error"));
2737 Fput (Qsingularity_error
, Qerror_conditions
,
2738 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2739 Fput (Qsingularity_error
, Qerror_message
,
2740 build_string ("Arithmetic singularity error"));
2742 Fput (Qoverflow_error
, Qerror_conditions
,
2743 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2744 Fput (Qoverflow_error
, Qerror_message
,
2745 build_string ("Arithmetic overflow error"));
2747 Fput (Qunderflow_error
, Qerror_conditions
,
2748 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2749 Fput (Qunderflow_error
, Qerror_message
,
2750 build_string ("Arithmetic underflow error"));
2752 staticpro (&Qrange_error
);
2753 staticpro (&Qdomain_error
);
2754 staticpro (&Qsingularity_error
);
2755 staticpro (&Qoverflow_error
);
2756 staticpro (&Qunderflow_error
);
2757 #endif /* LISP_FLOAT_TYPE */
2761 staticpro (&Qquote
);
2762 staticpro (&Qlambda
);
2764 staticpro (&Qunbound
);
2765 staticpro (&Qerror_conditions
);
2766 staticpro (&Qerror_message
);
2767 staticpro (&Qtop_level
);
2769 staticpro (&Qerror
);
2771 staticpro (&Qwrong_type_argument
);
2772 staticpro (&Qargs_out_of_range
);
2773 staticpro (&Qvoid_function
);
2774 staticpro (&Qcyclic_function_indirection
);
2775 staticpro (&Qvoid_variable
);
2776 staticpro (&Qsetting_constant
);
2777 staticpro (&Qinvalid_read_syntax
);
2778 staticpro (&Qwrong_number_of_arguments
);
2779 staticpro (&Qinvalid_function
);
2780 staticpro (&Qno_catch
);
2781 staticpro (&Qend_of_file
);
2782 staticpro (&Qarith_error
);
2783 staticpro (&Qbeginning_of_buffer
);
2784 staticpro (&Qend_of_buffer
);
2785 staticpro (&Qbuffer_read_only
);
2786 staticpro (&Qmark_inactive
);
2788 staticpro (&Qlistp
);
2789 staticpro (&Qconsp
);
2790 staticpro (&Qsymbolp
);
2791 staticpro (&Qintegerp
);
2792 staticpro (&Qnatnump
);
2793 staticpro (&Qwholenump
);
2794 staticpro (&Qstringp
);
2795 staticpro (&Qarrayp
);
2796 staticpro (&Qsequencep
);
2797 staticpro (&Qbufferp
);
2798 staticpro (&Qvectorp
);
2799 staticpro (&Qchar_or_string_p
);
2800 staticpro (&Qmarkerp
);
2801 staticpro (&Qbuffer_or_string_p
);
2802 staticpro (&Qinteger_or_marker_p
);
2803 #ifdef LISP_FLOAT_TYPE
2804 staticpro (&Qfloatp
);
2805 staticpro (&Qnumberp
);
2806 staticpro (&Qnumber_or_marker_p
);
2807 #endif /* LISP_FLOAT_TYPE */
2808 staticpro (&Qchar_table_p
);
2809 staticpro (&Qvector_or_char_table_p
);
2811 staticpro (&Qboundp
);
2812 staticpro (&Qfboundp
);
2814 staticpro (&Qad_advice_info
);
2815 staticpro (&Qad_activate
);
2817 /* Types that type-of returns. */
2818 Qinteger
= intern ("integer");
2819 Qsymbol
= intern ("symbol");
2820 Qstring
= intern ("string");
2821 Qcons
= intern ("cons");
2822 Qmarker
= intern ("marker");
2823 Qoverlay
= intern ("overlay");
2824 Qfloat
= intern ("float");
2825 Qwindow_configuration
= intern ("window-configuration");
2826 Qprocess
= intern ("process");
2827 Qwindow
= intern ("window");
2828 /* Qsubr = intern ("subr"); */
2829 Qcompiled_function
= intern ("compiled-function");
2830 Qbuffer
= intern ("buffer");
2831 Qframe
= intern ("frame");
2832 Qvector
= intern ("vector");
2833 Qchar_table
= intern ("char-table");
2834 Qbool_vector
= intern ("bool-vector");
2836 staticpro (&Qinteger
);
2837 staticpro (&Qsymbol
);
2838 staticpro (&Qstring
);
2840 staticpro (&Qmarker
);
2841 staticpro (&Qoverlay
);
2842 staticpro (&Qfloat
);
2843 staticpro (&Qwindow_configuration
);
2844 staticpro (&Qprocess
);
2845 staticpro (&Qwindow
);
2846 /* staticpro (&Qsubr); */
2847 staticpro (&Qcompiled_function
);
2848 staticpro (&Qbuffer
);
2849 staticpro (&Qframe
);
2850 staticpro (&Qvector
);
2851 staticpro (&Qchar_table
);
2852 staticpro (&Qbool_vector
);
2854 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2855 "Non-nil means it is an error to set a keyword symbol.\n\
2856 A keyword symbol is a symbol whose name starts with a colon (`:').");
2857 keyword_symbols_constant_flag
= 1;
2861 defsubr (&Stype_of
);
2866 defsubr (&Sintegerp
);
2867 defsubr (&Sinteger_or_marker_p
);
2868 defsubr (&Snumberp
);
2869 defsubr (&Snumber_or_marker_p
);
2870 #ifdef LISP_FLOAT_TYPE
2872 #endif /* LISP_FLOAT_TYPE */
2873 defsubr (&Snatnump
);
2874 defsubr (&Ssymbolp
);
2875 defsubr (&Sstringp
);
2876 defsubr (&Smultibyte_string_p
);
2877 defsubr (&Svectorp
);
2878 defsubr (&Schar_table_p
);
2879 defsubr (&Svector_or_char_table_p
);
2880 defsubr (&Sbool_vector_p
);
2882 defsubr (&Ssequencep
);
2883 defsubr (&Sbufferp
);
2884 defsubr (&Smarkerp
);
2886 defsubr (&Sbyte_code_function_p
);
2887 defsubr (&Schar_or_string_p
);
2890 defsubr (&Scar_safe
);
2891 defsubr (&Scdr_safe
);
2894 defsubr (&Ssymbol_function
);
2895 defsubr (&Sindirect_function
);
2896 defsubr (&Ssymbol_plist
);
2897 defsubr (&Ssymbol_name
);
2898 defsubr (&Smakunbound
);
2899 defsubr (&Sfmakunbound
);
2901 defsubr (&Sfboundp
);
2903 defsubr (&Sdefalias
);
2904 defsubr (&Ssetplist
);
2905 defsubr (&Ssymbol_value
);
2907 defsubr (&Sdefault_boundp
);
2908 defsubr (&Sdefault_value
);
2909 defsubr (&Sset_default
);
2910 defsubr (&Ssetq_default
);
2911 defsubr (&Smake_variable_buffer_local
);
2912 defsubr (&Smake_local_variable
);
2913 defsubr (&Skill_local_variable
);
2914 defsubr (&Smake_variable_frame_local
);
2915 defsubr (&Slocal_variable_p
);
2916 defsubr (&Slocal_variable_if_set_p
);
2919 defsubr (&Snumber_to_string
);
2920 defsubr (&Sstring_to_number
);
2921 defsubr (&Seqlsign
);
2945 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2952 #if defined(USG) && !defined(POSIX_SIGNALS)
2953 /* USG systems forget handlers when they are used;
2954 must reestablish each time */
2955 signal (signo
, arith_error
);
2958 /* VMS systems are like USG. */
2959 signal (signo
, arith_error
);
2963 #else /* not BSD4_1 */
2964 sigsetmask (SIGEMPTYMASK
);
2965 #endif /* not BSD4_1 */
2967 Fsignal (Qarith_error
, Qnil
);
2973 /* Don't do this if just dumping out.
2974 We don't want to call `signal' in this case
2975 so that we don't have trouble with dumping
2976 signal-delivering routines in an inconsistent state. */
2980 #endif /* CANNOT_DUMP */
2981 signal (SIGFPE
, arith_error
);
2984 signal (SIGEMT
, arith_error
);