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
;
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.")
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 if (BUFFER_LOCAL_VALUEP (valcontents
)
468 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
469 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
471 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
474 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
476 register Lisp_Object sym
;
478 CHECK_SYMBOL (sym
, 0);
479 return (EQ (XSYMBOL (sym
)->function
, Qunbound
) ? Qnil
: Qt
);
482 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
484 register Lisp_Object sym
;
486 CHECK_SYMBOL (sym
, 0);
487 if (NILP (sym
) || EQ (sym
, Qt
))
488 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
489 Fset (sym
, Qunbound
);
493 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
495 register Lisp_Object sym
;
497 CHECK_SYMBOL (sym
, 0);
498 if (NILP (sym
) || EQ (sym
, Qt
))
499 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
500 XSYMBOL (sym
)->function
= Qunbound
;
504 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
505 "Return SYMBOL's function definition. Error if that is void.")
507 register Lisp_Object symbol
;
509 CHECK_SYMBOL (symbol
, 0);
510 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
511 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
512 return XSYMBOL (symbol
)->function
;
515 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
517 register Lisp_Object sym
;
519 CHECK_SYMBOL (sym
, 0);
520 return XSYMBOL (sym
)->plist
;
523 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
525 register Lisp_Object sym
;
527 register Lisp_Object name
;
529 CHECK_SYMBOL (sym
, 0);
530 XSETSTRING (name
, XSYMBOL (sym
)->name
);
534 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
535 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
537 register Lisp_Object sym
, newdef
;
539 CHECK_SYMBOL (sym
, 0);
540 if (NILP (sym
) || EQ (sym
, Qt
))
541 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
542 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
543 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
545 XSYMBOL (sym
)->function
= newdef
;
546 /* Handle automatic advice activation */
547 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
549 call2 (Qad_activate
, sym
, Qnil
);
550 newdef
= XSYMBOL (sym
)->function
;
555 /* This name should be removed once it is eliminated from elsewhere. */
557 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
558 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
559 Associates the function with the current load file, if any.")
561 register Lisp_Object sym
, newdef
;
563 CHECK_SYMBOL (sym
, 0);
564 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
565 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
567 XSYMBOL (sym
)->function
= newdef
;
568 /* Handle automatic advice activation */
569 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
571 call2 (Qad_activate
, sym
, Qnil
);
572 newdef
= XSYMBOL (sym
)->function
;
574 LOADHIST_ATTACH (sym
);
578 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
579 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
580 Associates the function with the current load file, if any.")
582 register Lisp_Object sym
, newdef
;
584 CHECK_SYMBOL (sym
, 0);
585 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
586 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
588 XSYMBOL (sym
)->function
= newdef
;
589 /* Handle automatic advice activation */
590 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
592 call2 (Qad_activate
, sym
, Qnil
);
593 newdef
= XSYMBOL (sym
)->function
;
595 LOADHIST_ATTACH (sym
);
599 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
600 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
602 register Lisp_Object sym
, newplist
;
604 CHECK_SYMBOL (sym
, 0);
605 XSYMBOL (sym
)->plist
= newplist
;
610 /* Getting and setting values of symbols */
612 /* Given the raw contents of a symbol value cell,
613 return the Lisp value of the symbol.
614 This does not handle buffer-local variables; use
615 swap_in_symval_forwarding for that. */
618 do_symval_forwarding (valcontents
)
619 register Lisp_Object valcontents
;
621 register Lisp_Object val
;
623 if (MISCP (valcontents
))
624 switch (XMISC (valcontents
)->type
)
626 case Lisp_Misc_Intfwd
:
627 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
630 case Lisp_Misc_Boolfwd
:
631 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
633 case Lisp_Misc_Objfwd
:
634 return *XOBJFWD (valcontents
)->objvar
;
636 case Lisp_Misc_Buffer_Objfwd
:
637 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
638 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
643 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
644 of SYM. If SYM is buffer-local, VALCONTENTS should be the
645 buffer-independent contents of the value cell: forwarded just one
646 step past the buffer-localness. */
649 store_symval_forwarding (sym
, valcontents
, newval
)
651 register Lisp_Object valcontents
, newval
;
653 #ifdef SWITCH_ENUM_BUG
654 switch ((int) XTYPE (valcontents
))
656 switch (XTYPE (valcontents
))
660 switch (XMISC (valcontents
)->type
)
662 case Lisp_Misc_Intfwd
:
663 CHECK_NUMBER (newval
, 1);
664 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
667 case Lisp_Misc_Boolfwd
:
668 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
671 case Lisp_Misc_Objfwd
:
672 *XOBJFWD (valcontents
)->objvar
= newval
;
675 case Lisp_Misc_Buffer_Objfwd
:
677 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
680 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
681 if (! NILP (type
) && ! NILP (newval
)
682 && XTYPE (newval
) != XINT (type
))
683 buffer_slot_type_mismatch (offset
);
685 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
695 valcontents
= XSYMBOL (sym
)->value
;
696 if (BUFFER_LOCAL_VALUEP (valcontents
)
697 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
698 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
700 XSYMBOL (sym
)->value
= newval
;
704 /* Set up the buffer-local symbol SYM for validity in the current
705 buffer. VALCONTENTS is the contents of its value cell.
706 Return the value forwarded one step past the buffer-local indicator. */
709 swap_in_symval_forwarding (sym
, valcontents
)
710 Lisp_Object sym
, valcontents
;
712 /* valcontents is a list
713 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
715 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
716 local_var_alist, that being the element whose car is this
717 variable. Or it can be a pointer to the
718 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
719 an element in its alist for this variable.
721 If the current buffer is not BUFFER, we store the current
722 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
723 appropriate alist element for the buffer now current and set up
724 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
725 element, and store into BUFFER.
727 Note that REALVALUE can be a forwarding pointer. */
729 register Lisp_Object tem1
;
730 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
732 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
734 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
736 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
737 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
739 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
740 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
741 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
743 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
746 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
749 /* Find the value of a symbol, returning Qunbound if it's not bound.
750 This is helpful for code which just wants to get a variable's value
751 if it has one, without signalling an error.
752 Note that it must not be possible to quit
753 within this function. Great care is required for this. */
756 find_symbol_value (sym
)
759 register Lisp_Object valcontents
, tem1
;
760 register Lisp_Object val
;
761 CHECK_SYMBOL (sym
, 0);
762 valcontents
= XSYMBOL (sym
)->value
;
764 if (BUFFER_LOCAL_VALUEP (valcontents
)
765 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
766 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
768 if (MISCP (valcontents
))
770 switch (XMISC (valcontents
)->type
)
772 case Lisp_Misc_Intfwd
:
773 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
776 case Lisp_Misc_Boolfwd
:
777 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
779 case Lisp_Misc_Objfwd
:
780 return *XOBJFWD (valcontents
)->objvar
;
782 case Lisp_Misc_Buffer_Objfwd
:
783 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
784 + (char *)current_buffer
);
791 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
792 "Return SYMBOL's value. Error if that is void.")
798 val
= find_symbol_value (sym
);
799 if (EQ (val
, Qunbound
))
800 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
805 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
806 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
808 register Lisp_Object sym
, newval
;
810 int voide
= EQ (newval
, Qunbound
);
812 register Lisp_Object valcontents
, tem1
, current_alist_element
;
814 CHECK_SYMBOL (sym
, 0);
815 if (NILP (sym
) || EQ (sym
, Qt
))
816 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
817 valcontents
= XSYMBOL (sym
)->value
;
819 if (BUFFER_OBJFWDP (valcontents
))
821 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
822 register int mask
= XINT (*((Lisp_Object
*)
823 (idx
+ (char *)&buffer_local_flags
)));
825 current_buffer
->local_var_flags
|= mask
;
828 else if (BUFFER_LOCAL_VALUEP (valcontents
)
829 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
831 /* valcontents is actually a pointer to a struct resembling a cons,
832 with contents something like:
833 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
835 BUFFER is the last buffer for which this symbol's value was
838 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
839 local_var_alist, that being the element whose car is this
840 variable. Or it can be a pointer to the
841 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
842 have an element in its alist for this variable (that is, if
843 BUFFER sees the default value of this variable).
845 If we want to examine or set the value and BUFFER is current,
846 we just examine or set REALVALUE. If BUFFER is not current, we
847 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
848 then find the appropriate alist element for the buffer now
849 current and set up CURRENT-ALIST-ELEMENT. Then we set
850 REALVALUE out of that element, and store into BUFFER.
852 If we are setting the variable and the current buffer does
853 not have an alist entry for this variable, an alist entry is
856 Note that REALVALUE can be a forwarding pointer. Each time
857 it is examined or set, forwarding must be done. */
859 /* What value are we caching right now? */
860 current_alist_element
=
861 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
863 /* If the current buffer is not the buffer whose binding is
864 currently cached, or if it's a Lisp_Buffer_Local_Value and
865 we're looking at the default value, the cache is invalid; we
866 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
868 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
869 || (BUFFER_LOCAL_VALUEP (valcontents
)
870 && EQ (XCONS (current_alist_element
)->car
,
871 current_alist_element
)))
873 /* Write out the cached value for the old buffer; copy it
874 back to its alist element. This works if the current
875 buffer only sees the default value, too. */
876 Fsetcdr (current_alist_element
,
877 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
879 /* Find the new value for CURRENT-ALIST-ELEMENT. */
880 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
883 /* This buffer still sees the default value. */
885 /* If the variable is a Lisp_Some_Buffer_Local_Value,
886 make CURRENT-ALIST-ELEMENT point to itself,
887 indicating that we're seeing the default value. */
888 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
889 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
891 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
892 new assoc for a local value and set
893 CURRENT-ALIST-ELEMENT to point to that. */
896 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
897 current_buffer
->local_var_alist
=
898 Fcons (tem1
, current_buffer
->local_var_alist
);
901 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
902 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
905 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
906 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
909 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
912 /* If storing void (making the symbol void), forward only through
913 buffer-local indicator, not through Lisp_Objfwd, etc. */
915 store_symval_forwarding (sym
, Qnil
, newval
);
917 store_symval_forwarding (sym
, valcontents
, newval
);
922 /* Access or set a buffer-local symbol's default value. */
924 /* Return the default value of SYM, but don't check for voidness.
925 Return Qunbound if it is void. */
931 register Lisp_Object valcontents
;
933 CHECK_SYMBOL (sym
, 0);
934 valcontents
= XSYMBOL (sym
)->value
;
936 /* For a built-in buffer-local variable, get the default value
937 rather than letting do_symval_forwarding get the current value. */
938 if (BUFFER_OBJFWDP (valcontents
))
940 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
942 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
943 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
946 /* Handle user-created local variables. */
947 if (BUFFER_LOCAL_VALUEP (valcontents
)
948 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
950 /* If var is set up for a buffer that lacks a local value for it,
951 the current value is nominally the default value.
952 But the current value slot may be more up to date, since
953 ordinary setq stores just that slot. So use that. */
954 Lisp_Object current_alist_element
, alist_element_car
;
955 current_alist_element
956 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
957 alist_element_car
= XCONS (current_alist_element
)->car
;
958 if (EQ (alist_element_car
, current_alist_element
))
959 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
961 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
963 /* For other variables, get the current value. */
964 return do_symval_forwarding (valcontents
);
967 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
968 "Return T if SYMBOL has a non-void default value.\n\
969 This is the value that is seen in buffers that do not have their own values\n\
974 register Lisp_Object value
;
976 value
= default_value (sym
);
977 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
980 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
981 "Return SYMBOL's default value.\n\
982 This is the value that is seen in buffers that do not have their own values\n\
983 for this variable. The default value is meaningful for variables with\n\
984 local bindings in certain buffers.")
988 register Lisp_Object value
;
990 value
= default_value (sym
);
991 if (EQ (value
, Qunbound
))
992 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
996 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
997 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
998 The default value is seen in buffers that do not have their own values\n\
1001 Lisp_Object sym
, value
;
1003 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1005 CHECK_SYMBOL (sym
, 0);
1006 valcontents
= XSYMBOL (sym
)->value
;
1008 /* Handle variables like case-fold-search that have special slots
1009 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1011 if (BUFFER_OBJFWDP (valcontents
))
1013 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1014 register struct buffer
*b
;
1015 register int mask
= XINT (*((Lisp_Object
*)
1016 (idx
+ (char *)&buffer_local_flags
)));
1020 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1021 for (b
= all_buffers
; b
; b
= b
->next
)
1022 if (!(b
->local_var_flags
& mask
))
1023 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1028 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1029 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1030 return Fset (sym
, value
);
1032 /* Store new value into the DEFAULT-VALUE slot */
1033 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1035 /* If that slot is current, we must set the REALVALUE slot too */
1036 current_alist_element
1037 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1038 alist_element_buffer
= Fcar (current_alist_element
);
1039 if (EQ (alist_element_buffer
, current_alist_element
))
1040 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1046 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1047 "Set the default value of variable VAR to VALUE.\n\
1048 VAR, the variable name, is literal (not evaluated);\n\
1049 VALUE is an expression and it is evaluated.\n\
1050 The default value of a variable is seen in buffers\n\
1051 that do not have their own values for the variable.\n\
1053 More generally, you can use multiple variables and values, as in\n\
1054 (setq-default SYM VALUE SYM VALUE...)\n\
1055 This sets each SYM's default value to the corresponding VALUE.\n\
1056 The VALUE for the Nth SYM can refer to the new default values\n\
1061 register Lisp_Object args_left
;
1062 register Lisp_Object val
, sym
;
1063 struct gcpro gcpro1
;
1073 val
= Feval (Fcar (Fcdr (args_left
)));
1074 sym
= Fcar (args_left
);
1075 Fset_default (sym
, val
);
1076 args_left
= Fcdr (Fcdr (args_left
));
1078 while (!NILP (args_left
));
1084 /* Lisp functions for creating and removing buffer-local variables. */
1086 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1087 1, 1, "vMake Variable Buffer Local: ",
1088 "Make VARIABLE have a separate value for each buffer.\n\
1089 At any time, the value for the current buffer is in effect.\n\
1090 There is also a default value which is seen in any buffer which has not yet\n\
1091 set its own value.\n\
1092 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1093 for the current buffer if it was previously using the default value.\n\
1094 The function `default-value' gets the default value and `set-default' sets it.")
1096 register Lisp_Object sym
;
1098 register Lisp_Object tem
, valcontents
, newval
;
1100 CHECK_SYMBOL (sym
, 0);
1102 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1103 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1105 valcontents
= XSYMBOL (sym
)->value
;
1106 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1108 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1110 XMISC (XSYMBOL (sym
)->value
)->type
= Lisp_Misc_Buffer_Local_Value
;
1113 if (EQ (valcontents
, Qunbound
))
1114 XSYMBOL (sym
)->value
= Qnil
;
1115 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1116 XCONS (tem
)->car
= tem
;
1117 newval
= allocate_misc ();
1118 XMISC (newval
)->type
= Lisp_Misc_Buffer_Local_Value
;
1119 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1120 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1121 XSYMBOL (sym
)->value
= newval
;
1125 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1126 1, 1, "vMake Local Variable: ",
1127 "Make VARIABLE have a separate value in the current buffer.\n\
1128 Other buffers will continue to share a common default value.\n\
1129 \(The buffer-local value of VARIABLE starts out as the same value\n\
1130 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1131 See also `make-variable-buffer-local'.\n\n\
1132 If the variable is already arranged to become local when set,\n\
1133 this function causes a local value to exist for this buffer,\n\
1134 just as setting the variable would do.\n\
1136 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1137 Use `make-local-hook' instead.")
1139 register Lisp_Object sym
;
1141 register Lisp_Object tem
, valcontents
;
1143 CHECK_SYMBOL (sym
, 0);
1145 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1146 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1148 valcontents
= XSYMBOL (sym
)->value
;
1149 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1151 tem
= Fboundp (sym
);
1153 /* Make sure the symbol has a local value in this particular buffer,
1154 by setting it to the same value it already has. */
1155 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1158 /* Make sure sym is set up to hold per-buffer values */
1159 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1162 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1163 XCONS (tem
)->car
= tem
;
1164 newval
= allocate_misc ();
1165 XMISC (newval
)->type
= Lisp_Misc_Some_Buffer_Local_Value
;
1166 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1167 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1168 XSYMBOL (sym
)->value
= newval
;
1170 /* Make sure this buffer has its own value of sym */
1171 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1174 current_buffer
->local_var_alist
1175 = Fcons (Fcons (sym
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1176 current_buffer
->local_var_alist
);
1178 /* Make sure symbol does not think it is set up for this buffer;
1179 force it to look once again for this buffer's value */
1181 Lisp_Object
*pvalbuf
;
1182 valcontents
= XSYMBOL (sym
)->value
;
1183 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1184 if (current_buffer
== XBUFFER (*pvalbuf
))
1189 /* If the symbol forwards into a C variable, then swap in the
1190 variable for this buffer immediately. If C code modifies the
1191 variable before we swap in, then that new value will clobber the
1192 default value the next time we swap. */
1193 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->car
;
1194 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1195 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1200 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1201 1, 1, "vKill Local Variable: ",
1202 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1203 From now on the default value will apply in this buffer.")
1205 register Lisp_Object sym
;
1207 register Lisp_Object tem
, valcontents
;
1209 CHECK_SYMBOL (sym
, 0);
1211 valcontents
= XSYMBOL (sym
)->value
;
1213 if (BUFFER_OBJFWDP (valcontents
))
1215 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1216 register int mask
= XINT (*((Lisp_Object
*)
1217 (idx
+ (char *)&buffer_local_flags
)));
1221 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1222 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1223 current_buffer
->local_var_flags
&= ~mask
;
1228 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1229 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1232 /* Get rid of this buffer's alist element, if any */
1234 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1236 current_buffer
->local_var_alist
1237 = Fdelq (tem
, current_buffer
->local_var_alist
);
1239 /* Make sure symbol does not think it is set up for this buffer;
1240 force it to look once again for this buffer's value */
1242 Lisp_Object
*pvalbuf
;
1243 valcontents
= XSYMBOL (sym
)->value
;
1244 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1245 if (current_buffer
== XBUFFER (*pvalbuf
))
1252 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1254 "Non-nil if VARIABLE has a local binding in the current buffer.")
1256 register Lisp_Object sym
;
1258 Lisp_Object valcontents
;
1260 CHECK_SYMBOL (sym
, 0);
1262 valcontents
= XSYMBOL (sym
)->value
;
1263 return ((BUFFER_LOCAL_VALUEP (valcontents
)
1264 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1265 || BUFFER_OBJFWDP (valcontents
))
1269 /* Find the function at the end of a chain of symbol function indirections. */
1271 /* If OBJECT is a symbol, find the end of its function chain and
1272 return the value found there. If OBJECT is not a symbol, just
1273 return it. If there is a cycle in the function chain, signal a
1274 cyclic-function-indirection error.
1276 This is like Findirect_function, except that it doesn't signal an
1277 error if the chain ends up unbound. */
1279 indirect_function (object
)
1280 register Lisp_Object object
;
1282 Lisp_Object tortoise
, hare
;
1284 hare
= tortoise
= object
;
1288 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1290 hare
= XSYMBOL (hare
)->function
;
1291 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1293 hare
= XSYMBOL (hare
)->function
;
1295 tortoise
= XSYMBOL (tortoise
)->function
;
1297 if (EQ (hare
, tortoise
))
1298 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1304 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1305 "Return the function at the end of OBJECT's function chain.\n\
1306 If OBJECT is a symbol, follow all function indirections and return the final\n\
1307 function binding.\n\
1308 If OBJECT is not a symbol, just return it.\n\
1309 Signal a void-function error if the final symbol is unbound.\n\
1310 Signal a cyclic-function-indirection error if there is a loop in the\n\
1311 function chain of symbols.")
1313 register Lisp_Object object
;
1317 result
= indirect_function (object
);
1319 if (EQ (result
, Qunbound
))
1320 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1324 /* Extract and set vector and string elements */
1326 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1327 "Return the element of ARRAY at index INDEX.\n\
1328 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1330 register Lisp_Object array
;
1333 register int idxval
;
1335 CHECK_NUMBER (idx
, 1);
1336 idxval
= XINT (idx
);
1337 if (STRINGP (array
))
1340 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1341 args_out_of_range (array
, idx
);
1342 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1347 if (!VECTORP (array
) && !COMPILEDP (array
))
1348 array
= wrong_type_argument (Qarrayp
, array
);
1349 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1350 args_out_of_range (array
, idx
);
1351 return XVECTOR (array
)->contents
[idxval
];
1355 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1356 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1357 ARRAY may be a vector or a string. IDX starts at 0.")
1358 (array
, idx
, newelt
)
1359 register Lisp_Object array
;
1360 Lisp_Object idx
, newelt
;
1362 register int idxval
;
1364 CHECK_NUMBER (idx
, 1);
1365 idxval
= XINT (idx
);
1366 if (!VECTORP (array
) && !STRINGP (array
))
1367 array
= wrong_type_argument (Qarrayp
, array
);
1368 CHECK_IMPURE (array
);
1370 if (VECTORP (array
))
1372 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1373 args_out_of_range (array
, idx
);
1374 XVECTOR (array
)->contents
[idxval
] = newelt
;
1378 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1379 args_out_of_range (array
, idx
);
1380 CHECK_NUMBER (newelt
, 2);
1381 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1387 /* Arithmetic functions */
1389 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1392 arithcompare (num1
, num2
, comparison
)
1393 Lisp_Object num1
, num2
;
1394 enum comparison comparison
;
1399 #ifdef LISP_FLOAT_TYPE
1400 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1401 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1403 if (FLOATP (num1
) || FLOATP (num2
))
1406 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1407 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1410 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1411 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1412 #endif /* LISP_FLOAT_TYPE */
1417 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1422 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1427 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1432 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1437 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1442 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1451 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1452 "T if two args, both numbers or markers, are equal.")
1454 register Lisp_Object num1
, num2
;
1456 return arithcompare (num1
, num2
, equal
);
1459 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1460 "T if first arg is less than second arg. Both must be numbers or markers.")
1462 register Lisp_Object num1
, num2
;
1464 return arithcompare (num1
, num2
, less
);
1467 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1468 "T if first arg is greater than second arg. Both must be numbers or markers.")
1470 register Lisp_Object num1
, num2
;
1472 return arithcompare (num1
, num2
, grtr
);
1475 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1476 "T if first arg is less than or equal to second arg.\n\
1477 Both must be numbers or markers.")
1479 register Lisp_Object num1
, num2
;
1481 return arithcompare (num1
, num2
, less_or_equal
);
1484 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1485 "T if first arg is greater than or equal to second arg.\n\
1486 Both must be numbers or markers.")
1488 register Lisp_Object num1
, num2
;
1490 return arithcompare (num1
, num2
, grtr_or_equal
);
1493 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1494 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1496 register Lisp_Object num1
, num2
;
1498 return arithcompare (num1
, num2
, notequal
);
1501 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1503 register Lisp_Object num
;
1505 #ifdef LISP_FLOAT_TYPE
1506 CHECK_NUMBER_OR_FLOAT (num
, 0);
1510 if (XFLOAT(num
)->data
== 0.0)
1515 CHECK_NUMBER (num
, 0);
1516 #endif /* LISP_FLOAT_TYPE */
1523 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1529 unsigned int top
= i
>> 16;
1530 unsigned int bot
= i
& 0xFFFF;
1532 return make_number (bot
);
1534 return Fcons (make_number (-1), make_number (bot
));
1535 return Fcons (make_number (top
), make_number (bot
));
1542 Lisp_Object top
, bot
;
1545 top
= XCONS (c
)->car
;
1546 bot
= XCONS (c
)->cdr
;
1548 bot
= XCONS (bot
)->car
;
1549 return ((XINT (top
) << 16) | XINT (bot
));
1552 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1553 "Convert NUM to a string by printing it in decimal.\n\
1554 Uses a minus sign if negative.\n\
1555 NUM may be an integer or a floating point number.")
1561 #ifndef LISP_FLOAT_TYPE
1562 CHECK_NUMBER (num
, 0);
1564 CHECK_NUMBER_OR_FLOAT (num
, 0);
1568 char pigbuf
[350]; /* see comments in float_to_string */
1570 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1571 return build_string (pigbuf
);
1573 #endif /* LISP_FLOAT_TYPE */
1575 sprintf (buffer
, "%d", XINT (num
));
1576 return build_string (buffer
);
1579 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1580 "Convert STRING to a number by parsing it as a decimal number.\n\
1581 This parses both integers and floating point numbers.\n\
1582 It ignores leading spaces and tabs.")
1584 register Lisp_Object str
;
1588 CHECK_STRING (str
, 0);
1590 p
= XSTRING (str
)->data
;
1592 /* Skip any whitespace at the front of the number. Some versions of
1593 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1594 while (*p
== ' ' || *p
== '\t')
1597 #ifdef LISP_FLOAT_TYPE
1598 if (isfloat_string (p
))
1599 return make_float (atof (p
));
1600 #endif /* LISP_FLOAT_TYPE */
1602 return make_number (atoi (p
));
1606 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1608 extern Lisp_Object
float_arith_driver ();
1611 arith_driver (code
, nargs
, args
)
1614 register Lisp_Object
*args
;
1616 register Lisp_Object val
;
1617 register int argnum
;
1621 #ifdef SWITCH_ENUM_BUG
1638 for (argnum
= 0; argnum
< nargs
; argnum
++)
1640 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1641 #ifdef LISP_FLOAT_TYPE
1642 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1644 if (FLOATP (val
)) /* time to do serious math */
1645 return (float_arith_driver ((double) accum
, argnum
, code
,
1648 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1649 #endif /* LISP_FLOAT_TYPE */
1650 args
[argnum
] = val
; /* runs into a compiler bug. */
1651 next
= XINT (args
[argnum
]);
1652 #ifdef SWITCH_ENUM_BUG
1658 case Aadd
: accum
+= next
; break;
1660 if (!argnum
&& nargs
!= 1)
1664 case Amult
: accum
*= next
; break;
1666 if (!argnum
) accum
= next
;
1670 Fsignal (Qarith_error
, Qnil
);
1674 case Alogand
: accum
&= next
; break;
1675 case Alogior
: accum
|= next
; break;
1676 case Alogxor
: accum
^= next
; break;
1677 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1678 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1682 XSETINT (val
, accum
);
1686 #ifdef LISP_FLOAT_TYPE
1689 #define isnan(x) ((x) != (x))
1692 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1694 register int argnum
;
1697 register Lisp_Object
*args
;
1699 register Lisp_Object val
;
1702 for (; argnum
< nargs
; argnum
++)
1704 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1705 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1709 next
= XFLOAT (val
)->data
;
1713 args
[argnum
] = val
; /* runs into a compiler bug. */
1714 next
= XINT (args
[argnum
]);
1716 #ifdef SWITCH_ENUM_BUG
1726 if (!argnum
&& nargs
!= 1)
1739 Fsignal (Qarith_error
, Qnil
);
1746 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1748 if (!argnum
|| isnan (next
) || next
> accum
)
1752 if (!argnum
|| isnan (next
) || next
< accum
)
1758 return make_float (accum
);
1760 #endif /* LISP_FLOAT_TYPE */
1762 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1763 "Return sum of any number of arguments, which are numbers or markers.")
1768 return arith_driver (Aadd
, nargs
, args
);
1771 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1772 "Negate number or subtract numbers or markers.\n\
1773 With one arg, negates it. With more than one arg,\n\
1774 subtracts all but the first from the first.")
1779 return arith_driver (Asub
, nargs
, args
);
1782 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1783 "Returns product of any number of arguments, which are numbers or markers.")
1788 return arith_driver (Amult
, nargs
, args
);
1791 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1792 "Returns first argument divided by all the remaining arguments.\n\
1793 The arguments must be numbers or markers.")
1798 return arith_driver (Adiv
, nargs
, args
);
1801 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1802 "Returns remainder of first arg divided by second.\n\
1803 Both must be integers or markers.")
1805 register Lisp_Object num1
, num2
;
1809 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1810 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1812 if (XFASTINT (num2
) == 0)
1813 Fsignal (Qarith_error
, Qnil
);
1815 XSETINT (val
, XINT (num1
) % XINT (num2
));
1824 #ifdef HAVE_DREM /* Some systems use this non-standard name. */
1825 return (drem (f1
, f2
));
1826 #else /* Other systems don't seem to have it at all. */
1827 return (f1
- f2
* floor (f1
/f2
));
1830 #endif /* ! HAVE_FMOD */
1832 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1833 "Returns X modulo Y.\n\
1834 The result falls between zero (inclusive) and Y (exclusive).\n\
1835 Both X and Y must be numbers or markers.")
1837 register Lisp_Object num1
, num2
;
1842 #ifdef LISP_FLOAT_TYPE
1843 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1844 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
1846 if (FLOATP (num1
) || FLOATP (num2
))
1850 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
1851 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
1853 Fsignal (Qarith_error
, Qnil
);
1856 /* If the "remainder" comes out with the wrong sign, fix it. */
1857 if ((f1
< 0) != (f2
< 0))
1859 return (make_float (f1
));
1861 #else /* not LISP_FLOAT_TYPE */
1862 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1863 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1864 #endif /* not LISP_FLOAT_TYPE */
1870 Fsignal (Qarith_error
, Qnil
);
1874 /* If the "remainder" comes out with the wrong sign, fix it. */
1875 if ((i1
< 0) != (i2
< 0))
1882 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1883 "Return largest of all the arguments (which must be numbers or markers).\n\
1884 The value is always a number; markers are converted to numbers.")
1889 return arith_driver (Amax
, nargs
, args
);
1892 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1893 "Return smallest of all the arguments (which must be numbers or markers).\n\
1894 The value is always a number; markers are converted to numbers.")
1899 return arith_driver (Amin
, nargs
, args
);
1902 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1903 "Return bitwise-and of all the arguments.\n\
1904 Arguments may be integers, or markers converted to integers.")
1909 return arith_driver (Alogand
, nargs
, args
);
1912 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1913 "Return bitwise-or of all the arguments.\n\
1914 Arguments may be integers, or markers converted to integers.")
1919 return arith_driver (Alogior
, nargs
, args
);
1922 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1923 "Return bitwise-exclusive-or of all the arguments.\n\
1924 Arguments may be integers, or markers converted to integers.")
1929 return arith_driver (Alogxor
, nargs
, args
);
1932 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1933 "Return VALUE with its bits shifted left by COUNT.\n\
1934 If COUNT is negative, shifting is actually to the right.\n\
1935 In this case, the sign bit is duplicated.")
1937 register Lisp_Object num1
, num2
;
1939 register Lisp_Object val
;
1941 CHECK_NUMBER (num1
, 0);
1942 CHECK_NUMBER (num2
, 1);
1944 if (XINT (num2
) > 0)
1945 XSETINT (val
, XINT (num1
) << XFASTINT (num2
));
1947 XSETINT (val
, XINT (num1
) >> -XINT (num2
));
1951 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1952 "Return VALUE with its bits shifted left by COUNT.\n\
1953 If COUNT is negative, shifting is actually to the right.\n\
1954 In this case, zeros are shifted in on the left.")
1956 register Lisp_Object num1
, num2
;
1958 register Lisp_Object val
;
1960 CHECK_NUMBER (num1
, 0);
1961 CHECK_NUMBER (num2
, 1);
1963 if (XINT (num2
) > 0)
1964 XSETINT (val
, (EMACS_UINT
) XUINT (num1
) << XFASTINT (num2
));
1966 XSETINT (val
, (EMACS_UINT
) XUINT (num1
) >> -XINT (num2
));
1970 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1971 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1972 Markers are converted to integers.")
1974 register Lisp_Object num
;
1976 #ifdef LISP_FLOAT_TYPE
1977 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1980 return (make_float (1.0 + XFLOAT (num
)->data
));
1982 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1983 #endif /* LISP_FLOAT_TYPE */
1985 XSETINT (num
, XINT (num
) + 1);
1989 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1990 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1991 Markers are converted to integers.")
1993 register Lisp_Object num
;
1995 #ifdef LISP_FLOAT_TYPE
1996 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1999 return (make_float (-1.0 + XFLOAT (num
)->data
));
2001 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2002 #endif /* LISP_FLOAT_TYPE */
2004 XSETINT (num
, XINT (num
) - 1);
2008 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2009 "Return the bitwise complement of ARG. ARG must be an integer.")
2011 register Lisp_Object num
;
2013 CHECK_NUMBER (num
, 0);
2014 XSETINT (num
, ~XINT (num
));
2021 Lisp_Object error_tail
, arith_tail
;
2023 Qquote
= intern ("quote");
2024 Qlambda
= intern ("lambda");
2025 Qsubr
= intern ("subr");
2026 Qerror_conditions
= intern ("error-conditions");
2027 Qerror_message
= intern ("error-message");
2028 Qtop_level
= intern ("top-level");
2030 Qerror
= intern ("error");
2031 Qquit
= intern ("quit");
2032 Qwrong_type_argument
= intern ("wrong-type-argument");
2033 Qargs_out_of_range
= intern ("args-out-of-range");
2034 Qvoid_function
= intern ("void-function");
2035 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2036 Qvoid_variable
= intern ("void-variable");
2037 Qsetting_constant
= intern ("setting-constant");
2038 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2040 Qinvalid_function
= intern ("invalid-function");
2041 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2042 Qno_catch
= intern ("no-catch");
2043 Qend_of_file
= intern ("end-of-file");
2044 Qarith_error
= intern ("arith-error");
2045 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2046 Qend_of_buffer
= intern ("end-of-buffer");
2047 Qbuffer_read_only
= intern ("buffer-read-only");
2048 Qmark_inactive
= intern ("mark-inactive");
2050 Qlistp
= intern ("listp");
2051 Qconsp
= intern ("consp");
2052 Qsymbolp
= intern ("symbolp");
2053 Qintegerp
= intern ("integerp");
2054 Qnatnump
= intern ("natnump");
2055 Qwholenump
= intern ("wholenump");
2056 Qstringp
= intern ("stringp");
2057 Qarrayp
= intern ("arrayp");
2058 Qsequencep
= intern ("sequencep");
2059 Qbufferp
= intern ("bufferp");
2060 Qvectorp
= intern ("vectorp");
2061 Qchar_or_string_p
= intern ("char-or-string-p");
2062 Qmarkerp
= intern ("markerp");
2063 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2064 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2065 Qboundp
= intern ("boundp");
2066 Qfboundp
= intern ("fboundp");
2068 #ifdef LISP_FLOAT_TYPE
2069 Qfloatp
= intern ("floatp");
2070 Qnumberp
= intern ("numberp");
2071 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2072 #endif /* LISP_FLOAT_TYPE */
2074 Qcdr
= intern ("cdr");
2076 /* Handle automatic advice activation */
2077 Qad_advice_info
= intern ("ad-advice-info");
2078 Qad_activate
= intern ("ad-activate");
2080 error_tail
= Fcons (Qerror
, Qnil
);
2082 /* ERROR is used as a signaler for random errors for which nothing else is right */
2084 Fput (Qerror
, Qerror_conditions
,
2086 Fput (Qerror
, Qerror_message
,
2087 build_string ("error"));
2089 Fput (Qquit
, Qerror_conditions
,
2090 Fcons (Qquit
, Qnil
));
2091 Fput (Qquit
, Qerror_message
,
2092 build_string ("Quit"));
2094 Fput (Qwrong_type_argument
, Qerror_conditions
,
2095 Fcons (Qwrong_type_argument
, error_tail
));
2096 Fput (Qwrong_type_argument
, Qerror_message
,
2097 build_string ("Wrong type argument"));
2099 Fput (Qargs_out_of_range
, Qerror_conditions
,
2100 Fcons (Qargs_out_of_range
, error_tail
));
2101 Fput (Qargs_out_of_range
, Qerror_message
,
2102 build_string ("Args out of range"));
2104 Fput (Qvoid_function
, Qerror_conditions
,
2105 Fcons (Qvoid_function
, error_tail
));
2106 Fput (Qvoid_function
, Qerror_message
,
2107 build_string ("Symbol's function definition is void"));
2109 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2110 Fcons (Qcyclic_function_indirection
, error_tail
));
2111 Fput (Qcyclic_function_indirection
, Qerror_message
,
2112 build_string ("Symbol's chain of function indirections contains a loop"));
2114 Fput (Qvoid_variable
, Qerror_conditions
,
2115 Fcons (Qvoid_variable
, error_tail
));
2116 Fput (Qvoid_variable
, Qerror_message
,
2117 build_string ("Symbol's value as variable is void"));
2119 Fput (Qsetting_constant
, Qerror_conditions
,
2120 Fcons (Qsetting_constant
, error_tail
));
2121 Fput (Qsetting_constant
, Qerror_message
,
2122 build_string ("Attempt to set a constant symbol"));
2124 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2125 Fcons (Qinvalid_read_syntax
, error_tail
));
2126 Fput (Qinvalid_read_syntax
, Qerror_message
,
2127 build_string ("Invalid read syntax"));
2129 Fput (Qinvalid_function
, Qerror_conditions
,
2130 Fcons (Qinvalid_function
, error_tail
));
2131 Fput (Qinvalid_function
, Qerror_message
,
2132 build_string ("Invalid function"));
2134 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2135 Fcons (Qwrong_number_of_arguments
, error_tail
));
2136 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2137 build_string ("Wrong number of arguments"));
2139 Fput (Qno_catch
, Qerror_conditions
,
2140 Fcons (Qno_catch
, error_tail
));
2141 Fput (Qno_catch
, Qerror_message
,
2142 build_string ("No catch for tag"));
2144 Fput (Qend_of_file
, Qerror_conditions
,
2145 Fcons (Qend_of_file
, error_tail
));
2146 Fput (Qend_of_file
, Qerror_message
,
2147 build_string ("End of file during parsing"));
2149 arith_tail
= Fcons (Qarith_error
, error_tail
);
2150 Fput (Qarith_error
, Qerror_conditions
,
2152 Fput (Qarith_error
, Qerror_message
,
2153 build_string ("Arithmetic error"));
2155 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2156 Fcons (Qbeginning_of_buffer
, error_tail
));
2157 Fput (Qbeginning_of_buffer
, Qerror_message
,
2158 build_string ("Beginning of buffer"));
2160 Fput (Qend_of_buffer
, Qerror_conditions
,
2161 Fcons (Qend_of_buffer
, error_tail
));
2162 Fput (Qend_of_buffer
, Qerror_message
,
2163 build_string ("End of buffer"));
2165 Fput (Qbuffer_read_only
, Qerror_conditions
,
2166 Fcons (Qbuffer_read_only
, error_tail
));
2167 Fput (Qbuffer_read_only
, Qerror_message
,
2168 build_string ("Buffer is read-only"));
2170 #ifdef LISP_FLOAT_TYPE
2171 Qrange_error
= intern ("range-error");
2172 Qdomain_error
= intern ("domain-error");
2173 Qsingularity_error
= intern ("singularity-error");
2174 Qoverflow_error
= intern ("overflow-error");
2175 Qunderflow_error
= intern ("underflow-error");
2177 Fput (Qdomain_error
, Qerror_conditions
,
2178 Fcons (Qdomain_error
, arith_tail
));
2179 Fput (Qdomain_error
, Qerror_message
,
2180 build_string ("Arithmetic domain error"));
2182 Fput (Qrange_error
, Qerror_conditions
,
2183 Fcons (Qrange_error
, arith_tail
));
2184 Fput (Qrange_error
, Qerror_message
,
2185 build_string ("Arithmetic range error"));
2187 Fput (Qsingularity_error
, Qerror_conditions
,
2188 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2189 Fput (Qsingularity_error
, Qerror_message
,
2190 build_string ("Arithmetic singularity error"));
2192 Fput (Qoverflow_error
, Qerror_conditions
,
2193 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2194 Fput (Qoverflow_error
, Qerror_message
,
2195 build_string ("Arithmetic overflow error"));
2197 Fput (Qunderflow_error
, Qerror_conditions
,
2198 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2199 Fput (Qunderflow_error
, Qerror_message
,
2200 build_string ("Arithmetic underflow error"));
2202 staticpro (&Qrange_error
);
2203 staticpro (&Qdomain_error
);
2204 staticpro (&Qsingularity_error
);
2205 staticpro (&Qoverflow_error
);
2206 staticpro (&Qunderflow_error
);
2207 #endif /* LISP_FLOAT_TYPE */
2211 staticpro (&Qquote
);
2212 staticpro (&Qlambda
);
2214 staticpro (&Qunbound
);
2215 staticpro (&Qerror_conditions
);
2216 staticpro (&Qerror_message
);
2217 staticpro (&Qtop_level
);
2219 staticpro (&Qerror
);
2221 staticpro (&Qwrong_type_argument
);
2222 staticpro (&Qargs_out_of_range
);
2223 staticpro (&Qvoid_function
);
2224 staticpro (&Qcyclic_function_indirection
);
2225 staticpro (&Qvoid_variable
);
2226 staticpro (&Qsetting_constant
);
2227 staticpro (&Qinvalid_read_syntax
);
2228 staticpro (&Qwrong_number_of_arguments
);
2229 staticpro (&Qinvalid_function
);
2230 staticpro (&Qno_catch
);
2231 staticpro (&Qend_of_file
);
2232 staticpro (&Qarith_error
);
2233 staticpro (&Qbeginning_of_buffer
);
2234 staticpro (&Qend_of_buffer
);
2235 staticpro (&Qbuffer_read_only
);
2236 staticpro (&Qmark_inactive
);
2238 staticpro (&Qlistp
);
2239 staticpro (&Qconsp
);
2240 staticpro (&Qsymbolp
);
2241 staticpro (&Qintegerp
);
2242 staticpro (&Qnatnump
);
2243 staticpro (&Qwholenump
);
2244 staticpro (&Qstringp
);
2245 staticpro (&Qarrayp
);
2246 staticpro (&Qsequencep
);
2247 staticpro (&Qbufferp
);
2248 staticpro (&Qvectorp
);
2249 staticpro (&Qchar_or_string_p
);
2250 staticpro (&Qmarkerp
);
2251 staticpro (&Qbuffer_or_string_p
);
2252 staticpro (&Qinteger_or_marker_p
);
2253 #ifdef LISP_FLOAT_TYPE
2254 staticpro (&Qfloatp
);
2255 staticpro (&Qnumberp
);
2256 staticpro (&Qnumber_or_marker_p
);
2257 #endif /* LISP_FLOAT_TYPE */
2259 staticpro (&Qboundp
);
2260 staticpro (&Qfboundp
);
2262 staticpro (&Qad_advice_info
);
2263 staticpro (&Qad_activate
);
2271 defsubr (&Sintegerp
);
2272 defsubr (&Sinteger_or_marker_p
);
2273 defsubr (&Snumberp
);
2274 defsubr (&Snumber_or_marker_p
);
2275 #ifdef LISP_FLOAT_TYPE
2277 #endif /* LISP_FLOAT_TYPE */
2278 defsubr (&Snatnump
);
2279 defsubr (&Ssymbolp
);
2280 defsubr (&Sstringp
);
2281 defsubr (&Svectorp
);
2283 defsubr (&Ssequencep
);
2284 defsubr (&Sbufferp
);
2285 defsubr (&Smarkerp
);
2287 defsubr (&Sbyte_code_function_p
);
2288 defsubr (&Schar_or_string_p
);
2291 defsubr (&Scar_safe
);
2292 defsubr (&Scdr_safe
);
2295 defsubr (&Ssymbol_function
);
2296 defsubr (&Sindirect_function
);
2297 defsubr (&Ssymbol_plist
);
2298 defsubr (&Ssymbol_name
);
2299 defsubr (&Smakunbound
);
2300 defsubr (&Sfmakunbound
);
2302 defsubr (&Sfboundp
);
2304 defsubr (&Sdefalias
);
2305 defsubr (&Sdefine_function
);
2306 defsubr (&Ssetplist
);
2307 defsubr (&Ssymbol_value
);
2309 defsubr (&Sdefault_boundp
);
2310 defsubr (&Sdefault_value
);
2311 defsubr (&Sset_default
);
2312 defsubr (&Ssetq_default
);
2313 defsubr (&Smake_variable_buffer_local
);
2314 defsubr (&Smake_local_variable
);
2315 defsubr (&Skill_local_variable
);
2316 defsubr (&Slocal_variable_p
);
2319 defsubr (&Snumber_to_string
);
2320 defsubr (&Sstring_to_number
);
2321 defsubr (&Seqlsign
);
2345 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2353 /* USG systems forget handlers when they are used;
2354 must reestablish each time */
2355 signal (signo
, arith_error
);
2358 /* VMS systems are like USG. */
2359 signal (signo
, arith_error
);
2363 #else /* not BSD4_1 */
2364 sigsetmask (SIGEMPTYMASK
);
2365 #endif /* not BSD4_1 */
2367 Fsignal (Qarith_error
, Qnil
);
2372 /* Don't do this if just dumping out.
2373 We don't want to call `signal' in this case
2374 so that we don't have trouble with dumping
2375 signal-delivering routines in an inconsistent state. */
2379 #endif /* CANNOT_DUMP */
2380 signal (SIGFPE
, arith_error
);
2383 signal (SIGEMT
, arith_error
);