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 || selected_frame
!= XFRAME (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
, 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 XSETFRAME (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
)
1018 selected_frame
!= XFRAME (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
, 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 XSETFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->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
))
1650 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1651 args_out_of_range (array
, idx
);
1652 if (! STRING_MULTIBYTE (array
))
1653 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1654 idxval_byte
= string_char_to_byte (array
, idxval
);
1656 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1657 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1658 return make_number (c
);
1660 else if (BOOL_VECTOR_P (array
))
1664 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1665 args_out_of_range (array
, idx
);
1667 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1668 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1670 else if (CHAR_TABLE_P (array
))
1675 args_out_of_range (array
, idx
);
1676 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1678 /* For ASCII and 8-bit European characters, the element is
1679 stored in the top table. */
1680 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1682 val
= XCHAR_TABLE (array
)->defalt
;
1683 while (NILP (val
)) /* Follow parents until we find some value. */
1685 array
= XCHAR_TABLE (array
)->parent
;
1688 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1690 val
= XCHAR_TABLE (array
)->defalt
;
1697 Lisp_Object sub_table
;
1699 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1700 if (code
[0] != CHARSET_COMPOSITION
)
1702 if (code
[1] < 32) code
[1] = -1;
1703 else if (code
[2] < 32) code
[2] = -1;
1705 /* Here, the possible range of CODE[0] (== charset ID) is
1706 128..MAX_CHARSET. Since the top level char table contains
1707 data for multibyte characters after 256th element, we must
1708 increment CODE[0] by 128 to get a correct index. */
1710 code
[3] = -1; /* anchor */
1712 try_parent_char_table
:
1714 for (i
= 0; code
[i
] >= 0; i
++)
1716 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1717 if (SUB_CHAR_TABLE_P (val
))
1722 val
= XCHAR_TABLE (sub_table
)->defalt
;
1725 array
= XCHAR_TABLE (array
)->parent
;
1727 goto try_parent_char_table
;
1732 /* Here, VAL is a sub char table. We try the default value
1734 val
= XCHAR_TABLE (val
)->defalt
;
1737 array
= XCHAR_TABLE (array
)->parent
;
1739 goto try_parent_char_table
;
1747 if (VECTORP (array
))
1748 size
= XVECTOR (array
)->size
;
1749 else if (COMPILEDP (array
))
1750 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1752 wrong_type_argument (Qarrayp
, array
);
1754 if (idxval
< 0 || idxval
>= size
)
1755 args_out_of_range (array
, idx
);
1756 return XVECTOR (array
)->contents
[idxval
];
1760 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1761 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1762 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1764 (array
, idx
, newelt
)
1765 register Lisp_Object array
;
1766 Lisp_Object idx
, newelt
;
1768 register int idxval
;
1770 CHECK_NUMBER (idx
, 1);
1771 idxval
= XINT (idx
);
1772 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1773 && ! CHAR_TABLE_P (array
))
1774 array
= wrong_type_argument (Qarrayp
, array
);
1775 CHECK_IMPURE (array
);
1777 if (VECTORP (array
))
1779 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1780 args_out_of_range (array
, idx
);
1781 XVECTOR (array
)->contents
[idxval
] = newelt
;
1783 else if (BOOL_VECTOR_P (array
))
1787 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1788 args_out_of_range (array
, idx
);
1790 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1792 if (! NILP (newelt
))
1793 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1795 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1796 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1798 else if (CHAR_TABLE_P (array
))
1803 args_out_of_range (array
, idx
);
1804 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1805 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1811 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1812 if (code
[0] != CHARSET_COMPOSITION
)
1814 if (code
[1] < 32) code
[1] = -1;
1815 else if (code
[2] < 32) code
[2] = -1;
1817 /* See the comment of the corresponding part in Faref. */
1819 code
[3] = -1; /* anchor */
1820 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1822 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1823 if (SUB_CHAR_TABLE_P (val
))
1829 /* VAL is a leaf. Create a sub char table with the
1830 default value VAL or XCHAR_TABLE (array)->defalt
1831 and look into it. */
1833 temp
= make_sub_char_table (NILP (val
)
1834 ? XCHAR_TABLE (array
)->defalt
1836 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1840 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1843 else if (STRING_MULTIBYTE (array
))
1845 int c
, idxval_byte
, new_len
, actual_len
;
1847 unsigned char *p
, workbuf
[4], *str
;
1849 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1850 args_out_of_range (array
, idx
);
1852 idxval_byte
= string_char_to_byte (array
, idxval
);
1853 p
= &XSTRING (array
)->data
[idxval_byte
];
1855 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1856 CHECK_NUMBER (newelt
, 2);
1857 new_len
= CHAR_STRING (XINT (newelt
), workbuf
, str
);
1858 if (actual_len
!= new_len
)
1859 error ("Attempt to change byte length of a string");
1861 /* We can't accept a change causing byte combining. */
1862 if (!ASCII_BYTE_P (*str
)
1863 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1864 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1865 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1866 > idxval_byte
- prev_byte
))
1867 || (idxval
< XSTRING (array
)->size
- 1
1868 && !CHAR_HEAD_P (p
[actual_len
])
1869 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1870 error ("Attempt to change char length of a string");
1876 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1877 args_out_of_range (array
, idx
);
1878 CHECK_NUMBER (newelt
, 2);
1879 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1885 /* Arithmetic functions */
1887 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1890 arithcompare (num1
, num2
, comparison
)
1891 Lisp_Object num1
, num2
;
1892 enum comparison comparison
;
1897 #ifdef LISP_FLOAT_TYPE
1898 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1899 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1901 if (FLOATP (num1
) || FLOATP (num2
))
1904 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1905 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1908 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1909 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1910 #endif /* LISP_FLOAT_TYPE */
1915 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1920 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1925 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1930 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1935 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1940 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1949 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1950 "Return t if two args, both numbers or markers, are equal.")
1952 register Lisp_Object num1
, num2
;
1954 return arithcompare (num1
, num2
, equal
);
1957 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1958 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1960 register Lisp_Object num1
, num2
;
1962 return arithcompare (num1
, num2
, less
);
1965 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1966 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1968 register Lisp_Object num1
, num2
;
1970 return arithcompare (num1
, num2
, grtr
);
1973 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1974 "Return t if first arg is less than or equal to second arg.\n\
1975 Both must be numbers or markers.")
1977 register Lisp_Object num1
, num2
;
1979 return arithcompare (num1
, num2
, less_or_equal
);
1982 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1983 "Return t if first arg is greater than or equal to second arg.\n\
1984 Both must be numbers or markers.")
1986 register Lisp_Object num1
, num2
;
1988 return arithcompare (num1
, num2
, grtr_or_equal
);
1991 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1992 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1994 register Lisp_Object num1
, num2
;
1996 return arithcompare (num1
, num2
, notequal
);
1999 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2001 register Lisp_Object number
;
2003 #ifdef LISP_FLOAT_TYPE
2004 CHECK_NUMBER_OR_FLOAT (number
, 0);
2006 if (FLOATP (number
))
2008 if (XFLOAT(number
)->data
== 0.0)
2013 CHECK_NUMBER (number
, 0);
2014 #endif /* LISP_FLOAT_TYPE */
2021 /* Convert between long values and pairs of Lisp integers. */
2027 unsigned int top
= i
>> 16;
2028 unsigned int bot
= i
& 0xFFFF;
2030 return make_number (bot
);
2031 if (top
== (unsigned long)-1 >> 16)
2032 return Fcons (make_number (-1), make_number (bot
));
2033 return Fcons (make_number (top
), make_number (bot
));
2040 Lisp_Object top
, bot
;
2043 top
= XCONS (c
)->car
;
2044 bot
= XCONS (c
)->cdr
;
2046 bot
= XCONS (bot
)->car
;
2047 return ((XINT (top
) << 16) | XINT (bot
));
2050 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2051 "Convert NUMBER to a string by printing it in decimal.\n\
2052 Uses a minus sign if negative.\n\
2053 NUMBER may be an integer or a floating point number.")
2057 char buffer
[VALBITS
];
2059 #ifndef LISP_FLOAT_TYPE
2060 CHECK_NUMBER (number
, 0);
2062 CHECK_NUMBER_OR_FLOAT (number
, 0);
2064 if (FLOATP (number
))
2066 char pigbuf
[350]; /* see comments in float_to_string */
2068 float_to_string (pigbuf
, XFLOAT(number
)->data
);
2069 return build_string (pigbuf
);
2071 #endif /* LISP_FLOAT_TYPE */
2073 if (sizeof (int) == sizeof (EMACS_INT
))
2074 sprintf (buffer
, "%d", XINT (number
));
2075 else if (sizeof (long) == sizeof (EMACS_INT
))
2076 sprintf (buffer
, "%ld", XINT (number
));
2079 return build_string (buffer
);
2083 digit_to_number (character
, base
)
2084 int character
, base
;
2088 if (character
>= '0' && character
<= '9')
2089 digit
= character
- '0';
2090 else if (character
>= 'a' && character
<= 'z')
2091 digit
= character
- 'a' + 10;
2092 else if (character
>= 'A' && character
<= 'Z')
2093 digit
= character
- 'A' + 10;
2103 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2104 "Convert STRING to a number by parsing it as a decimal number.\n\
2105 This parses both integers and floating point numbers.\n\
2106 It ignores leading spaces and tabs.\n\
2108 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2109 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2110 If the base used is not 10, floating point is not recognized.")
2112 register Lisp_Object string
, base
;
2114 register unsigned char *p
;
2115 register int b
, digit
, v
= 0;
2118 CHECK_STRING (string
, 0);
2124 CHECK_NUMBER (base
, 1);
2126 if (b
< 2 || b
> 16)
2127 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2130 p
= XSTRING (string
)->data
;
2132 /* Skip any whitespace at the front of the number. Some versions of
2133 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2134 while (*p
== ' ' || *p
== '\t')
2145 #ifdef LISP_FLOAT_TYPE
2146 if (isfloat_string (p
) && b
== 10)
2147 return make_float (negative
* atof (p
));
2148 #endif /* LISP_FLOAT_TYPE */
2152 int digit
= digit_to_number (*p
++, b
);
2158 return make_number (negative
* v
);
2163 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2165 extern Lisp_Object
float_arith_driver ();
2166 extern Lisp_Object
fmod_float ();
2169 arith_driver (code
, nargs
, args
)
2172 register Lisp_Object
*args
;
2174 register Lisp_Object val
;
2175 register int argnum
;
2176 register EMACS_INT accum
;
2177 register EMACS_INT next
;
2179 switch (SWITCH_ENUM_CAST (code
))
2192 for (argnum
= 0; argnum
< nargs
; argnum
++)
2194 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2195 #ifdef LISP_FLOAT_TYPE
2196 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2198 if (FLOATP (val
)) /* time to do serious math */
2199 return (float_arith_driver ((double) accum
, argnum
, code
,
2202 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2203 #endif /* LISP_FLOAT_TYPE */
2204 args
[argnum
] = val
; /* runs into a compiler bug. */
2205 next
= XINT (args
[argnum
]);
2206 switch (SWITCH_ENUM_CAST (code
))
2208 case Aadd
: accum
+= next
; break;
2210 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2212 case Amult
: accum
*= next
; break;
2214 if (!argnum
) accum
= next
;
2218 Fsignal (Qarith_error
, Qnil
);
2222 case Alogand
: accum
&= next
; break;
2223 case Alogior
: accum
|= next
; break;
2224 case Alogxor
: accum
^= next
; break;
2225 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2226 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2230 XSETINT (val
, accum
);
2235 #define isnan(x) ((x) != (x))
2237 #ifdef LISP_FLOAT_TYPE
2240 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2242 register int argnum
;
2245 register Lisp_Object
*args
;
2247 register Lisp_Object val
;
2250 for (; argnum
< nargs
; argnum
++)
2252 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2253 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2257 next
= XFLOAT (val
)->data
;
2261 args
[argnum
] = val
; /* runs into a compiler bug. */
2262 next
= XINT (args
[argnum
]);
2264 switch (SWITCH_ENUM_CAST (code
))
2270 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2280 if (! IEEE_FLOATING_POINT
&& next
== 0)
2281 Fsignal (Qarith_error
, Qnil
);
2288 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2290 if (!argnum
|| isnan (next
) || next
> accum
)
2294 if (!argnum
|| isnan (next
) || next
< accum
)
2300 return make_float (accum
);
2302 #endif /* LISP_FLOAT_TYPE */
2304 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2305 "Return sum of any number of arguments, which are numbers or markers.")
2310 return arith_driver (Aadd
, nargs
, args
);
2313 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2314 "Negate number or subtract numbers or markers.\n\
2315 With one arg, negates it. With more than one arg,\n\
2316 subtracts all but the first from the first.")
2321 return arith_driver (Asub
, nargs
, args
);
2324 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2325 "Returns product of any number of arguments, which are numbers or markers.")
2330 return arith_driver (Amult
, nargs
, args
);
2333 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2334 "Returns first argument divided by all the remaining arguments.\n\
2335 The arguments must be numbers or markers.")
2340 return arith_driver (Adiv
, nargs
, args
);
2343 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2344 "Returns remainder of X divided by Y.\n\
2345 Both must be integers or markers.")
2347 register Lisp_Object x
, y
;
2351 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2352 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2354 if (XFASTINT (y
) == 0)
2355 Fsignal (Qarith_error
, Qnil
);
2357 XSETINT (val
, XINT (x
) % XINT (y
));
2371 /* If the magnitude of the result exceeds that of the divisor, or
2372 the sign of the result does not agree with that of the dividend,
2373 iterate with the reduced value. This does not yield a
2374 particularly accurate result, but at least it will be in the
2375 range promised by fmod. */
2377 r
-= f2
* floor (r
/ f2
);
2378 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2382 #endif /* ! HAVE_FMOD */
2384 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2385 "Returns X modulo Y.\n\
2386 The result falls between zero (inclusive) and Y (exclusive).\n\
2387 Both X and Y must be numbers or markers.")
2389 register Lisp_Object x
, y
;
2394 #ifdef LISP_FLOAT_TYPE
2395 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2396 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2398 if (FLOATP (x
) || FLOATP (y
))
2399 return fmod_float (x
, y
);
2401 #else /* not LISP_FLOAT_TYPE */
2402 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2403 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2404 #endif /* not LISP_FLOAT_TYPE */
2410 Fsignal (Qarith_error
, Qnil
);
2414 /* If the "remainder" comes out with the wrong sign, fix it. */
2415 if (i2
< 0 ? i1
> 0 : i1
< 0)
2422 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2423 "Return largest of all the arguments (which must be numbers or markers).\n\
2424 The value is always a number; markers are converted to numbers.")
2429 return arith_driver (Amax
, nargs
, args
);
2432 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2433 "Return smallest of all the arguments (which must be numbers or markers).\n\
2434 The value is always a number; markers are converted to numbers.")
2439 return arith_driver (Amin
, nargs
, args
);
2442 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2443 "Return bitwise-and of all the arguments.\n\
2444 Arguments may be integers, or markers converted to integers.")
2449 return arith_driver (Alogand
, nargs
, args
);
2452 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2453 "Return bitwise-or of all the arguments.\n\
2454 Arguments may be integers, or markers converted to integers.")
2459 return arith_driver (Alogior
, nargs
, args
);
2462 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2463 "Return bitwise-exclusive-or of all the arguments.\n\
2464 Arguments may be integers, or markers converted to integers.")
2469 return arith_driver (Alogxor
, nargs
, args
);
2472 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2473 "Return VALUE with its bits shifted left by COUNT.\n\
2474 If COUNT is negative, shifting is actually to the right.\n\
2475 In this case, the sign bit is duplicated.")
2477 register Lisp_Object value
, count
;
2479 register Lisp_Object val
;
2481 CHECK_NUMBER (value
, 0);
2482 CHECK_NUMBER (count
, 1);
2484 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2486 else if (XINT (count
) > 0)
2487 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2488 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2489 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2491 XSETINT (val
, XINT (value
) >> -XINT (count
));
2495 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2496 "Return VALUE with its bits shifted left by COUNT.\n\
2497 If COUNT is negative, shifting is actually to the right.\n\
2498 In this case, zeros are shifted in on the left.")
2500 register Lisp_Object value
, count
;
2502 register Lisp_Object val
;
2504 CHECK_NUMBER (value
, 0);
2505 CHECK_NUMBER (count
, 1);
2507 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2509 else if (XINT (count
) > 0)
2510 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2511 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2514 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2518 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2519 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2520 Markers are converted to integers.")
2522 register Lisp_Object number
;
2524 #ifdef LISP_FLOAT_TYPE
2525 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2527 if (FLOATP (number
))
2528 return (make_float (1.0 + XFLOAT (number
)->data
));
2530 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2531 #endif /* LISP_FLOAT_TYPE */
2533 XSETINT (number
, XINT (number
) + 1);
2537 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2538 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2539 Markers are converted to integers.")
2541 register Lisp_Object number
;
2543 #ifdef LISP_FLOAT_TYPE
2544 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2546 if (FLOATP (number
))
2547 return (make_float (-1.0 + XFLOAT (number
)->data
));
2549 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2550 #endif /* LISP_FLOAT_TYPE */
2552 XSETINT (number
, XINT (number
) - 1);
2556 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2557 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2559 register Lisp_Object number
;
2561 CHECK_NUMBER (number
, 0);
2562 XSETINT (number
, ~XINT (number
));
2569 Lisp_Object error_tail
, arith_tail
;
2571 Qquote
= intern ("quote");
2572 Qlambda
= intern ("lambda");
2573 Qsubr
= intern ("subr");
2574 Qerror_conditions
= intern ("error-conditions");
2575 Qerror_message
= intern ("error-message");
2576 Qtop_level
= intern ("top-level");
2578 Qerror
= intern ("error");
2579 Qquit
= intern ("quit");
2580 Qwrong_type_argument
= intern ("wrong-type-argument");
2581 Qargs_out_of_range
= intern ("args-out-of-range");
2582 Qvoid_function
= intern ("void-function");
2583 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2584 Qvoid_variable
= intern ("void-variable");
2585 Qsetting_constant
= intern ("setting-constant");
2586 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2588 Qinvalid_function
= intern ("invalid-function");
2589 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2590 Qno_catch
= intern ("no-catch");
2591 Qend_of_file
= intern ("end-of-file");
2592 Qarith_error
= intern ("arith-error");
2593 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2594 Qend_of_buffer
= intern ("end-of-buffer");
2595 Qbuffer_read_only
= intern ("buffer-read-only");
2596 Qmark_inactive
= intern ("mark-inactive");
2598 Qlistp
= intern ("listp");
2599 Qconsp
= intern ("consp");
2600 Qsymbolp
= intern ("symbolp");
2601 Qintegerp
= intern ("integerp");
2602 Qnatnump
= intern ("natnump");
2603 Qwholenump
= intern ("wholenump");
2604 Qstringp
= intern ("stringp");
2605 Qarrayp
= intern ("arrayp");
2606 Qsequencep
= intern ("sequencep");
2607 Qbufferp
= intern ("bufferp");
2608 Qvectorp
= intern ("vectorp");
2609 Qchar_or_string_p
= intern ("char-or-string-p");
2610 Qmarkerp
= intern ("markerp");
2611 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2612 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2613 Qboundp
= intern ("boundp");
2614 Qfboundp
= intern ("fboundp");
2616 #ifdef LISP_FLOAT_TYPE
2617 Qfloatp
= intern ("floatp");
2618 Qnumberp
= intern ("numberp");
2619 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2620 #endif /* LISP_FLOAT_TYPE */
2622 Qchar_table_p
= intern ("char-table-p");
2623 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2625 Qcdr
= intern ("cdr");
2627 /* Handle automatic advice activation */
2628 Qad_advice_info
= intern ("ad-advice-info");
2629 Qad_activate
= intern ("ad-activate");
2631 error_tail
= Fcons (Qerror
, Qnil
);
2633 /* ERROR is used as a signaler for random errors for which nothing else is right */
2635 Fput (Qerror
, Qerror_conditions
,
2637 Fput (Qerror
, Qerror_message
,
2638 build_string ("error"));
2640 Fput (Qquit
, Qerror_conditions
,
2641 Fcons (Qquit
, Qnil
));
2642 Fput (Qquit
, Qerror_message
,
2643 build_string ("Quit"));
2645 Fput (Qwrong_type_argument
, Qerror_conditions
,
2646 Fcons (Qwrong_type_argument
, error_tail
));
2647 Fput (Qwrong_type_argument
, Qerror_message
,
2648 build_string ("Wrong type argument"));
2650 Fput (Qargs_out_of_range
, Qerror_conditions
,
2651 Fcons (Qargs_out_of_range
, error_tail
));
2652 Fput (Qargs_out_of_range
, Qerror_message
,
2653 build_string ("Args out of range"));
2655 Fput (Qvoid_function
, Qerror_conditions
,
2656 Fcons (Qvoid_function
, error_tail
));
2657 Fput (Qvoid_function
, Qerror_message
,
2658 build_string ("Symbol's function definition is void"));
2660 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2661 Fcons (Qcyclic_function_indirection
, error_tail
));
2662 Fput (Qcyclic_function_indirection
, Qerror_message
,
2663 build_string ("Symbol's chain of function indirections contains a loop"));
2665 Fput (Qvoid_variable
, Qerror_conditions
,
2666 Fcons (Qvoid_variable
, error_tail
));
2667 Fput (Qvoid_variable
, Qerror_message
,
2668 build_string ("Symbol's value as variable is void"));
2670 Fput (Qsetting_constant
, Qerror_conditions
,
2671 Fcons (Qsetting_constant
, error_tail
));
2672 Fput (Qsetting_constant
, Qerror_message
,
2673 build_string ("Attempt to set a constant symbol"));
2675 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2676 Fcons (Qinvalid_read_syntax
, error_tail
));
2677 Fput (Qinvalid_read_syntax
, Qerror_message
,
2678 build_string ("Invalid read syntax"));
2680 Fput (Qinvalid_function
, Qerror_conditions
,
2681 Fcons (Qinvalid_function
, error_tail
));
2682 Fput (Qinvalid_function
, Qerror_message
,
2683 build_string ("Invalid function"));
2685 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2686 Fcons (Qwrong_number_of_arguments
, error_tail
));
2687 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2688 build_string ("Wrong number of arguments"));
2690 Fput (Qno_catch
, Qerror_conditions
,
2691 Fcons (Qno_catch
, error_tail
));
2692 Fput (Qno_catch
, Qerror_message
,
2693 build_string ("No catch for tag"));
2695 Fput (Qend_of_file
, Qerror_conditions
,
2696 Fcons (Qend_of_file
, error_tail
));
2697 Fput (Qend_of_file
, Qerror_message
,
2698 build_string ("End of file during parsing"));
2700 arith_tail
= Fcons (Qarith_error
, error_tail
);
2701 Fput (Qarith_error
, Qerror_conditions
,
2703 Fput (Qarith_error
, Qerror_message
,
2704 build_string ("Arithmetic error"));
2706 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2707 Fcons (Qbeginning_of_buffer
, error_tail
));
2708 Fput (Qbeginning_of_buffer
, Qerror_message
,
2709 build_string ("Beginning of buffer"));
2711 Fput (Qend_of_buffer
, Qerror_conditions
,
2712 Fcons (Qend_of_buffer
, error_tail
));
2713 Fput (Qend_of_buffer
, Qerror_message
,
2714 build_string ("End of buffer"));
2716 Fput (Qbuffer_read_only
, Qerror_conditions
,
2717 Fcons (Qbuffer_read_only
, error_tail
));
2718 Fput (Qbuffer_read_only
, Qerror_message
,
2719 build_string ("Buffer is read-only"));
2721 #ifdef LISP_FLOAT_TYPE
2722 Qrange_error
= intern ("range-error");
2723 Qdomain_error
= intern ("domain-error");
2724 Qsingularity_error
= intern ("singularity-error");
2725 Qoverflow_error
= intern ("overflow-error");
2726 Qunderflow_error
= intern ("underflow-error");
2728 Fput (Qdomain_error
, Qerror_conditions
,
2729 Fcons (Qdomain_error
, arith_tail
));
2730 Fput (Qdomain_error
, Qerror_message
,
2731 build_string ("Arithmetic domain error"));
2733 Fput (Qrange_error
, Qerror_conditions
,
2734 Fcons (Qrange_error
, arith_tail
));
2735 Fput (Qrange_error
, Qerror_message
,
2736 build_string ("Arithmetic range error"));
2738 Fput (Qsingularity_error
, Qerror_conditions
,
2739 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2740 Fput (Qsingularity_error
, Qerror_message
,
2741 build_string ("Arithmetic singularity error"));
2743 Fput (Qoverflow_error
, Qerror_conditions
,
2744 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2745 Fput (Qoverflow_error
, Qerror_message
,
2746 build_string ("Arithmetic overflow error"));
2748 Fput (Qunderflow_error
, Qerror_conditions
,
2749 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2750 Fput (Qunderflow_error
, Qerror_message
,
2751 build_string ("Arithmetic underflow error"));
2753 staticpro (&Qrange_error
);
2754 staticpro (&Qdomain_error
);
2755 staticpro (&Qsingularity_error
);
2756 staticpro (&Qoverflow_error
);
2757 staticpro (&Qunderflow_error
);
2758 #endif /* LISP_FLOAT_TYPE */
2762 staticpro (&Qquote
);
2763 staticpro (&Qlambda
);
2765 staticpro (&Qunbound
);
2766 staticpro (&Qerror_conditions
);
2767 staticpro (&Qerror_message
);
2768 staticpro (&Qtop_level
);
2770 staticpro (&Qerror
);
2772 staticpro (&Qwrong_type_argument
);
2773 staticpro (&Qargs_out_of_range
);
2774 staticpro (&Qvoid_function
);
2775 staticpro (&Qcyclic_function_indirection
);
2776 staticpro (&Qvoid_variable
);
2777 staticpro (&Qsetting_constant
);
2778 staticpro (&Qinvalid_read_syntax
);
2779 staticpro (&Qwrong_number_of_arguments
);
2780 staticpro (&Qinvalid_function
);
2781 staticpro (&Qno_catch
);
2782 staticpro (&Qend_of_file
);
2783 staticpro (&Qarith_error
);
2784 staticpro (&Qbeginning_of_buffer
);
2785 staticpro (&Qend_of_buffer
);
2786 staticpro (&Qbuffer_read_only
);
2787 staticpro (&Qmark_inactive
);
2789 staticpro (&Qlistp
);
2790 staticpro (&Qconsp
);
2791 staticpro (&Qsymbolp
);
2792 staticpro (&Qintegerp
);
2793 staticpro (&Qnatnump
);
2794 staticpro (&Qwholenump
);
2795 staticpro (&Qstringp
);
2796 staticpro (&Qarrayp
);
2797 staticpro (&Qsequencep
);
2798 staticpro (&Qbufferp
);
2799 staticpro (&Qvectorp
);
2800 staticpro (&Qchar_or_string_p
);
2801 staticpro (&Qmarkerp
);
2802 staticpro (&Qbuffer_or_string_p
);
2803 staticpro (&Qinteger_or_marker_p
);
2804 #ifdef LISP_FLOAT_TYPE
2805 staticpro (&Qfloatp
);
2806 staticpro (&Qnumberp
);
2807 staticpro (&Qnumber_or_marker_p
);
2808 #endif /* LISP_FLOAT_TYPE */
2809 staticpro (&Qchar_table_p
);
2810 staticpro (&Qvector_or_char_table_p
);
2812 staticpro (&Qboundp
);
2813 staticpro (&Qfboundp
);
2815 staticpro (&Qad_advice_info
);
2816 staticpro (&Qad_activate
);
2818 /* Types that type-of returns. */
2819 Qinteger
= intern ("integer");
2820 Qsymbol
= intern ("symbol");
2821 Qstring
= intern ("string");
2822 Qcons
= intern ("cons");
2823 Qmarker
= intern ("marker");
2824 Qoverlay
= intern ("overlay");
2825 Qfloat
= intern ("float");
2826 Qwindow_configuration
= intern ("window-configuration");
2827 Qprocess
= intern ("process");
2828 Qwindow
= intern ("window");
2829 /* Qsubr = intern ("subr"); */
2830 Qcompiled_function
= intern ("compiled-function");
2831 Qbuffer
= intern ("buffer");
2832 Qframe
= intern ("frame");
2833 Qvector
= intern ("vector");
2834 Qchar_table
= intern ("char-table");
2835 Qbool_vector
= intern ("bool-vector");
2837 staticpro (&Qinteger
);
2838 staticpro (&Qsymbol
);
2839 staticpro (&Qstring
);
2841 staticpro (&Qmarker
);
2842 staticpro (&Qoverlay
);
2843 staticpro (&Qfloat
);
2844 staticpro (&Qwindow_configuration
);
2845 staticpro (&Qprocess
);
2846 staticpro (&Qwindow
);
2847 /* staticpro (&Qsubr); */
2848 staticpro (&Qcompiled_function
);
2849 staticpro (&Qbuffer
);
2850 staticpro (&Qframe
);
2851 staticpro (&Qvector
);
2852 staticpro (&Qchar_table
);
2853 staticpro (&Qbool_vector
);
2855 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2856 "Non-nil means it is an error to set a keyword symbol.\n\
2857 A keyword symbol is a symbol whose name starts with a colon (`:').");
2858 keyword_symbols_constant_flag
= 1;
2862 defsubr (&Stype_of
);
2867 defsubr (&Sintegerp
);
2868 defsubr (&Sinteger_or_marker_p
);
2869 defsubr (&Snumberp
);
2870 defsubr (&Snumber_or_marker_p
);
2871 #ifdef LISP_FLOAT_TYPE
2873 #endif /* LISP_FLOAT_TYPE */
2874 defsubr (&Snatnump
);
2875 defsubr (&Ssymbolp
);
2876 defsubr (&Sstringp
);
2877 defsubr (&Smultibyte_string_p
);
2878 defsubr (&Svectorp
);
2879 defsubr (&Schar_table_p
);
2880 defsubr (&Svector_or_char_table_p
);
2881 defsubr (&Sbool_vector_p
);
2883 defsubr (&Ssequencep
);
2884 defsubr (&Sbufferp
);
2885 defsubr (&Smarkerp
);
2887 defsubr (&Sbyte_code_function_p
);
2888 defsubr (&Schar_or_string_p
);
2891 defsubr (&Scar_safe
);
2892 defsubr (&Scdr_safe
);
2895 defsubr (&Ssymbol_function
);
2896 defsubr (&Sindirect_function
);
2897 defsubr (&Ssymbol_plist
);
2898 defsubr (&Ssymbol_name
);
2899 defsubr (&Smakunbound
);
2900 defsubr (&Sfmakunbound
);
2902 defsubr (&Sfboundp
);
2904 defsubr (&Sdefalias
);
2905 defsubr (&Ssetplist
);
2906 defsubr (&Ssymbol_value
);
2908 defsubr (&Sdefault_boundp
);
2909 defsubr (&Sdefault_value
);
2910 defsubr (&Sset_default
);
2911 defsubr (&Ssetq_default
);
2912 defsubr (&Smake_variable_buffer_local
);
2913 defsubr (&Smake_local_variable
);
2914 defsubr (&Skill_local_variable
);
2915 defsubr (&Smake_variable_frame_local
);
2916 defsubr (&Slocal_variable_p
);
2917 defsubr (&Slocal_variable_if_set_p
);
2920 defsubr (&Snumber_to_string
);
2921 defsubr (&Sstring_to_number
);
2922 defsubr (&Seqlsign
);
2946 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2953 #if defined(USG) && !defined(POSIX_SIGNALS)
2954 /* USG systems forget handlers when they are used;
2955 must reestablish each time */
2956 signal (signo
, arith_error
);
2959 /* VMS systems are like USG. */
2960 signal (signo
, arith_error
);
2964 #else /* not BSD4_1 */
2965 sigsetmask (SIGEMPTYMASK
);
2966 #endif /* not BSD4_1 */
2968 Fsignal (Qarith_error
, Qnil
);
2974 /* Don't do this if just dumping out.
2975 We don't want to call `signal' in this case
2976 so that we don't have trouble with dumping
2977 signal-delivering routines in an inconsistent state. */
2981 #endif /* CANNOT_DUMP */
2982 signal (SIGFPE
, arith_error
);
2985 signal (SIGEMT
, arith_error
);