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 (XTYPE (value
) == Lisp_String
&&
99 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
100 return Fstring_to_number (value
);
101 if (XTYPE (value
) == Lisp_Int
&& EQ (predicate
, Qstringp
))
102 return Fnumber_to_string (value
);
104 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
105 tem
= call1 (predicate
, value
);
113 error ("Attempt to modify read-only object");
117 args_out_of_range (a1
, a2
)
121 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
125 args_out_of_range_3 (a1
, a2
, a3
)
126 Lisp_Object a1
, a2
, a3
;
129 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
136 register Lisp_Object val
;
137 XSET (val
, Lisp_Int
, num
);
141 /* On some machines, XINT needs a temporary location.
142 Here it is, in case it is needed. */
144 int sign_extend_temp
;
146 /* On a few machines, XINT can only be done by calling this. */
149 sign_extend_lisp_int (num
)
152 if (num
& (1 << (VALBITS
- 1)))
153 return num
| ((-1) << VALBITS
);
155 return num
& ((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.")
183 if (XTYPE (obj
) == Lisp_Cons
)
188 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
192 if (XTYPE (obj
) == Lisp_Cons
)
197 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
201 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
206 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
210 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
215 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
219 if (XTYPE (obj
) == Lisp_Symbol
)
224 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
228 if (XTYPE (obj
) == Lisp_Vector
)
233 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
237 if (XTYPE (obj
) == Lisp_String
)
242 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
246 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
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
) ||
257 XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
262 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
266 if (XTYPE (obj
) == Lisp_Buffer
)
271 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
275 if (XTYPE (obj
) == Lisp_Marker
)
280 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
284 if (XTYPE (obj
) == Lisp_Subr
)
289 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
290 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
294 if (XTYPE (obj
) == Lisp_Compiled
)
299 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
300 "T if OBJECT is a character (an integer) or a string.")
302 register Lisp_Object obj
;
304 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
309 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
313 if (XTYPE (obj
) == Lisp_Int
)
318 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
319 "T if OBJECT is an integer or a marker (editor pointer).")
321 register Lisp_Object obj
;
323 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
328 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
329 "T if OBJECT is a nonnegative integer.")
333 if (XTYPE (obj
) == Lisp_Int
&& XINT (obj
) >= 0)
338 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
339 "T if OBJECT is a number (floating point or integer).")
349 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
350 Snumber_or_marker_p
, 1, 1, 0,
351 "T if OBJECT is a number or a marker.")
356 || XTYPE (obj
) == Lisp_Marker
)
361 #ifdef LISP_FLOAT_TYPE
362 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
363 "T if OBJECT is a floating point number.")
367 if (XTYPE (obj
) == Lisp_Float
)
371 #endif /* LISP_FLOAT_TYPE */
373 /* Extract and set components of lists */
375 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
376 "Return the car of CONSCELL. If arg is nil, return nil.\n\
377 Error if arg is not nil and not a cons cell. See also `car-safe'.")
379 register Lisp_Object list
;
383 if (XTYPE (list
) == Lisp_Cons
)
384 return XCONS (list
)->car
;
385 else if (EQ (list
, Qnil
))
388 list
= wrong_type_argument (Qlistp
, list
);
392 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
393 "Return the car of OBJECT if it is a cons cell, or else nil.")
397 if (XTYPE (object
) == Lisp_Cons
)
398 return XCONS (object
)->car
;
403 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
404 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
405 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
408 register Lisp_Object list
;
412 if (XTYPE (list
) == Lisp_Cons
)
413 return XCONS (list
)->cdr
;
414 else if (EQ (list
, Qnil
))
417 list
= wrong_type_argument (Qlistp
, list
);
421 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
422 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
426 if (XTYPE (object
) == Lisp_Cons
)
427 return XCONS (object
)->cdr
;
432 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
433 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
435 register Lisp_Object cell
, newcar
;
437 if (XTYPE (cell
) != Lisp_Cons
)
438 cell
= wrong_type_argument (Qconsp
, cell
);
441 XCONS (cell
)->car
= newcar
;
445 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
446 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
448 register Lisp_Object cell
, newcdr
;
450 if (XTYPE (cell
) != Lisp_Cons
)
451 cell
= wrong_type_argument (Qconsp
, cell
);
454 XCONS (cell
)->cdr
= newcdr
;
458 /* Extract and set components of symbols */
460 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
462 register Lisp_Object sym
;
464 Lisp_Object valcontents
;
465 CHECK_SYMBOL (sym
, 0);
467 valcontents
= XSYMBOL (sym
)->value
;
469 #ifdef SWITCH_ENUM_BUG
470 switch ((int) XTYPE (valcontents
))
472 switch (XTYPE (valcontents
))
475 case Lisp_Buffer_Local_Value
:
476 case Lisp_Some_Buffer_Local_Value
:
477 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
480 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
484 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
486 register Lisp_Object sym
;
488 CHECK_SYMBOL (sym
, 0);
489 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
490 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
494 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
496 register Lisp_Object sym
;
498 CHECK_SYMBOL (sym
, 0);
499 if (NILP (sym
) || EQ (sym
, Qt
))
500 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
501 Fset (sym
, Qunbound
);
505 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
507 register Lisp_Object sym
;
509 CHECK_SYMBOL (sym
, 0);
510 if (NILP (sym
) || EQ (sym
, Qt
))
511 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
512 XSYMBOL (sym
)->function
= Qunbound
;
516 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
517 "Return SYMBOL's function definition. Error if that is void.")
519 register Lisp_Object symbol
;
521 CHECK_SYMBOL (symbol
, 0);
522 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
523 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
524 return XSYMBOL (symbol
)->function
;
527 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
529 register Lisp_Object sym
;
531 CHECK_SYMBOL (sym
, 0);
532 return XSYMBOL (sym
)->plist
;
535 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
537 register Lisp_Object sym
;
539 register Lisp_Object name
;
541 CHECK_SYMBOL (sym
, 0);
542 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
546 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
547 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
549 register Lisp_Object sym
, newdef
;
551 CHECK_SYMBOL (sym
, 0);
552 if (NILP (sym
) || EQ (sym
, Qt
))
553 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
554 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
555 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
557 XSYMBOL (sym
)->function
= newdef
;
558 /* Handle automatic advice activation */
559 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
561 call2 (Qad_activate
, sym
, Qnil
);
562 newdef
= XSYMBOL (sym
)->function
;
567 /* This name should be removed once it is eliminated from elsewhere. */
569 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
570 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
571 Associates the function with the current load file, if any.")
573 register Lisp_Object sym
, newdef
;
575 CHECK_SYMBOL (sym
, 0);
576 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
577 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
579 XSYMBOL (sym
)->function
= newdef
;
580 /* Handle automatic advice activation */
581 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
583 call2 (Qad_activate
, sym
, Qnil
);
584 newdef
= XSYMBOL (sym
)->function
;
586 LOADHIST_ATTACH (sym
);
590 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
591 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
592 Associates the function with the current load file, if any.")
594 register Lisp_Object sym
, newdef
;
596 CHECK_SYMBOL (sym
, 0);
597 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
598 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
600 XSYMBOL (sym
)->function
= newdef
;
601 /* Handle automatic advice activation */
602 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
604 call2 (Qad_activate
, sym
, Qnil
);
605 newdef
= XSYMBOL (sym
)->function
;
607 LOADHIST_ATTACH (sym
);
611 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
612 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
614 register Lisp_Object sym
, newplist
;
616 CHECK_SYMBOL (sym
, 0);
617 XSYMBOL (sym
)->plist
= newplist
;
622 /* Getting and setting values of symbols */
624 /* Given the raw contents of a symbol value cell,
625 return the Lisp value of the symbol.
626 This does not handle buffer-local variables; use
627 swap_in_symval_forwarding for that. */
630 do_symval_forwarding (valcontents
)
631 register Lisp_Object valcontents
;
633 register Lisp_Object val
;
634 #ifdef SWITCH_ENUM_BUG
635 switch ((int) XTYPE (valcontents
))
637 switch (XTYPE (valcontents
))
641 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
645 if (*XINTPTR (valcontents
))
650 return *XOBJFWD (valcontents
);
652 case Lisp_Buffer_Objfwd
:
653 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
658 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
659 of SYM. If SYM is buffer-local, VALCONTENTS should be the
660 buffer-independent contents of the value cell: forwarded just one
661 step past the buffer-localness. */
664 store_symval_forwarding (sym
, valcontents
, newval
)
666 register Lisp_Object valcontents
, newval
;
668 #ifdef SWITCH_ENUM_BUG
669 switch ((int) XTYPE (valcontents
))
671 switch (XTYPE (valcontents
))
675 CHECK_NUMBER (newval
, 1);
676 *XINTPTR (valcontents
) = XINT (newval
);
680 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
684 *XOBJFWD (valcontents
) = newval
;
687 case Lisp_Buffer_Objfwd
:
689 unsigned int offset
= XUINT (valcontents
);
692 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
693 if (! NILP (type
) && ! NILP (newval
)
694 && XTYPE (newval
) != XINT (type
))
695 buffer_slot_type_mismatch (valcontents
, newval
);
697 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
703 valcontents
= XSYMBOL (sym
)->value
;
704 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
705 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
706 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
708 XSYMBOL (sym
)->value
= newval
;
712 /* Set up the buffer-local symbol SYM for validity in the current
713 buffer. VALCONTENTS is the contents of its value cell.
714 Return the value forwarded one step past the buffer-local indicator. */
717 swap_in_symval_forwarding (sym
, valcontents
)
718 Lisp_Object sym
, valcontents
;
720 /* valcontents is a list
721 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
723 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
724 local_var_alist, that being the element whose car is this
725 variable. Or it can be a pointer to the
726 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
727 an element in its alist for this variable.
729 If the current buffer is not BUFFER, we store the current
730 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
731 appropriate alist element for the buffer now current and set up
732 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
733 element, and store into BUFFER.
735 Note that REALVALUE can be a forwarding pointer. */
737 register Lisp_Object tem1
;
738 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
740 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
742 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
743 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
744 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
746 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
747 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
748 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
749 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
751 return XCONS (valcontents
)->car
;
754 /* Find the value of a symbol, returning Qunbound if it's not bound.
755 This is helpful for code which just wants to get a variable's value
756 if it has one, without signalling an error.
757 Note that it must not be possible to quit
758 within this function. Great care is required for this. */
761 find_symbol_value (sym
)
764 register Lisp_Object valcontents
, tem1
;
765 register Lisp_Object val
;
766 CHECK_SYMBOL (sym
, 0);
767 valcontents
= XSYMBOL (sym
)->value
;
770 #ifdef SWITCH_ENUM_BUG
771 switch ((int) XTYPE (valcontents
))
773 switch (XTYPE (valcontents
))
776 case Lisp_Buffer_Local_Value
:
777 case Lisp_Some_Buffer_Local_Value
:
778 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
782 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
786 if (*XINTPTR (valcontents
))
791 return *XOBJFWD (valcontents
);
793 case Lisp_Buffer_Objfwd
:
794 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
803 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
804 "Return SYMBOL's value. Error if that is void.")
810 val
= find_symbol_value (sym
);
811 if (EQ (val
, Qunbound
))
812 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
817 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
818 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
820 register Lisp_Object sym
, newval
;
822 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
824 #ifndef RTPC_REGISTER_BUG
825 register Lisp_Object valcontents
, tem1
, current_alist_element
;
826 #else /* RTPC_REGISTER_BUG */
827 register Lisp_Object tem1
;
828 Lisp_Object valcontents
, current_alist_element
;
829 #endif /* RTPC_REGISTER_BUG */
831 CHECK_SYMBOL (sym
, 0);
832 if (NILP (sym
) || EQ (sym
, Qt
))
833 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
834 valcontents
= XSYMBOL (sym
)->value
;
836 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
838 register int idx
= XUINT (valcontents
);
839 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
841 current_buffer
->local_var_flags
|= mask
;
844 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
845 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
847 /* valcontents is actually a pointer to a cons heading something like:
848 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
850 BUFFER is the last buffer for which this symbol's value was
853 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
854 local_var_alist, that being the element whose car is this
855 variable. Or it can be a pointer to the
856 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
857 have an element in its alist for this variable (that is, if
858 BUFFER sees the default value of this variable).
860 If we want to examine or set the value and BUFFER is current,
861 we just examine or set REALVALUE. If BUFFER is not current, we
862 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
863 then find the appropriate alist element for the buffer now
864 current and set up CURRENT-ALIST-ELEMENT. Then we set
865 REALVALUE out of that element, and store into BUFFER.
867 If we are setting the variable and the current buffer does
868 not have an alist entry for this variable, an alist entry is
871 Note that REALVALUE can be a forwarding pointer. Each time
872 it is examined or set, forwarding must be done. */
874 /* What value are we caching right now? */
875 current_alist_element
=
876 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
878 /* If the current buffer is not the buffer whose binding is
879 currently cached, or if it's a Lisp_Buffer_Local_Value and
880 we're looking at the default value, the cache is invalid; we
881 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
883 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
884 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
885 && EQ (XCONS (current_alist_element
)->car
,
886 current_alist_element
)))
888 /* Write out the cached value for the old buffer; copy it
889 back to its alist element. This works if the current
890 buffer only sees the default value, too. */
891 Fsetcdr (current_alist_element
,
892 do_symval_forwarding (XCONS (valcontents
)->car
));
894 /* Find the new value for CURRENT-ALIST-ELEMENT. */
895 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
898 /* This buffer still sees the default value. */
900 /* If the variable is a Lisp_Some_Buffer_Local_Value,
901 make CURRENT-ALIST-ELEMENT point to itself,
902 indicating that we're seeing the default value. */
903 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
904 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
906 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
907 new assoc for a local value and set
908 CURRENT-ALIST-ELEMENT to point to that. */
911 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
912 current_buffer
->local_var_alist
=
913 Fcons (tem1
, current_buffer
->local_var_alist
);
916 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
917 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
919 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
920 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
921 Lisp_Buffer
, current_buffer
);
923 valcontents
= XCONS (valcontents
)->car
;
926 /* If storing void (making the symbol void), forward only through
927 buffer-local indicator, not through Lisp_Objfwd, etc. */
929 store_symval_forwarding (sym
, Qnil
, newval
);
931 store_symval_forwarding (sym
, valcontents
, newval
);
936 /* Access or set a buffer-local symbol's default value. */
938 /* Return the default value of SYM, but don't check for voidness.
939 Return Qunbound or a Lisp_Void object if it is void. */
945 register Lisp_Object valcontents
;
947 CHECK_SYMBOL (sym
, 0);
948 valcontents
= XSYMBOL (sym
)->value
;
950 /* For a built-in buffer-local variable, get the default value
951 rather than letting do_symval_forwarding get the current value. */
952 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
954 register int idx
= XUINT (valcontents
);
956 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
957 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
960 /* Handle user-created local variables. */
961 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
962 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
964 /* If var is set up for a buffer that lacks a local value for it,
965 the current value is nominally the default value.
966 But the current value slot may be more up to date, since
967 ordinary setq stores just that slot. So use that. */
968 Lisp_Object current_alist_element
, alist_element_car
;
969 current_alist_element
970 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
971 alist_element_car
= XCONS (current_alist_element
)->car
;
972 if (EQ (alist_element_car
, current_alist_element
))
973 return do_symval_forwarding (XCONS (valcontents
)->car
);
975 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
977 /* For other variables, get the current value. */
978 return do_symval_forwarding (valcontents
);
981 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
982 "Return T if SYMBOL has a non-void default value.\n\
983 This is the value that is seen in buffers that do not have their own values\n\
988 register Lisp_Object value
;
990 value
= default_value (sym
);
991 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
995 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
996 "Return SYMBOL's default value.\n\
997 This is the value that is seen in buffers that do not have their own values\n\
998 for this variable. The default value is meaningful for variables with\n\
999 local bindings in certain buffers.")
1003 register Lisp_Object value
;
1005 value
= default_value (sym
);
1006 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
1007 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1011 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1012 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1013 The default value is seen in buffers that do not have their own values\n\
1014 for this variable.")
1016 Lisp_Object sym
, value
;
1018 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1020 CHECK_SYMBOL (sym
, 0);
1021 valcontents
= XSYMBOL (sym
)->value
;
1023 /* Handle variables like case-fold-search that have special slots
1024 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1026 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1028 register int idx
= XUINT (valcontents
);
1029 #ifndef RTPC_REGISTER_BUG
1030 register struct buffer
*b
;
1034 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1038 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1039 for (b
= all_buffers
; b
; b
= b
->next
)
1040 if (!(b
->local_var_flags
& mask
))
1041 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1046 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1047 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1048 return Fset (sym
, value
);
1050 /* Store new value into the DEFAULT-VALUE slot */
1051 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1053 /* If that slot is current, we must set the REALVALUE slot too */
1054 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
1055 alist_element_buffer
= Fcar (current_alist_element
);
1056 if (EQ (alist_element_buffer
, current_alist_element
))
1057 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
1062 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1063 "Set the default value of variable VAR to VALUE.\n\
1064 VAR, the variable name, is literal (not evaluated);\n\
1065 VALUE is an expression and it is evaluated.\n\
1066 The default value of a variable is seen in buffers\n\
1067 that do not have their own values for the variable.\n\
1069 More generally, you can use multiple variables and values, as in\n\
1070 (setq-default SYM VALUE SYM VALUE...)\n\
1071 This sets each SYM's default value to the corresponding VALUE.\n\
1072 The VALUE for the Nth SYM can refer to the new default values\n\
1077 register Lisp_Object args_left
;
1078 register Lisp_Object val
, sym
;
1079 struct gcpro gcpro1
;
1089 val
= Feval (Fcar (Fcdr (args_left
)));
1090 sym
= Fcar (args_left
);
1091 Fset_default (sym
, val
);
1092 args_left
= Fcdr (Fcdr (args_left
));
1094 while (!NILP (args_left
));
1100 /* Lisp functions for creating and removing buffer-local variables. */
1102 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1103 1, 1, "vMake Variable Buffer Local: ",
1104 "Make VARIABLE have a separate value for each buffer.\n\
1105 At any time, the value for the current buffer is in effect.\n\
1106 There is also a default value which is seen in any buffer which has not yet\n\
1107 set its own value.\n\
1108 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1109 for the current buffer if it was previously using the default value.\n\
1110 The function `default-value' gets the default value and `set-default' sets it.")
1112 register Lisp_Object sym
;
1114 register Lisp_Object tem
, valcontents
;
1116 CHECK_SYMBOL (sym
, 0);
1118 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1119 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1121 valcontents
= XSYMBOL (sym
)->value
;
1122 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1123 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1125 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1127 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1130 if (EQ (valcontents
, Qunbound
))
1131 XSYMBOL (sym
)->value
= Qnil
;
1132 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1133 XCONS (tem
)->car
= tem
;
1134 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1135 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1139 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1140 1, 1, "vMake Local Variable: ",
1141 "Make VARIABLE have a separate value in the current buffer.\n\
1142 Other buffers will continue to share a common default value.\n\
1143 \(The buffer-local value of VARIABLE starts out as the same value\n\
1144 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1145 See also `make-variable-buffer-local'.\n\n\
1146 If the variable is already arranged to become local when set,\n\
1147 this function causes a local value to exist for this buffer,\n\
1148 just as if the variable were set.")
1150 register Lisp_Object sym
;
1152 register Lisp_Object tem
, valcontents
;
1154 CHECK_SYMBOL (sym
, 0);
1156 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1157 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1159 valcontents
= XSYMBOL (sym
)->value
;
1160 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1161 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1163 tem
= Fboundp (sym
);
1165 /* Make sure the symbol has a local value in this particular buffer,
1166 by setting it to the same value it already has. */
1167 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1170 /* Make sure sym is set up to hold per-buffer values */
1171 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1173 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1174 XCONS (tem
)->car
= tem
;
1175 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1176 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1178 /* Make sure this buffer has its own value of sym */
1179 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1182 current_buffer
->local_var_alist
1183 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1184 current_buffer
->local_var_alist
);
1186 /* Make sure symbol does not think it is set up for this buffer;
1187 force it to look once again for this buffer's value */
1189 /* This local variable avoids "expression too complex" on IBM RT. */
1192 xs
= XSYMBOL (sym
)->value
;
1193 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1194 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1198 /* If the symbol forwards into a C variable, then swap in the
1199 variable for this buffer immediately. If C code modifies the
1200 variable before we swap in, then that new value will clobber the
1201 default value the next time we swap. */
1202 valcontents
= XCONS (XSYMBOL (sym
)->value
)->car
;
1203 if (XTYPE (valcontents
) == Lisp_Intfwd
1204 || XTYPE (valcontents
) == Lisp_Boolfwd
1205 || XTYPE (valcontents
) == Lisp_Objfwd
)
1206 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1211 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1212 1, 1, "vKill Local Variable: ",
1213 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1214 From now on the default value will apply in this buffer.")
1216 register Lisp_Object sym
;
1218 register Lisp_Object tem
, valcontents
;
1220 CHECK_SYMBOL (sym
, 0);
1222 valcontents
= XSYMBOL (sym
)->value
;
1224 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1226 register int idx
= XUINT (valcontents
);
1227 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1231 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1232 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1233 current_buffer
->local_var_flags
&= ~mask
;
1238 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1239 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1242 /* Get rid of this buffer's alist element, if any */
1244 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1246 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1248 /* Make sure symbol does not think it is set up for this buffer;
1249 force it to look once again for this buffer's value */
1252 sv
= XSYMBOL (sym
)->value
;
1253 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1254 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1260 /* Find the function at the end of a chain of symbol function indirections. */
1262 /* If OBJECT is a symbol, find the end of its function chain and
1263 return the value found there. If OBJECT is not a symbol, just
1264 return it. If there is a cycle in the function chain, signal a
1265 cyclic-function-indirection error.
1267 This is like Findirect_function, except that it doesn't signal an
1268 error if the chain ends up unbound. */
1270 indirect_function (object
)
1271 register Lisp_Object object
;
1273 Lisp_Object tortoise
, hare
;
1275 hare
= tortoise
= object
;
1279 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1281 hare
= XSYMBOL (hare
)->function
;
1282 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1284 hare
= XSYMBOL (hare
)->function
;
1286 tortoise
= XSYMBOL (tortoise
)->function
;
1288 if (EQ (hare
, tortoise
))
1289 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1295 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1296 "Return the function at the end of OBJECT's function chain.\n\
1297 If OBJECT is a symbol, follow all function indirections and return the final\n\
1298 function binding.\n\
1299 If OBJECT is not a symbol, just return it.\n\
1300 Signal a void-function error if the final symbol is unbound.\n\
1301 Signal a cyclic-function-indirection error if there is a loop in the\n\
1302 function chain of symbols.")
1304 register Lisp_Object object
;
1308 result
= indirect_function (object
);
1310 if (EQ (result
, Qunbound
))
1311 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1315 /* Extract and set vector and string elements */
1317 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1318 "Return the element of ARRAY at index INDEX.\n\
1319 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1321 register Lisp_Object array
;
1324 register int idxval
;
1326 CHECK_NUMBER (idx
, 1);
1327 idxval
= XINT (idx
);
1328 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1329 && XTYPE (array
) != Lisp_Compiled
)
1330 array
= wrong_type_argument (Qarrayp
, array
);
1331 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1332 args_out_of_range (array
, idx
);
1333 if (XTYPE (array
) == Lisp_String
)
1336 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1340 return XVECTOR (array
)->contents
[idxval
];
1343 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1344 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1345 ARRAY may be a vector or a string. IDX starts at 0.")
1346 (array
, idx
, newelt
)
1347 register Lisp_Object array
;
1348 Lisp_Object idx
, newelt
;
1350 register int idxval
;
1352 CHECK_NUMBER (idx
, 1);
1353 idxval
= XINT (idx
);
1354 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1355 array
= wrong_type_argument (Qarrayp
, array
);
1356 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1357 args_out_of_range (array
, idx
);
1358 CHECK_IMPURE (array
);
1360 if (XTYPE (array
) == Lisp_Vector
)
1361 XVECTOR (array
)->contents
[idxval
] = newelt
;
1364 CHECK_NUMBER (newelt
, 2);
1365 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1372 Farray_length (array
)
1373 register Lisp_Object array
;
1375 register Lisp_Object size
;
1376 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1377 && XTYPE (array
) != Lisp_Compiled
)
1378 array
= wrong_type_argument (Qarrayp
, array
);
1379 XFASTINT (size
) = XVECTOR (array
)->size
;
1383 /* Arithmetic functions */
1385 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1388 arithcompare (num1
, num2
, comparison
)
1389 Lisp_Object num1
, num2
;
1390 enum comparison comparison
;
1395 #ifdef LISP_FLOAT_TYPE
1396 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1397 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1399 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1402 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1403 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1406 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1407 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1408 #endif /* LISP_FLOAT_TYPE */
1413 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1418 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1423 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1428 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1433 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1438 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1447 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1448 "T if two args, both numbers or markers, are equal.")
1450 register Lisp_Object num1
, num2
;
1452 return arithcompare (num1
, num2
, equal
);
1455 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1456 "T if first arg is less than second arg. Both must be numbers or markers.")
1458 register Lisp_Object num1
, num2
;
1460 return arithcompare (num1
, num2
, less
);
1463 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1464 "T if first arg is greater than second arg. Both must be numbers or markers.")
1466 register Lisp_Object num1
, num2
;
1468 return arithcompare (num1
, num2
, grtr
);
1471 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1472 "T if first arg is less than or equal to second arg.\n\
1473 Both must be numbers or markers.")
1475 register Lisp_Object num1
, num2
;
1477 return arithcompare (num1
, num2
, less_or_equal
);
1480 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1481 "T if first arg is greater than or equal to second arg.\n\
1482 Both must be numbers or markers.")
1484 register Lisp_Object num1
, num2
;
1486 return arithcompare (num1
, num2
, grtr_or_equal
);
1489 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1490 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1492 register Lisp_Object num1
, num2
;
1494 return arithcompare (num1
, num2
, notequal
);
1497 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1499 register Lisp_Object num
;
1501 #ifdef LISP_FLOAT_TYPE
1502 CHECK_NUMBER_OR_FLOAT (num
, 0);
1504 if (XTYPE(num
) == Lisp_Float
)
1506 if (XFLOAT(num
)->data
== 0.0)
1511 CHECK_NUMBER (num
, 0);
1512 #endif /* LISP_FLOAT_TYPE */
1519 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1525 unsigned int top
= i
>> 16;
1526 unsigned int bot
= i
& 0xFFFF;
1528 return make_number (bot
);
1530 return Fcons (make_number (-1), make_number (bot
));
1531 return Fcons (make_number (top
), make_number (bot
));
1538 Lisp_Object top
, bot
;
1541 top
= XCONS (c
)->car
;
1542 bot
= XCONS (c
)->cdr
;
1544 bot
= XCONS (bot
)->car
;
1545 return ((XINT (top
) << 16) | XINT (bot
));
1548 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1549 "Convert NUM to a string by printing it in decimal.\n\
1550 Uses a minus sign if negative.\n\
1551 NUM may be an integer or a floating point number.")
1557 #ifndef LISP_FLOAT_TYPE
1558 CHECK_NUMBER (num
, 0);
1560 CHECK_NUMBER_OR_FLOAT (num
, 0);
1562 if (XTYPE(num
) == Lisp_Float
)
1564 char pigbuf
[350]; /* see comments in float_to_string */
1566 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1567 return build_string (pigbuf
);
1569 #endif /* LISP_FLOAT_TYPE */
1571 sprintf (buffer
, "%d", XINT (num
));
1572 return build_string (buffer
);
1575 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1576 "Convert STRING to a number by parsing it as a decimal number.\n\
1577 This parses both integers and floating point numbers.\n\
1578 It ignores leading spaces and tabs.")
1580 register Lisp_Object str
;
1584 CHECK_STRING (str
, 0);
1586 p
= XSTRING (str
)->data
;
1588 /* Skip any whitespace at the front of the number. Some versions of
1589 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1590 while (*p
== ' ' || *p
== '\t')
1593 #ifdef LISP_FLOAT_TYPE
1594 if (isfloat_string (p
))
1595 return make_float (atof (p
));
1596 #endif /* LISP_FLOAT_TYPE */
1598 return make_number (atoi (p
));
1602 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1604 extern Lisp_Object
float_arith_driver ();
1607 arith_driver (code
, nargs
, args
)
1610 register Lisp_Object
*args
;
1612 register Lisp_Object val
;
1613 register int argnum
;
1617 #ifdef SWITCH_ENUM_BUG
1634 for (argnum
= 0; argnum
< nargs
; argnum
++)
1636 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1637 #ifdef LISP_FLOAT_TYPE
1638 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1640 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1641 return (float_arith_driver ((double) accum
, argnum
, code
,
1644 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1645 #endif /* LISP_FLOAT_TYPE */
1646 args
[argnum
] = val
; /* runs into a compiler bug. */
1647 next
= XINT (args
[argnum
]);
1648 #ifdef SWITCH_ENUM_BUG
1654 case Aadd
: accum
+= next
; break;
1656 if (!argnum
&& nargs
!= 1)
1660 case Amult
: accum
*= next
; break;
1662 if (!argnum
) accum
= next
;
1666 Fsignal (Qarith_error
, Qnil
);
1670 case Alogand
: accum
&= next
; break;
1671 case Alogior
: accum
|= next
; break;
1672 case Alogxor
: accum
^= next
; break;
1673 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1674 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1678 XSET (val
, Lisp_Int
, accum
);
1682 #ifdef LISP_FLOAT_TYPE
1685 #define isnan(x) ((x) != (x))
1688 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1690 register int argnum
;
1693 register Lisp_Object
*args
;
1695 register Lisp_Object val
;
1698 for (; argnum
< nargs
; argnum
++)
1700 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1701 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1703 if (XTYPE (val
) == Lisp_Float
)
1705 next
= XFLOAT (val
)->data
;
1709 args
[argnum
] = val
; /* runs into a compiler bug. */
1710 next
= XINT (args
[argnum
]);
1712 #ifdef SWITCH_ENUM_BUG
1722 if (!argnum
&& nargs
!= 1)
1735 Fsignal (Qarith_error
, Qnil
);
1742 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1744 if (!argnum
|| isnan (next
) || next
> accum
)
1748 if (!argnum
|| isnan (next
) || next
< accum
)
1754 return make_float (accum
);
1756 #endif /* LISP_FLOAT_TYPE */
1758 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1759 "Return sum of any number of arguments, which are numbers or markers.")
1764 return arith_driver (Aadd
, nargs
, args
);
1767 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1768 "Negate number or subtract numbers or markers.\n\
1769 With one arg, negates it. With more than one arg,\n\
1770 subtracts all but the first from the first.")
1775 return arith_driver (Asub
, nargs
, args
);
1778 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1779 "Returns product of any number of arguments, which are numbers or markers.")
1784 return arith_driver (Amult
, nargs
, args
);
1787 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1788 "Returns first argument divided by all the remaining arguments.\n\
1789 The arguments must be numbers or markers.")
1794 return arith_driver (Adiv
, nargs
, args
);
1797 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1798 "Returns remainder of first arg divided by second.\n\
1799 Both must be integers or markers.")
1801 register Lisp_Object num1
, num2
;
1805 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1806 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1808 if (XFASTINT (num2
) == 0)
1809 Fsignal (Qarith_error
, Qnil
);
1811 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1820 #ifdef HAVE_DREM /* Some systems use this non-standard name. */
1821 return (drem (f1
, f2
));
1822 #else /* Other systems don't seem to have it at all. */
1823 return (f1
- f2
* floor (f1
/f2
));
1826 #endif /* ! HAVE_FMOD */
1828 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1829 "Returns X modulo Y.\n\
1830 The result falls between zero (inclusive) and Y (exclusive).\n\
1831 Both X and Y must be numbers or markers.")
1833 register Lisp_Object num1
, num2
;
1838 #ifdef LISP_FLOAT_TYPE
1839 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1840 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
1842 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1846 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1847 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1849 Fsignal (Qarith_error
, Qnil
);
1852 /* If the "remainder" comes out with the wrong sign, fix it. */
1853 if ((f1
< 0) != (f2
< 0))
1855 return (make_float (f1
));
1857 #else /* not LISP_FLOAT_TYPE */
1858 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1859 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1860 #endif /* not LISP_FLOAT_TYPE */
1866 Fsignal (Qarith_error
, Qnil
);
1870 /* If the "remainder" comes out with the wrong sign, fix it. */
1871 if ((i1
< 0) != (i2
< 0))
1874 XSET (val
, Lisp_Int
, i1
);
1878 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1879 "Return largest of all the arguments (which must be numbers or markers).\n\
1880 The value is always a number; markers are converted to numbers.")
1885 return arith_driver (Amax
, nargs
, args
);
1888 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1889 "Return smallest of all the arguments (which must be numbers or markers).\n\
1890 The value is always a number; markers are converted to numbers.")
1895 return arith_driver (Amin
, nargs
, args
);
1898 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1899 "Return bitwise-and of all the arguments.\n\
1900 Arguments may be integers, or markers converted to integers.")
1905 return arith_driver (Alogand
, nargs
, args
);
1908 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1909 "Return bitwise-or of all the arguments.\n\
1910 Arguments may be integers, or markers converted to integers.")
1915 return arith_driver (Alogior
, nargs
, args
);
1918 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1919 "Return bitwise-exclusive-or of all the arguments.\n\
1920 Arguments may be integers, or markers converted to integers.")
1925 return arith_driver (Alogxor
, nargs
, args
);
1928 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1929 "Return VALUE with its bits shifted left by COUNT.\n\
1930 If COUNT is negative, shifting is actually to the right.\n\
1931 In this case, the sign bit is duplicated.")
1933 register Lisp_Object num1
, num2
;
1935 register Lisp_Object val
;
1937 CHECK_NUMBER (num1
, 0);
1938 CHECK_NUMBER (num2
, 1);
1940 if (XINT (num2
) > 0)
1941 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1943 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1947 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1948 "Return VALUE with its bits shifted left by COUNT.\n\
1949 If COUNT is negative, shifting is actually to the right.\n\
1950 In this case, zeros are shifted in on the left.")
1952 register Lisp_Object num1
, num2
;
1954 register Lisp_Object val
;
1956 CHECK_NUMBER (num1
, 0);
1957 CHECK_NUMBER (num2
, 1);
1959 if (XINT (num2
) > 0)
1960 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1962 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1966 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1967 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1968 Markers are converted to integers.")
1970 register Lisp_Object num
;
1972 #ifdef LISP_FLOAT_TYPE
1973 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1975 if (XTYPE (num
) == Lisp_Float
)
1976 return (make_float (1.0 + XFLOAT (num
)->data
));
1978 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1979 #endif /* LISP_FLOAT_TYPE */
1981 XSETINT (num
, XFASTINT (num
) + 1);
1985 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1986 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1987 Markers are converted to integers.")
1989 register Lisp_Object num
;
1991 #ifdef LISP_FLOAT_TYPE
1992 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1994 if (XTYPE (num
) == Lisp_Float
)
1995 return (make_float (-1.0 + XFLOAT (num
)->data
));
1997 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1998 #endif /* LISP_FLOAT_TYPE */
2000 XSETINT (num
, XFASTINT (num
) - 1);
2004 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2005 "Return the bitwise complement of ARG. ARG must be an integer.")
2007 register Lisp_Object num
;
2009 CHECK_NUMBER (num
, 0);
2010 XSETINT (num
, ~XFASTINT (num
));
2017 Lisp_Object error_tail
, arith_tail
;
2019 Qquote
= intern ("quote");
2020 Qlambda
= intern ("lambda");
2021 Qsubr
= intern ("subr");
2022 Qerror_conditions
= intern ("error-conditions");
2023 Qerror_message
= intern ("error-message");
2024 Qtop_level
= intern ("top-level");
2026 Qerror
= intern ("error");
2027 Qquit
= intern ("quit");
2028 Qwrong_type_argument
= intern ("wrong-type-argument");
2029 Qargs_out_of_range
= intern ("args-out-of-range");
2030 Qvoid_function
= intern ("void-function");
2031 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2032 Qvoid_variable
= intern ("void-variable");
2033 Qsetting_constant
= intern ("setting-constant");
2034 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2036 Qinvalid_function
= intern ("invalid-function");
2037 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2038 Qno_catch
= intern ("no-catch");
2039 Qend_of_file
= intern ("end-of-file");
2040 Qarith_error
= intern ("arith-error");
2041 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2042 Qend_of_buffer
= intern ("end-of-buffer");
2043 Qbuffer_read_only
= intern ("buffer-read-only");
2044 Qmark_inactive
= intern ("mark-inactive");
2046 Qlistp
= intern ("listp");
2047 Qconsp
= intern ("consp");
2048 Qsymbolp
= intern ("symbolp");
2049 Qintegerp
= intern ("integerp");
2050 Qnatnump
= intern ("natnump");
2051 Qwholenump
= intern ("wholenump");
2052 Qstringp
= intern ("stringp");
2053 Qarrayp
= intern ("arrayp");
2054 Qsequencep
= intern ("sequencep");
2055 Qbufferp
= intern ("bufferp");
2056 Qvectorp
= intern ("vectorp");
2057 Qchar_or_string_p
= intern ("char-or-string-p");
2058 Qmarkerp
= intern ("markerp");
2059 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2060 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2061 Qboundp
= intern ("boundp");
2062 Qfboundp
= intern ("fboundp");
2064 #ifdef LISP_FLOAT_TYPE
2065 Qfloatp
= intern ("floatp");
2066 Qnumberp
= intern ("numberp");
2067 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2068 #endif /* LISP_FLOAT_TYPE */
2070 Qcdr
= intern ("cdr");
2072 /* Handle automatic advice activation */
2073 Qad_advice_info
= intern ("ad-advice-info");
2074 Qad_activate
= intern ("ad-activate");
2076 error_tail
= Fcons (Qerror
, Qnil
);
2078 /* ERROR is used as a signaler for random errors for which nothing else is right */
2080 Fput (Qerror
, Qerror_conditions
,
2082 Fput (Qerror
, Qerror_message
,
2083 build_string ("error"));
2085 Fput (Qquit
, Qerror_conditions
,
2086 Fcons (Qquit
, Qnil
));
2087 Fput (Qquit
, Qerror_message
,
2088 build_string ("Quit"));
2090 Fput (Qwrong_type_argument
, Qerror_conditions
,
2091 Fcons (Qwrong_type_argument
, error_tail
));
2092 Fput (Qwrong_type_argument
, Qerror_message
,
2093 build_string ("Wrong type argument"));
2095 Fput (Qargs_out_of_range
, Qerror_conditions
,
2096 Fcons (Qargs_out_of_range
, error_tail
));
2097 Fput (Qargs_out_of_range
, Qerror_message
,
2098 build_string ("Args out of range"));
2100 Fput (Qvoid_function
, Qerror_conditions
,
2101 Fcons (Qvoid_function
, error_tail
));
2102 Fput (Qvoid_function
, Qerror_message
,
2103 build_string ("Symbol's function definition is void"));
2105 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2106 Fcons (Qcyclic_function_indirection
, error_tail
));
2107 Fput (Qcyclic_function_indirection
, Qerror_message
,
2108 build_string ("Symbol's chain of function indirections contains a loop"));
2110 Fput (Qvoid_variable
, Qerror_conditions
,
2111 Fcons (Qvoid_variable
, error_tail
));
2112 Fput (Qvoid_variable
, Qerror_message
,
2113 build_string ("Symbol's value as variable is void"));
2115 Fput (Qsetting_constant
, Qerror_conditions
,
2116 Fcons (Qsetting_constant
, error_tail
));
2117 Fput (Qsetting_constant
, Qerror_message
,
2118 build_string ("Attempt to set a constant symbol"));
2120 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2121 Fcons (Qinvalid_read_syntax
, error_tail
));
2122 Fput (Qinvalid_read_syntax
, Qerror_message
,
2123 build_string ("Invalid read syntax"));
2125 Fput (Qinvalid_function
, Qerror_conditions
,
2126 Fcons (Qinvalid_function
, error_tail
));
2127 Fput (Qinvalid_function
, Qerror_message
,
2128 build_string ("Invalid function"));
2130 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2131 Fcons (Qwrong_number_of_arguments
, error_tail
));
2132 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2133 build_string ("Wrong number of arguments"));
2135 Fput (Qno_catch
, Qerror_conditions
,
2136 Fcons (Qno_catch
, error_tail
));
2137 Fput (Qno_catch
, Qerror_message
,
2138 build_string ("No catch for tag"));
2140 Fput (Qend_of_file
, Qerror_conditions
,
2141 Fcons (Qend_of_file
, error_tail
));
2142 Fput (Qend_of_file
, Qerror_message
,
2143 build_string ("End of file during parsing"));
2145 arith_tail
= Fcons (Qarith_error
, error_tail
);
2146 Fput (Qarith_error
, Qerror_conditions
,
2148 Fput (Qarith_error
, Qerror_message
,
2149 build_string ("Arithmetic error"));
2151 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2152 Fcons (Qbeginning_of_buffer
, error_tail
));
2153 Fput (Qbeginning_of_buffer
, Qerror_message
,
2154 build_string ("Beginning of buffer"));
2156 Fput (Qend_of_buffer
, Qerror_conditions
,
2157 Fcons (Qend_of_buffer
, error_tail
));
2158 Fput (Qend_of_buffer
, Qerror_message
,
2159 build_string ("End of buffer"));
2161 Fput (Qbuffer_read_only
, Qerror_conditions
,
2162 Fcons (Qbuffer_read_only
, error_tail
));
2163 Fput (Qbuffer_read_only
, Qerror_message
,
2164 build_string ("Buffer is read-only"));
2166 #ifdef LISP_FLOAT_TYPE
2167 Qrange_error
= intern ("range-error");
2168 Qdomain_error
= intern ("domain-error");
2169 Qsingularity_error
= intern ("singularity-error");
2170 Qoverflow_error
= intern ("overflow-error");
2171 Qunderflow_error
= intern ("underflow-error");
2173 Fput (Qdomain_error
, Qerror_conditions
,
2174 Fcons (Qdomain_error
, arith_tail
));
2175 Fput (Qdomain_error
, Qerror_message
,
2176 build_string ("Arithmetic domain error"));
2178 Fput (Qrange_error
, Qerror_conditions
,
2179 Fcons (Qrange_error
, arith_tail
));
2180 Fput (Qrange_error
, Qerror_message
,
2181 build_string ("Arithmetic range error"));
2183 Fput (Qsingularity_error
, Qerror_conditions
,
2184 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2185 Fput (Qsingularity_error
, Qerror_message
,
2186 build_string ("Arithmetic singularity error"));
2188 Fput (Qoverflow_error
, Qerror_conditions
,
2189 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2190 Fput (Qoverflow_error
, Qerror_message
,
2191 build_string ("Arithmetic overflow error"));
2193 Fput (Qunderflow_error
, Qerror_conditions
,
2194 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2195 Fput (Qunderflow_error
, Qerror_message
,
2196 build_string ("Arithmetic underflow error"));
2198 staticpro (&Qrange_error
);
2199 staticpro (&Qdomain_error
);
2200 staticpro (&Qsingularity_error
);
2201 staticpro (&Qoverflow_error
);
2202 staticpro (&Qunderflow_error
);
2203 #endif /* LISP_FLOAT_TYPE */
2207 staticpro (&Qquote
);
2208 staticpro (&Qlambda
);
2210 staticpro (&Qunbound
);
2211 staticpro (&Qerror_conditions
);
2212 staticpro (&Qerror_message
);
2213 staticpro (&Qtop_level
);
2215 staticpro (&Qerror
);
2217 staticpro (&Qwrong_type_argument
);
2218 staticpro (&Qargs_out_of_range
);
2219 staticpro (&Qvoid_function
);
2220 staticpro (&Qcyclic_function_indirection
);
2221 staticpro (&Qvoid_variable
);
2222 staticpro (&Qsetting_constant
);
2223 staticpro (&Qinvalid_read_syntax
);
2224 staticpro (&Qwrong_number_of_arguments
);
2225 staticpro (&Qinvalid_function
);
2226 staticpro (&Qno_catch
);
2227 staticpro (&Qend_of_file
);
2228 staticpro (&Qarith_error
);
2229 staticpro (&Qbeginning_of_buffer
);
2230 staticpro (&Qend_of_buffer
);
2231 staticpro (&Qbuffer_read_only
);
2232 staticpro (&Qmark_inactive
);
2234 staticpro (&Qlistp
);
2235 staticpro (&Qconsp
);
2236 staticpro (&Qsymbolp
);
2237 staticpro (&Qintegerp
);
2238 staticpro (&Qnatnump
);
2239 staticpro (&Qwholenump
);
2240 staticpro (&Qstringp
);
2241 staticpro (&Qarrayp
);
2242 staticpro (&Qsequencep
);
2243 staticpro (&Qbufferp
);
2244 staticpro (&Qvectorp
);
2245 staticpro (&Qchar_or_string_p
);
2246 staticpro (&Qmarkerp
);
2247 staticpro (&Qbuffer_or_string_p
);
2248 staticpro (&Qinteger_or_marker_p
);
2249 #ifdef LISP_FLOAT_TYPE
2250 staticpro (&Qfloatp
);
2251 staticpro (&Qnumberp
);
2252 staticpro (&Qnumber_or_marker_p
);
2253 #endif /* LISP_FLOAT_TYPE */
2255 staticpro (&Qboundp
);
2256 staticpro (&Qfboundp
);
2258 staticpro (&Qad_advice_info
);
2259 staticpro (&Qad_activate
);
2267 defsubr (&Sintegerp
);
2268 defsubr (&Sinteger_or_marker_p
);
2269 defsubr (&Snumberp
);
2270 defsubr (&Snumber_or_marker_p
);
2271 #ifdef LISP_FLOAT_TYPE
2273 #endif /* LISP_FLOAT_TYPE */
2274 defsubr (&Snatnump
);
2275 defsubr (&Ssymbolp
);
2276 defsubr (&Sstringp
);
2277 defsubr (&Svectorp
);
2279 defsubr (&Ssequencep
);
2280 defsubr (&Sbufferp
);
2281 defsubr (&Smarkerp
);
2283 defsubr (&Sbyte_code_function_p
);
2284 defsubr (&Schar_or_string_p
);
2287 defsubr (&Scar_safe
);
2288 defsubr (&Scdr_safe
);
2291 defsubr (&Ssymbol_function
);
2292 defsubr (&Sindirect_function
);
2293 defsubr (&Ssymbol_plist
);
2294 defsubr (&Ssymbol_name
);
2295 defsubr (&Smakunbound
);
2296 defsubr (&Sfmakunbound
);
2298 defsubr (&Sfboundp
);
2300 defsubr (&Sdefalias
);
2301 defsubr (&Sdefine_function
);
2302 defsubr (&Ssetplist
);
2303 defsubr (&Ssymbol_value
);
2305 defsubr (&Sdefault_boundp
);
2306 defsubr (&Sdefault_value
);
2307 defsubr (&Sset_default
);
2308 defsubr (&Ssetq_default
);
2309 defsubr (&Smake_variable_buffer_local
);
2310 defsubr (&Smake_local_variable
);
2311 defsubr (&Skill_local_variable
);
2314 defsubr (&Snumber_to_string
);
2315 defsubr (&Sstring_to_number
);
2316 defsubr (&Seqlsign
);
2340 Fset (Qwholenump
, Qnatnump
);
2348 /* USG systems forget handlers when they are used;
2349 must reestablish each time */
2350 signal (signo
, arith_error
);
2353 /* VMS systems are like USG. */
2354 signal (signo
, arith_error
);
2358 #else /* not BSD4_1 */
2359 sigsetmask (SIGEMPTYMASK
);
2360 #endif /* not BSD4_1 */
2362 Fsignal (Qarith_error
, Qnil
);
2367 /* Don't do this if just dumping out.
2368 We don't want to call `signal' in this case
2369 so that we don't have trouble with dumping
2370 signal-delivering routines in an inconsistent state. */
2374 #endif /* CANNOT_DUMP */
2375 signal (SIGFPE
, arith_error
);
2378 signal (SIGEMT
, arith_error
);