1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994 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 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
31 #include "syssignal.h"
34 /* These are redefined (correctly, but differently) in values.h. */
40 #ifdef LISP_FLOAT_TYPE
46 /* Work around a problem that happens because math.h on hpux 7
47 defines two static variables--which, in Emacs, are not really static,
48 because `static' is defined as nothing. The problem is that they are
49 here, in floatfns.c, and in lread.c.
50 These macros prevent the name conflict. */
51 #if defined (HPUX) && !defined (HPUX8)
52 #define _MAXLDBL data_c_maxldbl
53 #define _NMAXLDBL data_c_nmaxldbl
57 #endif /* LISP_FLOAT_TYPE */
60 extern double atof ();
63 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
64 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
65 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
66 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
67 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
68 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
69 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
70 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
71 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
72 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
73 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
74 Lisp_Object Qbuffer_or_string_p
;
75 Lisp_Object Qboundp
, Qfboundp
;
77 Lisp_Object Qad_advice_info
, Qad_activate
;
79 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
80 Lisp_Object Qoverflow_error
, Qunderflow_error
;
82 #ifdef LISP_FLOAT_TYPE
84 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
87 static Lisp_Object
swap_in_symval_forwarding ();
90 wrong_type_argument (predicate
, value
)
91 register Lisp_Object predicate
, value
;
93 register Lisp_Object tem
;
96 if (!EQ (Vmocklisp_arguments
, Qt
))
98 if (STRINGP (value
) &&
99 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
100 return Fstring_to_number (value
);
101 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
102 return Fnumber_to_string (value
);
104 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
105 tem
= call1 (predicate
, value
);
113 error ("Attempt to modify read-only object");
117 args_out_of_range (a1
, a2
)
121 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
125 args_out_of_range_3 (a1
, a2
, a3
)
126 Lisp_Object a1
, a2
, a3
;
129 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
136 register Lisp_Object val
;
137 XSET (val
, Lisp_Int
, num
);
141 /* On some machines, XINT needs a temporary location.
142 Here it is, in case it is needed. */
144 int sign_extend_temp
;
146 /* On a few machines, XINT can only be done by calling this. */
149 sign_extend_lisp_int (num
)
152 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
153 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
155 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
158 /* Data type predicates */
160 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
161 "T if the two args are the same Lisp object.")
163 Lisp_Object obj1
, obj2
;
170 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
179 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
188 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
197 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
201 if (CONSP (obj
) || NILP (obj
))
206 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
210 if (CONSP (obj
) || NILP (obj
))
215 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
224 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
233 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
242 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
246 if (VECTORP (obj
) || STRINGP (obj
))
251 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
252 "T if OBJECT is a sequence (list or array).")
254 register Lisp_Object obj
;
256 if (CONSP (obj
) || NILP (obj
) || VECTORP (obj
) || STRINGP (obj
))
261 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
270 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
279 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
288 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
289 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
298 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
299 "T if OBJECT is a character (an integer) or a string.")
301 register Lisp_Object obj
;
303 if (INTEGERP (obj
) || STRINGP (obj
))
308 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
317 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
318 "T if OBJECT is an integer or a marker (editor pointer).")
320 register Lisp_Object obj
;
322 if (MARKERP (obj
) || INTEGERP (obj
))
327 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
328 "T if OBJECT is a nonnegative integer.")
332 if (INTEGERP (obj
) && XINT (obj
) >= 0)
337 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
338 "T if OBJECT is a number (floating point or integer).")
348 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
349 Snumber_or_marker_p
, 1, 1, 0,
350 "T if OBJECT is a number or a marker.")
354 if (NUMBERP (obj
) || MARKERP (obj
))
359 #ifdef LISP_FLOAT_TYPE
360 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
361 "T if OBJECT is a floating point number.")
369 #endif /* LISP_FLOAT_TYPE */
371 /* Extract and set components of lists */
373 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
374 "Return the car of CONSCELL. If arg is nil, return nil.\n\
375 Error if arg is not nil and not a cons cell. See also `car-safe'.")
377 register Lisp_Object list
;
382 return XCONS (list
)->car
;
383 else if (EQ (list
, Qnil
))
386 list
= wrong_type_argument (Qlistp
, list
);
390 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
391 "Return the car of OBJECT if it is a cons cell, or else nil.")
396 return XCONS (object
)->car
;
401 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
402 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
403 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
406 register Lisp_Object list
;
411 return XCONS (list
)->cdr
;
412 else if (EQ (list
, Qnil
))
415 list
= wrong_type_argument (Qlistp
, list
);
419 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
420 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
425 return XCONS (object
)->cdr
;
430 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
431 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
433 register Lisp_Object cell
, newcar
;
436 cell
= wrong_type_argument (Qconsp
, cell
);
439 XCONS (cell
)->car
= newcar
;
443 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
444 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
446 register Lisp_Object cell
, newcdr
;
449 cell
= wrong_type_argument (Qconsp
, cell
);
452 XCONS (cell
)->cdr
= newcdr
;
456 /* Extract and set components of symbols */
458 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
460 register Lisp_Object sym
;
462 Lisp_Object valcontents
;
463 CHECK_SYMBOL (sym
, 0);
465 valcontents
= XSYMBOL (sym
)->value
;
467 #ifdef SWITCH_ENUM_BUG
468 switch ((int) XTYPE (valcontents
))
470 switch (XTYPE (valcontents
))
473 case Lisp_Buffer_Local_Value
:
474 case Lisp_Some_Buffer_Local_Value
:
475 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
478 return (VOIDP (valcontents
) || EQ (valcontents
, Qunbound
)
482 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
484 register Lisp_Object sym
;
486 CHECK_SYMBOL (sym
, 0);
487 return ((VOIDP (XSYMBOL (sym
)->function
)
488 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
492 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
494 register Lisp_Object sym
;
496 CHECK_SYMBOL (sym
, 0);
497 if (NILP (sym
) || EQ (sym
, Qt
))
498 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
499 Fset (sym
, Qunbound
);
503 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
505 register Lisp_Object sym
;
507 CHECK_SYMBOL (sym
, 0);
508 if (NILP (sym
) || EQ (sym
, Qt
))
509 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
510 XSYMBOL (sym
)->function
= Qunbound
;
514 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
515 "Return SYMBOL's function definition. Error if that is void.")
517 register Lisp_Object symbol
;
519 CHECK_SYMBOL (symbol
, 0);
520 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
521 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
522 return XSYMBOL (symbol
)->function
;
525 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
527 register Lisp_Object sym
;
529 CHECK_SYMBOL (sym
, 0);
530 return XSYMBOL (sym
)->plist
;
533 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
535 register Lisp_Object sym
;
537 register Lisp_Object name
;
539 CHECK_SYMBOL (sym
, 0);
540 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
544 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
545 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
547 register Lisp_Object sym
, newdef
;
549 CHECK_SYMBOL (sym
, 0);
550 if (NILP (sym
) || EQ (sym
, Qt
))
551 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
552 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
553 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
555 XSYMBOL (sym
)->function
= newdef
;
556 /* Handle automatic advice activation */
557 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
559 call2 (Qad_activate
, sym
, Qnil
);
560 newdef
= XSYMBOL (sym
)->function
;
565 /* This name should be removed once it is eliminated from elsewhere. */
567 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
568 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
569 Associates the function with the current load file, if any.")
571 register Lisp_Object sym
, newdef
;
573 CHECK_SYMBOL (sym
, 0);
574 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
575 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
577 XSYMBOL (sym
)->function
= newdef
;
578 /* Handle automatic advice activation */
579 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
581 call2 (Qad_activate
, sym
, Qnil
);
582 newdef
= XSYMBOL (sym
)->function
;
584 LOADHIST_ATTACH (sym
);
588 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
589 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
590 Associates the function with the current load file, if any.")
592 register Lisp_Object sym
, newdef
;
594 CHECK_SYMBOL (sym
, 0);
595 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
596 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
598 XSYMBOL (sym
)->function
= newdef
;
599 /* Handle automatic advice activation */
600 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
602 call2 (Qad_activate
, sym
, Qnil
);
603 newdef
= XSYMBOL (sym
)->function
;
605 LOADHIST_ATTACH (sym
);
609 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
610 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
612 register Lisp_Object sym
, newplist
;
614 CHECK_SYMBOL (sym
, 0);
615 XSYMBOL (sym
)->plist
= newplist
;
620 /* Getting and setting values of symbols */
622 /* Given the raw contents of a symbol value cell,
623 return the Lisp value of the symbol.
624 This does not handle buffer-local variables; use
625 swap_in_symval_forwarding for that. */
628 do_symval_forwarding (valcontents
)
629 register Lisp_Object valcontents
;
631 register Lisp_Object val
;
632 #ifdef SWITCH_ENUM_BUG
633 switch ((int) XTYPE (valcontents
))
635 switch (XTYPE (valcontents
))
639 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
643 if (*XINTPTR (valcontents
))
648 return *XOBJFWD (valcontents
);
650 case Lisp_Buffer_Objfwd
:
651 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
656 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
657 of SYM. If SYM is buffer-local, VALCONTENTS should be the
658 buffer-independent contents of the value cell: forwarded just one
659 step past the buffer-localness. */
662 store_symval_forwarding (sym
, valcontents
, newval
)
664 register Lisp_Object valcontents
, newval
;
666 #ifdef SWITCH_ENUM_BUG
667 switch ((int) XTYPE (valcontents
))
669 switch (XTYPE (valcontents
))
673 CHECK_NUMBER (newval
, 1);
674 *XINTPTR (valcontents
) = XINT (newval
);
678 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
682 *XOBJFWD (valcontents
) = newval
;
685 case Lisp_Buffer_Objfwd
:
687 unsigned int offset
= XUINT (valcontents
);
690 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
691 if (! NILP (type
) && ! NILP (newval
)
692 && XTYPE (newval
) != XINT (type
))
693 buffer_slot_type_mismatch (valcontents
, newval
);
695 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
701 valcontents
= XSYMBOL (sym
)->value
;
702 if (BUFFER_LOCAL_VALUEP (valcontents
)
703 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
704 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
706 XSYMBOL (sym
)->value
= newval
;
710 /* Set up the buffer-local symbol SYM for validity in the current
711 buffer. VALCONTENTS is the contents of its value cell.
712 Return the value forwarded one step past the buffer-local indicator. */
715 swap_in_symval_forwarding (sym
, valcontents
)
716 Lisp_Object sym
, valcontents
;
718 /* valcontents is a list
719 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
721 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
722 local_var_alist, that being the element whose car is this
723 variable. Or it can be a pointer to the
724 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
725 an element in its alist for this variable.
727 If the current buffer is not BUFFER, we store the current
728 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
729 appropriate alist element for the buffer now current and set up
730 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
731 element, and store into BUFFER.
733 Note that REALVALUE can be a forwarding pointer. */
735 register Lisp_Object tem1
;
736 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
738 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
740 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
741 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
742 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
744 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
745 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
746 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
747 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
749 return XCONS (valcontents
)->car
;
752 /* Find the value of a symbol, returning Qunbound if it's not bound.
753 This is helpful for code which just wants to get a variable's value
754 if it has one, without signalling an error.
755 Note that it must not be possible to quit
756 within this function. Great care is required for this. */
759 find_symbol_value (sym
)
762 register Lisp_Object valcontents
, tem1
;
763 register Lisp_Object val
;
764 CHECK_SYMBOL (sym
, 0);
765 valcontents
= XSYMBOL (sym
)->value
;
768 #ifdef SWITCH_ENUM_BUG
769 switch ((int) XTYPE (valcontents
))
771 switch (XTYPE (valcontents
))
774 case Lisp_Buffer_Local_Value
:
775 case Lisp_Some_Buffer_Local_Value
:
776 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
780 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
784 if (*XINTPTR (valcontents
))
789 return *XOBJFWD (valcontents
);
791 case Lisp_Buffer_Objfwd
:
792 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
801 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
802 "Return SYMBOL's value. Error if that is void.")
808 val
= find_symbol_value (sym
);
809 if (EQ (val
, Qunbound
))
810 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
815 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
816 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
818 register Lisp_Object sym
, newval
;
820 int voide
= (VOIDP (newval
) || EQ (newval
, Qunbound
));
822 register Lisp_Object valcontents
, tem1
, current_alist_element
;
824 CHECK_SYMBOL (sym
, 0);
825 if (NILP (sym
) || EQ (sym
, Qt
))
826 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
827 valcontents
= XSYMBOL (sym
)->value
;
829 if (BUFFER_OBJFWDP (valcontents
))
831 register int idx
= XUINT (valcontents
);
832 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
834 current_buffer
->local_var_flags
|= mask
;
837 else if (BUFFER_LOCAL_VALUEP (valcontents
)
838 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
840 /* valcontents is actually a pointer to a cons heading something like:
841 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
843 BUFFER is the last buffer for which this symbol's value was
846 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
847 local_var_alist, that being the element whose car is this
848 variable. Or it can be a pointer to the
849 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
850 have an element in its alist for this variable (that is, if
851 BUFFER sees the default value of this variable).
853 If we want to examine or set the value and BUFFER is current,
854 we just examine or set REALVALUE. If BUFFER is not current, we
855 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
856 then find the appropriate alist element for the buffer now
857 current and set up CURRENT-ALIST-ELEMENT. Then we set
858 REALVALUE out of that element, and store into BUFFER.
860 If we are setting the variable and the current buffer does
861 not have an alist entry for this variable, an alist entry is
864 Note that REALVALUE can be a forwarding pointer. Each time
865 it is examined or set, forwarding must be done. */
867 /* What value are we caching right now? */
868 current_alist_element
=
869 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
871 /* If the current buffer is not the buffer whose binding is
872 currently cached, or if it's a Lisp_Buffer_Local_Value and
873 we're looking at the default value, the cache is invalid; we
874 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
876 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
877 || (BUFFER_LOCAL_VALUEP (valcontents
)
878 && EQ (XCONS (current_alist_element
)->car
,
879 current_alist_element
)))
881 /* Write out the cached value for the old buffer; copy it
882 back to its alist element. This works if the current
883 buffer only sees the default value, too. */
884 Fsetcdr (current_alist_element
,
885 do_symval_forwarding (XCONS (valcontents
)->car
));
887 /* Find the new value for CURRENT-ALIST-ELEMENT. */
888 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
891 /* This buffer still sees the default value. */
893 /* If the variable is a Lisp_Some_Buffer_Local_Value,
894 make CURRENT-ALIST-ELEMENT point to itself,
895 indicating that we're seeing the default value. */
896 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
897 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
899 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
900 new assoc for a local value and set
901 CURRENT-ALIST-ELEMENT to point to that. */
904 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
905 current_buffer
->local_var_alist
=
906 Fcons (tem1
, current_buffer
->local_var_alist
);
909 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
910 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
912 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
913 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
914 Lisp_Buffer
, current_buffer
);
916 valcontents
= XCONS (valcontents
)->car
;
919 /* If storing void (making the symbol void), forward only through
920 buffer-local indicator, not through Lisp_Objfwd, etc. */
922 store_symval_forwarding (sym
, Qnil
, newval
);
924 store_symval_forwarding (sym
, valcontents
, newval
);
929 /* Access or set a buffer-local symbol's default value. */
931 /* Return the default value of SYM, but don't check for voidness.
932 Return Qunbound or a Lisp_Void object if it is void. */
938 register Lisp_Object valcontents
;
940 CHECK_SYMBOL (sym
, 0);
941 valcontents
= XSYMBOL (sym
)->value
;
943 /* For a built-in buffer-local variable, get the default value
944 rather than letting do_symval_forwarding get the current value. */
945 if (BUFFER_OBJFWDP (valcontents
))
947 register int idx
= XUINT (valcontents
);
949 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
950 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
953 /* Handle user-created local variables. */
954 if (BUFFER_LOCAL_VALUEP (valcontents
)
955 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
957 /* If var is set up for a buffer that lacks a local value for it,
958 the current value is nominally the default value.
959 But the current value slot may be more up to date, since
960 ordinary setq stores just that slot. So use that. */
961 Lisp_Object current_alist_element
, alist_element_car
;
962 current_alist_element
963 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
964 alist_element_car
= XCONS (current_alist_element
)->car
;
965 if (EQ (alist_element_car
, current_alist_element
))
966 return do_symval_forwarding (XCONS (valcontents
)->car
);
968 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
970 /* For other variables, get the current value. */
971 return do_symval_forwarding (valcontents
);
974 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
975 "Return T if SYMBOL has a non-void default value.\n\
976 This is the value that is seen in buffers that do not have their own values\n\
981 register Lisp_Object value
;
983 value
= default_value (sym
);
984 return (VOIDP (value
) || EQ (value
, Qunbound
)
988 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
989 "Return SYMBOL's default value.\n\
990 This is the value that is seen in buffers that do not have their own values\n\
991 for this variable. The default value is meaningful for variables with\n\
992 local bindings in certain buffers.")
996 register Lisp_Object value
;
998 value
= default_value (sym
);
999 if (VOIDP (value
) || EQ (value
, Qunbound
))
1000 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1004 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1005 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1006 The default value is seen in buffers that do not have their own values\n\
1007 for this variable.")
1009 Lisp_Object sym
, value
;
1011 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1013 CHECK_SYMBOL (sym
, 0);
1014 valcontents
= XSYMBOL (sym
)->value
;
1016 /* Handle variables like case-fold-search that have special slots
1017 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1019 if (BUFFER_OBJFWDP (valcontents
))
1021 register int idx
= XUINT (valcontents
);
1022 register struct buffer
*b
;
1023 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1027 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1028 for (b
= all_buffers
; b
; b
= b
->next
)
1029 if (!(b
->local_var_flags
& mask
))
1030 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1035 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1036 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1037 return Fset (sym
, value
);
1039 /* Store new value into the DEFAULT-VALUE slot */
1040 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1042 /* If that slot is current, we must set the REALVALUE slot too */
1043 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
1044 alist_element_buffer
= Fcar (current_alist_element
);
1045 if (EQ (alist_element_buffer
, current_alist_element
))
1046 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
1051 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1052 "Set the default value of variable VAR to VALUE.\n\
1053 VAR, the variable name, is literal (not evaluated);\n\
1054 VALUE is an expression and it is evaluated.\n\
1055 The default value of a variable is seen in buffers\n\
1056 that do not have their own values for the variable.\n\
1058 More generally, you can use multiple variables and values, as in\n\
1059 (setq-default SYM VALUE SYM VALUE...)\n\
1060 This sets each SYM's default value to the corresponding VALUE.\n\
1061 The VALUE for the Nth SYM can refer to the new default values\n\
1066 register Lisp_Object args_left
;
1067 register Lisp_Object val
, sym
;
1068 struct gcpro gcpro1
;
1078 val
= Feval (Fcar (Fcdr (args_left
)));
1079 sym
= Fcar (args_left
);
1080 Fset_default (sym
, val
);
1081 args_left
= Fcdr (Fcdr (args_left
));
1083 while (!NILP (args_left
));
1089 /* Lisp functions for creating and removing buffer-local variables. */
1091 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1092 1, 1, "vMake Variable Buffer Local: ",
1093 "Make VARIABLE have a separate value for each buffer.\n\
1094 At any time, the value for the current buffer is in effect.\n\
1095 There is also a default value which is seen in any buffer which has not yet\n\
1096 set its own value.\n\
1097 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1098 for the current buffer if it was previously using the default value.\n\
1099 The function `default-value' gets the default value and `set-default' sets it.")
1101 register Lisp_Object sym
;
1103 register Lisp_Object tem
, valcontents
;
1105 CHECK_SYMBOL (sym
, 0);
1107 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1108 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1110 valcontents
= XSYMBOL (sym
)->value
;
1111 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1113 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1115 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1118 if (EQ (valcontents
, Qunbound
))
1119 XSYMBOL (sym
)->value
= Qnil
;
1120 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1121 XCONS (tem
)->car
= tem
;
1122 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1123 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1127 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1128 1, 1, "vMake Local Variable: ",
1129 "Make VARIABLE have a separate value in the current buffer.\n\
1130 Other buffers will continue to share a common default value.\n\
1131 \(The buffer-local value of VARIABLE starts out as the same value\n\
1132 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1133 See also `make-variable-buffer-local'.\n\n\
1134 If the variable is already arranged to become local when set,\n\
1135 this function causes a local value to exist for this buffer,\n\
1136 just as if the variable were set.")
1138 register Lisp_Object sym
;
1140 register Lisp_Object tem
, valcontents
;
1142 CHECK_SYMBOL (sym
, 0);
1144 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1145 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1147 valcontents
= XSYMBOL (sym
)->value
;
1148 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1150 tem
= Fboundp (sym
);
1152 /* Make sure the symbol has a local value in this particular buffer,
1153 by setting it to the same value it already has. */
1154 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1157 /* Make sure sym is set up to hold per-buffer values */
1158 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1160 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1161 XCONS (tem
)->car
= tem
;
1162 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1163 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1165 /* Make sure this buffer has its own value of sym */
1166 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1169 current_buffer
->local_var_alist
1170 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1171 current_buffer
->local_var_alist
);
1173 /* Make sure symbol does not think it is set up for this buffer;
1174 force it to look once again for this buffer's value */
1176 /* This local variable avoids "expression too complex" on IBM RT. */
1179 xs
= XSYMBOL (sym
)->value
;
1180 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1181 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1185 /* If the symbol forwards into a C variable, then swap in the
1186 variable for this buffer immediately. If C code modifies the
1187 variable before we swap in, then that new value will clobber the
1188 default value the next time we swap. */
1189 valcontents
= XCONS (XSYMBOL (sym
)->value
)->car
;
1190 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1191 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1196 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1197 1, 1, "vKill Local Variable: ",
1198 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1199 From now on the default value will apply in this buffer.")
1201 register Lisp_Object sym
;
1203 register Lisp_Object tem
, valcontents
;
1205 CHECK_SYMBOL (sym
, 0);
1207 valcontents
= XSYMBOL (sym
)->value
;
1209 if (BUFFER_OBJFWDP (valcontents
))
1211 register int idx
= XUINT (valcontents
);
1212 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1216 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1217 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1218 current_buffer
->local_var_flags
&= ~mask
;
1223 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1224 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1227 /* Get rid of this buffer's alist element, if any */
1229 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1231 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1233 /* Make sure symbol does not think it is set up for this buffer;
1234 force it to look once again for this buffer's value */
1237 sv
= XSYMBOL (sym
)->value
;
1238 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1239 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1245 /* Find the function at the end of a chain of symbol function indirections. */
1247 /* If OBJECT is a symbol, find the end of its function chain and
1248 return the value found there. If OBJECT is not a symbol, just
1249 return it. If there is a cycle in the function chain, signal a
1250 cyclic-function-indirection error.
1252 This is like Findirect_function, except that it doesn't signal an
1253 error if the chain ends up unbound. */
1255 indirect_function (object
)
1256 register Lisp_Object object
;
1258 Lisp_Object tortoise
, hare
;
1260 hare
= tortoise
= object
;
1264 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1266 hare
= XSYMBOL (hare
)->function
;
1267 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1269 hare
= XSYMBOL (hare
)->function
;
1271 tortoise
= XSYMBOL (tortoise
)->function
;
1273 if (EQ (hare
, tortoise
))
1274 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1280 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1281 "Return the function at the end of OBJECT's function chain.\n\
1282 If OBJECT is a symbol, follow all function indirections and return the final\n\
1283 function binding.\n\
1284 If OBJECT is not a symbol, just return it.\n\
1285 Signal a void-function error if the final symbol is unbound.\n\
1286 Signal a cyclic-function-indirection error if there is a loop in the\n\
1287 function chain of symbols.")
1289 register Lisp_Object object
;
1293 result
= indirect_function (object
);
1295 if (EQ (result
, Qunbound
))
1296 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1300 /* Extract and set vector and string elements */
1302 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1303 "Return the element of ARRAY at index INDEX.\n\
1304 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1306 register Lisp_Object array
;
1309 register int idxval
;
1311 CHECK_NUMBER (idx
, 1);
1312 idxval
= XINT (idx
);
1313 if (!VECTORP (array
) && !STRINGP (array
) && !COMPILEDP (array
))
1314 array
= wrong_type_argument (Qarrayp
, array
);
1315 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1316 args_out_of_range (array
, idx
);
1317 if (STRINGP (array
))
1320 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1324 return XVECTOR (array
)->contents
[idxval
];
1327 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1328 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1329 ARRAY may be a vector or a string. IDX starts at 0.")
1330 (array
, idx
, newelt
)
1331 register Lisp_Object array
;
1332 Lisp_Object idx
, newelt
;
1334 register int idxval
;
1336 CHECK_NUMBER (idx
, 1);
1337 idxval
= XINT (idx
);
1338 if (!VECTORP (array
) && !STRINGP (array
))
1339 array
= wrong_type_argument (Qarrayp
, array
);
1340 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1341 args_out_of_range (array
, idx
);
1342 CHECK_IMPURE (array
);
1344 if (VECTORP (array
))
1345 XVECTOR (array
)->contents
[idxval
] = newelt
;
1348 CHECK_NUMBER (newelt
, 2);
1349 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1356 Farray_length (array
)
1357 register Lisp_Object array
;
1359 register Lisp_Object size
;
1360 if (!VECTORP (array
) && !STRINGP (array
) && !COMPILEDP (array
))
1361 array
= wrong_type_argument (Qarrayp
, array
);
1362 XFASTINT (size
) = XVECTOR (array
)->size
;
1366 /* Arithmetic functions */
1368 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1371 arithcompare (num1
, num2
, comparison
)
1372 Lisp_Object num1
, num2
;
1373 enum comparison comparison
;
1378 #ifdef LISP_FLOAT_TYPE
1379 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1380 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1382 if (FLOATP (num1
) || FLOATP (num2
))
1385 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1386 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1389 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1390 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1391 #endif /* LISP_FLOAT_TYPE */
1396 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1401 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1406 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1411 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1416 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1421 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1430 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1431 "T if two args, both numbers or markers, are equal.")
1433 register Lisp_Object num1
, num2
;
1435 return arithcompare (num1
, num2
, equal
);
1438 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1439 "T if first arg is less than second arg. Both must be numbers or markers.")
1441 register Lisp_Object num1
, num2
;
1443 return arithcompare (num1
, num2
, less
);
1446 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1447 "T if first arg is greater than second arg. Both must be numbers or markers.")
1449 register Lisp_Object num1
, num2
;
1451 return arithcompare (num1
, num2
, grtr
);
1454 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1455 "T if first arg is less than or equal to second arg.\n\
1456 Both must be numbers or markers.")
1458 register Lisp_Object num1
, num2
;
1460 return arithcompare (num1
, num2
, less_or_equal
);
1463 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1464 "T if first arg is greater than or equal to second arg.\n\
1465 Both must be numbers or markers.")
1467 register Lisp_Object num1
, num2
;
1469 return arithcompare (num1
, num2
, grtr_or_equal
);
1472 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1473 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1475 register Lisp_Object num1
, num2
;
1477 return arithcompare (num1
, num2
, notequal
);
1480 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1482 register Lisp_Object num
;
1484 #ifdef LISP_FLOAT_TYPE
1485 CHECK_NUMBER_OR_FLOAT (num
, 0);
1489 if (XFLOAT(num
)->data
== 0.0)
1494 CHECK_NUMBER (num
, 0);
1495 #endif /* LISP_FLOAT_TYPE */
1502 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1508 unsigned int top
= i
>> 16;
1509 unsigned int bot
= i
& 0xFFFF;
1511 return make_number (bot
);
1513 return Fcons (make_number (-1), make_number (bot
));
1514 return Fcons (make_number (top
), make_number (bot
));
1521 Lisp_Object top
, bot
;
1524 top
= XCONS (c
)->car
;
1525 bot
= XCONS (c
)->cdr
;
1527 bot
= XCONS (bot
)->car
;
1528 return ((XINT (top
) << 16) | XINT (bot
));
1531 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1532 "Convert NUM to a string by printing it in decimal.\n\
1533 Uses a minus sign if negative.\n\
1534 NUM may be an integer or a floating point number.")
1540 #ifndef LISP_FLOAT_TYPE
1541 CHECK_NUMBER (num
, 0);
1543 CHECK_NUMBER_OR_FLOAT (num
, 0);
1547 char pigbuf
[350]; /* see comments in float_to_string */
1549 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1550 return build_string (pigbuf
);
1552 #endif /* LISP_FLOAT_TYPE */
1554 sprintf (buffer
, "%d", XINT (num
));
1555 return build_string (buffer
);
1558 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1559 "Convert STRING to a number by parsing it as a decimal number.\n\
1560 This parses both integers and floating point numbers.\n\
1561 It ignores leading spaces and tabs.")
1563 register Lisp_Object str
;
1567 CHECK_STRING (str
, 0);
1569 p
= XSTRING (str
)->data
;
1571 /* Skip any whitespace at the front of the number. Some versions of
1572 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1573 while (*p
== ' ' || *p
== '\t')
1576 #ifdef LISP_FLOAT_TYPE
1577 if (isfloat_string (p
))
1578 return make_float (atof (p
));
1579 #endif /* LISP_FLOAT_TYPE */
1581 return make_number (atoi (p
));
1585 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1587 extern Lisp_Object
float_arith_driver ();
1590 arith_driver (code
, nargs
, args
)
1593 register Lisp_Object
*args
;
1595 register Lisp_Object val
;
1596 register int argnum
;
1600 #ifdef SWITCH_ENUM_BUG
1617 for (argnum
= 0; argnum
< nargs
; argnum
++)
1619 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1620 #ifdef LISP_FLOAT_TYPE
1621 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1623 if (FLOATP (val
)) /* time to do serious math */
1624 return (float_arith_driver ((double) accum
, argnum
, code
,
1627 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1628 #endif /* LISP_FLOAT_TYPE */
1629 args
[argnum
] = val
; /* runs into a compiler bug. */
1630 next
= XINT (args
[argnum
]);
1631 #ifdef SWITCH_ENUM_BUG
1637 case Aadd
: accum
+= next
; break;
1639 if (!argnum
&& nargs
!= 1)
1643 case Amult
: accum
*= next
; break;
1645 if (!argnum
) accum
= next
;
1649 Fsignal (Qarith_error
, Qnil
);
1653 case Alogand
: accum
&= next
; break;
1654 case Alogior
: accum
|= next
; break;
1655 case Alogxor
: accum
^= next
; break;
1656 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1657 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1661 XSET (val
, Lisp_Int
, accum
);
1665 #ifdef LISP_FLOAT_TYPE
1668 #define isnan(x) ((x) != (x))
1671 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1673 register int argnum
;
1676 register Lisp_Object
*args
;
1678 register Lisp_Object val
;
1681 for (; argnum
< nargs
; argnum
++)
1683 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1684 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1688 next
= XFLOAT (val
)->data
;
1692 args
[argnum
] = val
; /* runs into a compiler bug. */
1693 next
= XINT (args
[argnum
]);
1695 #ifdef SWITCH_ENUM_BUG
1705 if (!argnum
&& nargs
!= 1)
1718 Fsignal (Qarith_error
, Qnil
);
1725 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1727 if (!argnum
|| isnan (next
) || next
> accum
)
1731 if (!argnum
|| isnan (next
) || next
< accum
)
1737 return make_float (accum
);
1739 #endif /* LISP_FLOAT_TYPE */
1741 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1742 "Return sum of any number of arguments, which are numbers or markers.")
1747 return arith_driver (Aadd
, nargs
, args
);
1750 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1751 "Negate number or subtract numbers or markers.\n\
1752 With one arg, negates it. With more than one arg,\n\
1753 subtracts all but the first from the first.")
1758 return arith_driver (Asub
, nargs
, args
);
1761 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1762 "Returns product of any number of arguments, which are numbers or markers.")
1767 return arith_driver (Amult
, nargs
, args
);
1770 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1771 "Returns first argument divided by all the remaining arguments.\n\
1772 The arguments must be numbers or markers.")
1777 return arith_driver (Adiv
, nargs
, args
);
1780 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1781 "Returns remainder of first arg divided by second.\n\
1782 Both must be integers or markers.")
1784 register Lisp_Object num1
, num2
;
1788 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1789 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1791 if (XFASTINT (num2
) == 0)
1792 Fsignal (Qarith_error
, Qnil
);
1794 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1803 #ifdef HAVE_DREM /* Some systems use this non-standard name. */
1804 return (drem (f1
, f2
));
1805 #else /* Other systems don't seem to have it at all. */
1806 return (f1
- f2
* floor (f1
/f2
));
1809 #endif /* ! HAVE_FMOD */
1811 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1812 "Returns X modulo Y.\n\
1813 The result falls between zero (inclusive) and Y (exclusive).\n\
1814 Both X and Y must be numbers or markers.")
1816 register Lisp_Object num1
, num2
;
1821 #ifdef LISP_FLOAT_TYPE
1822 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1823 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
1825 if (FLOATP (num1
) || FLOATP (num2
))
1829 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
1830 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
1832 Fsignal (Qarith_error
, Qnil
);
1835 /* If the "remainder" comes out with the wrong sign, fix it. */
1836 if ((f1
< 0) != (f2
< 0))
1838 return (make_float (f1
));
1840 #else /* not LISP_FLOAT_TYPE */
1841 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1842 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1843 #endif /* not LISP_FLOAT_TYPE */
1849 Fsignal (Qarith_error
, Qnil
);
1853 /* If the "remainder" comes out with the wrong sign, fix it. */
1854 if ((i1
< 0) != (i2
< 0))
1857 XSET (val
, Lisp_Int
, i1
);
1861 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1862 "Return largest of all the arguments (which must be numbers or markers).\n\
1863 The value is always a number; markers are converted to numbers.")
1868 return arith_driver (Amax
, nargs
, args
);
1871 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1872 "Return smallest of all the arguments (which must be numbers or markers).\n\
1873 The value is always a number; markers are converted to numbers.")
1878 return arith_driver (Amin
, nargs
, args
);
1881 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1882 "Return bitwise-and of all the arguments.\n\
1883 Arguments may be integers, or markers converted to integers.")
1888 return arith_driver (Alogand
, nargs
, args
);
1891 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1892 "Return bitwise-or of all the arguments.\n\
1893 Arguments may be integers, or markers converted to integers.")
1898 return arith_driver (Alogior
, nargs
, args
);
1901 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1902 "Return bitwise-exclusive-or of all the arguments.\n\
1903 Arguments may be integers, or markers converted to integers.")
1908 return arith_driver (Alogxor
, nargs
, args
);
1911 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1912 "Return VALUE with its bits shifted left by COUNT.\n\
1913 If COUNT is negative, shifting is actually to the right.\n\
1914 In this case, the sign bit is duplicated.")
1916 register Lisp_Object num1
, num2
;
1918 register Lisp_Object val
;
1920 CHECK_NUMBER (num1
, 0);
1921 CHECK_NUMBER (num2
, 1);
1923 if (XINT (num2
) > 0)
1924 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1926 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1930 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1931 "Return VALUE with its bits shifted left by COUNT.\n\
1932 If COUNT is negative, shifting is actually to the right.\n\
1933 In this case, zeros are shifted in on the left.")
1935 register Lisp_Object num1
, num2
;
1937 register Lisp_Object val
;
1939 CHECK_NUMBER (num1
, 0);
1940 CHECK_NUMBER (num2
, 1);
1942 if (XINT (num2
) > 0)
1943 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1945 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1949 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1950 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1951 Markers are converted to integers.")
1953 register Lisp_Object num
;
1955 #ifdef LISP_FLOAT_TYPE
1956 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1959 return (make_float (1.0 + XFLOAT (num
)->data
));
1961 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1962 #endif /* LISP_FLOAT_TYPE */
1964 XSETINT (num
, XFASTINT (num
) + 1);
1968 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1969 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1970 Markers are converted to integers.")
1972 register Lisp_Object num
;
1974 #ifdef LISP_FLOAT_TYPE
1975 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1978 return (make_float (-1.0 + XFLOAT (num
)->data
));
1980 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1981 #endif /* LISP_FLOAT_TYPE */
1983 XSETINT (num
, XFASTINT (num
) - 1);
1987 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1988 "Return the bitwise complement of ARG. ARG must be an integer.")
1990 register Lisp_Object num
;
1992 CHECK_NUMBER (num
, 0);
1993 XSETINT (num
, ~XFASTINT (num
));
2000 Lisp_Object error_tail
, arith_tail
;
2002 Qquote
= intern ("quote");
2003 Qlambda
= intern ("lambda");
2004 Qsubr
= intern ("subr");
2005 Qerror_conditions
= intern ("error-conditions");
2006 Qerror_message
= intern ("error-message");
2007 Qtop_level
= intern ("top-level");
2009 Qerror
= intern ("error");
2010 Qquit
= intern ("quit");
2011 Qwrong_type_argument
= intern ("wrong-type-argument");
2012 Qargs_out_of_range
= intern ("args-out-of-range");
2013 Qvoid_function
= intern ("void-function");
2014 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2015 Qvoid_variable
= intern ("void-variable");
2016 Qsetting_constant
= intern ("setting-constant");
2017 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2019 Qinvalid_function
= intern ("invalid-function");
2020 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2021 Qno_catch
= intern ("no-catch");
2022 Qend_of_file
= intern ("end-of-file");
2023 Qarith_error
= intern ("arith-error");
2024 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2025 Qend_of_buffer
= intern ("end-of-buffer");
2026 Qbuffer_read_only
= intern ("buffer-read-only");
2027 Qmark_inactive
= intern ("mark-inactive");
2029 Qlistp
= intern ("listp");
2030 Qconsp
= intern ("consp");
2031 Qsymbolp
= intern ("symbolp");
2032 Qintegerp
= intern ("integerp");
2033 Qnatnump
= intern ("natnump");
2034 Qwholenump
= intern ("wholenump");
2035 Qstringp
= intern ("stringp");
2036 Qarrayp
= intern ("arrayp");
2037 Qsequencep
= intern ("sequencep");
2038 Qbufferp
= intern ("bufferp");
2039 Qvectorp
= intern ("vectorp");
2040 Qchar_or_string_p
= intern ("char-or-string-p");
2041 Qmarkerp
= intern ("markerp");
2042 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2043 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2044 Qboundp
= intern ("boundp");
2045 Qfboundp
= intern ("fboundp");
2047 #ifdef LISP_FLOAT_TYPE
2048 Qfloatp
= intern ("floatp");
2049 Qnumberp
= intern ("numberp");
2050 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2051 #endif /* LISP_FLOAT_TYPE */
2053 Qcdr
= intern ("cdr");
2055 /* Handle automatic advice activation */
2056 Qad_advice_info
= intern ("ad-advice-info");
2057 Qad_activate
= intern ("ad-activate");
2059 error_tail
= Fcons (Qerror
, Qnil
);
2061 /* ERROR is used as a signaler for random errors for which nothing else is right */
2063 Fput (Qerror
, Qerror_conditions
,
2065 Fput (Qerror
, Qerror_message
,
2066 build_string ("error"));
2068 Fput (Qquit
, Qerror_conditions
,
2069 Fcons (Qquit
, Qnil
));
2070 Fput (Qquit
, Qerror_message
,
2071 build_string ("Quit"));
2073 Fput (Qwrong_type_argument
, Qerror_conditions
,
2074 Fcons (Qwrong_type_argument
, error_tail
));
2075 Fput (Qwrong_type_argument
, Qerror_message
,
2076 build_string ("Wrong type argument"));
2078 Fput (Qargs_out_of_range
, Qerror_conditions
,
2079 Fcons (Qargs_out_of_range
, error_tail
));
2080 Fput (Qargs_out_of_range
, Qerror_message
,
2081 build_string ("Args out of range"));
2083 Fput (Qvoid_function
, Qerror_conditions
,
2084 Fcons (Qvoid_function
, error_tail
));
2085 Fput (Qvoid_function
, Qerror_message
,
2086 build_string ("Symbol's function definition is void"));
2088 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2089 Fcons (Qcyclic_function_indirection
, error_tail
));
2090 Fput (Qcyclic_function_indirection
, Qerror_message
,
2091 build_string ("Symbol's chain of function indirections contains a loop"));
2093 Fput (Qvoid_variable
, Qerror_conditions
,
2094 Fcons (Qvoid_variable
, error_tail
));
2095 Fput (Qvoid_variable
, Qerror_message
,
2096 build_string ("Symbol's value as variable is void"));
2098 Fput (Qsetting_constant
, Qerror_conditions
,
2099 Fcons (Qsetting_constant
, error_tail
));
2100 Fput (Qsetting_constant
, Qerror_message
,
2101 build_string ("Attempt to set a constant symbol"));
2103 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2104 Fcons (Qinvalid_read_syntax
, error_tail
));
2105 Fput (Qinvalid_read_syntax
, Qerror_message
,
2106 build_string ("Invalid read syntax"));
2108 Fput (Qinvalid_function
, Qerror_conditions
,
2109 Fcons (Qinvalid_function
, error_tail
));
2110 Fput (Qinvalid_function
, Qerror_message
,
2111 build_string ("Invalid function"));
2113 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2114 Fcons (Qwrong_number_of_arguments
, error_tail
));
2115 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2116 build_string ("Wrong number of arguments"));
2118 Fput (Qno_catch
, Qerror_conditions
,
2119 Fcons (Qno_catch
, error_tail
));
2120 Fput (Qno_catch
, Qerror_message
,
2121 build_string ("No catch for tag"));
2123 Fput (Qend_of_file
, Qerror_conditions
,
2124 Fcons (Qend_of_file
, error_tail
));
2125 Fput (Qend_of_file
, Qerror_message
,
2126 build_string ("End of file during parsing"));
2128 arith_tail
= Fcons (Qarith_error
, error_tail
);
2129 Fput (Qarith_error
, Qerror_conditions
,
2131 Fput (Qarith_error
, Qerror_message
,
2132 build_string ("Arithmetic error"));
2134 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2135 Fcons (Qbeginning_of_buffer
, error_tail
));
2136 Fput (Qbeginning_of_buffer
, Qerror_message
,
2137 build_string ("Beginning of buffer"));
2139 Fput (Qend_of_buffer
, Qerror_conditions
,
2140 Fcons (Qend_of_buffer
, error_tail
));
2141 Fput (Qend_of_buffer
, Qerror_message
,
2142 build_string ("End of buffer"));
2144 Fput (Qbuffer_read_only
, Qerror_conditions
,
2145 Fcons (Qbuffer_read_only
, error_tail
));
2146 Fput (Qbuffer_read_only
, Qerror_message
,
2147 build_string ("Buffer is read-only"));
2149 #ifdef LISP_FLOAT_TYPE
2150 Qrange_error
= intern ("range-error");
2151 Qdomain_error
= intern ("domain-error");
2152 Qsingularity_error
= intern ("singularity-error");
2153 Qoverflow_error
= intern ("overflow-error");
2154 Qunderflow_error
= intern ("underflow-error");
2156 Fput (Qdomain_error
, Qerror_conditions
,
2157 Fcons (Qdomain_error
, arith_tail
));
2158 Fput (Qdomain_error
, Qerror_message
,
2159 build_string ("Arithmetic domain error"));
2161 Fput (Qrange_error
, Qerror_conditions
,
2162 Fcons (Qrange_error
, arith_tail
));
2163 Fput (Qrange_error
, Qerror_message
,
2164 build_string ("Arithmetic range error"));
2166 Fput (Qsingularity_error
, Qerror_conditions
,
2167 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2168 Fput (Qsingularity_error
, Qerror_message
,
2169 build_string ("Arithmetic singularity error"));
2171 Fput (Qoverflow_error
, Qerror_conditions
,
2172 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2173 Fput (Qoverflow_error
, Qerror_message
,
2174 build_string ("Arithmetic overflow error"));
2176 Fput (Qunderflow_error
, Qerror_conditions
,
2177 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2178 Fput (Qunderflow_error
, Qerror_message
,
2179 build_string ("Arithmetic underflow error"));
2181 staticpro (&Qrange_error
);
2182 staticpro (&Qdomain_error
);
2183 staticpro (&Qsingularity_error
);
2184 staticpro (&Qoverflow_error
);
2185 staticpro (&Qunderflow_error
);
2186 #endif /* LISP_FLOAT_TYPE */
2190 staticpro (&Qquote
);
2191 staticpro (&Qlambda
);
2193 staticpro (&Qunbound
);
2194 staticpro (&Qerror_conditions
);
2195 staticpro (&Qerror_message
);
2196 staticpro (&Qtop_level
);
2198 staticpro (&Qerror
);
2200 staticpro (&Qwrong_type_argument
);
2201 staticpro (&Qargs_out_of_range
);
2202 staticpro (&Qvoid_function
);
2203 staticpro (&Qcyclic_function_indirection
);
2204 staticpro (&Qvoid_variable
);
2205 staticpro (&Qsetting_constant
);
2206 staticpro (&Qinvalid_read_syntax
);
2207 staticpro (&Qwrong_number_of_arguments
);
2208 staticpro (&Qinvalid_function
);
2209 staticpro (&Qno_catch
);
2210 staticpro (&Qend_of_file
);
2211 staticpro (&Qarith_error
);
2212 staticpro (&Qbeginning_of_buffer
);
2213 staticpro (&Qend_of_buffer
);
2214 staticpro (&Qbuffer_read_only
);
2215 staticpro (&Qmark_inactive
);
2217 staticpro (&Qlistp
);
2218 staticpro (&Qconsp
);
2219 staticpro (&Qsymbolp
);
2220 staticpro (&Qintegerp
);
2221 staticpro (&Qnatnump
);
2222 staticpro (&Qwholenump
);
2223 staticpro (&Qstringp
);
2224 staticpro (&Qarrayp
);
2225 staticpro (&Qsequencep
);
2226 staticpro (&Qbufferp
);
2227 staticpro (&Qvectorp
);
2228 staticpro (&Qchar_or_string_p
);
2229 staticpro (&Qmarkerp
);
2230 staticpro (&Qbuffer_or_string_p
);
2231 staticpro (&Qinteger_or_marker_p
);
2232 #ifdef LISP_FLOAT_TYPE
2233 staticpro (&Qfloatp
);
2234 staticpro (&Qnumberp
);
2235 staticpro (&Qnumber_or_marker_p
);
2236 #endif /* LISP_FLOAT_TYPE */
2238 staticpro (&Qboundp
);
2239 staticpro (&Qfboundp
);
2241 staticpro (&Qad_advice_info
);
2242 staticpro (&Qad_activate
);
2250 defsubr (&Sintegerp
);
2251 defsubr (&Sinteger_or_marker_p
);
2252 defsubr (&Snumberp
);
2253 defsubr (&Snumber_or_marker_p
);
2254 #ifdef LISP_FLOAT_TYPE
2256 #endif /* LISP_FLOAT_TYPE */
2257 defsubr (&Snatnump
);
2258 defsubr (&Ssymbolp
);
2259 defsubr (&Sstringp
);
2260 defsubr (&Svectorp
);
2262 defsubr (&Ssequencep
);
2263 defsubr (&Sbufferp
);
2264 defsubr (&Smarkerp
);
2266 defsubr (&Sbyte_code_function_p
);
2267 defsubr (&Schar_or_string_p
);
2270 defsubr (&Scar_safe
);
2271 defsubr (&Scdr_safe
);
2274 defsubr (&Ssymbol_function
);
2275 defsubr (&Sindirect_function
);
2276 defsubr (&Ssymbol_plist
);
2277 defsubr (&Ssymbol_name
);
2278 defsubr (&Smakunbound
);
2279 defsubr (&Sfmakunbound
);
2281 defsubr (&Sfboundp
);
2283 defsubr (&Sdefalias
);
2284 defsubr (&Sdefine_function
);
2285 defsubr (&Ssetplist
);
2286 defsubr (&Ssymbol_value
);
2288 defsubr (&Sdefault_boundp
);
2289 defsubr (&Sdefault_value
);
2290 defsubr (&Sset_default
);
2291 defsubr (&Ssetq_default
);
2292 defsubr (&Smake_variable_buffer_local
);
2293 defsubr (&Smake_local_variable
);
2294 defsubr (&Skill_local_variable
);
2297 defsubr (&Snumber_to_string
);
2298 defsubr (&Sstring_to_number
);
2299 defsubr (&Seqlsign
);
2323 Fset (Qwholenump
, Qnatnump
);
2331 /* USG systems forget handlers when they are used;
2332 must reestablish each time */
2333 signal (signo
, arith_error
);
2336 /* VMS systems are like USG. */
2337 signal (signo
, arith_error
);
2341 #else /* not BSD4_1 */
2342 sigsetmask (SIGEMPTYMASK
);
2343 #endif /* not BSD4_1 */
2345 Fsignal (Qarith_error
, Qnil
);
2350 /* Don't do this if just dumping out.
2351 We don't want to call `signal' in this case
2352 so that we don't have trouble with dumping
2353 signal-delivering routines in an inconsistent state. */
2357 #endif /* CANNOT_DUMP */
2358 signal (SIGFPE
, arith_error
);
2361 signal (SIGEMT
, arith_error
);