1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993 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"
33 #ifdef LISP_FLOAT_TYPE
38 #endif /* LISP_FLOAT_TYPE */
40 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
41 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
42 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
43 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
44 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
45 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
46 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
47 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
48 Lisp_Object Qintegerp
, Qnatnump
, Qsymbolp
, Qlistp
, Qconsp
;
49 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
50 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
51 Lisp_Object Qbuffer_or_string_p
;
52 Lisp_Object Qboundp
, Qfboundp
;
55 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
56 Lisp_Object Qoverflow_error
, Qunderflow_error
;
58 #ifdef LISP_FLOAT_TYPE
60 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
63 static Lisp_Object
swap_in_symval_forwarding ();
66 wrong_type_argument (predicate
, value
)
67 register Lisp_Object predicate
, value
;
69 register Lisp_Object tem
;
72 if (!EQ (Vmocklisp_arguments
, Qt
))
74 if (XTYPE (value
) == Lisp_String
&&
75 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
76 return Fstring_to_number (value
);
77 if (XTYPE (value
) == Lisp_Int
&& EQ (predicate
, Qstringp
))
78 return Fnumber_to_string (value
);
80 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
81 tem
= call1 (predicate
, value
);
89 error ("Attempt to modify read-only object");
93 args_out_of_range (a1
, a2
)
97 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
101 args_out_of_range_3 (a1
, a2
, a3
)
102 Lisp_Object a1
, a2
, a3
;
105 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
112 register Lisp_Object val
;
113 XSET (val
, Lisp_Int
, num
);
117 /* On some machines, XINT needs a temporary location.
118 Here it is, in case it is needed. */
120 int sign_extend_temp
;
122 /* On a few machines, XINT can only be done by calling this. */
125 sign_extend_lisp_int (num
)
128 if (num
& (1 << (VALBITS
- 1)))
129 return num
| ((-1) << VALBITS
);
131 return num
& ((1 << VALBITS
) - 1);
134 /* Data type predicates */
136 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
137 "T if the two args are the same Lisp object.")
139 Lisp_Object obj1
, obj2
;
146 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
155 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
159 if (XTYPE (obj
) == Lisp_Cons
)
164 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
168 if (XTYPE (obj
) == Lisp_Cons
)
173 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
177 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
182 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
186 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
191 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
195 if (XTYPE (obj
) == Lisp_Symbol
)
200 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
204 if (XTYPE (obj
) == Lisp_Vector
)
209 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
213 if (XTYPE (obj
) == Lisp_String
)
218 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
222 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
227 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
228 "T if OBJECT is a sequence (list or array).")
230 register Lisp_Object obj
;
232 if (CONSP (obj
) || NILP (obj
) ||
233 XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
238 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
242 if (XTYPE (obj
) == Lisp_Buffer
)
247 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
251 if (XTYPE (obj
) == Lisp_Marker
)
256 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
260 if (XTYPE (obj
) == Lisp_Subr
)
265 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
266 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
270 if (XTYPE (obj
) == Lisp_Compiled
)
275 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0, "T if OBJECT is a character (a number) or a string.")
277 register Lisp_Object obj
;
279 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
284 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is a number.")
288 if (XTYPE (obj
) == Lisp_Int
)
293 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
294 "T if OBJECT is an integer or a marker (editor pointer).")
296 register Lisp_Object obj
;
298 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
303 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0, "T if OBJECT is a nonnegative number.")
307 if (XTYPE (obj
) == Lisp_Int
&& XINT (obj
) >= 0)
312 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
313 "T if OBJECT is a number (floating point or integer).")
323 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
324 Snumber_or_marker_p
, 1, 1, 0,
325 "T if OBJECT is a number or a marker.")
330 || XTYPE (obj
) == Lisp_Marker
)
335 #ifdef LISP_FLOAT_TYPE
336 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
337 "T if OBJECT is a floating point number.")
341 if (XTYPE (obj
) == Lisp_Float
)
345 #endif /* LISP_FLOAT_TYPE */
347 /* Extract and set components of lists */
349 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
350 "Return the car of CONSCELL. If arg is nil, return nil.\n\
351 Error if arg is not nil and not a cons cell. See also `car-safe'.")
353 register Lisp_Object list
;
357 if (XTYPE (list
) == Lisp_Cons
)
358 return XCONS (list
)->car
;
359 else if (EQ (list
, Qnil
))
362 list
= wrong_type_argument (Qlistp
, list
);
366 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
367 "Return the car of OBJECT if it is a cons cell, or else nil.")
371 if (XTYPE (object
) == Lisp_Cons
)
372 return XCONS (object
)->car
;
377 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
378 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
379 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
382 register Lisp_Object list
;
386 if (XTYPE (list
) == Lisp_Cons
)
387 return XCONS (list
)->cdr
;
388 else if (EQ (list
, Qnil
))
391 list
= wrong_type_argument (Qlistp
, list
);
395 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
396 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
400 if (XTYPE (object
) == Lisp_Cons
)
401 return XCONS (object
)->cdr
;
406 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
407 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
409 register Lisp_Object cell
, newcar
;
411 if (XTYPE (cell
) != Lisp_Cons
)
412 cell
= wrong_type_argument (Qconsp
, cell
);
415 XCONS (cell
)->car
= newcar
;
419 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
420 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
422 register Lisp_Object cell
, newcdr
;
424 if (XTYPE (cell
) != Lisp_Cons
)
425 cell
= wrong_type_argument (Qconsp
, cell
);
428 XCONS (cell
)->cdr
= newcdr
;
432 /* Extract and set components of symbols */
434 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
436 register Lisp_Object sym
;
438 Lisp_Object valcontents
;
439 CHECK_SYMBOL (sym
, 0);
441 valcontents
= XSYMBOL (sym
)->value
;
443 #ifdef SWITCH_ENUM_BUG
444 switch ((int) XTYPE (valcontents
))
446 switch (XTYPE (valcontents
))
449 case Lisp_Buffer_Local_Value
:
450 case Lisp_Some_Buffer_Local_Value
:
451 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
454 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
458 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
460 register Lisp_Object sym
;
462 CHECK_SYMBOL (sym
, 0);
463 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
464 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
468 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
470 register Lisp_Object sym
;
472 CHECK_SYMBOL (sym
, 0);
473 if (NILP (sym
) || EQ (sym
, Qt
))
474 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
475 Fset (sym
, Qunbound
);
479 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
481 register Lisp_Object sym
;
483 CHECK_SYMBOL (sym
, 0);
484 XSYMBOL (sym
)->function
= Qunbound
;
488 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
489 "Return SYMBOL's function definition. Error if that is void.")
491 register Lisp_Object symbol
;
493 CHECK_SYMBOL (symbol
, 0);
494 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
495 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
496 return XSYMBOL (symbol
)->function
;
499 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
501 register Lisp_Object sym
;
503 CHECK_SYMBOL (sym
, 0);
504 return XSYMBOL (sym
)->plist
;
507 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
509 register Lisp_Object sym
;
511 register Lisp_Object name
;
513 CHECK_SYMBOL (sym
, 0);
514 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
518 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
519 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
521 register Lisp_Object sym
, newdef
;
523 CHECK_SYMBOL (sym
, 0);
525 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
526 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
528 XSYMBOL (sym
)->function
= newdef
;
532 /* This name should be removed once it is eliminated from elsewhere. */
534 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
535 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
536 Associates the function with the current load file, if any.")
538 register Lisp_Object sym
, newdef
;
540 CHECK_SYMBOL (sym
, 0);
541 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
542 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
544 XSYMBOL (sym
)->function
= newdef
;
545 LOADHIST_ATTACH (sym
);
549 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
550 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
551 Associates the function with the current load file, if any.")
553 register Lisp_Object sym
, newdef
;
555 CHECK_SYMBOL (sym
, 0);
556 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
557 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
559 XSYMBOL (sym
)->function
= newdef
;
560 LOADHIST_ATTACH (sym
);
564 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
565 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
567 register Lisp_Object sym
, newplist
;
569 CHECK_SYMBOL (sym
, 0);
570 XSYMBOL (sym
)->plist
= newplist
;
575 /* Getting and setting values of symbols */
577 /* Given the raw contents of a symbol value cell,
578 return the Lisp value of the symbol.
579 This does not handle buffer-local variables; use
580 swap_in_symval_forwarding for that. */
583 do_symval_forwarding (valcontents
)
584 register Lisp_Object valcontents
;
586 register Lisp_Object val
;
587 #ifdef SWITCH_ENUM_BUG
588 switch ((int) XTYPE (valcontents
))
590 switch (XTYPE (valcontents
))
594 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
598 if (*XINTPTR (valcontents
))
603 return *XOBJFWD (valcontents
);
605 case Lisp_Buffer_Objfwd
:
606 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
611 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
612 of SYM. If SYM is buffer-local, VALCONTENTS should be the
613 buffer-independent contents of the value cell: forwarded just one
614 step past the buffer-localness. */
617 store_symval_forwarding (sym
, valcontents
, newval
)
619 register Lisp_Object valcontents
, newval
;
621 #ifdef SWITCH_ENUM_BUG
622 switch ((int) XTYPE (valcontents
))
624 switch (XTYPE (valcontents
))
628 CHECK_NUMBER (newval
, 1);
629 *XINTPTR (valcontents
) = XINT (newval
);
633 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
637 *XOBJFWD (valcontents
) = newval
;
640 case Lisp_Buffer_Objfwd
:
642 unsigned int offset
= XUINT (valcontents
);
644 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
646 if (! NILP (type
) && ! NILP (newval
)
647 && XTYPE (newval
) != XINT (type
))
648 buffer_slot_type_mismatch (valcontents
, newval
);
650 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
656 valcontents
= XSYMBOL (sym
)->value
;
657 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
658 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
659 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
661 XSYMBOL (sym
)->value
= newval
;
665 /* Set up the buffer-local symbol SYM for validity in the current
666 buffer. VALCONTENTS is the contents of its value cell.
667 Return the value forwarded one step past the buffer-local indicator. */
670 swap_in_symval_forwarding (sym
, valcontents
)
671 Lisp_Object sym
, valcontents
;
673 /* valcontents is a list
674 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
676 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
677 local_var_alist, that being the element whose car is this
678 variable. Or it can be a pointer to the
679 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
680 an element in its alist for this variable.
682 If the current buffer is not BUFFER, we store the current
683 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
684 appropriate alist element for the buffer now current and set up
685 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
686 element, and store into BUFFER.
688 Note that REALVALUE can be a forwarding pointer. */
690 register Lisp_Object tem1
;
691 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
693 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
695 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
696 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
697 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
699 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
700 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
701 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
702 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
704 return XCONS (valcontents
)->car
;
707 /* Find the value of a symbol, returning Qunbound if it's not bound.
708 This is helpful for code which just wants to get a variable's value
709 if it has one, without signalling an error.
710 Note that it must not be possible to quit
711 within this function. Great care is required for this. */
714 find_symbol_value (sym
)
717 register Lisp_Object valcontents
, tem1
;
718 register Lisp_Object val
;
719 CHECK_SYMBOL (sym
, 0);
720 valcontents
= XSYMBOL (sym
)->value
;
723 #ifdef SWITCH_ENUM_BUG
724 switch ((int) XTYPE (valcontents
))
726 switch (XTYPE (valcontents
))
729 case Lisp_Buffer_Local_Value
:
730 case Lisp_Some_Buffer_Local_Value
:
731 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
735 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
739 if (*XINTPTR (valcontents
))
744 return *XOBJFWD (valcontents
);
746 case Lisp_Buffer_Objfwd
:
747 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
756 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
757 "Return SYMBOL's value. Error if that is void.")
761 Lisp_Object val
= find_symbol_value (sym
);
763 if (EQ (val
, Qunbound
))
764 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
769 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
770 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
772 register Lisp_Object sym
, newval
;
774 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
776 #ifndef RTPC_REGISTER_BUG
777 register Lisp_Object valcontents
, tem1
, current_alist_element
;
778 #else /* RTPC_REGISTER_BUG */
779 register Lisp_Object tem1
;
780 Lisp_Object valcontents
, current_alist_element
;
781 #endif /* RTPC_REGISTER_BUG */
783 CHECK_SYMBOL (sym
, 0);
784 if (NILP (sym
) || EQ (sym
, Qt
))
785 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
786 valcontents
= XSYMBOL (sym
)->value
;
788 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
790 register int idx
= XUINT (valcontents
);
791 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
793 current_buffer
->local_var_flags
|= mask
;
796 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
797 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
799 /* valcontents is actually a pointer to a cons heading something like:
800 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
802 BUFFER is the last buffer for which this symbol's value was
805 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
806 local_var_alist, that being the element whose car is this
807 variable. Or it can be a pointer to the
808 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
809 have an element in its alist for this variable (that is, if
810 BUFFER sees the default value of this variable).
812 If we want to examine or set the value and BUFFER is current,
813 we just examine or set REALVALUE. If BUFFER is not current, we
814 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
815 then find the appropriate alist element for the buffer now
816 current and set up CURRENT-ALIST-ELEMENT. Then we set
817 REALVALUE out of that element, and store into BUFFER.
819 If we are setting the variable and the current buffer does
820 not have an alist entry for this variable, an alist entry is
823 Note that REALVALUE can be a forwarding pointer. Each time
824 it is examined or set, forwarding must be done. */
826 /* What value are we caching right now? */
827 current_alist_element
=
828 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
830 /* If the current buffer is not the buffer whose binding is
831 currently cached, or if it's a Lisp_Buffer_Local_Value and
832 we're looking at the default value, the cache is invalid; we
833 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
835 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
836 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
837 && EQ (XCONS (current_alist_element
)->car
,
838 current_alist_element
)))
840 /* Write out the cached value for the old buffer; copy it
841 back to its alist element. This works if the current
842 buffer only sees the default value, too. */
843 Fsetcdr (current_alist_element
,
844 do_symval_forwarding (XCONS (valcontents
)->car
));
846 /* Find the new value for CURRENT-ALIST-ELEMENT. */
847 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
850 /* This buffer still sees the default value. */
852 /* If the variable is a Lisp_Some_Buffer_Local_Value,
853 make CURRENT-ALIST-ELEMENT point to itself,
854 indicating that we're seeing the default value. */
855 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
856 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
858 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
859 new assoc for a local value and set
860 CURRENT-ALIST-ELEMENT to point to that. */
863 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
864 current_buffer
->local_var_alist
=
865 Fcons (tem1
, current_buffer
->local_var_alist
);
868 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
869 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
871 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
872 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
873 Lisp_Buffer
, current_buffer
);
875 valcontents
= XCONS (valcontents
)->car
;
878 /* If storing void (making the symbol void), forward only through
879 buffer-local indicator, not through Lisp_Objfwd, etc. */
881 store_symval_forwarding (sym
, Qnil
, newval
);
883 store_symval_forwarding (sym
, valcontents
, newval
);
888 /* Access or set a buffer-local symbol's default value. */
890 /* Return the default value of SYM, but don't check for voidness.
891 Return Qunbound or a Lisp_Void object if it is void. */
897 register Lisp_Object valcontents
;
899 CHECK_SYMBOL (sym
, 0);
900 valcontents
= XSYMBOL (sym
)->value
;
902 /* For a built-in buffer-local variable, get the default value
903 rather than letting do_symval_forwarding get the current value. */
904 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
906 register int idx
= XUINT (valcontents
);
908 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
909 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
912 /* Handle user-created local variables. */
913 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
914 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
916 /* If var is set up for a buffer that lacks a local value for it,
917 the current value is nominally the default value.
918 But the current value slot may be more up to date, since
919 ordinary setq stores just that slot. So use that. */
920 Lisp_Object current_alist_element
, alist_element_car
;
921 current_alist_element
922 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
923 alist_element_car
= XCONS (current_alist_element
)->car
;
924 if (EQ (alist_element_car
, current_alist_element
))
925 return do_symval_forwarding (XCONS (valcontents
)->car
);
927 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
929 /* For other variables, get the current value. */
930 return do_symval_forwarding (valcontents
);
933 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
934 "Return T if SYMBOL has a non-void default value.\n\
935 This is the value that is seen in buffers that do not have their own values\n\
940 register Lisp_Object value
;
942 value
= default_value (sym
);
943 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
947 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
948 "Return SYMBOL's default value.\n\
949 This is the value that is seen in buffers that do not have their own values\n\
950 for this variable. The default value is meaningful for variables with\n\
951 local bindings in certain buffers.")
955 register Lisp_Object value
;
957 value
= default_value (sym
);
958 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
959 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
963 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
964 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
965 The default value is seen in buffers that do not have their own values\n\
968 Lisp_Object sym
, value
;
970 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
972 CHECK_SYMBOL (sym
, 0);
973 valcontents
= XSYMBOL (sym
)->value
;
975 /* Handle variables like case-fold-search that have special slots
976 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
978 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
980 register int idx
= XUINT (valcontents
);
981 #ifndef RTPC_REGISTER_BUG
982 register struct buffer
*b
;
986 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
990 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
991 for (b
= all_buffers
; b
; b
= b
->next
)
992 if (!(b
->local_var_flags
& mask
))
993 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
998 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
999 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1000 return Fset (sym
, value
);
1002 /* Store new value into the DEFAULT-VALUE slot */
1003 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1005 /* If that slot is current, we must set the REALVALUE slot too */
1006 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
1007 alist_element_buffer
= Fcar (current_alist_element
);
1008 if (EQ (alist_element_buffer
, current_alist_element
))
1009 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
1014 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1016 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
1017 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
1018 not have their own values for this variable.")
1022 register Lisp_Object args_left
;
1023 register Lisp_Object val
, sym
;
1024 struct gcpro gcpro1
;
1034 val
= Feval (Fcar (Fcdr (args_left
)));
1035 sym
= Fcar (args_left
);
1036 Fset_default (sym
, val
);
1037 args_left
= Fcdr (Fcdr (args_left
));
1039 while (!NILP (args_left
));
1045 /* Lisp functions for creating and removing buffer-local variables. */
1047 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1048 1, 1, "vMake Variable Buffer Local: ",
1049 "Make VARIABLE have a separate value for each buffer.\n\
1050 At any time, the value for the current buffer is in effect.\n\
1051 There is also a default value which is seen in any buffer which has not yet\n\
1052 set its own value.\n\
1053 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1054 for the current buffer if it was previously using the default value.\n\
1055 The function `default-value' gets the default value and `set-default' sets it.")
1057 register Lisp_Object sym
;
1059 register Lisp_Object tem
, valcontents
;
1061 CHECK_SYMBOL (sym
, 0);
1063 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1064 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1066 valcontents
= XSYMBOL (sym
)->value
;
1067 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1068 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1070 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1072 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1075 if (EQ (valcontents
, Qunbound
))
1076 XSYMBOL (sym
)->value
= Qnil
;
1077 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1078 XCONS (tem
)->car
= tem
;
1079 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1080 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1084 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1085 1, 1, "vMake Local Variable: ",
1086 "Make VARIABLE have a separate value in the current buffer.\n\
1087 Other buffers will continue to share a common default value.\n\
1088 See also `make-variable-buffer-local'.\n\n\
1089 If the variable is already arranged to become local when set,\n\
1090 this function causes a local value to exist for this buffer,\n\
1091 just as if the variable were set.")
1093 register Lisp_Object sym
;
1095 register Lisp_Object tem
, valcontents
;
1097 CHECK_SYMBOL (sym
, 0);
1099 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1100 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1102 valcontents
= XSYMBOL (sym
)->value
;
1103 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1104 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1106 tem
= Fboundp (sym
);
1108 /* Make sure the symbol has a local value in this particular buffer,
1109 by setting it to the same value it already has. */
1110 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1113 /* Make sure sym is set up to hold per-buffer values */
1114 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1116 if (EQ (valcontents
, Qunbound
))
1117 XSYMBOL (sym
)->value
= Qnil
;
1118 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1119 XCONS (tem
)->car
= tem
;
1120 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1121 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1123 /* Make sure this buffer has its own value of sym */
1124 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1127 current_buffer
->local_var_alist
1128 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1129 current_buffer
->local_var_alist
);
1131 /* Make sure symbol does not think it is set up for this buffer;
1132 force it to look once again for this buffer's value */
1134 /* This local variable avoids "expression too complex" on IBM RT. */
1137 xs
= XSYMBOL (sym
)->value
;
1138 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1139 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1143 /* If the symbol forwards into a C variable, then swap in the
1144 variable for this buffer immediately. If C code modifies the
1145 variable before we swap in, then that new value will clobber the
1146 default value the next time we swap. */
1147 valcontents
= XCONS (XSYMBOL (sym
)->value
)->car
;
1148 if (XTYPE (valcontents
) == Lisp_Intfwd
1149 || XTYPE (valcontents
) == Lisp_Boolfwd
1150 || XTYPE (valcontents
) == Lisp_Objfwd
)
1151 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1156 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1157 1, 1, "vKill Local Variable: ",
1158 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1159 From now on the default value will apply in this buffer.")
1161 register Lisp_Object sym
;
1163 register Lisp_Object tem
, valcontents
;
1165 CHECK_SYMBOL (sym
, 0);
1167 valcontents
= XSYMBOL (sym
)->value
;
1169 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1171 register int idx
= XUINT (valcontents
);
1172 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1176 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1177 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1178 current_buffer
->local_var_flags
&= ~mask
;
1183 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1184 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1187 /* Get rid of this buffer's alist element, if any */
1189 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1191 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1193 /* Make sure symbol does not think it is set up for this buffer;
1194 force it to look once again for this buffer's value */
1197 sv
= XSYMBOL (sym
)->value
;
1198 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1199 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1205 /* Find the function at the end of a chain of symbol function indirections. */
1207 /* If OBJECT is a symbol, find the end of its function chain and
1208 return the value found there. If OBJECT is not a symbol, just
1209 return it. If there is a cycle in the function chain, signal a
1210 cyclic-function-indirection error.
1212 This is like Findirect_function, except that it doesn't signal an
1213 error if the chain ends up unbound. */
1215 indirect_function (object
)
1216 register Lisp_Object object
;
1218 Lisp_Object tortoise
, hare
;
1220 hare
= tortoise
= object
;
1224 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1226 hare
= XSYMBOL (hare
)->function
;
1227 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1229 hare
= XSYMBOL (hare
)->function
;
1231 tortoise
= XSYMBOL (tortoise
)->function
;
1233 if (EQ (hare
, tortoise
))
1234 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1240 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1241 "Return the function at the end of OBJECT's function chain.\n\
1242 If OBJECT is a symbol, follow all function indirections and return the final\n\
1243 function binding.\n\
1244 If OBJECT is not a symbol, just return it.\n\
1245 Signal a void-function error if the final symbol is unbound.\n\
1246 Signal a cyclic-function-indirection error if there is a loop in the\n\
1247 function chain of symbols.")
1249 register Lisp_Object object
;
1253 result
= indirect_function (object
);
1255 if (EQ (result
, Qunbound
))
1256 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1260 /* Extract and set vector and string elements */
1262 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1263 "Return the element of ARRAY at index INDEX.\n\
1264 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1266 register Lisp_Object array
;
1269 register int idxval
;
1271 CHECK_NUMBER (idx
, 1);
1272 idxval
= XINT (idx
);
1273 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1274 && XTYPE (array
) != Lisp_Compiled
)
1275 array
= wrong_type_argument (Qarrayp
, array
);
1276 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1277 args_out_of_range (array
, idx
);
1278 if (XTYPE (array
) == Lisp_String
)
1281 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1285 return XVECTOR (array
)->contents
[idxval
];
1288 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1289 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1290 ARRAY may be a vector or a string. INDEX starts at 0.")
1291 (array
, idx
, newelt
)
1292 register Lisp_Object array
;
1293 Lisp_Object idx
, newelt
;
1295 register int idxval
;
1297 CHECK_NUMBER (idx
, 1);
1298 idxval
= XINT (idx
);
1299 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1300 array
= wrong_type_argument (Qarrayp
, array
);
1301 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1302 args_out_of_range (array
, idx
);
1303 CHECK_IMPURE (array
);
1305 if (XTYPE (array
) == Lisp_Vector
)
1306 XVECTOR (array
)->contents
[idxval
] = newelt
;
1309 CHECK_NUMBER (newelt
, 2);
1310 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1317 Farray_length (array
)
1318 register Lisp_Object array
;
1320 register Lisp_Object size
;
1321 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1322 && XTYPE (array
) != Lisp_Compiled
)
1323 array
= wrong_type_argument (Qarrayp
, array
);
1324 XFASTINT (size
) = XVECTOR (array
)->size
;
1328 /* Arithmetic functions */
1330 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1333 arithcompare (num1
, num2
, comparison
)
1334 Lisp_Object num1
, num2
;
1335 enum comparison comparison
;
1340 #ifdef LISP_FLOAT_TYPE
1341 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1342 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1344 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1347 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1348 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1351 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1352 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1353 #endif /* LISP_FLOAT_TYPE */
1358 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1363 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1368 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1373 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1378 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1383 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1392 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1393 "T if two args, both numbers or markers, are equal.")
1395 register Lisp_Object num1
, num2
;
1397 return arithcompare (num1
, num2
, equal
);
1400 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1401 "T if first arg is less than second arg. Both must be numbers or markers.")
1403 register Lisp_Object num1
, num2
;
1405 return arithcompare (num1
, num2
, less
);
1408 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1409 "T if first arg is greater than second arg. Both must be numbers or markers.")
1411 register Lisp_Object num1
, num2
;
1413 return arithcompare (num1
, num2
, grtr
);
1416 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1417 "T if first arg is less than or equal to second arg.\n\
1418 Both must be numbers or markers.")
1420 register Lisp_Object num1
, num2
;
1422 return arithcompare (num1
, num2
, less_or_equal
);
1425 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1426 "T if first arg is greater than or equal to second arg.\n\
1427 Both must be numbers or markers.")
1429 register Lisp_Object num1
, num2
;
1431 return arithcompare (num1
, num2
, grtr_or_equal
);
1434 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1435 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1437 register Lisp_Object num1
, num2
;
1439 return arithcompare (num1
, num2
, notequal
);
1442 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1444 register Lisp_Object num
;
1446 #ifdef LISP_FLOAT_TYPE
1447 CHECK_NUMBER_OR_FLOAT (num
, 0);
1449 if (XTYPE(num
) == Lisp_Float
)
1451 if (XFLOAT(num
)->data
== 0.0)
1456 CHECK_NUMBER (num
, 0);
1457 #endif /* LISP_FLOAT_TYPE */
1464 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1470 unsigned int top
= i
>> 16;
1471 unsigned int bot
= i
& 0xFFFF;
1473 return make_number (bot
);
1475 return Fcons (make_number (-1), make_number (bot
));
1476 return Fcons (make_number (top
), make_number (bot
));
1483 Lisp_Object top
, bot
;
1486 top
= XCONS (c
)->car
;
1487 bot
= XCONS (c
)->cdr
;
1489 bot
= XCONS (bot
)->car
;
1490 return ((XINT (top
) << 16) | XINT (bot
));
1493 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1494 "Convert NUM to a string by printing it in decimal.\n\
1495 Uses a minus sign if negative.\n\
1496 NUM may be an integer or a floating point number.")
1502 #ifndef LISP_FLOAT_TYPE
1503 CHECK_NUMBER (num
, 0);
1505 CHECK_NUMBER_OR_FLOAT (num
, 0);
1507 if (XTYPE(num
) == Lisp_Float
)
1509 char pigbuf
[350]; /* see comments in float_to_string */
1511 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1512 return build_string (pigbuf
);
1514 #endif /* LISP_FLOAT_TYPE */
1516 sprintf (buffer
, "%d", XINT (num
));
1517 return build_string (buffer
);
1520 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1521 "Convert STRING to a number by parsing it as a decimal number.\n\
1522 This parses both integers and floating point numbers.")
1524 register Lisp_Object str
;
1528 CHECK_STRING (str
, 0);
1530 p
= XSTRING (str
)->data
;
1532 /* Skip any whitespace at the front of the number. Some versions of
1533 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1534 while (*p
== ' ' || *p
== '\t')
1537 #ifdef LISP_FLOAT_TYPE
1538 if (isfloat_string (p
))
1539 return make_float (atof (p
));
1540 #endif /* LISP_FLOAT_TYPE */
1542 return make_number (atoi (p
));
1546 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1548 extern Lisp_Object
float_arith_driver ();
1551 arith_driver (code
, nargs
, args
)
1554 register Lisp_Object
*args
;
1556 register Lisp_Object val
;
1557 register int argnum
;
1561 #ifdef SWITCH_ENUM_BUG
1578 for (argnum
= 0; argnum
< nargs
; argnum
++)
1580 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1581 #ifdef LISP_FLOAT_TYPE
1582 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1584 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1585 return (float_arith_driver ((double) accum
, argnum
, code
,
1588 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1589 #endif /* LISP_FLOAT_TYPE */
1590 args
[argnum
] = val
; /* runs into a compiler bug. */
1591 next
= XINT (args
[argnum
]);
1592 #ifdef SWITCH_ENUM_BUG
1598 case Aadd
: accum
+= next
; break;
1600 if (!argnum
&& nargs
!= 1)
1604 case Amult
: accum
*= next
; break;
1606 if (!argnum
) accum
= next
;
1610 Fsignal (Qarith_error
, Qnil
);
1614 case Alogand
: accum
&= next
; break;
1615 case Alogior
: accum
|= next
; break;
1616 case Alogxor
: accum
^= next
; break;
1617 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1618 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1622 XSET (val
, Lisp_Int
, accum
);
1626 #ifdef LISP_FLOAT_TYPE
1628 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1630 register int argnum
;
1633 register Lisp_Object
*args
;
1635 register Lisp_Object val
;
1638 for (; argnum
< nargs
; argnum
++)
1640 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1641 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1643 if (XTYPE (val
) == Lisp_Float
)
1645 next
= XFLOAT (val
)->data
;
1649 args
[argnum
] = val
; /* runs into a compiler bug. */
1650 next
= XINT (args
[argnum
]);
1652 #ifdef SWITCH_ENUM_BUG
1662 if (!argnum
&& nargs
!= 1)
1675 Fsignal (Qarith_error
, Qnil
);
1682 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1684 if (!argnum
|| next
> accum
)
1688 if (!argnum
|| next
< accum
)
1694 return make_float (accum
);
1696 #endif /* LISP_FLOAT_TYPE */
1698 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1699 "Return sum of any number of arguments, which are numbers or markers.")
1704 return arith_driver (Aadd
, nargs
, args
);
1707 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1708 "Negate number or subtract numbers or markers.\n\
1709 With one arg, negates it. With more than one arg,\n\
1710 subtracts all but the first from the first.")
1715 return arith_driver (Asub
, nargs
, args
);
1718 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1719 "Returns product of any number of arguments, which are numbers or markers.")
1724 return arith_driver (Amult
, nargs
, args
);
1727 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1728 "Returns first argument divided by all the remaining arguments.\n\
1729 The arguments must be numbers or markers.")
1734 return arith_driver (Adiv
, nargs
, args
);
1737 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1738 "Returns remainder of first arg divided by second.\n\
1739 Both must be integers or markers.")
1741 register Lisp_Object num1
, num2
;
1745 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1746 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1748 if (XFASTINT (num2
) == 0)
1749 Fsignal (Qarith_error
, Qnil
);
1751 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1755 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1756 "Returns X modulo Y.\n\
1757 The result falls between zero (inclusive) and Y (exclusive).\n\
1758 Both X and Y must be numbers or markers.")
1760 register Lisp_Object num1
, num2
;
1765 #ifdef LISP_FLOAT_TYPE
1766 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1767 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
1769 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1773 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1774 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1776 Fsignal (Qarith_error
, Qnil
);
1778 #if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux)
1783 /* If the "remainder" comes out with the wrong sign, fix it. */
1784 if ((f1
< 0) != (f2
< 0))
1786 return (make_float (f1
));
1788 #else /* not LISP_FLOAT_TYPE */
1789 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1790 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1791 #endif /* not LISP_FLOAT_TYPE */
1797 Fsignal (Qarith_error
, Qnil
);
1801 /* If the "remainder" comes out with the wrong sign, fix it. */
1802 if ((i1
< 0) != (i2
< 0))
1805 XSET (val
, Lisp_Int
, i1
);
1809 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1810 "Return largest of all the arguments (which must be numbers or markers).\n\
1811 The value is always a number; markers are converted to numbers.")
1816 return arith_driver (Amax
, nargs
, args
);
1819 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1820 "Return smallest of all the arguments (which must be numbers or markers).\n\
1821 The value is always a number; markers are converted to numbers.")
1826 return arith_driver (Amin
, nargs
, args
);
1829 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1830 "Return bitwise-and of all the arguments.\n\
1831 Arguments may be integers, or markers converted to integers.")
1836 return arith_driver (Alogand
, nargs
, args
);
1839 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1840 "Return bitwise-or of all the arguments.\n\
1841 Arguments may be integers, or markers converted to integers.")
1846 return arith_driver (Alogior
, nargs
, args
);
1849 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1850 "Return bitwise-exclusive-or of all the arguments.\n\
1851 Arguments may be integers, or markers converted to integers.")
1856 return arith_driver (Alogxor
, nargs
, args
);
1859 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1860 "Return VALUE with its bits shifted left by COUNT.\n\
1861 If COUNT is negative, shifting is actually to the right.\n\
1862 In this case, the sign bit is duplicated.")
1864 register Lisp_Object num1
, num2
;
1866 register Lisp_Object val
;
1868 CHECK_NUMBER (num1
, 0);
1869 CHECK_NUMBER (num2
, 1);
1871 if (XINT (num2
) > 0)
1872 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1874 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1878 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1879 "Return VALUE with its bits shifted left by COUNT.\n\
1880 If COUNT is negative, shifting is actually to the right.\n\
1881 In this case, zeros are shifted in on the left.")
1883 register Lisp_Object num1
, num2
;
1885 register Lisp_Object val
;
1887 CHECK_NUMBER (num1
, 0);
1888 CHECK_NUMBER (num2
, 1);
1890 if (XINT (num2
) > 0)
1891 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1893 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1897 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1898 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1899 Markers are converted to integers.")
1901 register Lisp_Object num
;
1903 #ifdef LISP_FLOAT_TYPE
1904 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1906 if (XTYPE (num
) == Lisp_Float
)
1907 return (make_float (1.0 + XFLOAT (num
)->data
));
1909 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1910 #endif /* LISP_FLOAT_TYPE */
1912 XSETINT (num
, XFASTINT (num
) + 1);
1916 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1917 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1918 Markers are converted to integers.")
1920 register Lisp_Object num
;
1922 #ifdef LISP_FLOAT_TYPE
1923 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1925 if (XTYPE (num
) == Lisp_Float
)
1926 return (make_float (-1.0 + XFLOAT (num
)->data
));
1928 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1929 #endif /* LISP_FLOAT_TYPE */
1931 XSETINT (num
, XFASTINT (num
) - 1);
1935 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1936 "Return the bitwise complement of ARG. ARG must be an integer.")
1938 register Lisp_Object num
;
1940 CHECK_NUMBER (num
, 0);
1941 XSETINT (num
, ~XFASTINT (num
));
1948 Lisp_Object error_tail
, arith_tail
;
1950 Qquote
= intern ("quote");
1951 Qlambda
= intern ("lambda");
1952 Qsubr
= intern ("subr");
1953 Qerror_conditions
= intern ("error-conditions");
1954 Qerror_message
= intern ("error-message");
1955 Qtop_level
= intern ("top-level");
1957 Qerror
= intern ("error");
1958 Qquit
= intern ("quit");
1959 Qwrong_type_argument
= intern ("wrong-type-argument");
1960 Qargs_out_of_range
= intern ("args-out-of-range");
1961 Qvoid_function
= intern ("void-function");
1962 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
1963 Qvoid_variable
= intern ("void-variable");
1964 Qsetting_constant
= intern ("setting-constant");
1965 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1967 Qinvalid_function
= intern ("invalid-function");
1968 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1969 Qno_catch
= intern ("no-catch");
1970 Qend_of_file
= intern ("end-of-file");
1971 Qarith_error
= intern ("arith-error");
1972 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1973 Qend_of_buffer
= intern ("end-of-buffer");
1974 Qbuffer_read_only
= intern ("buffer-read-only");
1975 Qmark_inactive
= intern ("mark-inactive");
1977 Qlistp
= intern ("listp");
1978 Qconsp
= intern ("consp");
1979 Qsymbolp
= intern ("symbolp");
1980 Qintegerp
= intern ("integerp");
1981 Qnatnump
= intern ("natnump");
1982 Qstringp
= intern ("stringp");
1983 Qarrayp
= intern ("arrayp");
1984 Qsequencep
= intern ("sequencep");
1985 Qbufferp
= intern ("bufferp");
1986 Qvectorp
= intern ("vectorp");
1987 Qchar_or_string_p
= intern ("char-or-string-p");
1988 Qmarkerp
= intern ("markerp");
1989 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
1990 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1991 Qboundp
= intern ("boundp");
1992 Qfboundp
= intern ("fboundp");
1994 #ifdef LISP_FLOAT_TYPE
1995 Qfloatp
= intern ("floatp");
1996 Qnumberp
= intern ("numberp");
1997 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1998 #endif /* LISP_FLOAT_TYPE */
2000 Qcdr
= intern ("cdr");
2002 error_tail
= Fcons (Qerror
, Qnil
);
2004 /* ERROR is used as a signaler for random errors for which nothing else is right */
2006 Fput (Qerror
, Qerror_conditions
,
2008 Fput (Qerror
, Qerror_message
,
2009 build_string ("error"));
2011 Fput (Qquit
, Qerror_conditions
,
2012 Fcons (Qquit
, Qnil
));
2013 Fput (Qquit
, Qerror_message
,
2014 build_string ("Quit"));
2016 Fput (Qwrong_type_argument
, Qerror_conditions
,
2017 Fcons (Qwrong_type_argument
, error_tail
));
2018 Fput (Qwrong_type_argument
, Qerror_message
,
2019 build_string ("Wrong type argument"));
2021 Fput (Qargs_out_of_range
, Qerror_conditions
,
2022 Fcons (Qargs_out_of_range
, error_tail
));
2023 Fput (Qargs_out_of_range
, Qerror_message
,
2024 build_string ("Args out of range"));
2026 Fput (Qvoid_function
, Qerror_conditions
,
2027 Fcons (Qvoid_function
, error_tail
));
2028 Fput (Qvoid_function
, Qerror_message
,
2029 build_string ("Symbol's function definition is void"));
2031 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2032 Fcons (Qcyclic_function_indirection
, error_tail
));
2033 Fput (Qcyclic_function_indirection
, Qerror_message
,
2034 build_string ("Symbol's chain of function indirections contains a loop"));
2036 Fput (Qvoid_variable
, Qerror_conditions
,
2037 Fcons (Qvoid_variable
, error_tail
));
2038 Fput (Qvoid_variable
, Qerror_message
,
2039 build_string ("Symbol's value as variable is void"));
2041 Fput (Qsetting_constant
, Qerror_conditions
,
2042 Fcons (Qsetting_constant
, error_tail
));
2043 Fput (Qsetting_constant
, Qerror_message
,
2044 build_string ("Attempt to set a constant symbol"));
2046 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2047 Fcons (Qinvalid_read_syntax
, error_tail
));
2048 Fput (Qinvalid_read_syntax
, Qerror_message
,
2049 build_string ("Invalid read syntax"));
2051 Fput (Qinvalid_function
, Qerror_conditions
,
2052 Fcons (Qinvalid_function
, error_tail
));
2053 Fput (Qinvalid_function
, Qerror_message
,
2054 build_string ("Invalid function"));
2056 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2057 Fcons (Qwrong_number_of_arguments
, error_tail
));
2058 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2059 build_string ("Wrong number of arguments"));
2061 Fput (Qno_catch
, Qerror_conditions
,
2062 Fcons (Qno_catch
, error_tail
));
2063 Fput (Qno_catch
, Qerror_message
,
2064 build_string ("No catch for tag"));
2066 Fput (Qend_of_file
, Qerror_conditions
,
2067 Fcons (Qend_of_file
, error_tail
));
2068 Fput (Qend_of_file
, Qerror_message
,
2069 build_string ("End of file during parsing"));
2071 arith_tail
= Fcons (Qarith_error
, error_tail
);
2072 Fput (Qarith_error
, Qerror_conditions
,
2074 Fput (Qarith_error
, Qerror_message
,
2075 build_string ("Arithmetic error"));
2077 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2078 Fcons (Qbeginning_of_buffer
, error_tail
));
2079 Fput (Qbeginning_of_buffer
, Qerror_message
,
2080 build_string ("Beginning of buffer"));
2082 Fput (Qend_of_buffer
, Qerror_conditions
,
2083 Fcons (Qend_of_buffer
, error_tail
));
2084 Fput (Qend_of_buffer
, Qerror_message
,
2085 build_string ("End of buffer"));
2087 Fput (Qbuffer_read_only
, Qerror_conditions
,
2088 Fcons (Qbuffer_read_only
, error_tail
));
2089 Fput (Qbuffer_read_only
, Qerror_message
,
2090 build_string ("Buffer is read-only"));
2092 #ifdef LISP_FLOAT_TYPE
2093 Qrange_error
= intern ("range-error");
2094 Qdomain_error
= intern ("domain-error");
2095 Qsingularity_error
= intern ("singularity-error");
2096 Qoverflow_error
= intern ("overflow-error");
2097 Qunderflow_error
= intern ("underflow-error");
2099 Fput (Qdomain_error
, Qerror_conditions
,
2100 Fcons (Qdomain_error
, arith_tail
));
2101 Fput (Qdomain_error
, Qerror_message
,
2102 build_string ("Arithmetic domain error"));
2104 Fput (Qrange_error
, Qerror_conditions
,
2105 Fcons (Qrange_error
, arith_tail
));
2106 Fput (Qrange_error
, Qerror_message
,
2107 build_string ("Arithmetic range error"));
2109 Fput (Qsingularity_error
, Qerror_conditions
,
2110 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2111 Fput (Qsingularity_error
, Qerror_message
,
2112 build_string ("Arithmetic singularity error"));
2114 Fput (Qoverflow_error
, Qerror_conditions
,
2115 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2116 Fput (Qoverflow_error
, Qerror_message
,
2117 build_string ("Arithmetic overflow error"));
2119 Fput (Qunderflow_error
, Qerror_conditions
,
2120 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2121 Fput (Qunderflow_error
, Qerror_message
,
2122 build_string ("Arithmetic underflow error"));
2124 staticpro (&Qrange_error
);
2125 staticpro (&Qdomain_error
);
2126 staticpro (&Qsingularity_error
);
2127 staticpro (&Qoverflow_error
);
2128 staticpro (&Qunderflow_error
);
2129 #endif /* LISP_FLOAT_TYPE */
2133 staticpro (&Qquote
);
2134 staticpro (&Qlambda
);
2136 staticpro (&Qunbound
);
2137 staticpro (&Qerror_conditions
);
2138 staticpro (&Qerror_message
);
2139 staticpro (&Qtop_level
);
2141 staticpro (&Qerror
);
2143 staticpro (&Qwrong_type_argument
);
2144 staticpro (&Qargs_out_of_range
);
2145 staticpro (&Qvoid_function
);
2146 staticpro (&Qcyclic_function_indirection
);
2147 staticpro (&Qvoid_variable
);
2148 staticpro (&Qsetting_constant
);
2149 staticpro (&Qinvalid_read_syntax
);
2150 staticpro (&Qwrong_number_of_arguments
);
2151 staticpro (&Qinvalid_function
);
2152 staticpro (&Qno_catch
);
2153 staticpro (&Qend_of_file
);
2154 staticpro (&Qarith_error
);
2155 staticpro (&Qbeginning_of_buffer
);
2156 staticpro (&Qend_of_buffer
);
2157 staticpro (&Qbuffer_read_only
);
2158 staticpro (&Qmark_inactive
);
2160 staticpro (&Qlistp
);
2161 staticpro (&Qconsp
);
2162 staticpro (&Qsymbolp
);
2163 staticpro (&Qintegerp
);
2164 staticpro (&Qnatnump
);
2165 staticpro (&Qstringp
);
2166 staticpro (&Qarrayp
);
2167 staticpro (&Qsequencep
);
2168 staticpro (&Qbufferp
);
2169 staticpro (&Qvectorp
);
2170 staticpro (&Qchar_or_string_p
);
2171 staticpro (&Qmarkerp
);
2172 staticpro (&Qbuffer_or_string_p
);
2173 staticpro (&Qinteger_or_marker_p
);
2174 #ifdef LISP_FLOAT_TYPE
2175 staticpro (&Qfloatp
);
2176 staticpro (&Qnumberp
);
2177 staticpro (&Qnumber_or_marker_p
);
2178 #endif /* LISP_FLOAT_TYPE */
2180 staticpro (&Qboundp
);
2181 staticpro (&Qfboundp
);
2190 defsubr (&Sintegerp
);
2191 defsubr (&Sinteger_or_marker_p
);
2192 defsubr (&Snumberp
);
2193 defsubr (&Snumber_or_marker_p
);
2194 #ifdef LISP_FLOAT_TYPE
2196 #endif /* LISP_FLOAT_TYPE */
2197 defsubr (&Snatnump
);
2198 defsubr (&Ssymbolp
);
2199 defsubr (&Sstringp
);
2200 defsubr (&Svectorp
);
2202 defsubr (&Ssequencep
);
2203 defsubr (&Sbufferp
);
2204 defsubr (&Smarkerp
);
2206 defsubr (&Sbyte_code_function_p
);
2207 defsubr (&Schar_or_string_p
);
2210 defsubr (&Scar_safe
);
2211 defsubr (&Scdr_safe
);
2214 defsubr (&Ssymbol_function
);
2215 defsubr (&Sindirect_function
);
2216 defsubr (&Ssymbol_plist
);
2217 defsubr (&Ssymbol_name
);
2218 defsubr (&Smakunbound
);
2219 defsubr (&Sfmakunbound
);
2221 defsubr (&Sfboundp
);
2223 defsubr (&Sdefalias
);
2224 defsubr (&Sdefine_function
);
2225 defsubr (&Ssetplist
);
2226 defsubr (&Ssymbol_value
);
2228 defsubr (&Sdefault_boundp
);
2229 defsubr (&Sdefault_value
);
2230 defsubr (&Sset_default
);
2231 defsubr (&Ssetq_default
);
2232 defsubr (&Smake_variable_buffer_local
);
2233 defsubr (&Smake_local_variable
);
2234 defsubr (&Skill_local_variable
);
2237 defsubr (&Snumber_to_string
);
2238 defsubr (&Sstring_to_number
);
2239 defsubr (&Seqlsign
);
2269 /* USG systems forget handlers when they are used;
2270 must reestablish each time */
2271 signal (signo
, arith_error
);
2274 /* VMS systems are like USG. */
2275 signal (signo
, arith_error
);
2279 #else /* not BSD4_1 */
2280 sigsetmask (SIGEMPTYMASK
);
2281 #endif /* not BSD4_1 */
2283 Fsignal (Qarith_error
, Qnil
);
2288 /* Don't do this if just dumping out.
2289 We don't want to call `signal' in this case
2290 so that we don't have trouble with dumping
2291 signal-delivering routines in an inconsistent state. */
2295 #endif /* CANNOT_DUMP */
2296 signal (SIGFPE
, arith_error
);
2299 signal (SIGEMT
, arith_error
);