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. */
36 #include "syssignal.h"
38 #ifdef LISP_FLOAT_TYPE
45 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
46 #ifndef IEEE_FLOATING_POINT
47 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
48 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
49 #define IEEE_FLOATING_POINT 1
51 #define IEEE_FLOATING_POINT 0
55 /* Work around a problem that happens because math.h on hpux 7
56 defines two static variables--which, in Emacs, are not really static,
57 because `static' is defined as nothing. The problem is that they are
58 here, in floatfns.c, and in lread.c.
59 These macros prevent the name conflict. */
60 #if defined (HPUX) && !defined (HPUX8)
61 #define _MAXLDBL data_c_maxldbl
62 #define _NMAXLDBL data_c_nmaxldbl
66 #endif /* LISP_FLOAT_TYPE */
69 extern double atof ();
72 /* Nonzero means it is an error to set a symbol whose name starts with
74 int keyword_symbols_constant_flag
;
76 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
77 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
78 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
79 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
80 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
81 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
82 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
83 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
84 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
85 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
86 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
87 Lisp_Object Qbuffer_or_string_p
;
88 Lisp_Object Qboundp
, Qfboundp
;
89 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
92 Lisp_Object Qad_advice_info
, Qad_activate
;
94 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
95 Lisp_Object Qoverflow_error
, Qunderflow_error
;
97 #ifdef LISP_FLOAT_TYPE
99 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
102 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
103 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
104 Lisp_Object Qprocess
;
105 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
106 static Lisp_Object Qchar_table
, Qbool_vector
;
108 static Lisp_Object
swap_in_symval_forwarding ();
110 Lisp_Object
set_internal ();
113 wrong_type_argument (predicate
, value
)
114 register Lisp_Object predicate
, value
;
116 register Lisp_Object tem
;
119 if (!EQ (Vmocklisp_arguments
, Qt
))
121 if (STRINGP (value
) &&
122 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
123 return Fstring_to_number (value
, Qnil
);
124 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
125 return Fnumber_to_string (value
);
128 /* If VALUE is not even a valid Lisp object, abort here
129 where we can get a backtrace showing where it came from. */
130 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
133 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
134 tem
= call1 (predicate
, value
);
143 error ("Attempt to modify read-only object");
147 args_out_of_range (a1
, a2
)
151 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
155 args_out_of_range_3 (a1
, a2
, a3
)
156 Lisp_Object a1
, a2
, a3
;
159 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
162 /* On some machines, XINT needs a temporary location.
163 Here it is, in case it is needed. */
165 int sign_extend_temp
;
167 /* On a few machines, XINT can only be done by calling this. */
170 sign_extend_lisp_int (num
)
173 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
174 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
176 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
179 /* Data type predicates */
181 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
182 "Return t if the two args are the same Lisp object.")
184 Lisp_Object obj1
, obj2
;
191 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
200 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
201 "Return a symbol representing the type of OBJECT.\n\
202 The symbol returned names the object's basic type;\n\
203 for example, (type-of 1) returns `integer'.")
207 switch (XGCTYPE (object
))
222 switch (XMISCTYPE (object
))
224 case Lisp_Misc_Marker
:
226 case Lisp_Misc_Overlay
:
228 case Lisp_Misc_Float
:
233 case Lisp_Vectorlike
:
234 if (GC_WINDOW_CONFIGURATIONP (object
))
235 return Qwindow_configuration
;
236 if (GC_PROCESSP (object
))
238 if (GC_WINDOWP (object
))
240 if (GC_SUBRP (object
))
242 if (GC_COMPILEDP (object
))
243 return Qcompiled_function
;
244 if (GC_BUFFERP (object
))
246 if (GC_CHAR_TABLE_P (object
))
248 if (GC_BOOL_VECTOR_P (object
))
250 if (GC_FRAMEP (object
))
254 #ifdef LISP_FLOAT_TYPE
264 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
273 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
274 "Return t if OBJECT is not a cons cell. This includes nil.")
283 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
284 "Return t if OBJECT is a list. This includes nil.")
288 if (CONSP (object
) || NILP (object
))
293 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
294 "Return t if OBJECT is not a list. Lists include nil.")
298 if (CONSP (object
) || NILP (object
))
303 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
304 "Return t if OBJECT is a symbol.")
308 if (SYMBOLP (object
))
313 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
314 "Return t if OBJECT is a vector.")
318 if (VECTORP (object
))
323 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
324 "Return t if OBJECT is a string.")
328 if (STRINGP (object
))
333 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
334 1, 1, 0, "Return t if OBJECT is a multibyte string.")
338 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
343 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
344 "Return t if OBJECT is a char-table.")
348 if (CHAR_TABLE_P (object
))
353 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
354 Svector_or_char_table_p
, 1, 1, 0,
355 "Return t if OBJECT is a char-table or vector.")
359 if (VECTORP (object
) || CHAR_TABLE_P (object
))
364 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
368 if (BOOL_VECTOR_P (object
))
373 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
377 if (VECTORP (object
) || STRINGP (object
)
378 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
383 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
384 "Return t if OBJECT is a sequence (list or array).")
386 register Lisp_Object object
;
388 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
389 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
394 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
398 if (BUFFERP (object
))
403 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
407 if (MARKERP (object
))
412 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
421 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
422 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
426 if (COMPILEDP (object
))
431 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
432 "Return t if OBJECT is a character (an integer) or a string.")
434 register Lisp_Object object
;
436 if (INTEGERP (object
) || STRINGP (object
))
441 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
445 if (INTEGERP (object
))
450 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
451 "Return t if OBJECT is an integer or a marker (editor pointer).")
453 register Lisp_Object object
;
455 if (MARKERP (object
) || INTEGERP (object
))
460 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
461 "Return t if OBJECT is a nonnegative integer.")
465 if (NATNUMP (object
))
470 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
471 "Return t if OBJECT is a number (floating point or integer).")
475 if (NUMBERP (object
))
481 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
482 Snumber_or_marker_p
, 1, 1, 0,
483 "Return t if OBJECT is a number or a marker.")
487 if (NUMBERP (object
) || MARKERP (object
))
492 #ifdef LISP_FLOAT_TYPE
493 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
494 "Return t if OBJECT is a floating point number.")
502 #endif /* LISP_FLOAT_TYPE */
504 /* Extract and set components of lists */
506 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
507 "Return the car of LIST. If arg is nil, return nil.\n\
508 Error if arg is not nil and not a cons cell. See also `car-safe'.")
510 register Lisp_Object list
;
515 return XCONS (list
)->car
;
516 else if (EQ (list
, Qnil
))
519 list
= wrong_type_argument (Qlistp
, list
);
523 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
524 "Return the car of OBJECT if it is a cons cell, or else nil.")
529 return XCONS (object
)->car
;
534 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
535 "Return the cdr of LIST. If arg is nil, return nil.\n\
536 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
539 register Lisp_Object list
;
544 return XCONS (list
)->cdr
;
545 else if (EQ (list
, Qnil
))
548 list
= wrong_type_argument (Qlistp
, list
);
552 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
553 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
558 return XCONS (object
)->cdr
;
563 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
564 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
566 register Lisp_Object cell
, newcar
;
569 cell
= wrong_type_argument (Qconsp
, cell
);
572 XCONS (cell
)->car
= newcar
;
576 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
577 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
579 register Lisp_Object cell
, newcdr
;
582 cell
= wrong_type_argument (Qconsp
, cell
);
585 XCONS (cell
)->cdr
= newcdr
;
589 /* Extract and set components of symbols */
591 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
593 register Lisp_Object symbol
;
595 Lisp_Object valcontents
;
596 CHECK_SYMBOL (symbol
, 0);
598 valcontents
= XSYMBOL (symbol
)->value
;
600 if (BUFFER_LOCAL_VALUEP (valcontents
)
601 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
602 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
604 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
607 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
609 register Lisp_Object symbol
;
611 CHECK_SYMBOL (symbol
, 0);
612 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
615 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
617 register Lisp_Object symbol
;
619 CHECK_SYMBOL (symbol
, 0);
620 if (NILP (symbol
) || EQ (symbol
, Qt
)
621 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
622 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
623 && keyword_symbols_constant_flag
))
624 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
625 Fset (symbol
, Qunbound
);
629 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
, 0);
634 if (NILP (symbol
) || EQ (symbol
, Qt
))
635 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
636 XSYMBOL (symbol
)->function
= Qunbound
;
640 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
641 "Return SYMBOL's function definition. Error if that is void.")
643 register Lisp_Object symbol
;
645 CHECK_SYMBOL (symbol
, 0);
646 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
647 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
648 return XSYMBOL (symbol
)->function
;
651 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
653 register Lisp_Object symbol
;
655 CHECK_SYMBOL (symbol
, 0);
656 return XSYMBOL (symbol
)->plist
;
659 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
661 register Lisp_Object symbol
;
663 register Lisp_Object name
;
665 CHECK_SYMBOL (symbol
, 0);
666 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
670 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
671 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
673 register Lisp_Object symbol
, definition
;
675 CHECK_SYMBOL (symbol
, 0);
676 if (NILP (symbol
) || EQ (symbol
, Qt
))
677 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
678 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
679 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
681 XSYMBOL (symbol
)->function
= definition
;
682 /* Handle automatic advice activation */
683 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
685 call2 (Qad_activate
, symbol
, Qnil
);
686 definition
= XSYMBOL (symbol
)->function
;
691 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
692 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
693 Associates the function with the current load file, if any.")
695 register Lisp_Object symbol
, definition
;
697 definition
= Ffset (symbol
, definition
);
698 LOADHIST_ATTACH (symbol
);
702 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
703 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
705 register Lisp_Object symbol
, newplist
;
707 CHECK_SYMBOL (symbol
, 0);
708 XSYMBOL (symbol
)->plist
= newplist
;
713 /* Getting and setting values of symbols */
715 /* Given the raw contents of a symbol value cell,
716 return the Lisp value of the symbol.
717 This does not handle buffer-local variables; use
718 swap_in_symval_forwarding for that. */
721 do_symval_forwarding (valcontents
)
722 register Lisp_Object valcontents
;
724 register Lisp_Object val
;
726 if (MISCP (valcontents
))
727 switch (XMISCTYPE (valcontents
))
729 case Lisp_Misc_Intfwd
:
730 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
733 case Lisp_Misc_Boolfwd
:
734 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
736 case Lisp_Misc_Objfwd
:
737 return *XOBJFWD (valcontents
)->objvar
;
739 case Lisp_Misc_Buffer_Objfwd
:
740 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
741 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
743 case Lisp_Misc_Kboard_Objfwd
:
744 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
745 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
750 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
751 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
752 buffer-independent contents of the value cell: forwarded just one
753 step past the buffer-localness. */
756 store_symval_forwarding (symbol
, valcontents
, newval
)
758 register Lisp_Object valcontents
, newval
;
760 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
763 switch (XMISCTYPE (valcontents
))
765 case Lisp_Misc_Intfwd
:
766 CHECK_NUMBER (newval
, 1);
767 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
768 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
769 error ("Value out of range for variable `%s'",
770 XSYMBOL (symbol
)->name
->data
);
773 case Lisp_Misc_Boolfwd
:
774 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
777 case Lisp_Misc_Objfwd
:
778 *XOBJFWD (valcontents
)->objvar
= newval
;
781 case Lisp_Misc_Buffer_Objfwd
:
783 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
786 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
787 if (XINT (type
) == -1)
788 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
790 if (! NILP (type
) && ! NILP (newval
)
791 && XTYPE (newval
) != XINT (type
))
792 buffer_slot_type_mismatch (offset
);
794 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
798 case Lisp_Misc_Kboard_Objfwd
:
799 (*(Lisp_Object
*)((char *)current_kboard
800 + XKBOARD_OBJFWD (valcontents
)->offset
))
811 valcontents
= XSYMBOL (symbol
)->value
;
812 if (BUFFER_LOCAL_VALUEP (valcontents
)
813 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
814 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
816 XSYMBOL (symbol
)->value
= newval
;
820 /* Set up the buffer-local symbol SYMBOL for validity in the current
821 buffer. VALCONTENTS is the contents of its value cell.
822 Return the value forwarded one step past the buffer-local indicator. */
825 swap_in_symval_forwarding (symbol
, valcontents
)
826 Lisp_Object symbol
, valcontents
;
828 /* valcontents is a pointer to a struct resembling the cons
829 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
831 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
832 local_var_alist, that being the element whose car is this
833 variable. Or it can be a pointer to the
834 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
835 an element in its alist for this variable.
837 If the current buffer is not BUFFER, we store the current
838 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
839 appropriate alist element for the buffer now current and set up
840 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
841 element, and store into BUFFER.
843 Note that REALVALUE can be a forwarding pointer. */
845 register Lisp_Object tem1
;
846 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
848 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
)
849 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
851 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
853 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
854 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
855 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
856 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
859 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
860 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
862 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
864 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
867 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
869 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
= tem1
;
870 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
871 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
872 store_symval_forwarding (symbol
,
873 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
876 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
879 /* Find the value of a symbol, returning Qunbound if it's not bound.
880 This is helpful for code which just wants to get a variable's value
881 if it has one, without signaling an error.
882 Note that it must not be possible to quit
883 within this function. Great care is required for this. */
886 find_symbol_value (symbol
)
889 register Lisp_Object valcontents
;
890 register Lisp_Object val
;
891 CHECK_SYMBOL (symbol
, 0);
892 valcontents
= XSYMBOL (symbol
)->value
;
894 if (BUFFER_LOCAL_VALUEP (valcontents
)
895 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
896 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
898 if (MISCP (valcontents
))
900 switch (XMISCTYPE (valcontents
))
902 case Lisp_Misc_Intfwd
:
903 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
906 case Lisp_Misc_Boolfwd
:
907 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
909 case Lisp_Misc_Objfwd
:
910 return *XOBJFWD (valcontents
)->objvar
;
912 case Lisp_Misc_Buffer_Objfwd
:
913 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
914 + (char *)current_buffer
);
916 case Lisp_Misc_Kboard_Objfwd
:
917 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
918 + (char *)current_kboard
);
925 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
926 "Return SYMBOL's value. Error if that is void.")
932 val
= find_symbol_value (symbol
);
933 if (EQ (val
, Qunbound
))
934 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
939 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
940 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
942 register Lisp_Object symbol
, newval
;
944 return set_internal (symbol
, newval
, 0);
947 /* Store the value NEWVAL into SYMBOL.
948 If BINDFLAG is zero, then if this symbol is supposed to become
949 local in every buffer where it is set, then we make it local.
950 If BINDFLAG is nonzero, we don't do that. */
953 set_internal (symbol
, newval
, bindflag
)
954 register Lisp_Object symbol
, newval
;
957 int voide
= EQ (newval
, Qunbound
);
959 register Lisp_Object valcontents
, tem1
, current_alist_element
;
961 CHECK_SYMBOL (symbol
, 0);
962 if (NILP (symbol
) || EQ (symbol
, Qt
)
963 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
964 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
965 && keyword_symbols_constant_flag
&& ! EQ (newval
, symbol
)))
966 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
967 valcontents
= XSYMBOL (symbol
)->value
;
969 if (BUFFER_OBJFWDP (valcontents
))
971 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
972 register int mask
= XINT (*((Lisp_Object
*)
973 (idx
+ (char *)&buffer_local_flags
)));
974 if (mask
> 0 && ! bindflag
)
975 current_buffer
->local_var_flags
|= mask
;
978 else if (BUFFER_LOCAL_VALUEP (valcontents
)
979 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
981 /* valcontents is actually a pointer to a struct resembling a cons,
982 with contents something like:
983 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
985 BUFFER is the last buffer for which this symbol's value was
988 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
989 local_var_alist, that being the element whose car is this
990 variable. Or it can be a pointer to the
991 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
992 have an element in its alist for this variable (that is, if
993 BUFFER sees the default value of this variable).
995 If we want to examine or set the value and BUFFER is current,
996 we just examine or set REALVALUE. If BUFFER is not current, we
997 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
998 then find the appropriate alist element for the buffer now
999 current and set up CURRENT-ALIST-ELEMENT. Then we set
1000 REALVALUE out of that element, and store into BUFFER.
1002 If we are setting the variable and the current buffer does
1003 not have an alist entry for this variable, an alist entry is
1006 Note that REALVALUE can be a forwarding pointer. Each time
1007 it is examined or set, forwarding must be done. */
1009 /* What value are we caching right now? */
1010 current_alist_element
1011 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1013 /* If the current buffer is not the buffer whose binding is
1014 currently cached, or if it's a Lisp_Buffer_Local_Value and
1015 we're looking at the default value, the cache is invalid; we
1016 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
1017 if (current_buffer
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1018 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)
1019 || (BUFFER_LOCAL_VALUEP (valcontents
)
1020 && EQ (XCONS (current_alist_element
)->car
,
1021 current_alist_element
)))
1023 /* Write out the cached value for the old buffer; copy it
1024 back to its alist element. This works if the current
1025 buffer only sees the default value, too. */
1026 Fsetcdr (current_alist_element
,
1027 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1029 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1030 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1031 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1032 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1036 /* This buffer still sees the default value. */
1038 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1039 or if this is `let' rather than `set',
1040 make CURRENT-ALIST-ELEMENT point to itself,
1041 indicating that we're seeing the default value. */
1042 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1044 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1046 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1047 tem1
= Fassq (symbol
,
1048 XFRAME (selected_frame
)->param_alist
);
1051 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1053 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1055 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1056 give this buffer a new assoc for a local value and set
1057 CURRENT-ALIST-ELEMENT to point to that. */
1060 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1061 current_buffer
->local_var_alist
1062 = Fcons (tem1
, current_buffer
->local_var_alist
);
1066 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1067 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
1070 /* Set BUFFER and FRAME for binding now loaded. */
1071 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
,
1073 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1075 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1078 /* If storing void (making the symbol void), forward only through
1079 buffer-local indicator, not through Lisp_Objfwd, etc. */
1081 store_symval_forwarding (symbol
, Qnil
, newval
);
1083 store_symval_forwarding (symbol
, valcontents
, newval
);
1088 /* Access or set a buffer-local symbol's default value. */
1090 /* Return the default value of SYMBOL, but don't check for voidness.
1091 Return Qunbound if it is void. */
1094 default_value (symbol
)
1097 register Lisp_Object valcontents
;
1099 CHECK_SYMBOL (symbol
, 0);
1100 valcontents
= XSYMBOL (symbol
)->value
;
1102 /* For a built-in buffer-local variable, get the default value
1103 rather than letting do_symval_forwarding get the current value. */
1104 if (BUFFER_OBJFWDP (valcontents
))
1106 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1108 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1109 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1112 /* Handle user-created local variables. */
1113 if (BUFFER_LOCAL_VALUEP (valcontents
)
1114 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1116 /* If var is set up for a buffer that lacks a local value for it,
1117 the current value is nominally the default value.
1118 But the current value slot may be more up to date, since
1119 ordinary setq stores just that slot. So use that. */
1120 Lisp_Object current_alist_element
, alist_element_car
;
1121 current_alist_element
1122 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1123 alist_element_car
= XCONS (current_alist_element
)->car
;
1124 if (EQ (alist_element_car
, current_alist_element
))
1125 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1127 return XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1129 /* For other variables, get the current value. */
1130 return do_symval_forwarding (valcontents
);
1133 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1134 "Return t if SYMBOL has a non-void default value.\n\
1135 This is the value that is seen in buffers that do not have their own values\n\
1136 for this variable.")
1140 register Lisp_Object value
;
1142 value
= default_value (symbol
);
1143 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1146 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1147 "Return SYMBOL's default value.\n\
1148 This is the value that is seen in buffers that do not have their own values\n\
1149 for this variable. The default value is meaningful for variables with\n\
1150 local bindings in certain buffers.")
1154 register Lisp_Object value
;
1156 value
= default_value (symbol
);
1157 if (EQ (value
, Qunbound
))
1158 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1162 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1163 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1164 The default value is seen in buffers that do not have their own values\n\
1165 for this variable.")
1167 Lisp_Object symbol
, value
;
1169 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1171 CHECK_SYMBOL (symbol
, 0);
1172 valcontents
= XSYMBOL (symbol
)->value
;
1174 /* Handle variables like case-fold-search that have special slots
1175 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1177 if (BUFFER_OBJFWDP (valcontents
))
1179 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1180 register struct buffer
*b
;
1181 register int mask
= XINT (*((Lisp_Object
*)
1182 (idx
+ (char *)&buffer_local_flags
)));
1184 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1186 /* If this variable is not always local in all buffers,
1187 set it in the buffers that don't nominally have a local value. */
1190 for (b
= all_buffers
; b
; b
= b
->next
)
1191 if (!(b
->local_var_flags
& mask
))
1192 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1197 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1198 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1199 return Fset (symbol
, value
);
1201 /* Store new value into the DEFAULT-VALUE slot */
1202 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
= value
;
1204 /* If that slot is current, we must set the REALVALUE slot too */
1205 current_alist_element
1206 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1207 alist_element_buffer
= Fcar (current_alist_element
);
1208 if (EQ (alist_element_buffer
, current_alist_element
))
1209 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1215 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1216 "Set the default value of variable VAR to VALUE.\n\
1217 VAR, the variable name, is literal (not evaluated);\n\
1218 VALUE is an expression and it is evaluated.\n\
1219 The default value of a variable is seen in buffers\n\
1220 that do not have their own values for the variable.\n\
1222 More generally, you can use multiple variables and values, as in\n\
1223 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1224 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1225 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1230 register Lisp_Object args_left
;
1231 register Lisp_Object val
, symbol
;
1232 struct gcpro gcpro1
;
1242 val
= Feval (Fcar (Fcdr (args_left
)));
1243 symbol
= Fcar (args_left
);
1244 Fset_default (symbol
, val
);
1245 args_left
= Fcdr (Fcdr (args_left
));
1247 while (!NILP (args_left
));
1253 /* Lisp functions for creating and removing buffer-local variables. */
1255 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1256 1, 1, "vMake Variable Buffer Local: ",
1257 "Make VARIABLE have a separate value for each buffer.\n\
1258 At any time, the value for the current buffer is in effect.\n\
1259 There is also a default value which is seen in any buffer which has not yet\n\
1260 set its own value.\n\
1261 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1262 for the current buffer if it was previously using the default value.\n\
1263 The function `default-value' gets the default value and `set-default' sets it.")
1265 register Lisp_Object variable
;
1267 register Lisp_Object tem
, valcontents
, newval
;
1269 CHECK_SYMBOL (variable
, 0);
1271 valcontents
= XSYMBOL (variable
)->value
;
1272 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1273 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1275 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1277 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1279 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1282 if (EQ (valcontents
, Qunbound
))
1283 XSYMBOL (variable
)->value
= Qnil
;
1284 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1285 XCONS (tem
)->car
= tem
;
1286 newval
= allocate_misc ();
1287 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1288 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1289 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1290 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1291 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 1;
1292 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1293 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1294 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1295 XSYMBOL (variable
)->value
= newval
;
1299 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1300 1, 1, "vMake Local Variable: ",
1301 "Make VARIABLE have a separate value in the current buffer.\n\
1302 Other buffers will continue to share a common default value.\n\
1303 \(The buffer-local value of VARIABLE starts out as the same value\n\
1304 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1305 See also `make-variable-buffer-local'.\n\
1307 If the variable is already arranged to become local when set,\n\
1308 this function causes a local value to exist for this buffer,\n\
1309 just as setting the variable would do.\n\
1311 This function returns VARIABLE, and therefore\n\
1312 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1315 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1316 Use `make-local-hook' instead.")
1318 register Lisp_Object variable
;
1320 register Lisp_Object tem
, valcontents
;
1322 CHECK_SYMBOL (variable
, 0);
1324 valcontents
= XSYMBOL (variable
)->value
;
1325 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1326 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1328 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1330 tem
= Fboundp (variable
);
1332 /* Make sure the symbol has a local value in this particular buffer,
1333 by setting it to the same value it already has. */
1334 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1337 /* Make sure symbol is set up to hold per-buffer values */
1338 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1341 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1342 XCONS (tem
)->car
= tem
;
1343 newval
= allocate_misc ();
1344 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1345 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1346 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1347 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1348 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1349 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1350 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1351 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1352 XSYMBOL (variable
)->value
= newval
;
1354 /* Make sure this buffer has its own value of symbol */
1355 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1358 /* Swap out any local binding for some other buffer, and make
1359 sure the current value is permanently recorded, if it's the
1361 find_symbol_value (variable
);
1363 current_buffer
->local_var_alist
1364 = Fcons (Fcons (variable
, XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
),
1365 current_buffer
->local_var_alist
);
1367 /* Make sure symbol does not think it is set up for this buffer;
1368 force it to look once again for this buffer's value */
1370 Lisp_Object
*pvalbuf
;
1372 valcontents
= XSYMBOL (variable
)->value
;
1374 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1375 if (current_buffer
== XBUFFER (*pvalbuf
))
1377 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1381 /* If the symbol forwards into a C variable, then swap in the
1382 variable for this buffer immediately. If C code modifies the
1383 variable before we swap in, then that new value will clobber the
1384 default value the next time we swap. */
1385 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1386 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1387 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1392 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1393 1, 1, "vKill Local Variable: ",
1394 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1395 From now on the default value will apply in this buffer.")
1397 register Lisp_Object variable
;
1399 register Lisp_Object tem
, valcontents
;
1401 CHECK_SYMBOL (variable
, 0);
1403 valcontents
= XSYMBOL (variable
)->value
;
1405 if (BUFFER_OBJFWDP (valcontents
))
1407 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1408 register int mask
= XINT (*((Lisp_Object
*)
1409 (idx
+ (char *)&buffer_local_flags
)));
1413 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1414 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1415 current_buffer
->local_var_flags
&= ~mask
;
1420 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1421 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1424 /* Get rid of this buffer's alist element, if any */
1426 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1428 current_buffer
->local_var_alist
1429 = Fdelq (tem
, current_buffer
->local_var_alist
);
1431 /* If the symbol is set up for the current buffer, recompute its
1432 value. We have to do it now, or else forwarded objects won't
1435 Lisp_Object
*pvalbuf
;
1436 valcontents
= XSYMBOL (variable
)->value
;
1437 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1438 if (current_buffer
== XBUFFER (*pvalbuf
))
1441 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1442 find_symbol_value (variable
);
1449 /* Lisp functions for creating and removing buffer-local variables. */
1451 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1452 1, 1, "vMake Variable Frame Local: ",
1453 "Enable VARIABLE to have frame-local bindings.\n\
1454 When a frame-local binding exists in the current frame,\n\
1455 it is in effect whenever the current buffer has no buffer-local binding.\n\
1456 A frame-local binding is actual a frame parameter value;\n\
1457 thus, any given frame has a local binding for VARIABLE\n\
1458 if it has a value for the frame parameter named VARIABLE.\n\
1459 See `modify-frame-parameters'.")
1461 register Lisp_Object variable
;
1463 register Lisp_Object tem
, valcontents
, newval
;
1465 CHECK_SYMBOL (variable
, 0);
1467 valcontents
= XSYMBOL (variable
)->value
;
1468 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1469 || BUFFER_OBJFWDP (valcontents
))
1470 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1472 if (BUFFER_LOCAL_VALUEP (valcontents
)
1473 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1476 if (EQ (valcontents
, Qunbound
))
1477 XSYMBOL (variable
)->value
= Qnil
;
1478 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1479 XCONS (tem
)->car
= tem
;
1480 newval
= allocate_misc ();
1481 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1482 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1483 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1484 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1485 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1486 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1487 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1488 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1489 XSYMBOL (variable
)->value
= newval
;
1493 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1495 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1496 BUFFER defaults to the current buffer.")
1498 register Lisp_Object variable
, buffer
;
1500 Lisp_Object valcontents
;
1501 register struct buffer
*buf
;
1504 buf
= current_buffer
;
1507 CHECK_BUFFER (buffer
, 0);
1508 buf
= XBUFFER (buffer
);
1511 CHECK_SYMBOL (variable
, 0);
1513 valcontents
= XSYMBOL (variable
)->value
;
1514 if (BUFFER_LOCAL_VALUEP (valcontents
)
1515 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1517 Lisp_Object tail
, elt
;
1518 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1520 elt
= XCONS (tail
)->car
;
1521 if (EQ (variable
, XCONS (elt
)->car
))
1525 if (BUFFER_OBJFWDP (valcontents
))
1527 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1528 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1529 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1535 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1537 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1538 BUFFER defaults to the current buffer.")
1540 register Lisp_Object variable
, buffer
;
1542 Lisp_Object valcontents
;
1543 register struct buffer
*buf
;
1546 buf
= current_buffer
;
1549 CHECK_BUFFER (buffer
, 0);
1550 buf
= XBUFFER (buffer
);
1553 CHECK_SYMBOL (variable
, 0);
1555 valcontents
= XSYMBOL (variable
)->value
;
1557 /* This means that make-variable-buffer-local was done. */
1558 if (BUFFER_LOCAL_VALUEP (valcontents
))
1560 /* All these slots become local if they are set. */
1561 if (BUFFER_OBJFWDP (valcontents
))
1563 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1565 Lisp_Object tail
, elt
;
1566 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1568 elt
= XCONS (tail
)->car
;
1569 if (EQ (variable
, XCONS (elt
)->car
))
1576 /* Find the function at the end of a chain of symbol function indirections. */
1578 /* If OBJECT is a symbol, find the end of its function chain and
1579 return the value found there. If OBJECT is not a symbol, just
1580 return it. If there is a cycle in the function chain, signal a
1581 cyclic-function-indirection error.
1583 This is like Findirect_function, except that it doesn't signal an
1584 error if the chain ends up unbound. */
1586 indirect_function (object
)
1587 register Lisp_Object object
;
1589 Lisp_Object tortoise
, hare
;
1591 hare
= tortoise
= object
;
1595 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1597 hare
= XSYMBOL (hare
)->function
;
1598 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1600 hare
= XSYMBOL (hare
)->function
;
1602 tortoise
= XSYMBOL (tortoise
)->function
;
1604 if (EQ (hare
, tortoise
))
1605 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1611 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1612 "Return the function at the end of OBJECT's function chain.\n\
1613 If OBJECT is a symbol, follow all function indirections and return the final\n\
1614 function binding.\n\
1615 If OBJECT is not a symbol, just return it.\n\
1616 Signal a void-function error if the final symbol is unbound.\n\
1617 Signal a cyclic-function-indirection error if there is a loop in the\n\
1618 function chain of symbols.")
1620 register Lisp_Object object
;
1624 result
= indirect_function (object
);
1626 if (EQ (result
, Qunbound
))
1627 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1631 /* Extract and set vector and string elements */
1633 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1634 "Return the element of ARRAY at index IDX.\n\
1635 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1636 or a byte-code object. IDX starts at 0.")
1638 register Lisp_Object array
;
1641 register int idxval
;
1643 CHECK_NUMBER (idx
, 1);
1644 idxval
= XINT (idx
);
1645 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
))
1800 args_out_of_range (array
, idx
);
1801 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1802 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1808 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1809 if (code
[0] != CHARSET_COMPOSITION
)
1811 if (code
[1] < 32) code
[1] = -1;
1812 else if (code
[2] < 32) code
[2] = -1;
1814 /* See the comment of the corresponding part in Faref. */
1816 code
[3] = -1; /* anchor */
1817 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1819 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1820 if (SUB_CHAR_TABLE_P (val
))
1826 /* VAL is a leaf. Create a sub char table with the
1827 default value VAL or XCHAR_TABLE (array)->defalt
1828 and look into it. */
1830 temp
= make_sub_char_table (NILP (val
)
1831 ? XCHAR_TABLE (array
)->defalt
1833 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1837 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1840 else if (STRING_MULTIBYTE (array
))
1842 int idxval_byte
, new_len
, actual_len
;
1844 unsigned char *p
, workbuf
[4], *str
;
1846 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1847 args_out_of_range (array
, idx
);
1849 idxval_byte
= string_char_to_byte (array
, idxval
);
1850 p
= &XSTRING (array
)->data
[idxval_byte
];
1852 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1853 CHECK_NUMBER (newelt
, 2);
1854 new_len
= CHAR_STRING (XINT (newelt
), workbuf
, str
);
1855 if (actual_len
!= new_len
)
1856 error ("Attempt to change byte length of a string");
1858 /* We can't accept a change causing byte combining. */
1859 if (!ASCII_BYTE_P (*str
)
1860 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1861 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1862 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1863 > idxval_byte
- prev_byte
))
1864 || (idxval
< XSTRING (array
)->size
- 1
1865 && !CHAR_HEAD_P (p
[actual_len
])
1866 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1867 error ("Attempt to change char length of a string");
1873 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1874 args_out_of_range (array
, idx
);
1875 CHECK_NUMBER (newelt
, 2);
1876 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1882 /* Arithmetic functions */
1884 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1887 arithcompare (num1
, num2
, comparison
)
1888 Lisp_Object num1
, num2
;
1889 enum comparison comparison
;
1894 #ifdef LISP_FLOAT_TYPE
1895 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1896 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1898 if (FLOATP (num1
) || FLOATP (num2
))
1901 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1902 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1905 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1906 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1907 #endif /* LISP_FLOAT_TYPE */
1912 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1917 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1922 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1927 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1932 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1937 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1946 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1947 "Return t if two args, both numbers or markers, are equal.")
1949 register Lisp_Object num1
, num2
;
1951 return arithcompare (num1
, num2
, equal
);
1954 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1955 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1957 register Lisp_Object num1
, num2
;
1959 return arithcompare (num1
, num2
, less
);
1962 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1963 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1965 register Lisp_Object num1
, num2
;
1967 return arithcompare (num1
, num2
, grtr
);
1970 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1971 "Return t if first arg is less than or equal to second arg.\n\
1972 Both must be numbers or markers.")
1974 register Lisp_Object num1
, num2
;
1976 return arithcompare (num1
, num2
, less_or_equal
);
1979 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1980 "Return t if first arg is greater than or equal to second arg.\n\
1981 Both must be numbers or markers.")
1983 register Lisp_Object num1
, num2
;
1985 return arithcompare (num1
, num2
, grtr_or_equal
);
1988 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1989 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1991 register Lisp_Object num1
, num2
;
1993 return arithcompare (num1
, num2
, notequal
);
1996 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1998 register Lisp_Object number
;
2000 #ifdef LISP_FLOAT_TYPE
2001 CHECK_NUMBER_OR_FLOAT (number
, 0);
2003 if (FLOATP (number
))
2005 if (XFLOAT(number
)->data
== 0.0)
2010 CHECK_NUMBER (number
, 0);
2011 #endif /* LISP_FLOAT_TYPE */
2018 /* Convert between long values and pairs of Lisp integers. */
2024 unsigned int top
= i
>> 16;
2025 unsigned int bot
= i
& 0xFFFF;
2027 return make_number (bot
);
2028 if (top
== (unsigned long)-1 >> 16)
2029 return Fcons (make_number (-1), make_number (bot
));
2030 return Fcons (make_number (top
), make_number (bot
));
2037 Lisp_Object top
, bot
;
2040 top
= XCONS (c
)->car
;
2041 bot
= XCONS (c
)->cdr
;
2043 bot
= XCONS (bot
)->car
;
2044 return ((XINT (top
) << 16) | XINT (bot
));
2047 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2048 "Convert NUMBER to a string by printing it in decimal.\n\
2049 Uses a minus sign if negative.\n\
2050 NUMBER may be an integer or a floating point number.")
2054 char buffer
[VALBITS
];
2056 #ifndef LISP_FLOAT_TYPE
2057 CHECK_NUMBER (number
, 0);
2059 CHECK_NUMBER_OR_FLOAT (number
, 0);
2061 if (FLOATP (number
))
2063 char pigbuf
[350]; /* see comments in float_to_string */
2065 float_to_string (pigbuf
, XFLOAT(number
)->data
);
2066 return build_string (pigbuf
);
2068 #endif /* LISP_FLOAT_TYPE */
2070 if (sizeof (int) == sizeof (EMACS_INT
))
2071 sprintf (buffer
, "%d", XINT (number
));
2072 else if (sizeof (long) == sizeof (EMACS_INT
))
2073 sprintf (buffer
, "%ld", (long) XINT (number
));
2076 return build_string (buffer
);
2080 digit_to_number (character
, base
)
2081 int character
, base
;
2085 if (character
>= '0' && character
<= '9')
2086 digit
= character
- '0';
2087 else if (character
>= 'a' && character
<= 'z')
2088 digit
= character
- 'a' + 10;
2089 else if (character
>= 'A' && character
<= 'Z')
2090 digit
= character
- 'A' + 10;
2100 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2101 "Convert STRING to a number by parsing it as a decimal number.\n\
2102 This parses both integers and floating point numbers.\n\
2103 It ignores leading spaces and tabs.\n\
2105 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2106 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2107 If the base used is not 10, floating point is not recognized.")
2109 register Lisp_Object string
, base
;
2111 register unsigned char *p
;
2112 register int b
, v
= 0;
2115 CHECK_STRING (string
, 0);
2121 CHECK_NUMBER (base
, 1);
2123 if (b
< 2 || b
> 16)
2124 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2127 p
= XSTRING (string
)->data
;
2129 /* Skip any whitespace at the front of the number. Some versions of
2130 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2131 while (*p
== ' ' || *p
== '\t')
2142 #ifdef LISP_FLOAT_TYPE
2143 if (isfloat_string (p
) && b
== 10)
2144 return make_float (negative
* atof (p
));
2145 #endif /* LISP_FLOAT_TYPE */
2149 int digit
= digit_to_number (*p
++, b
);
2155 return make_number (negative
* v
);
2160 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2162 extern Lisp_Object
float_arith_driver ();
2163 extern Lisp_Object
fmod_float ();
2166 arith_driver (code
, nargs
, args
)
2169 register Lisp_Object
*args
;
2171 register Lisp_Object val
;
2172 register int argnum
;
2173 register EMACS_INT accum
;
2174 register EMACS_INT next
;
2176 switch (SWITCH_ENUM_CAST (code
))
2189 for (argnum
= 0; argnum
< nargs
; argnum
++)
2191 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2192 #ifdef LISP_FLOAT_TYPE
2193 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2195 if (FLOATP (val
)) /* time to do serious math */
2196 return (float_arith_driver ((double) accum
, argnum
, code
,
2199 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2200 #endif /* LISP_FLOAT_TYPE */
2201 args
[argnum
] = val
; /* runs into a compiler bug. */
2202 next
= XINT (args
[argnum
]);
2203 switch (SWITCH_ENUM_CAST (code
))
2205 case Aadd
: accum
+= next
; break;
2207 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2209 case Amult
: accum
*= next
; break;
2211 if (!argnum
) accum
= next
;
2215 Fsignal (Qarith_error
, Qnil
);
2219 case Alogand
: accum
&= next
; break;
2220 case Alogior
: accum
|= next
; break;
2221 case Alogxor
: accum
^= next
; break;
2222 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2223 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2227 XSETINT (val
, accum
);
2232 #define isnan(x) ((x) != (x))
2234 #ifdef LISP_FLOAT_TYPE
2237 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2239 register int argnum
;
2242 register Lisp_Object
*args
;
2244 register Lisp_Object val
;
2247 for (; argnum
< nargs
; argnum
++)
2249 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2250 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2254 next
= XFLOAT (val
)->data
;
2258 args
[argnum
] = val
; /* runs into a compiler bug. */
2259 next
= XINT (args
[argnum
]);
2261 switch (SWITCH_ENUM_CAST (code
))
2267 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2277 if (! IEEE_FLOATING_POINT
&& next
== 0)
2278 Fsignal (Qarith_error
, Qnil
);
2285 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2287 if (!argnum
|| isnan (next
) || next
> accum
)
2291 if (!argnum
|| isnan (next
) || next
< accum
)
2297 return make_float (accum
);
2299 #endif /* LISP_FLOAT_TYPE */
2301 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2302 "Return sum of any number of arguments, which are numbers or markers.")
2307 return arith_driver (Aadd
, nargs
, args
);
2310 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2311 "Negate number or subtract numbers or markers.\n\
2312 With one arg, negates it. With more than one arg,\n\
2313 subtracts all but the first from the first.")
2318 return arith_driver (Asub
, nargs
, args
);
2321 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2322 "Returns product of any number of arguments, which are numbers or markers.")
2327 return arith_driver (Amult
, nargs
, args
);
2330 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2331 "Returns first argument divided by all the remaining arguments.\n\
2332 The arguments must be numbers or markers.")
2337 return arith_driver (Adiv
, nargs
, args
);
2340 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2341 "Returns remainder of X divided by Y.\n\
2342 Both must be integers or markers.")
2344 register Lisp_Object x
, y
;
2348 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2349 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2351 if (XFASTINT (y
) == 0)
2352 Fsignal (Qarith_error
, Qnil
);
2354 XSETINT (val
, XINT (x
) % XINT (y
));
2368 /* If the magnitude of the result exceeds that of the divisor, or
2369 the sign of the result does not agree with that of the dividend,
2370 iterate with the reduced value. This does not yield a
2371 particularly accurate result, but at least it will be in the
2372 range promised by fmod. */
2374 r
-= f2
* floor (r
/ f2
);
2375 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2379 #endif /* ! HAVE_FMOD */
2381 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2382 "Returns X modulo Y.\n\
2383 The result falls between zero (inclusive) and Y (exclusive).\n\
2384 Both X and Y must be numbers or markers.")
2386 register Lisp_Object x
, y
;
2391 #ifdef LISP_FLOAT_TYPE
2392 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2393 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2395 if (FLOATP (x
) || FLOATP (y
))
2396 return fmod_float (x
, y
);
2398 #else /* not LISP_FLOAT_TYPE */
2399 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2400 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2401 #endif /* not LISP_FLOAT_TYPE */
2407 Fsignal (Qarith_error
, Qnil
);
2411 /* If the "remainder" comes out with the wrong sign, fix it. */
2412 if (i2
< 0 ? i1
> 0 : i1
< 0)
2419 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2420 "Return largest of all the arguments (which must be numbers or markers).\n\
2421 The value is always a number; markers are converted to numbers.")
2426 return arith_driver (Amax
, nargs
, args
);
2429 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2430 "Return smallest of all the arguments (which must be numbers or markers).\n\
2431 The value is always a number; markers are converted to numbers.")
2436 return arith_driver (Amin
, nargs
, args
);
2439 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2440 "Return bitwise-and of all the arguments.\n\
2441 Arguments may be integers, or markers converted to integers.")
2446 return arith_driver (Alogand
, nargs
, args
);
2449 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2450 "Return bitwise-or of all the arguments.\n\
2451 Arguments may be integers, or markers converted to integers.")
2456 return arith_driver (Alogior
, nargs
, args
);
2459 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2460 "Return bitwise-exclusive-or of all the arguments.\n\
2461 Arguments may be integers, or markers converted to integers.")
2466 return arith_driver (Alogxor
, nargs
, args
);
2469 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2470 "Return VALUE with its bits shifted left by COUNT.\n\
2471 If COUNT is negative, shifting is actually to the right.\n\
2472 In this case, the sign bit is duplicated.")
2474 register Lisp_Object value
, count
;
2476 register Lisp_Object val
;
2478 CHECK_NUMBER (value
, 0);
2479 CHECK_NUMBER (count
, 1);
2481 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2483 else if (XINT (count
) > 0)
2484 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2485 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2486 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2488 XSETINT (val
, XINT (value
) >> -XINT (count
));
2492 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2493 "Return VALUE with its bits shifted left by COUNT.\n\
2494 If COUNT is negative, shifting is actually to the right.\n\
2495 In this case, zeros are shifted in on the left.")
2497 register Lisp_Object value
, count
;
2499 register Lisp_Object val
;
2501 CHECK_NUMBER (value
, 0);
2502 CHECK_NUMBER (count
, 1);
2504 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2506 else if (XINT (count
) > 0)
2507 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2508 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2511 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2515 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2516 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2517 Markers are converted to integers.")
2519 register Lisp_Object number
;
2521 #ifdef LISP_FLOAT_TYPE
2522 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2524 if (FLOATP (number
))
2525 return (make_float (1.0 + XFLOAT (number
)->data
));
2527 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2528 #endif /* LISP_FLOAT_TYPE */
2530 XSETINT (number
, XINT (number
) + 1);
2534 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2535 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2536 Markers are converted to integers.")
2538 register Lisp_Object number
;
2540 #ifdef LISP_FLOAT_TYPE
2541 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2543 if (FLOATP (number
))
2544 return (make_float (-1.0 + XFLOAT (number
)->data
));
2546 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2547 #endif /* LISP_FLOAT_TYPE */
2549 XSETINT (number
, XINT (number
) - 1);
2553 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2554 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2556 register Lisp_Object number
;
2558 CHECK_NUMBER (number
, 0);
2559 XSETINT (number
, ~XINT (number
));
2566 Lisp_Object error_tail
, arith_tail
;
2568 Qquote
= intern ("quote");
2569 Qlambda
= intern ("lambda");
2570 Qsubr
= intern ("subr");
2571 Qerror_conditions
= intern ("error-conditions");
2572 Qerror_message
= intern ("error-message");
2573 Qtop_level
= intern ("top-level");
2575 Qerror
= intern ("error");
2576 Qquit
= intern ("quit");
2577 Qwrong_type_argument
= intern ("wrong-type-argument");
2578 Qargs_out_of_range
= intern ("args-out-of-range");
2579 Qvoid_function
= intern ("void-function");
2580 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2581 Qvoid_variable
= intern ("void-variable");
2582 Qsetting_constant
= intern ("setting-constant");
2583 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2585 Qinvalid_function
= intern ("invalid-function");
2586 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2587 Qno_catch
= intern ("no-catch");
2588 Qend_of_file
= intern ("end-of-file");
2589 Qarith_error
= intern ("arith-error");
2590 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2591 Qend_of_buffer
= intern ("end-of-buffer");
2592 Qbuffer_read_only
= intern ("buffer-read-only");
2593 Qmark_inactive
= intern ("mark-inactive");
2595 Qlistp
= intern ("listp");
2596 Qconsp
= intern ("consp");
2597 Qsymbolp
= intern ("symbolp");
2598 Qintegerp
= intern ("integerp");
2599 Qnatnump
= intern ("natnump");
2600 Qwholenump
= intern ("wholenump");
2601 Qstringp
= intern ("stringp");
2602 Qarrayp
= intern ("arrayp");
2603 Qsequencep
= intern ("sequencep");
2604 Qbufferp
= intern ("bufferp");
2605 Qvectorp
= intern ("vectorp");
2606 Qchar_or_string_p
= intern ("char-or-string-p");
2607 Qmarkerp
= intern ("markerp");
2608 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2609 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2610 Qboundp
= intern ("boundp");
2611 Qfboundp
= intern ("fboundp");
2613 #ifdef LISP_FLOAT_TYPE
2614 Qfloatp
= intern ("floatp");
2615 Qnumberp
= intern ("numberp");
2616 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2617 #endif /* LISP_FLOAT_TYPE */
2619 Qchar_table_p
= intern ("char-table-p");
2620 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2622 Qcdr
= intern ("cdr");
2624 /* Handle automatic advice activation */
2625 Qad_advice_info
= intern ("ad-advice-info");
2626 Qad_activate
= intern ("ad-activate");
2628 error_tail
= Fcons (Qerror
, Qnil
);
2630 /* ERROR is used as a signaler for random errors for which nothing else is right */
2632 Fput (Qerror
, Qerror_conditions
,
2634 Fput (Qerror
, Qerror_message
,
2635 build_string ("error"));
2637 Fput (Qquit
, Qerror_conditions
,
2638 Fcons (Qquit
, Qnil
));
2639 Fput (Qquit
, Qerror_message
,
2640 build_string ("Quit"));
2642 Fput (Qwrong_type_argument
, Qerror_conditions
,
2643 Fcons (Qwrong_type_argument
, error_tail
));
2644 Fput (Qwrong_type_argument
, Qerror_message
,
2645 build_string ("Wrong type argument"));
2647 Fput (Qargs_out_of_range
, Qerror_conditions
,
2648 Fcons (Qargs_out_of_range
, error_tail
));
2649 Fput (Qargs_out_of_range
, Qerror_message
,
2650 build_string ("Args out of range"));
2652 Fput (Qvoid_function
, Qerror_conditions
,
2653 Fcons (Qvoid_function
, error_tail
));
2654 Fput (Qvoid_function
, Qerror_message
,
2655 build_string ("Symbol's function definition is void"));
2657 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2658 Fcons (Qcyclic_function_indirection
, error_tail
));
2659 Fput (Qcyclic_function_indirection
, Qerror_message
,
2660 build_string ("Symbol's chain of function indirections contains a loop"));
2662 Fput (Qvoid_variable
, Qerror_conditions
,
2663 Fcons (Qvoid_variable
, error_tail
));
2664 Fput (Qvoid_variable
, Qerror_message
,
2665 build_string ("Symbol's value as variable is void"));
2667 Fput (Qsetting_constant
, Qerror_conditions
,
2668 Fcons (Qsetting_constant
, error_tail
));
2669 Fput (Qsetting_constant
, Qerror_message
,
2670 build_string ("Attempt to set a constant symbol"));
2672 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2673 Fcons (Qinvalid_read_syntax
, error_tail
));
2674 Fput (Qinvalid_read_syntax
, Qerror_message
,
2675 build_string ("Invalid read syntax"));
2677 Fput (Qinvalid_function
, Qerror_conditions
,
2678 Fcons (Qinvalid_function
, error_tail
));
2679 Fput (Qinvalid_function
, Qerror_message
,
2680 build_string ("Invalid function"));
2682 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2683 Fcons (Qwrong_number_of_arguments
, error_tail
));
2684 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2685 build_string ("Wrong number of arguments"));
2687 Fput (Qno_catch
, Qerror_conditions
,
2688 Fcons (Qno_catch
, error_tail
));
2689 Fput (Qno_catch
, Qerror_message
,
2690 build_string ("No catch for tag"));
2692 Fput (Qend_of_file
, Qerror_conditions
,
2693 Fcons (Qend_of_file
, error_tail
));
2694 Fput (Qend_of_file
, Qerror_message
,
2695 build_string ("End of file during parsing"));
2697 arith_tail
= Fcons (Qarith_error
, error_tail
);
2698 Fput (Qarith_error
, Qerror_conditions
,
2700 Fput (Qarith_error
, Qerror_message
,
2701 build_string ("Arithmetic error"));
2703 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2704 Fcons (Qbeginning_of_buffer
, error_tail
));
2705 Fput (Qbeginning_of_buffer
, Qerror_message
,
2706 build_string ("Beginning of buffer"));
2708 Fput (Qend_of_buffer
, Qerror_conditions
,
2709 Fcons (Qend_of_buffer
, error_tail
));
2710 Fput (Qend_of_buffer
, Qerror_message
,
2711 build_string ("End of buffer"));
2713 Fput (Qbuffer_read_only
, Qerror_conditions
,
2714 Fcons (Qbuffer_read_only
, error_tail
));
2715 Fput (Qbuffer_read_only
, Qerror_message
,
2716 build_string ("Buffer is read-only"));
2718 #ifdef LISP_FLOAT_TYPE
2719 Qrange_error
= intern ("range-error");
2720 Qdomain_error
= intern ("domain-error");
2721 Qsingularity_error
= intern ("singularity-error");
2722 Qoverflow_error
= intern ("overflow-error");
2723 Qunderflow_error
= intern ("underflow-error");
2725 Fput (Qdomain_error
, Qerror_conditions
,
2726 Fcons (Qdomain_error
, arith_tail
));
2727 Fput (Qdomain_error
, Qerror_message
,
2728 build_string ("Arithmetic domain error"));
2730 Fput (Qrange_error
, Qerror_conditions
,
2731 Fcons (Qrange_error
, arith_tail
));
2732 Fput (Qrange_error
, Qerror_message
,
2733 build_string ("Arithmetic range error"));
2735 Fput (Qsingularity_error
, Qerror_conditions
,
2736 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2737 Fput (Qsingularity_error
, Qerror_message
,
2738 build_string ("Arithmetic singularity error"));
2740 Fput (Qoverflow_error
, Qerror_conditions
,
2741 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2742 Fput (Qoverflow_error
, Qerror_message
,
2743 build_string ("Arithmetic overflow error"));
2745 Fput (Qunderflow_error
, Qerror_conditions
,
2746 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2747 Fput (Qunderflow_error
, Qerror_message
,
2748 build_string ("Arithmetic underflow error"));
2750 staticpro (&Qrange_error
);
2751 staticpro (&Qdomain_error
);
2752 staticpro (&Qsingularity_error
);
2753 staticpro (&Qoverflow_error
);
2754 staticpro (&Qunderflow_error
);
2755 #endif /* LISP_FLOAT_TYPE */
2759 staticpro (&Qquote
);
2760 staticpro (&Qlambda
);
2762 staticpro (&Qunbound
);
2763 staticpro (&Qerror_conditions
);
2764 staticpro (&Qerror_message
);
2765 staticpro (&Qtop_level
);
2767 staticpro (&Qerror
);
2769 staticpro (&Qwrong_type_argument
);
2770 staticpro (&Qargs_out_of_range
);
2771 staticpro (&Qvoid_function
);
2772 staticpro (&Qcyclic_function_indirection
);
2773 staticpro (&Qvoid_variable
);
2774 staticpro (&Qsetting_constant
);
2775 staticpro (&Qinvalid_read_syntax
);
2776 staticpro (&Qwrong_number_of_arguments
);
2777 staticpro (&Qinvalid_function
);
2778 staticpro (&Qno_catch
);
2779 staticpro (&Qend_of_file
);
2780 staticpro (&Qarith_error
);
2781 staticpro (&Qbeginning_of_buffer
);
2782 staticpro (&Qend_of_buffer
);
2783 staticpro (&Qbuffer_read_only
);
2784 staticpro (&Qmark_inactive
);
2786 staticpro (&Qlistp
);
2787 staticpro (&Qconsp
);
2788 staticpro (&Qsymbolp
);
2789 staticpro (&Qintegerp
);
2790 staticpro (&Qnatnump
);
2791 staticpro (&Qwholenump
);
2792 staticpro (&Qstringp
);
2793 staticpro (&Qarrayp
);
2794 staticpro (&Qsequencep
);
2795 staticpro (&Qbufferp
);
2796 staticpro (&Qvectorp
);
2797 staticpro (&Qchar_or_string_p
);
2798 staticpro (&Qmarkerp
);
2799 staticpro (&Qbuffer_or_string_p
);
2800 staticpro (&Qinteger_or_marker_p
);
2801 #ifdef LISP_FLOAT_TYPE
2802 staticpro (&Qfloatp
);
2803 staticpro (&Qnumberp
);
2804 staticpro (&Qnumber_or_marker_p
);
2805 #endif /* LISP_FLOAT_TYPE */
2806 staticpro (&Qchar_table_p
);
2807 staticpro (&Qvector_or_char_table_p
);
2809 staticpro (&Qboundp
);
2810 staticpro (&Qfboundp
);
2812 staticpro (&Qad_advice_info
);
2813 staticpro (&Qad_activate
);
2815 /* Types that type-of returns. */
2816 Qinteger
= intern ("integer");
2817 Qsymbol
= intern ("symbol");
2818 Qstring
= intern ("string");
2819 Qcons
= intern ("cons");
2820 Qmarker
= intern ("marker");
2821 Qoverlay
= intern ("overlay");
2822 Qfloat
= intern ("float");
2823 Qwindow_configuration
= intern ("window-configuration");
2824 Qprocess
= intern ("process");
2825 Qwindow
= intern ("window");
2826 /* Qsubr = intern ("subr"); */
2827 Qcompiled_function
= intern ("compiled-function");
2828 Qbuffer
= intern ("buffer");
2829 Qframe
= intern ("frame");
2830 Qvector
= intern ("vector");
2831 Qchar_table
= intern ("char-table");
2832 Qbool_vector
= intern ("bool-vector");
2834 staticpro (&Qinteger
);
2835 staticpro (&Qsymbol
);
2836 staticpro (&Qstring
);
2838 staticpro (&Qmarker
);
2839 staticpro (&Qoverlay
);
2840 staticpro (&Qfloat
);
2841 staticpro (&Qwindow_configuration
);
2842 staticpro (&Qprocess
);
2843 staticpro (&Qwindow
);
2844 /* staticpro (&Qsubr); */
2845 staticpro (&Qcompiled_function
);
2846 staticpro (&Qbuffer
);
2847 staticpro (&Qframe
);
2848 staticpro (&Qvector
);
2849 staticpro (&Qchar_table
);
2850 staticpro (&Qbool_vector
);
2852 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2853 "Non-nil means it is an error to set a keyword symbol.\n\
2854 A keyword symbol is a symbol whose name starts with a colon (`:').");
2855 keyword_symbols_constant_flag
= 1;
2859 defsubr (&Stype_of
);
2864 defsubr (&Sintegerp
);
2865 defsubr (&Sinteger_or_marker_p
);
2866 defsubr (&Snumberp
);
2867 defsubr (&Snumber_or_marker_p
);
2868 #ifdef LISP_FLOAT_TYPE
2870 #endif /* LISP_FLOAT_TYPE */
2871 defsubr (&Snatnump
);
2872 defsubr (&Ssymbolp
);
2873 defsubr (&Sstringp
);
2874 defsubr (&Smultibyte_string_p
);
2875 defsubr (&Svectorp
);
2876 defsubr (&Schar_table_p
);
2877 defsubr (&Svector_or_char_table_p
);
2878 defsubr (&Sbool_vector_p
);
2880 defsubr (&Ssequencep
);
2881 defsubr (&Sbufferp
);
2882 defsubr (&Smarkerp
);
2884 defsubr (&Sbyte_code_function_p
);
2885 defsubr (&Schar_or_string_p
);
2888 defsubr (&Scar_safe
);
2889 defsubr (&Scdr_safe
);
2892 defsubr (&Ssymbol_function
);
2893 defsubr (&Sindirect_function
);
2894 defsubr (&Ssymbol_plist
);
2895 defsubr (&Ssymbol_name
);
2896 defsubr (&Smakunbound
);
2897 defsubr (&Sfmakunbound
);
2899 defsubr (&Sfboundp
);
2901 defsubr (&Sdefalias
);
2902 defsubr (&Ssetplist
);
2903 defsubr (&Ssymbol_value
);
2905 defsubr (&Sdefault_boundp
);
2906 defsubr (&Sdefault_value
);
2907 defsubr (&Sset_default
);
2908 defsubr (&Ssetq_default
);
2909 defsubr (&Smake_variable_buffer_local
);
2910 defsubr (&Smake_local_variable
);
2911 defsubr (&Skill_local_variable
);
2912 defsubr (&Smake_variable_frame_local
);
2913 defsubr (&Slocal_variable_p
);
2914 defsubr (&Slocal_variable_if_set_p
);
2917 defsubr (&Snumber_to_string
);
2918 defsubr (&Sstring_to_number
);
2919 defsubr (&Seqlsign
);
2943 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2950 #if defined(USG) && !defined(POSIX_SIGNALS)
2951 /* USG systems forget handlers when they are used;
2952 must reestablish each time */
2953 signal (signo
, arith_error
);
2956 /* VMS systems are like USG. */
2957 signal (signo
, arith_error
);
2961 #else /* not BSD4_1 */
2962 sigsetmask (SIGEMPTYMASK
);
2963 #endif /* not BSD4_1 */
2965 Fsignal (Qarith_error
, Qnil
);
2971 /* Don't do this if just dumping out.
2972 We don't want to call `signal' in this case
2973 so that we don't have trouble with dumping
2974 signal-delivering routines in an inconsistent state. */
2978 #endif /* CANNOT_DUMP */
2979 signal (SIGFPE
, arith_error
);
2982 signal (SIGEMT
, arith_error
);