1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 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
);
105 /* If VALUE is not even a valid Lisp object, abort here
106 where we can get a backtrace showing where it came from. */
107 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
110 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
111 tem
= call1 (predicate
, value
);
119 error ("Attempt to modify read-only object");
123 args_out_of_range (a1
, a2
)
127 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
131 args_out_of_range_3 (a1
, a2
, a3
)
132 Lisp_Object a1
, a2
, a3
;
135 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
142 register Lisp_Object val
;
147 /* On some machines, XINT needs a temporary location.
148 Here it is, in case it is needed. */
150 int sign_extend_temp
;
152 /* On a few machines, XINT can only be done by calling this. */
155 sign_extend_lisp_int (num
)
158 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
159 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
161 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
164 /* Data type predicates */
166 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
167 "T if the two args are the same Lisp object.")
169 Lisp_Object obj1
, obj2
;
176 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
185 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
194 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
203 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
207 if (CONSP (obj
) || NILP (obj
))
212 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
216 if (CONSP (obj
) || NILP (obj
))
221 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
230 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
239 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
248 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
252 if (VECTORP (obj
) || STRINGP (obj
))
257 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
258 "T if OBJECT is a sequence (list or array).")
260 register Lisp_Object obj
;
262 if (CONSP (obj
) || NILP (obj
) || VECTORP (obj
) || STRINGP (obj
))
267 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
276 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
285 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
294 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
295 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
304 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
305 "T if OBJECT is a character (an integer) or a string.")
307 register Lisp_Object obj
;
309 if (INTEGERP (obj
) || STRINGP (obj
))
314 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
323 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
324 "T if OBJECT is an integer or a marker (editor pointer).")
326 register Lisp_Object obj
;
328 if (MARKERP (obj
) || INTEGERP (obj
))
333 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
334 "T if OBJECT is a nonnegative integer.")
343 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
344 "T if OBJECT is a number (floating point or integer).")
354 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
355 Snumber_or_marker_p
, 1, 1, 0,
356 "T if OBJECT is a number or a marker.")
360 if (NUMBERP (obj
) || MARKERP (obj
))
365 #ifdef LISP_FLOAT_TYPE
366 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
367 "T if OBJECT is a floating point number.")
375 #endif /* LISP_FLOAT_TYPE */
377 /* Extract and set components of lists */
379 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
380 "Return the car of CONSCELL. If arg is nil, return nil.\n\
381 Error if arg is not nil and not a cons cell. See also `car-safe'.")
383 register Lisp_Object list
;
388 return XCONS (list
)->car
;
389 else if (EQ (list
, Qnil
))
392 list
= wrong_type_argument (Qlistp
, list
);
396 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
397 "Return the car of OBJECT if it is a cons cell, or else nil.")
402 return XCONS (object
)->car
;
407 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
408 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
409 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
412 register Lisp_Object list
;
417 return XCONS (list
)->cdr
;
418 else if (EQ (list
, Qnil
))
421 list
= wrong_type_argument (Qlistp
, list
);
425 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
426 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
431 return XCONS (object
)->cdr
;
436 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
437 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
439 register Lisp_Object cell
, newcar
;
442 cell
= wrong_type_argument (Qconsp
, cell
);
445 XCONS (cell
)->car
= newcar
;
449 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
450 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
452 register Lisp_Object cell
, newcdr
;
455 cell
= wrong_type_argument (Qconsp
, cell
);
458 XCONS (cell
)->cdr
= newcdr
;
462 /* Extract and set components of symbols */
464 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
466 register Lisp_Object sym
;
468 Lisp_Object valcontents
;
469 CHECK_SYMBOL (sym
, 0);
471 valcontents
= XSYMBOL (sym
)->value
;
473 if (BUFFER_LOCAL_VALUEP (valcontents
)
474 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
475 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
477 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
480 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
482 register Lisp_Object sym
;
484 CHECK_SYMBOL (sym
, 0);
485 return (EQ (XSYMBOL (sym
)->function
, Qunbound
) ? Qnil
: Qt
);
488 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
490 register Lisp_Object sym
;
492 CHECK_SYMBOL (sym
, 0);
493 if (NILP (sym
) || EQ (sym
, Qt
))
494 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
495 Fset (sym
, Qunbound
);
499 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
501 register Lisp_Object sym
;
503 CHECK_SYMBOL (sym
, 0);
504 if (NILP (sym
) || EQ (sym
, Qt
))
505 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
506 XSYMBOL (sym
)->function
= Qunbound
;
510 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
511 "Return SYMBOL's function definition. Error if that is void.")
513 register Lisp_Object symbol
;
515 CHECK_SYMBOL (symbol
, 0);
516 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
517 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
518 return XSYMBOL (symbol
)->function
;
521 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
523 register Lisp_Object sym
;
525 CHECK_SYMBOL (sym
, 0);
526 return XSYMBOL (sym
)->plist
;
529 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
531 register Lisp_Object sym
;
533 register Lisp_Object name
;
535 CHECK_SYMBOL (sym
, 0);
536 XSETSTRING (name
, XSYMBOL (sym
)->name
);
540 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
541 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
543 register Lisp_Object sym
, newdef
;
545 CHECK_SYMBOL (sym
, 0);
546 if (NILP (sym
) || EQ (sym
, Qt
))
547 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
548 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
549 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
551 XSYMBOL (sym
)->function
= newdef
;
552 /* Handle automatic advice activation */
553 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
555 call2 (Qad_activate
, sym
, Qnil
);
556 newdef
= XSYMBOL (sym
)->function
;
561 /* This name should be removed once it is eliminated from elsewhere. */
563 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
564 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
565 Associates the function with the current load file, if any.")
567 register Lisp_Object sym
, newdef
;
569 CHECK_SYMBOL (sym
, 0);
570 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
571 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
573 XSYMBOL (sym
)->function
= newdef
;
574 /* Handle automatic advice activation */
575 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
577 call2 (Qad_activate
, sym
, Qnil
);
578 newdef
= XSYMBOL (sym
)->function
;
580 LOADHIST_ATTACH (sym
);
584 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
585 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
586 Associates the function with the current load file, if any.")
588 register Lisp_Object sym
, newdef
;
590 CHECK_SYMBOL (sym
, 0);
591 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
592 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
594 XSYMBOL (sym
)->function
= newdef
;
595 /* Handle automatic advice activation */
596 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
598 call2 (Qad_activate
, sym
, Qnil
);
599 newdef
= XSYMBOL (sym
)->function
;
601 LOADHIST_ATTACH (sym
);
605 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
606 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
608 register Lisp_Object sym
, newplist
;
610 CHECK_SYMBOL (sym
, 0);
611 XSYMBOL (sym
)->plist
= newplist
;
616 /* Getting and setting values of symbols */
618 /* Given the raw contents of a symbol value cell,
619 return the Lisp value of the symbol.
620 This does not handle buffer-local variables; use
621 swap_in_symval_forwarding for that. */
624 do_symval_forwarding (valcontents
)
625 register Lisp_Object valcontents
;
627 register Lisp_Object val
;
629 if (MISCP (valcontents
))
630 switch (XMISC (valcontents
)->type
)
632 case Lisp_Misc_Intfwd
:
633 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
636 case Lisp_Misc_Boolfwd
:
637 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
639 case Lisp_Misc_Objfwd
:
640 return *XOBJFWD (valcontents
)->objvar
;
642 case Lisp_Misc_Buffer_Objfwd
:
643 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
644 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
646 case Lisp_Misc_Display_Objfwd
:
647 if (!current_perdisplay
)
649 offset
= XDISPLAY_OBJFWD (valcontents
)->offset
;
650 return *(Lisp_Object
*)(offset
+ (char *)current_perdisplay
);
655 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
656 of SYM. If SYM is buffer-local, VALCONTENTS should be the
657 buffer-independent contents of the value cell: forwarded just one
658 step past the buffer-localness. */
661 store_symval_forwarding (sym
, valcontents
, newval
)
663 register Lisp_Object valcontents
, newval
;
665 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
668 switch (XMISC (valcontents
)->type
)
670 case Lisp_Misc_Intfwd
:
671 CHECK_NUMBER (newval
, 1);
672 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
675 case Lisp_Misc_Boolfwd
:
676 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
679 case Lisp_Misc_Objfwd
:
680 *XOBJFWD (valcontents
)->objvar
= newval
;
683 case Lisp_Misc_Buffer_Objfwd
:
685 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
688 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
689 if (! NILP (type
) && ! NILP (newval
)
690 && XTYPE (newval
) != XINT (type
))
691 buffer_slot_type_mismatch (offset
);
693 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
697 case Lisp_Misc_Display_Objfwd
:
698 if (!current_perdisplay
)
700 (*(Lisp_Object
*)((char *)current_perdisplay
701 + XDISPLAY_OBJFWD (valcontents
)->offset
))
712 valcontents
= XSYMBOL (sym
)->value
;
713 if (BUFFER_LOCAL_VALUEP (valcontents
)
714 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
715 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
717 XSYMBOL (sym
)->value
= newval
;
721 /* Set up the buffer-local symbol SYM for validity in the current
722 buffer. VALCONTENTS is the contents of its value cell.
723 Return the value forwarded one step past the buffer-local indicator. */
726 swap_in_symval_forwarding (sym
, valcontents
)
727 Lisp_Object sym
, valcontents
;
729 /* valcontents is a pointer to a struct resembling the cons
730 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
732 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
733 local_var_alist, that being the element whose car is this
734 variable. Or it can be a pointer to the
735 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
736 an element in its alist for this variable.
738 If the current buffer is not BUFFER, we store the current
739 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
740 appropriate alist element for the buffer now current and set up
741 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
742 element, and store into BUFFER.
744 Note that REALVALUE can be a forwarding pointer. */
746 register Lisp_Object tem1
;
747 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
749 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
751 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
753 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
754 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
756 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
757 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
758 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
760 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
763 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
766 /* Find the value of a symbol, returning Qunbound if it's not bound.
767 This is helpful for code which just wants to get a variable's value
768 if it has one, without signalling an error.
769 Note that it must not be possible to quit
770 within this function. Great care is required for this. */
773 find_symbol_value (sym
)
776 register Lisp_Object valcontents
, tem1
;
777 register Lisp_Object val
;
778 CHECK_SYMBOL (sym
, 0);
779 valcontents
= XSYMBOL (sym
)->value
;
781 if (BUFFER_LOCAL_VALUEP (valcontents
)
782 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
783 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
785 if (MISCP (valcontents
))
787 switch (XMISC (valcontents
)->type
)
789 case Lisp_Misc_Intfwd
:
790 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
793 case Lisp_Misc_Boolfwd
:
794 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
796 case Lisp_Misc_Objfwd
:
797 return *XOBJFWD (valcontents
)->objvar
;
799 case Lisp_Misc_Buffer_Objfwd
:
800 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
801 + (char *)current_buffer
);
803 case Lisp_Misc_Display_Objfwd
:
804 if (!current_perdisplay
)
806 return *(Lisp_Object
*)(XDISPLAY_OBJFWD (valcontents
)->offset
807 + (char *)current_perdisplay
);
814 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
815 "Return SYMBOL's value. Error if that is void.")
821 val
= find_symbol_value (sym
);
822 if (EQ (val
, Qunbound
))
823 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
828 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
829 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
831 register Lisp_Object sym
, newval
;
833 int voide
= EQ (newval
, Qunbound
);
835 register Lisp_Object valcontents
, tem1
, current_alist_element
;
837 CHECK_SYMBOL (sym
, 0);
838 if (NILP (sym
) || EQ (sym
, Qt
))
839 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
840 valcontents
= XSYMBOL (sym
)->value
;
842 if (BUFFER_OBJFWDP (valcontents
))
844 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
845 register int mask
= XINT (*((Lisp_Object
*)
846 (idx
+ (char *)&buffer_local_flags
)));
848 current_buffer
->local_var_flags
|= mask
;
851 else if (BUFFER_LOCAL_VALUEP (valcontents
)
852 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
854 /* valcontents is actually a pointer to a struct resembling a cons,
855 with contents something like:
856 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
858 BUFFER is the last buffer for which this symbol's value was
861 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
862 local_var_alist, that being the element whose car is this
863 variable. Or it can be a pointer to the
864 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
865 have an element in its alist for this variable (that is, if
866 BUFFER sees the default value of this variable).
868 If we want to examine or set the value and BUFFER is current,
869 we just examine or set REALVALUE. If BUFFER is not current, we
870 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
871 then find the appropriate alist element for the buffer now
872 current and set up CURRENT-ALIST-ELEMENT. Then we set
873 REALVALUE out of that element, and store into BUFFER.
875 If we are setting the variable and the current buffer does
876 not have an alist entry for this variable, an alist entry is
879 Note that REALVALUE can be a forwarding pointer. Each time
880 it is examined or set, forwarding must be done. */
882 /* What value are we caching right now? */
883 current_alist_element
=
884 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
886 /* If the current buffer is not the buffer whose binding is
887 currently cached, or if it's a Lisp_Buffer_Local_Value and
888 we're looking at the default value, the cache is invalid; we
889 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
891 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
892 || (BUFFER_LOCAL_VALUEP (valcontents
)
893 && EQ (XCONS (current_alist_element
)->car
,
894 current_alist_element
)))
896 /* Write out the cached value for the old buffer; copy it
897 back to its alist element. This works if the current
898 buffer only sees the default value, too. */
899 Fsetcdr (current_alist_element
,
900 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
902 /* Find the new value for CURRENT-ALIST-ELEMENT. */
903 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
906 /* This buffer still sees the default value. */
908 /* If the variable is a Lisp_Some_Buffer_Local_Value,
909 make CURRENT-ALIST-ELEMENT point to itself,
910 indicating that we're seeing the default value. */
911 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
912 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
914 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
915 new assoc for a local value and set
916 CURRENT-ALIST-ELEMENT to point to that. */
919 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
920 current_buffer
->local_var_alist
=
921 Fcons (tem1
, current_buffer
->local_var_alist
);
924 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
925 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
928 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
929 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
932 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
935 /* If storing void (making the symbol void), forward only through
936 buffer-local indicator, not through Lisp_Objfwd, etc. */
938 store_symval_forwarding (sym
, Qnil
, newval
);
940 store_symval_forwarding (sym
, valcontents
, newval
);
945 /* Access or set a buffer-local symbol's default value. */
947 /* Return the default value of SYM, but don't check for voidness.
948 Return Qunbound if it is void. */
954 register Lisp_Object valcontents
;
956 CHECK_SYMBOL (sym
, 0);
957 valcontents
= XSYMBOL (sym
)->value
;
959 /* For a built-in buffer-local variable, get the default value
960 rather than letting do_symval_forwarding get the current value. */
961 if (BUFFER_OBJFWDP (valcontents
))
963 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
965 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
966 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
969 /* Handle user-created local variables. */
970 if (BUFFER_LOCAL_VALUEP (valcontents
)
971 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
973 /* If var is set up for a buffer that lacks a local value for it,
974 the current value is nominally the default value.
975 But the current value slot may be more up to date, since
976 ordinary setq stores just that slot. So use that. */
977 Lisp_Object current_alist_element
, alist_element_car
;
978 current_alist_element
979 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
980 alist_element_car
= XCONS (current_alist_element
)->car
;
981 if (EQ (alist_element_car
, current_alist_element
))
982 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
984 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
986 /* For other variables, get the current value. */
987 return do_symval_forwarding (valcontents
);
990 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
991 "Return T if SYMBOL has a non-void default value.\n\
992 This is the value that is seen in buffers that do not have their own values\n\
997 register Lisp_Object value
;
999 value
= default_value (sym
);
1000 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1003 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1004 "Return SYMBOL's default value.\n\
1005 This is the value that is seen in buffers that do not have their own values\n\
1006 for this variable. The default value is meaningful for variables with\n\
1007 local bindings in certain buffers.")
1011 register Lisp_Object value
;
1013 value
= default_value (sym
);
1014 if (EQ (value
, Qunbound
))
1015 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1019 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1020 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1021 The default value is seen in buffers that do not have their own values\n\
1022 for this variable.")
1024 Lisp_Object sym
, value
;
1026 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1028 CHECK_SYMBOL (sym
, 0);
1029 valcontents
= XSYMBOL (sym
)->value
;
1031 /* Handle variables like case-fold-search that have special slots
1032 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1034 if (BUFFER_OBJFWDP (valcontents
))
1036 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1037 register struct buffer
*b
;
1038 register int mask
= XINT (*((Lisp_Object
*)
1039 (idx
+ (char *)&buffer_local_flags
)));
1043 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1044 for (b
= all_buffers
; b
; b
= b
->next
)
1045 if (!(b
->local_var_flags
& mask
))
1046 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1051 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1052 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1053 return Fset (sym
, value
);
1055 /* Store new value into the DEFAULT-VALUE slot */
1056 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1058 /* If that slot is current, we must set the REALVALUE slot too */
1059 current_alist_element
1060 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1061 alist_element_buffer
= Fcar (current_alist_element
);
1062 if (EQ (alist_element_buffer
, current_alist_element
))
1063 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1069 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1070 "Set the default value of variable VAR to VALUE.\n\
1071 VAR, the variable name, is literal (not evaluated);\n\
1072 VALUE is an expression and it is evaluated.\n\
1073 The default value of a variable is seen in buffers\n\
1074 that do not have their own values for the variable.\n\
1076 More generally, you can use multiple variables and values, as in\n\
1077 (setq-default SYM VALUE SYM VALUE...)\n\
1078 This sets each SYM's default value to the corresponding VALUE.\n\
1079 The VALUE for the Nth SYM can refer to the new default values\n\
1084 register Lisp_Object args_left
;
1085 register Lisp_Object val
, sym
;
1086 struct gcpro gcpro1
;
1096 val
= Feval (Fcar (Fcdr (args_left
)));
1097 sym
= Fcar (args_left
);
1098 Fset_default (sym
, val
);
1099 args_left
= Fcdr (Fcdr (args_left
));
1101 while (!NILP (args_left
));
1107 /* Lisp functions for creating and removing buffer-local variables. */
1109 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1110 1, 1, "vMake Variable Buffer Local: ",
1111 "Make VARIABLE have a separate value for each buffer.\n\
1112 At any time, the value for the current buffer is in effect.\n\
1113 There is also a default value which is seen in any buffer which has not yet\n\
1114 set its own value.\n\
1115 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1116 for the current buffer if it was previously using the default value.\n\
1117 The function `default-value' gets the default value and `set-default' sets it.")
1119 register Lisp_Object sym
;
1121 register Lisp_Object tem
, valcontents
, newval
;
1123 CHECK_SYMBOL (sym
, 0);
1125 valcontents
= XSYMBOL (sym
)->value
;
1126 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || DISPLAY_OBJFWDP (valcontents
))
1127 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1129 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1131 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1133 XMISC (XSYMBOL (sym
)->value
)->type
= Lisp_Misc_Buffer_Local_Value
;
1136 if (EQ (valcontents
, Qunbound
))
1137 XSYMBOL (sym
)->value
= Qnil
;
1138 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1139 XCONS (tem
)->car
= tem
;
1140 newval
= allocate_misc ();
1141 XMISC (newval
)->type
= Lisp_Misc_Buffer_Local_Value
;
1142 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1143 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1144 XSYMBOL (sym
)->value
= newval
;
1148 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1149 1, 1, "vMake Local Variable: ",
1150 "Make VARIABLE have a separate value in the current buffer.\n\
1151 Other buffers will continue to share a common default value.\n\
1152 \(The buffer-local value of VARIABLE starts out as the same value\n\
1153 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1154 See also `make-variable-buffer-local'.\n\n\
1155 If the variable is already arranged to become local when set,\n\
1156 this function causes a local value to exist for this buffer,\n\
1157 just as setting the variable would do.\n\
1159 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1160 Use `make-local-hook' instead.")
1162 register Lisp_Object sym
;
1164 register Lisp_Object tem
, valcontents
;
1166 CHECK_SYMBOL (sym
, 0);
1168 valcontents
= XSYMBOL (sym
)->value
;
1169 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || DISPLAY_OBJFWDP (valcontents
))
1170 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1172 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1174 tem
= Fboundp (sym
);
1176 /* Make sure the symbol has a local value in this particular buffer,
1177 by setting it to the same value it already has. */
1178 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1181 /* Make sure sym is set up to hold per-buffer values */
1182 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1185 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1186 XCONS (tem
)->car
= tem
;
1187 newval
= allocate_misc ();
1188 XMISC (newval
)->type
= Lisp_Misc_Some_Buffer_Local_Value
;
1189 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1190 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1191 XSYMBOL (sym
)->value
= newval
;
1193 /* Make sure this buffer has its own value of sym */
1194 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1197 current_buffer
->local_var_alist
1198 = Fcons (Fcons (sym
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1199 current_buffer
->local_var_alist
);
1201 /* Make sure symbol does not think it is set up for this buffer;
1202 force it to look once again for this buffer's value */
1204 Lisp_Object
*pvalbuf
;
1205 valcontents
= XSYMBOL (sym
)->value
;
1206 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1207 if (current_buffer
== XBUFFER (*pvalbuf
))
1212 /* If the symbol forwards into a C variable, then swap in the
1213 variable for this buffer immediately. If C code modifies the
1214 variable before we swap in, then that new value will clobber the
1215 default value the next time we swap. */
1216 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->car
;
1217 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1218 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1223 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1224 1, 1, "vKill Local Variable: ",
1225 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1226 From now on the default value will apply in this buffer.")
1228 register Lisp_Object sym
;
1230 register Lisp_Object tem
, valcontents
;
1232 CHECK_SYMBOL (sym
, 0);
1234 valcontents
= XSYMBOL (sym
)->value
;
1236 if (BUFFER_OBJFWDP (valcontents
))
1238 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1239 register int mask
= XINT (*((Lisp_Object
*)
1240 (idx
+ (char *)&buffer_local_flags
)));
1244 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1245 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1246 current_buffer
->local_var_flags
&= ~mask
;
1251 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1252 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1255 /* Get rid of this buffer's alist element, if any */
1257 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1259 current_buffer
->local_var_alist
1260 = Fdelq (tem
, current_buffer
->local_var_alist
);
1262 /* Make sure symbol does not think it is set up for this buffer;
1263 force it to look once again for this buffer's value */
1265 Lisp_Object
*pvalbuf
;
1266 valcontents
= XSYMBOL (sym
)->value
;
1267 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1268 if (current_buffer
== XBUFFER (*pvalbuf
))
1275 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1277 "Non-nil if VARIABLE has a local binding in the current buffer.")
1279 register Lisp_Object sym
;
1281 Lisp_Object valcontents
;
1283 CHECK_SYMBOL (sym
, 0);
1285 valcontents
= XSYMBOL (sym
)->value
;
1286 return ((BUFFER_LOCAL_VALUEP (valcontents
)
1287 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1288 || BUFFER_OBJFWDP (valcontents
))
1292 /* Find the function at the end of a chain of symbol function indirections. */
1294 /* If OBJECT is a symbol, find the end of its function chain and
1295 return the value found there. If OBJECT is not a symbol, just
1296 return it. If there is a cycle in the function chain, signal a
1297 cyclic-function-indirection error.
1299 This is like Findirect_function, except that it doesn't signal an
1300 error if the chain ends up unbound. */
1302 indirect_function (object
)
1303 register Lisp_Object object
;
1305 Lisp_Object tortoise
, hare
;
1307 hare
= tortoise
= object
;
1311 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1313 hare
= XSYMBOL (hare
)->function
;
1314 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1316 hare
= XSYMBOL (hare
)->function
;
1318 tortoise
= XSYMBOL (tortoise
)->function
;
1320 if (EQ (hare
, tortoise
))
1321 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1327 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1328 "Return the function at the end of OBJECT's function chain.\n\
1329 If OBJECT is a symbol, follow all function indirections and return the final\n\
1330 function binding.\n\
1331 If OBJECT is not a symbol, just return it.\n\
1332 Signal a void-function error if the final symbol is unbound.\n\
1333 Signal a cyclic-function-indirection error if there is a loop in the\n\
1334 function chain of symbols.")
1336 register Lisp_Object object
;
1340 result
= indirect_function (object
);
1342 if (EQ (result
, Qunbound
))
1343 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1347 /* Extract and set vector and string elements */
1349 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1350 "Return the element of ARRAY at index INDEX.\n\
1351 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1353 register Lisp_Object array
;
1356 register int idxval
;
1358 CHECK_NUMBER (idx
, 1);
1359 idxval
= XINT (idx
);
1360 if (STRINGP (array
))
1363 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1364 args_out_of_range (array
, idx
);
1365 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1371 if (VECTORP (array
))
1372 size
= XVECTOR (array
)->size
;
1373 else if (COMPILEDP (array
))
1374 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1376 wrong_type_argument (Qarrayp
, array
);
1378 if (idxval
< 0 || idxval
>= size
)
1379 args_out_of_range (array
, idx
);
1380 return XVECTOR (array
)->contents
[idxval
];
1384 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1385 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1386 ARRAY may be a vector or a string. IDX starts at 0.")
1387 (array
, idx
, newelt
)
1388 register Lisp_Object array
;
1389 Lisp_Object idx
, newelt
;
1391 register int idxval
;
1393 CHECK_NUMBER (idx
, 1);
1394 idxval
= XINT (idx
);
1395 if (!VECTORP (array
) && !STRINGP (array
))
1396 array
= wrong_type_argument (Qarrayp
, array
);
1397 CHECK_IMPURE (array
);
1399 if (VECTORP (array
))
1401 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1402 args_out_of_range (array
, idx
);
1403 XVECTOR (array
)->contents
[idxval
] = newelt
;
1407 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1408 args_out_of_range (array
, idx
);
1409 CHECK_NUMBER (newelt
, 2);
1410 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1416 /* Arithmetic functions */
1418 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1421 arithcompare (num1
, num2
, comparison
)
1422 Lisp_Object num1
, num2
;
1423 enum comparison comparison
;
1428 #ifdef LISP_FLOAT_TYPE
1429 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1430 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1432 if (FLOATP (num1
) || FLOATP (num2
))
1435 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1436 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1439 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1440 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1441 #endif /* LISP_FLOAT_TYPE */
1446 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1451 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1456 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1461 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1466 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1471 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1480 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1481 "T if two args, both numbers or markers, are equal.")
1483 register Lisp_Object num1
, num2
;
1485 return arithcompare (num1
, num2
, equal
);
1488 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1489 "T if first arg is less than second arg. Both must be numbers or markers.")
1491 register Lisp_Object num1
, num2
;
1493 return arithcompare (num1
, num2
, less
);
1496 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1497 "T if first arg is greater than second arg. Both must be numbers or markers.")
1499 register Lisp_Object num1
, num2
;
1501 return arithcompare (num1
, num2
, grtr
);
1504 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1505 "T if first arg is less than or equal to second arg.\n\
1506 Both must be numbers or markers.")
1508 register Lisp_Object num1
, num2
;
1510 return arithcompare (num1
, num2
, less_or_equal
);
1513 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1514 "T if first arg is greater than or equal to second arg.\n\
1515 Both must be numbers or markers.")
1517 register Lisp_Object num1
, num2
;
1519 return arithcompare (num1
, num2
, grtr_or_equal
);
1522 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1523 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1525 register Lisp_Object num1
, num2
;
1527 return arithcompare (num1
, num2
, notequal
);
1530 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1532 register Lisp_Object num
;
1534 #ifdef LISP_FLOAT_TYPE
1535 CHECK_NUMBER_OR_FLOAT (num
, 0);
1539 if (XFLOAT(num
)->data
== 0.0)
1544 CHECK_NUMBER (num
, 0);
1545 #endif /* LISP_FLOAT_TYPE */
1552 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1558 unsigned int top
= i
>> 16;
1559 unsigned int bot
= i
& 0xFFFF;
1561 return make_number (bot
);
1563 return Fcons (make_number (-1), make_number (bot
));
1564 return Fcons (make_number (top
), make_number (bot
));
1571 Lisp_Object top
, bot
;
1574 top
= XCONS (c
)->car
;
1575 bot
= XCONS (c
)->cdr
;
1577 bot
= XCONS (bot
)->car
;
1578 return ((XINT (top
) << 16) | XINT (bot
));
1581 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1582 "Convert NUM to a string by printing it in decimal.\n\
1583 Uses a minus sign if negative.\n\
1584 NUM may be an integer or a floating point number.")
1590 #ifndef LISP_FLOAT_TYPE
1591 CHECK_NUMBER (num
, 0);
1593 CHECK_NUMBER_OR_FLOAT (num
, 0);
1597 char pigbuf
[350]; /* see comments in float_to_string */
1599 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1600 return build_string (pigbuf
);
1602 #endif /* LISP_FLOAT_TYPE */
1604 sprintf (buffer
, "%d", XINT (num
));
1605 return build_string (buffer
);
1608 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1609 "Convert STRING to a number by parsing it as a decimal number.\n\
1610 This parses both integers and floating point numbers.\n\
1611 It ignores leading spaces and tabs.")
1613 register Lisp_Object str
;
1617 CHECK_STRING (str
, 0);
1619 p
= XSTRING (str
)->data
;
1621 /* Skip any whitespace at the front of the number. Some versions of
1622 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1623 while (*p
== ' ' || *p
== '\t')
1626 #ifdef LISP_FLOAT_TYPE
1627 if (isfloat_string (p
))
1628 return make_float (atof (p
));
1629 #endif /* LISP_FLOAT_TYPE */
1631 return make_number (atoi (p
));
1635 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1637 extern Lisp_Object
float_arith_driver ();
1640 arith_driver (code
, nargs
, args
)
1643 register Lisp_Object
*args
;
1645 register Lisp_Object val
;
1646 register int argnum
;
1650 switch (SWITCH_ENUM_CAST (code
))
1663 for (argnum
= 0; argnum
< nargs
; argnum
++)
1665 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1666 #ifdef LISP_FLOAT_TYPE
1667 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1669 if (FLOATP (val
)) /* time to do serious math */
1670 return (float_arith_driver ((double) accum
, argnum
, code
,
1673 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1674 #endif /* LISP_FLOAT_TYPE */
1675 args
[argnum
] = val
; /* runs into a compiler bug. */
1676 next
= XINT (args
[argnum
]);
1677 switch (SWITCH_ENUM_CAST (code
))
1679 case Aadd
: accum
+= next
; break;
1681 if (!argnum
&& nargs
!= 1)
1685 case Amult
: accum
*= next
; break;
1687 if (!argnum
) accum
= next
;
1691 Fsignal (Qarith_error
, Qnil
);
1695 case Alogand
: accum
&= next
; break;
1696 case Alogior
: accum
|= next
; break;
1697 case Alogxor
: accum
^= next
; break;
1698 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1699 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1703 XSETINT (val
, accum
);
1707 #ifdef LISP_FLOAT_TYPE
1710 #define isnan(x) ((x) != (x))
1713 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1715 register int argnum
;
1718 register Lisp_Object
*args
;
1720 register Lisp_Object val
;
1723 for (; argnum
< nargs
; argnum
++)
1725 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1726 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1730 next
= XFLOAT (val
)->data
;
1734 args
[argnum
] = val
; /* runs into a compiler bug. */
1735 next
= XINT (args
[argnum
]);
1737 switch (SWITCH_ENUM_CAST (code
))
1743 if (!argnum
&& nargs
!= 1)
1756 Fsignal (Qarith_error
, Qnil
);
1763 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1765 if (!argnum
|| isnan (next
) || next
> accum
)
1769 if (!argnum
|| isnan (next
) || next
< accum
)
1775 return make_float (accum
);
1777 #endif /* LISP_FLOAT_TYPE */
1779 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1780 "Return sum of any number of arguments, which are numbers or markers.")
1785 return arith_driver (Aadd
, nargs
, args
);
1788 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1789 "Negate number or subtract numbers or markers.\n\
1790 With one arg, negates it. With more than one arg,\n\
1791 subtracts all but the first from the first.")
1796 return arith_driver (Asub
, nargs
, args
);
1799 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1800 "Returns product of any number of arguments, which are numbers or markers.")
1805 return arith_driver (Amult
, nargs
, args
);
1808 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1809 "Returns first argument divided by all the remaining arguments.\n\
1810 The arguments must be numbers or markers.")
1815 return arith_driver (Adiv
, nargs
, args
);
1818 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1819 "Returns remainder of first arg divided by second.\n\
1820 Both must be integers or markers.")
1822 register Lisp_Object num1
, num2
;
1826 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1827 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1829 if (XFASTINT (num2
) == 0)
1830 Fsignal (Qarith_error
, Qnil
);
1832 XSETINT (val
, XINT (num1
) % XINT (num2
));
1841 #ifdef HAVE_DREM /* Some systems use this non-standard name. */
1842 return (drem (f1
, f2
));
1843 #else /* Other systems don't seem to have it at all. */
1844 return (f1
- f2
* floor (f1
/f2
));
1847 #endif /* ! HAVE_FMOD */
1849 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1850 "Returns X modulo Y.\n\
1851 The result falls between zero (inclusive) and Y (exclusive).\n\
1852 Both X and Y must be numbers or markers.")
1854 register Lisp_Object num1
, num2
;
1859 #ifdef LISP_FLOAT_TYPE
1860 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1861 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
1863 if (FLOATP (num1
) || FLOATP (num2
))
1867 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
1868 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
1870 Fsignal (Qarith_error
, Qnil
);
1873 /* If the "remainder" comes out with the wrong sign, fix it. */
1874 if ((f1
< 0) != (f2
< 0))
1876 return (make_float (f1
));
1878 #else /* not LISP_FLOAT_TYPE */
1879 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1880 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1881 #endif /* not LISP_FLOAT_TYPE */
1887 Fsignal (Qarith_error
, Qnil
);
1891 /* If the "remainder" comes out with the wrong sign, fix it. */
1892 if ((i1
< 0) != (i2
< 0))
1899 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1900 "Return largest of all the arguments (which must be numbers or markers).\n\
1901 The value is always a number; markers are converted to numbers.")
1906 return arith_driver (Amax
, nargs
, args
);
1909 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1910 "Return smallest of all the arguments (which must be numbers or markers).\n\
1911 The value is always a number; markers are converted to numbers.")
1916 return arith_driver (Amin
, nargs
, args
);
1919 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1920 "Return bitwise-and of all the arguments.\n\
1921 Arguments may be integers, or markers converted to integers.")
1926 return arith_driver (Alogand
, nargs
, args
);
1929 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1930 "Return bitwise-or of all the arguments.\n\
1931 Arguments may be integers, or markers converted to integers.")
1936 return arith_driver (Alogior
, nargs
, args
);
1939 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1940 "Return bitwise-exclusive-or of all the arguments.\n\
1941 Arguments may be integers, or markers converted to integers.")
1946 return arith_driver (Alogxor
, nargs
, args
);
1949 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1950 "Return VALUE with its bits shifted left by COUNT.\n\
1951 If COUNT is negative, shifting is actually to the right.\n\
1952 In this case, the sign bit is duplicated.")
1954 register Lisp_Object num1
, num2
;
1956 register Lisp_Object val
;
1958 CHECK_NUMBER (num1
, 0);
1959 CHECK_NUMBER (num2
, 1);
1961 if (XINT (num2
) > 0)
1962 XSETINT (val
, XINT (num1
) << XFASTINT (num2
));
1964 XSETINT (val
, XINT (num1
) >> -XINT (num2
));
1968 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1969 "Return VALUE with its bits shifted left by COUNT.\n\
1970 If COUNT is negative, shifting is actually to the right.\n\
1971 In this case, zeros are shifted in on the left.")
1973 register Lisp_Object num1
, num2
;
1975 register Lisp_Object val
;
1977 CHECK_NUMBER (num1
, 0);
1978 CHECK_NUMBER (num2
, 1);
1980 if (XINT (num2
) > 0)
1981 XSETINT (val
, (EMACS_UINT
) XUINT (num1
) << XFASTINT (num2
));
1983 XSETINT (val
, (EMACS_UINT
) XUINT (num1
) >> -XINT (num2
));
1987 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1988 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1989 Markers are converted to integers.")
1991 register Lisp_Object num
;
1993 #ifdef LISP_FLOAT_TYPE
1994 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1997 return (make_float (1.0 + XFLOAT (num
)->data
));
1999 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2000 #endif /* LISP_FLOAT_TYPE */
2002 XSETINT (num
, XINT (num
) + 1);
2006 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2007 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2008 Markers are converted to integers.")
2010 register Lisp_Object num
;
2012 #ifdef LISP_FLOAT_TYPE
2013 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2016 return (make_float (-1.0 + XFLOAT (num
)->data
));
2018 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2019 #endif /* LISP_FLOAT_TYPE */
2021 XSETINT (num
, XINT (num
) - 1);
2025 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2026 "Return the bitwise complement of ARG. ARG must be an integer.")
2028 register Lisp_Object num
;
2030 CHECK_NUMBER (num
, 0);
2031 XSETINT (num
, ~XINT (num
));
2038 Lisp_Object error_tail
, arith_tail
;
2040 Qquote
= intern ("quote");
2041 Qlambda
= intern ("lambda");
2042 Qsubr
= intern ("subr");
2043 Qerror_conditions
= intern ("error-conditions");
2044 Qerror_message
= intern ("error-message");
2045 Qtop_level
= intern ("top-level");
2047 Qerror
= intern ("error");
2048 Qquit
= intern ("quit");
2049 Qwrong_type_argument
= intern ("wrong-type-argument");
2050 Qargs_out_of_range
= intern ("args-out-of-range");
2051 Qvoid_function
= intern ("void-function");
2052 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2053 Qvoid_variable
= intern ("void-variable");
2054 Qsetting_constant
= intern ("setting-constant");
2055 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2057 Qinvalid_function
= intern ("invalid-function");
2058 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2059 Qno_catch
= intern ("no-catch");
2060 Qend_of_file
= intern ("end-of-file");
2061 Qarith_error
= intern ("arith-error");
2062 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2063 Qend_of_buffer
= intern ("end-of-buffer");
2064 Qbuffer_read_only
= intern ("buffer-read-only");
2065 Qmark_inactive
= intern ("mark-inactive");
2067 Qlistp
= intern ("listp");
2068 Qconsp
= intern ("consp");
2069 Qsymbolp
= intern ("symbolp");
2070 Qintegerp
= intern ("integerp");
2071 Qnatnump
= intern ("natnump");
2072 Qwholenump
= intern ("wholenump");
2073 Qstringp
= intern ("stringp");
2074 Qarrayp
= intern ("arrayp");
2075 Qsequencep
= intern ("sequencep");
2076 Qbufferp
= intern ("bufferp");
2077 Qvectorp
= intern ("vectorp");
2078 Qchar_or_string_p
= intern ("char-or-string-p");
2079 Qmarkerp
= intern ("markerp");
2080 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2081 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2082 Qboundp
= intern ("boundp");
2083 Qfboundp
= intern ("fboundp");
2085 #ifdef LISP_FLOAT_TYPE
2086 Qfloatp
= intern ("floatp");
2087 Qnumberp
= intern ("numberp");
2088 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2089 #endif /* LISP_FLOAT_TYPE */
2091 Qcdr
= intern ("cdr");
2093 /* Handle automatic advice activation */
2094 Qad_advice_info
= intern ("ad-advice-info");
2095 Qad_activate
= intern ("ad-activate");
2097 error_tail
= Fcons (Qerror
, Qnil
);
2099 /* ERROR is used as a signaler for random errors for which nothing else is right */
2101 Fput (Qerror
, Qerror_conditions
,
2103 Fput (Qerror
, Qerror_message
,
2104 build_string ("error"));
2106 Fput (Qquit
, Qerror_conditions
,
2107 Fcons (Qquit
, Qnil
));
2108 Fput (Qquit
, Qerror_message
,
2109 build_string ("Quit"));
2111 Fput (Qwrong_type_argument
, Qerror_conditions
,
2112 Fcons (Qwrong_type_argument
, error_tail
));
2113 Fput (Qwrong_type_argument
, Qerror_message
,
2114 build_string ("Wrong type argument"));
2116 Fput (Qargs_out_of_range
, Qerror_conditions
,
2117 Fcons (Qargs_out_of_range
, error_tail
));
2118 Fput (Qargs_out_of_range
, Qerror_message
,
2119 build_string ("Args out of range"));
2121 Fput (Qvoid_function
, Qerror_conditions
,
2122 Fcons (Qvoid_function
, error_tail
));
2123 Fput (Qvoid_function
, Qerror_message
,
2124 build_string ("Symbol's function definition is void"));
2126 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2127 Fcons (Qcyclic_function_indirection
, error_tail
));
2128 Fput (Qcyclic_function_indirection
, Qerror_message
,
2129 build_string ("Symbol's chain of function indirections contains a loop"));
2131 Fput (Qvoid_variable
, Qerror_conditions
,
2132 Fcons (Qvoid_variable
, error_tail
));
2133 Fput (Qvoid_variable
, Qerror_message
,
2134 build_string ("Symbol's value as variable is void"));
2136 Fput (Qsetting_constant
, Qerror_conditions
,
2137 Fcons (Qsetting_constant
, error_tail
));
2138 Fput (Qsetting_constant
, Qerror_message
,
2139 build_string ("Attempt to set a constant symbol"));
2141 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2142 Fcons (Qinvalid_read_syntax
, error_tail
));
2143 Fput (Qinvalid_read_syntax
, Qerror_message
,
2144 build_string ("Invalid read syntax"));
2146 Fput (Qinvalid_function
, Qerror_conditions
,
2147 Fcons (Qinvalid_function
, error_tail
));
2148 Fput (Qinvalid_function
, Qerror_message
,
2149 build_string ("Invalid function"));
2151 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2152 Fcons (Qwrong_number_of_arguments
, error_tail
));
2153 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2154 build_string ("Wrong number of arguments"));
2156 Fput (Qno_catch
, Qerror_conditions
,
2157 Fcons (Qno_catch
, error_tail
));
2158 Fput (Qno_catch
, Qerror_message
,
2159 build_string ("No catch for tag"));
2161 Fput (Qend_of_file
, Qerror_conditions
,
2162 Fcons (Qend_of_file
, error_tail
));
2163 Fput (Qend_of_file
, Qerror_message
,
2164 build_string ("End of file during parsing"));
2166 arith_tail
= Fcons (Qarith_error
, error_tail
);
2167 Fput (Qarith_error
, Qerror_conditions
,
2169 Fput (Qarith_error
, Qerror_message
,
2170 build_string ("Arithmetic error"));
2172 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2173 Fcons (Qbeginning_of_buffer
, error_tail
));
2174 Fput (Qbeginning_of_buffer
, Qerror_message
,
2175 build_string ("Beginning of buffer"));
2177 Fput (Qend_of_buffer
, Qerror_conditions
,
2178 Fcons (Qend_of_buffer
, error_tail
));
2179 Fput (Qend_of_buffer
, Qerror_message
,
2180 build_string ("End of buffer"));
2182 Fput (Qbuffer_read_only
, Qerror_conditions
,
2183 Fcons (Qbuffer_read_only
, error_tail
));
2184 Fput (Qbuffer_read_only
, Qerror_message
,
2185 build_string ("Buffer is read-only"));
2187 #ifdef LISP_FLOAT_TYPE
2188 Qrange_error
= intern ("range-error");
2189 Qdomain_error
= intern ("domain-error");
2190 Qsingularity_error
= intern ("singularity-error");
2191 Qoverflow_error
= intern ("overflow-error");
2192 Qunderflow_error
= intern ("underflow-error");
2194 Fput (Qdomain_error
, Qerror_conditions
,
2195 Fcons (Qdomain_error
, arith_tail
));
2196 Fput (Qdomain_error
, Qerror_message
,
2197 build_string ("Arithmetic domain error"));
2199 Fput (Qrange_error
, Qerror_conditions
,
2200 Fcons (Qrange_error
, arith_tail
));
2201 Fput (Qrange_error
, Qerror_message
,
2202 build_string ("Arithmetic range error"));
2204 Fput (Qsingularity_error
, Qerror_conditions
,
2205 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2206 Fput (Qsingularity_error
, Qerror_message
,
2207 build_string ("Arithmetic singularity error"));
2209 Fput (Qoverflow_error
, Qerror_conditions
,
2210 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2211 Fput (Qoverflow_error
, Qerror_message
,
2212 build_string ("Arithmetic overflow error"));
2214 Fput (Qunderflow_error
, Qerror_conditions
,
2215 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2216 Fput (Qunderflow_error
, Qerror_message
,
2217 build_string ("Arithmetic underflow error"));
2219 staticpro (&Qrange_error
);
2220 staticpro (&Qdomain_error
);
2221 staticpro (&Qsingularity_error
);
2222 staticpro (&Qoverflow_error
);
2223 staticpro (&Qunderflow_error
);
2224 #endif /* LISP_FLOAT_TYPE */
2228 staticpro (&Qquote
);
2229 staticpro (&Qlambda
);
2231 staticpro (&Qunbound
);
2232 staticpro (&Qerror_conditions
);
2233 staticpro (&Qerror_message
);
2234 staticpro (&Qtop_level
);
2236 staticpro (&Qerror
);
2238 staticpro (&Qwrong_type_argument
);
2239 staticpro (&Qargs_out_of_range
);
2240 staticpro (&Qvoid_function
);
2241 staticpro (&Qcyclic_function_indirection
);
2242 staticpro (&Qvoid_variable
);
2243 staticpro (&Qsetting_constant
);
2244 staticpro (&Qinvalid_read_syntax
);
2245 staticpro (&Qwrong_number_of_arguments
);
2246 staticpro (&Qinvalid_function
);
2247 staticpro (&Qno_catch
);
2248 staticpro (&Qend_of_file
);
2249 staticpro (&Qarith_error
);
2250 staticpro (&Qbeginning_of_buffer
);
2251 staticpro (&Qend_of_buffer
);
2252 staticpro (&Qbuffer_read_only
);
2253 staticpro (&Qmark_inactive
);
2255 staticpro (&Qlistp
);
2256 staticpro (&Qconsp
);
2257 staticpro (&Qsymbolp
);
2258 staticpro (&Qintegerp
);
2259 staticpro (&Qnatnump
);
2260 staticpro (&Qwholenump
);
2261 staticpro (&Qstringp
);
2262 staticpro (&Qarrayp
);
2263 staticpro (&Qsequencep
);
2264 staticpro (&Qbufferp
);
2265 staticpro (&Qvectorp
);
2266 staticpro (&Qchar_or_string_p
);
2267 staticpro (&Qmarkerp
);
2268 staticpro (&Qbuffer_or_string_p
);
2269 staticpro (&Qinteger_or_marker_p
);
2270 #ifdef LISP_FLOAT_TYPE
2271 staticpro (&Qfloatp
);
2272 staticpro (&Qnumberp
);
2273 staticpro (&Qnumber_or_marker_p
);
2274 #endif /* LISP_FLOAT_TYPE */
2276 staticpro (&Qboundp
);
2277 staticpro (&Qfboundp
);
2279 staticpro (&Qad_advice_info
);
2280 staticpro (&Qad_activate
);
2288 defsubr (&Sintegerp
);
2289 defsubr (&Sinteger_or_marker_p
);
2290 defsubr (&Snumberp
);
2291 defsubr (&Snumber_or_marker_p
);
2292 #ifdef LISP_FLOAT_TYPE
2294 #endif /* LISP_FLOAT_TYPE */
2295 defsubr (&Snatnump
);
2296 defsubr (&Ssymbolp
);
2297 defsubr (&Sstringp
);
2298 defsubr (&Svectorp
);
2300 defsubr (&Ssequencep
);
2301 defsubr (&Sbufferp
);
2302 defsubr (&Smarkerp
);
2304 defsubr (&Sbyte_code_function_p
);
2305 defsubr (&Schar_or_string_p
);
2308 defsubr (&Scar_safe
);
2309 defsubr (&Scdr_safe
);
2312 defsubr (&Ssymbol_function
);
2313 defsubr (&Sindirect_function
);
2314 defsubr (&Ssymbol_plist
);
2315 defsubr (&Ssymbol_name
);
2316 defsubr (&Smakunbound
);
2317 defsubr (&Sfmakunbound
);
2319 defsubr (&Sfboundp
);
2321 defsubr (&Sdefalias
);
2322 defsubr (&Sdefine_function
);
2323 defsubr (&Ssetplist
);
2324 defsubr (&Ssymbol_value
);
2326 defsubr (&Sdefault_boundp
);
2327 defsubr (&Sdefault_value
);
2328 defsubr (&Sset_default
);
2329 defsubr (&Ssetq_default
);
2330 defsubr (&Smake_variable_buffer_local
);
2331 defsubr (&Smake_local_variable
);
2332 defsubr (&Skill_local_variable
);
2333 defsubr (&Slocal_variable_p
);
2336 defsubr (&Snumber_to_string
);
2337 defsubr (&Sstring_to_number
);
2338 defsubr (&Seqlsign
);
2362 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2370 /* USG systems forget handlers when they are used;
2371 must reestablish each time */
2372 signal (signo
, arith_error
);
2375 /* VMS systems are like USG. */
2376 signal (signo
, arith_error
);
2380 #else /* not BSD4_1 */
2381 sigsetmask (SIGEMPTYMASK
);
2382 #endif /* not BSD4_1 */
2384 Fsignal (Qarith_error
, Qnil
);
2389 /* Don't do this if just dumping out.
2390 We don't want to call `signal' in this case
2391 so that we don't have trouble with dumping
2392 signal-delivering routines in an inconsistent state. */
2396 #endif /* CANNOT_DUMP */
2397 signal (SIGFPE
, arith_error
);
2400 signal (SIGEMT
, arith_error
);