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
;
78 Lisp_Object Qad_advice_info
, Qad_activate
;
80 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
81 Lisp_Object Qoverflow_error
, Qunderflow_error
;
83 #ifdef LISP_FLOAT_TYPE
85 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
88 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
89 static Lisp_Object Qfloat
, Qwindow_configuration
, Qprocess
, Qwindow
;
90 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
92 static Lisp_Object
swap_in_symval_forwarding ();
95 wrong_type_argument (predicate
, value
)
96 register Lisp_Object predicate
, value
;
98 register Lisp_Object tem
;
101 if (!EQ (Vmocklisp_arguments
, Qt
))
103 if (STRINGP (value
) &&
104 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
105 return Fstring_to_number (value
);
106 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
107 return Fnumber_to_string (value
);
110 /* If VALUE is not even a valid Lisp object, abort here
111 where we can get a backtrace showing where it came from. */
112 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
115 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
116 tem
= call1 (predicate
, value
);
124 error ("Attempt to modify read-only object");
128 args_out_of_range (a1
, a2
)
132 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
136 args_out_of_range_3 (a1
, a2
, a3
)
137 Lisp_Object a1
, a2
, a3
;
140 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
147 register Lisp_Object val
;
152 /* On some machines, XINT needs a temporary location.
153 Here it is, in case it is needed. */
155 int sign_extend_temp
;
157 /* On a few machines, XINT can only be done by calling this. */
160 sign_extend_lisp_int (num
)
163 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
164 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
166 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
169 /* Data type predicates */
171 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
172 "T if the two args are the same Lisp object.")
174 Lisp_Object obj1
, obj2
;
181 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
190 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
191 "Return a symbol representing the type of OBJECT.\n\
192 The symbol returned names the object's basic type;\n\
193 for example, (type-of 1) returns `integer'.")
197 switch (XGCTYPE (object
))
212 switch (XMISCTYPE (object
))
214 case Lisp_Misc_Marker
:
216 case Lisp_Misc_Overlay
:
218 case Lisp_Misc_Float
:
223 case Lisp_Vectorlike
:
224 if (GC_WINDOW_CONFIGURATIONP (object
))
225 return Qwindow_configuration
;
226 if (GC_PROCESSP (object
))
228 if (GC_WINDOWP (object
))
230 if (GC_SUBRP (object
))
232 if (GC_COMPILEDP (object
))
233 return Qcompiled_function
;
234 if (GC_BUFFERP (object
))
238 if (GC_FRAMEP (object
))
243 #ifdef LISP_FLOAT_TYPE
253 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
262 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
271 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
275 if (CONSP (object
) || NILP (object
))
280 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
293 if (SYMBOLP (object
))
298 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
302 if (VECTORP (object
))
307 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
311 if (STRINGP (object
))
316 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
320 if (VECTORP (object
) || STRINGP (object
))
325 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
326 "T if OBJECT is a sequence (list or array).")
328 register Lisp_Object object
;
330 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
))
335 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
339 if (BUFFERP (object
))
344 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
348 if (MARKERP (object
))
353 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
362 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
363 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
367 if (COMPILEDP (object
))
372 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
373 "T if OBJECT is a character (an integer) or a string.")
375 register Lisp_Object object
;
377 if (INTEGERP (object
) || STRINGP (object
))
382 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
386 if (INTEGERP (object
))
391 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
392 "T if OBJECT is an integer or a marker (editor pointer).")
394 register Lisp_Object object
;
396 if (MARKERP (object
) || INTEGERP (object
))
401 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
402 "T if OBJECT is a nonnegative integer.")
406 if (NATNUMP (object
))
411 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
412 "T if OBJECT is a number (floating point or integer).")
416 if (NUMBERP (object
))
422 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
423 Snumber_or_marker_p
, 1, 1, 0,
424 "T if OBJECT is a number or a marker.")
428 if (NUMBERP (object
) || MARKERP (object
))
433 #ifdef LISP_FLOAT_TYPE
434 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
435 "T if OBJECT is a floating point number.")
443 #endif /* LISP_FLOAT_TYPE */
445 /* Extract and set components of lists */
447 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
448 "Return the car of LIST. If arg is nil, return nil.\n\
449 Error if arg is not nil and not a cons cell. See also `car-safe'.")
451 register Lisp_Object list
;
456 return XCONS (list
)->car
;
457 else if (EQ (list
, Qnil
))
460 list
= wrong_type_argument (Qlistp
, list
);
464 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
465 "Return the car of OBJECT if it is a cons cell, or else nil.")
470 return XCONS (object
)->car
;
475 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
476 "Return the cdr of LIST. If arg is nil, return nil.\n\
477 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
480 register Lisp_Object list
;
485 return XCONS (list
)->cdr
;
486 else if (EQ (list
, Qnil
))
489 list
= wrong_type_argument (Qlistp
, list
);
493 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
494 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
499 return XCONS (object
)->cdr
;
504 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
505 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
507 register Lisp_Object cell
, newcar
;
510 cell
= wrong_type_argument (Qconsp
, cell
);
513 XCONS (cell
)->car
= newcar
;
517 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
518 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
520 register Lisp_Object cell
, newcdr
;
523 cell
= wrong_type_argument (Qconsp
, cell
);
526 XCONS (cell
)->cdr
= newcdr
;
530 /* Extract and set components of symbols */
532 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
534 register Lisp_Object sym
;
536 Lisp_Object valcontents
;
537 CHECK_SYMBOL (sym
, 0);
539 valcontents
= XSYMBOL (sym
)->value
;
541 if (BUFFER_LOCAL_VALUEP (valcontents
)
542 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
543 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
545 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
548 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
550 register Lisp_Object sym
;
552 CHECK_SYMBOL (sym
, 0);
553 return (EQ (XSYMBOL (sym
)->function
, Qunbound
) ? Qnil
: Qt
);
556 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
558 register Lisp_Object sym
;
560 CHECK_SYMBOL (sym
, 0);
561 if (NILP (sym
) || EQ (sym
, Qt
))
562 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
563 Fset (sym
, Qunbound
);
567 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
569 register Lisp_Object sym
;
571 CHECK_SYMBOL (sym
, 0);
572 if (NILP (sym
) || EQ (sym
, Qt
))
573 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
574 XSYMBOL (sym
)->function
= Qunbound
;
578 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
579 "Return SYMBOL's function definition. Error if that is void.")
581 register Lisp_Object symbol
;
583 CHECK_SYMBOL (symbol
, 0);
584 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
585 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
586 return XSYMBOL (symbol
)->function
;
589 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
591 register Lisp_Object sym
;
593 CHECK_SYMBOL (sym
, 0);
594 return XSYMBOL (sym
)->plist
;
597 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
599 register Lisp_Object sym
;
601 register Lisp_Object name
;
603 CHECK_SYMBOL (sym
, 0);
604 XSETSTRING (name
, XSYMBOL (sym
)->name
);
608 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
609 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
611 register Lisp_Object sym
, newdef
;
613 CHECK_SYMBOL (sym
, 0);
614 if (NILP (sym
) || EQ (sym
, Qt
))
615 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
616 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
617 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
619 XSYMBOL (sym
)->function
= newdef
;
620 /* Handle automatic advice activation */
621 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
623 call2 (Qad_activate
, sym
, Qnil
);
624 newdef
= XSYMBOL (sym
)->function
;
629 /* This name should be removed once it is eliminated from elsewhere. */
631 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
632 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
633 Associates the function with the current load file, if any.")
635 register Lisp_Object sym
, newdef
;
637 CHECK_SYMBOL (sym
, 0);
638 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
639 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
641 XSYMBOL (sym
)->function
= newdef
;
642 /* Handle automatic advice activation */
643 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
645 call2 (Qad_activate
, sym
, Qnil
);
646 newdef
= XSYMBOL (sym
)->function
;
648 LOADHIST_ATTACH (sym
);
652 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
653 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
654 Associates the function with the current load file, if any.")
656 register Lisp_Object sym
, newdef
;
658 CHECK_SYMBOL (sym
, 0);
659 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
660 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
662 XSYMBOL (sym
)->function
= newdef
;
663 /* Handle automatic advice activation */
664 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
666 call2 (Qad_activate
, sym
, Qnil
);
667 newdef
= XSYMBOL (sym
)->function
;
669 LOADHIST_ATTACH (sym
);
673 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
674 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
676 register Lisp_Object sym
, newplist
;
678 CHECK_SYMBOL (sym
, 0);
679 XSYMBOL (sym
)->plist
= newplist
;
684 /* Getting and setting values of symbols */
686 /* Given the raw contents of a symbol value cell,
687 return the Lisp value of the symbol.
688 This does not handle buffer-local variables; use
689 swap_in_symval_forwarding for that. */
692 do_symval_forwarding (valcontents
)
693 register Lisp_Object valcontents
;
695 register Lisp_Object val
;
697 if (MISCP (valcontents
))
698 switch (XMISCTYPE (valcontents
))
700 case Lisp_Misc_Intfwd
:
701 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
704 case Lisp_Misc_Boolfwd
:
705 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
707 case Lisp_Misc_Objfwd
:
708 return *XOBJFWD (valcontents
)->objvar
;
710 case Lisp_Misc_Buffer_Objfwd
:
711 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
712 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
714 case Lisp_Misc_Kboard_Objfwd
:
715 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
716 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
721 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
722 of SYM. If SYM is buffer-local, VALCONTENTS should be the
723 buffer-independent contents of the value cell: forwarded just one
724 step past the buffer-localness. */
727 store_symval_forwarding (sym
, valcontents
, newval
)
729 register Lisp_Object valcontents
, newval
;
731 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
734 switch (XMISCTYPE (valcontents
))
736 case Lisp_Misc_Intfwd
:
737 CHECK_NUMBER (newval
, 1);
738 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
741 case Lisp_Misc_Boolfwd
:
742 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
745 case Lisp_Misc_Objfwd
:
746 *XOBJFWD (valcontents
)->objvar
= newval
;
749 case Lisp_Misc_Buffer_Objfwd
:
751 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
754 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
755 if (! NILP (type
) && ! NILP (newval
)
756 && XTYPE (newval
) != XINT (type
))
757 buffer_slot_type_mismatch (offset
);
759 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
763 case Lisp_Misc_Kboard_Objfwd
:
764 (*(Lisp_Object
*)((char *)current_kboard
765 + XKBOARD_OBJFWD (valcontents
)->offset
))
776 valcontents
= XSYMBOL (sym
)->value
;
777 if (BUFFER_LOCAL_VALUEP (valcontents
)
778 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
779 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
781 XSYMBOL (sym
)->value
= newval
;
785 /* Set up the buffer-local symbol SYM for validity in the current
786 buffer. VALCONTENTS is the contents of its value cell.
787 Return the value forwarded one step past the buffer-local indicator. */
790 swap_in_symval_forwarding (sym
, valcontents
)
791 Lisp_Object sym
, valcontents
;
793 /* valcontents is a pointer to a struct resembling the cons
794 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
796 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
797 local_var_alist, that being the element whose car is this
798 variable. Or it can be a pointer to the
799 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
800 an element in its alist for this variable.
802 If the current buffer is not BUFFER, we store the current
803 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
804 appropriate alist element for the buffer now current and set up
805 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
806 element, and store into BUFFER.
808 Note that REALVALUE can be a forwarding pointer. */
810 register Lisp_Object tem1
;
811 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
813 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
815 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
817 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
818 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
820 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
821 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
822 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
824 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
827 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
830 /* Find the value of a symbol, returning Qunbound if it's not bound.
831 This is helpful for code which just wants to get a variable's value
832 if it has one, without signalling an error.
833 Note that it must not be possible to quit
834 within this function. Great care is required for this. */
837 find_symbol_value (sym
)
840 register Lisp_Object valcontents
, tem1
;
841 register Lisp_Object val
;
842 CHECK_SYMBOL (sym
, 0);
843 valcontents
= XSYMBOL (sym
)->value
;
845 if (BUFFER_LOCAL_VALUEP (valcontents
)
846 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
847 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
849 if (MISCP (valcontents
))
851 switch (XMISCTYPE (valcontents
))
853 case Lisp_Misc_Intfwd
:
854 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
857 case Lisp_Misc_Boolfwd
:
858 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
860 case Lisp_Misc_Objfwd
:
861 return *XOBJFWD (valcontents
)->objvar
;
863 case Lisp_Misc_Buffer_Objfwd
:
864 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
865 + (char *)current_buffer
);
867 case Lisp_Misc_Kboard_Objfwd
:
868 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
869 + (char *)current_kboard
);
876 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
877 "Return SYMBOL's value. Error if that is void.")
883 val
= find_symbol_value (sym
);
884 if (EQ (val
, Qunbound
))
885 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
890 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
891 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
893 register Lisp_Object sym
, newval
;
895 int voide
= EQ (newval
, Qunbound
);
897 register Lisp_Object valcontents
, tem1
, current_alist_element
;
899 CHECK_SYMBOL (sym
, 0);
900 if (NILP (sym
) || EQ (sym
, Qt
))
901 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
902 valcontents
= XSYMBOL (sym
)->value
;
904 if (BUFFER_OBJFWDP (valcontents
))
906 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
907 register int mask
= XINT (*((Lisp_Object
*)
908 (idx
+ (char *)&buffer_local_flags
)));
910 current_buffer
->local_var_flags
|= mask
;
913 else if (BUFFER_LOCAL_VALUEP (valcontents
)
914 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
916 /* valcontents is actually a pointer to a struct resembling a cons,
917 with contents something like:
918 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
920 BUFFER is the last buffer for which this symbol's value was
923 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
924 local_var_alist, that being the element whose car is this
925 variable. Or it can be a pointer to the
926 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
927 have an element in its alist for this variable (that is, if
928 BUFFER sees the default value of this variable).
930 If we want to examine or set the value and BUFFER is current,
931 we just examine or set REALVALUE. If BUFFER is not current, we
932 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
933 then find the appropriate alist element for the buffer now
934 current and set up CURRENT-ALIST-ELEMENT. Then we set
935 REALVALUE out of that element, and store into BUFFER.
937 If we are setting the variable and the current buffer does
938 not have an alist entry for this variable, an alist entry is
941 Note that REALVALUE can be a forwarding pointer. Each time
942 it is examined or set, forwarding must be done. */
944 /* What value are we caching right now? */
945 current_alist_element
=
946 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
948 /* If the current buffer is not the buffer whose binding is
949 currently cached, or if it's a Lisp_Buffer_Local_Value and
950 we're looking at the default value, the cache is invalid; we
951 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
953 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
954 || (BUFFER_LOCAL_VALUEP (valcontents
)
955 && EQ (XCONS (current_alist_element
)->car
,
956 current_alist_element
)))
958 /* Write out the cached value for the old buffer; copy it
959 back to its alist element. This works if the current
960 buffer only sees the default value, too. */
961 Fsetcdr (current_alist_element
,
962 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
964 /* Find the new value for CURRENT-ALIST-ELEMENT. */
965 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
968 /* This buffer still sees the default value. */
970 /* If the variable is a Lisp_Some_Buffer_Local_Value,
971 make CURRENT-ALIST-ELEMENT point to itself,
972 indicating that we're seeing the default value. */
973 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
974 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
976 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
977 new assoc for a local value and set
978 CURRENT-ALIST-ELEMENT to point to that. */
981 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
982 current_buffer
->local_var_alist
=
983 Fcons (tem1
, current_buffer
->local_var_alist
);
986 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
987 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
990 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
991 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
994 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
997 /* If storing void (making the symbol void), forward only through
998 buffer-local indicator, not through Lisp_Objfwd, etc. */
1000 store_symval_forwarding (sym
, Qnil
, newval
);
1002 store_symval_forwarding (sym
, valcontents
, newval
);
1007 /* Access or set a buffer-local symbol's default value. */
1009 /* Return the default value of SYM, but don't check for voidness.
1010 Return Qunbound if it is void. */
1016 register Lisp_Object valcontents
;
1018 CHECK_SYMBOL (sym
, 0);
1019 valcontents
= XSYMBOL (sym
)->value
;
1021 /* For a built-in buffer-local variable, get the default value
1022 rather than letting do_symval_forwarding get the current value. */
1023 if (BUFFER_OBJFWDP (valcontents
))
1025 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1027 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1028 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1031 /* Handle user-created local variables. */
1032 if (BUFFER_LOCAL_VALUEP (valcontents
)
1033 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1035 /* If var is set up for a buffer that lacks a local value for it,
1036 the current value is nominally the default value.
1037 But the current value slot may be more up to date, since
1038 ordinary setq stores just that slot. So use that. */
1039 Lisp_Object current_alist_element
, alist_element_car
;
1040 current_alist_element
1041 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1042 alist_element_car
= XCONS (current_alist_element
)->car
;
1043 if (EQ (alist_element_car
, current_alist_element
))
1044 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1046 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1048 /* For other variables, get the current value. */
1049 return do_symval_forwarding (valcontents
);
1052 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1053 "Return T if SYMBOL has a non-void default value.\n\
1054 This is the value that is seen in buffers that do not have their own values\n\
1055 for this variable.")
1059 register Lisp_Object value
;
1061 value
= default_value (sym
);
1062 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1065 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1066 "Return SYMBOL's default value.\n\
1067 This is the value that is seen in buffers that do not have their own values\n\
1068 for this variable. The default value is meaningful for variables with\n\
1069 local bindings in certain buffers.")
1073 register Lisp_Object value
;
1075 value
= default_value (sym
);
1076 if (EQ (value
, Qunbound
))
1077 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1081 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1082 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1083 The default value is seen in buffers that do not have their own values\n\
1084 for this variable.")
1086 Lisp_Object sym
, value
;
1088 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1090 CHECK_SYMBOL (sym
, 0);
1091 valcontents
= XSYMBOL (sym
)->value
;
1093 /* Handle variables like case-fold-search that have special slots
1094 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1096 if (BUFFER_OBJFWDP (valcontents
))
1098 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1099 register struct buffer
*b
;
1100 register int mask
= XINT (*((Lisp_Object
*)
1101 (idx
+ (char *)&buffer_local_flags
)));
1105 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1106 for (b
= all_buffers
; b
; b
= b
->next
)
1107 if (!(b
->local_var_flags
& mask
))
1108 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1113 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1114 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1115 return Fset (sym
, value
);
1117 /* Store new value into the DEFAULT-VALUE slot */
1118 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1120 /* If that slot is current, we must set the REALVALUE slot too */
1121 current_alist_element
1122 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1123 alist_element_buffer
= Fcar (current_alist_element
);
1124 if (EQ (alist_element_buffer
, current_alist_element
))
1125 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1131 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1132 "Set the default value of variable VAR to VALUE.\n\
1133 VAR, the variable name, is literal (not evaluated);\n\
1134 VALUE is an expression and it is evaluated.\n\
1135 The default value of a variable is seen in buffers\n\
1136 that do not have their own values for the variable.\n\
1138 More generally, you can use multiple variables and values, as in\n\
1139 (setq-default SYM VALUE SYM VALUE...)\n\
1140 This sets each SYM's default value to the corresponding VALUE.\n\
1141 The VALUE for the Nth SYM can refer to the new default values\n\
1146 register Lisp_Object args_left
;
1147 register Lisp_Object val
, sym
;
1148 struct gcpro gcpro1
;
1158 val
= Feval (Fcar (Fcdr (args_left
)));
1159 sym
= Fcar (args_left
);
1160 Fset_default (sym
, val
);
1161 args_left
= Fcdr (Fcdr (args_left
));
1163 while (!NILP (args_left
));
1169 /* Lisp functions for creating and removing buffer-local variables. */
1171 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1172 1, 1, "vMake Variable Buffer Local: ",
1173 "Make VARIABLE have a separate value for each buffer.\n\
1174 At any time, the value for the current buffer is in effect.\n\
1175 There is also a default value which is seen in any buffer which has not yet\n\
1176 set its own value.\n\
1177 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1178 for the current buffer if it was previously using the default value.\n\
1179 The function `default-value' gets the default value and `set-default' sets it.")
1181 register Lisp_Object sym
;
1183 register Lisp_Object tem
, valcontents
, newval
;
1185 CHECK_SYMBOL (sym
, 0);
1187 valcontents
= XSYMBOL (sym
)->value
;
1188 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1189 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1191 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1193 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1195 XMISCTYPE (XSYMBOL (sym
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1198 if (EQ (valcontents
, Qunbound
))
1199 XSYMBOL (sym
)->value
= Qnil
;
1200 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1201 XCONS (tem
)->car
= tem
;
1202 newval
= allocate_misc ();
1203 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1204 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1205 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1206 XSYMBOL (sym
)->value
= newval
;
1210 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1211 1, 1, "vMake Local Variable: ",
1212 "Make VARIABLE have a separate value in the current buffer.\n\
1213 Other buffers will continue to share a common default value.\n\
1214 \(The buffer-local value of VARIABLE starts out as the same value\n\
1215 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1216 See also `make-variable-buffer-local'.\n\n\
1217 If the variable is already arranged to become local when set,\n\
1218 this function causes a local value to exist for this buffer,\n\
1219 just as setting the variable would do.\n\
1221 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1222 Use `make-local-hook' instead.")
1224 register Lisp_Object sym
;
1226 register Lisp_Object tem
, valcontents
;
1228 CHECK_SYMBOL (sym
, 0);
1230 valcontents
= XSYMBOL (sym
)->value
;
1231 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1232 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1234 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1236 tem
= Fboundp (sym
);
1238 /* Make sure the symbol has a local value in this particular buffer,
1239 by setting it to the same value it already has. */
1240 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1243 /* Make sure sym is set up to hold per-buffer values */
1244 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1247 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1248 XCONS (tem
)->car
= tem
;
1249 newval
= allocate_misc ();
1250 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1251 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1252 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1253 XSYMBOL (sym
)->value
= newval
;
1255 /* Make sure this buffer has its own value of sym */
1256 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1259 current_buffer
->local_var_alist
1260 = Fcons (Fcons (sym
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1261 current_buffer
->local_var_alist
);
1263 /* Make sure symbol does not think it is set up for this buffer;
1264 force it to look once again for this buffer's value */
1266 Lisp_Object
*pvalbuf
;
1267 valcontents
= XSYMBOL (sym
)->value
;
1268 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1269 if (current_buffer
== XBUFFER (*pvalbuf
))
1274 /* If the symbol forwards into a C variable, then swap in the
1275 variable for this buffer immediately. If C code modifies the
1276 variable before we swap in, then that new value will clobber the
1277 default value the next time we swap. */
1278 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->car
;
1279 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1280 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1285 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1286 1, 1, "vKill Local Variable: ",
1287 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1288 From now on the default value will apply in this buffer.")
1290 register Lisp_Object sym
;
1292 register Lisp_Object tem
, valcontents
;
1294 CHECK_SYMBOL (sym
, 0);
1296 valcontents
= XSYMBOL (sym
)->value
;
1298 if (BUFFER_OBJFWDP (valcontents
))
1300 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1301 register int mask
= XINT (*((Lisp_Object
*)
1302 (idx
+ (char *)&buffer_local_flags
)));
1306 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1307 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1308 current_buffer
->local_var_flags
&= ~mask
;
1313 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1314 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1317 /* Get rid of this buffer's alist element, if any */
1319 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1321 current_buffer
->local_var_alist
1322 = Fdelq (tem
, current_buffer
->local_var_alist
);
1324 /* Make sure symbol does not think it is set up for this buffer;
1325 force it to look once again for this buffer's value */
1327 Lisp_Object
*pvalbuf
;
1328 valcontents
= XSYMBOL (sym
)->value
;
1329 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1330 if (current_buffer
== XBUFFER (*pvalbuf
))
1337 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1339 "Non-nil if VARIABLE has a local binding in the current buffer.")
1341 register Lisp_Object sym
;
1343 Lisp_Object valcontents
;
1345 CHECK_SYMBOL (sym
, 0);
1347 valcontents
= XSYMBOL (sym
)->value
;
1348 return ((BUFFER_LOCAL_VALUEP (valcontents
)
1349 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1350 || BUFFER_OBJFWDP (valcontents
))
1354 /* Find the function at the end of a chain of symbol function indirections. */
1356 /* If OBJECT is a symbol, find the end of its function chain and
1357 return the value found there. If OBJECT is not a symbol, just
1358 return it. If there is a cycle in the function chain, signal a
1359 cyclic-function-indirection error.
1361 This is like Findirect_function, except that it doesn't signal an
1362 error if the chain ends up unbound. */
1364 indirect_function (object
)
1365 register Lisp_Object object
;
1367 Lisp_Object tortoise
, hare
;
1369 hare
= tortoise
= object
;
1373 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1375 hare
= XSYMBOL (hare
)->function
;
1376 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1378 hare
= XSYMBOL (hare
)->function
;
1380 tortoise
= XSYMBOL (tortoise
)->function
;
1382 if (EQ (hare
, tortoise
))
1383 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1389 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1390 "Return the function at the end of OBJECT's function chain.\n\
1391 If OBJECT is a symbol, follow all function indirections and return the final\n\
1392 function binding.\n\
1393 If OBJECT is not a symbol, just return it.\n\
1394 Signal a void-function error if the final symbol is unbound.\n\
1395 Signal a cyclic-function-indirection error if there is a loop in the\n\
1396 function chain of symbols.")
1398 register Lisp_Object object
;
1402 result
= indirect_function (object
);
1404 if (EQ (result
, Qunbound
))
1405 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1409 /* Extract and set vector and string elements */
1411 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1412 "Return the element of ARRAY at index INDEX.\n\
1413 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1415 register Lisp_Object array
;
1418 register int idxval
;
1420 CHECK_NUMBER (idx
, 1);
1421 idxval
= XINT (idx
);
1422 if (STRINGP (array
))
1425 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1426 args_out_of_range (array
, idx
);
1427 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1433 if (VECTORP (array
))
1434 size
= XVECTOR (array
)->size
;
1435 else if (COMPILEDP (array
))
1436 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1438 wrong_type_argument (Qarrayp
, array
);
1440 if (idxval
< 0 || idxval
>= size
)
1441 args_out_of_range (array
, idx
);
1442 return XVECTOR (array
)->contents
[idxval
];
1446 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1447 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1448 ARRAY may be a vector or a string. IDX starts at 0.")
1449 (array
, idx
, newelt
)
1450 register Lisp_Object array
;
1451 Lisp_Object idx
, newelt
;
1453 register int idxval
;
1455 CHECK_NUMBER (idx
, 1);
1456 idxval
= XINT (idx
);
1457 if (!VECTORP (array
) && !STRINGP (array
))
1458 array
= wrong_type_argument (Qarrayp
, array
);
1459 CHECK_IMPURE (array
);
1461 if (VECTORP (array
))
1463 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1464 args_out_of_range (array
, idx
);
1465 XVECTOR (array
)->contents
[idxval
] = newelt
;
1469 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1470 args_out_of_range (array
, idx
);
1471 CHECK_NUMBER (newelt
, 2);
1472 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1478 /* Arithmetic functions */
1480 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1483 arithcompare (num1
, num2
, comparison
)
1484 Lisp_Object num1
, num2
;
1485 enum comparison comparison
;
1490 #ifdef LISP_FLOAT_TYPE
1491 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1492 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1494 if (FLOATP (num1
) || FLOATP (num2
))
1497 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1498 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1501 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1502 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1503 #endif /* LISP_FLOAT_TYPE */
1508 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1513 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1518 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1523 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1528 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1533 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1542 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1543 "T if two args, both numbers or markers, are equal.")
1545 register Lisp_Object num1
, num2
;
1547 return arithcompare (num1
, num2
, equal
);
1550 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1551 "T if first arg is less than second arg. Both must be numbers or markers.")
1553 register Lisp_Object num1
, num2
;
1555 return arithcompare (num1
, num2
, less
);
1558 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1559 "T if first arg is greater than second arg. Both must be numbers or markers.")
1561 register Lisp_Object num1
, num2
;
1563 return arithcompare (num1
, num2
, grtr
);
1566 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1567 "T if first arg is less than or equal to second arg.\n\
1568 Both must be numbers or markers.")
1570 register Lisp_Object num1
, num2
;
1572 return arithcompare (num1
, num2
, less_or_equal
);
1575 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1576 "T if first arg is greater than or equal to second arg.\n\
1577 Both must be numbers or markers.")
1579 register Lisp_Object num1
, num2
;
1581 return arithcompare (num1
, num2
, grtr_or_equal
);
1584 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1585 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1587 register Lisp_Object num1
, num2
;
1589 return arithcompare (num1
, num2
, notequal
);
1592 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1594 register Lisp_Object num
;
1596 #ifdef LISP_FLOAT_TYPE
1597 CHECK_NUMBER_OR_FLOAT (num
, 0);
1601 if (XFLOAT(num
)->data
== 0.0)
1606 CHECK_NUMBER (num
, 0);
1607 #endif /* LISP_FLOAT_TYPE */
1614 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1620 unsigned int top
= i
>> 16;
1621 unsigned int bot
= i
& 0xFFFF;
1623 return make_number (bot
);
1625 return Fcons (make_number (-1), make_number (bot
));
1626 return Fcons (make_number (top
), make_number (bot
));
1633 Lisp_Object top
, bot
;
1636 top
= XCONS (c
)->car
;
1637 bot
= XCONS (c
)->cdr
;
1639 bot
= XCONS (bot
)->car
;
1640 return ((XINT (top
) << 16) | XINT (bot
));
1643 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1644 "Convert NUM to a string by printing it in decimal.\n\
1645 Uses a minus sign if negative.\n\
1646 NUM may be an integer or a floating point number.")
1652 #ifndef LISP_FLOAT_TYPE
1653 CHECK_NUMBER (num
, 0);
1655 CHECK_NUMBER_OR_FLOAT (num
, 0);
1659 char pigbuf
[350]; /* see comments in float_to_string */
1661 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1662 return build_string (pigbuf
);
1664 #endif /* LISP_FLOAT_TYPE */
1666 sprintf (buffer
, "%d", XINT (num
));
1667 return build_string (buffer
);
1670 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1671 "Convert STRING to a number by parsing it as a decimal number.\n\
1672 This parses both integers and floating point numbers.\n\
1673 It ignores leading spaces and tabs.")
1675 register Lisp_Object str
;
1679 CHECK_STRING (str
, 0);
1681 p
= XSTRING (str
)->data
;
1683 /* Skip any whitespace at the front of the number. Some versions of
1684 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1685 while (*p
== ' ' || *p
== '\t')
1688 #ifdef LISP_FLOAT_TYPE
1689 if (isfloat_string (p
))
1690 return make_float (atof (p
));
1691 #endif /* LISP_FLOAT_TYPE */
1693 return make_number (atoi (p
));
1697 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1699 extern Lisp_Object
float_arith_driver ();
1702 arith_driver (code
, nargs
, args
)
1705 register Lisp_Object
*args
;
1707 register Lisp_Object val
;
1708 register int argnum
;
1712 switch (SWITCH_ENUM_CAST (code
))
1725 for (argnum
= 0; argnum
< nargs
; argnum
++)
1727 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1728 #ifdef LISP_FLOAT_TYPE
1729 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1731 if (FLOATP (val
)) /* time to do serious math */
1732 return (float_arith_driver ((double) accum
, argnum
, code
,
1735 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1736 #endif /* LISP_FLOAT_TYPE */
1737 args
[argnum
] = val
; /* runs into a compiler bug. */
1738 next
= XINT (args
[argnum
]);
1739 switch (SWITCH_ENUM_CAST (code
))
1741 case Aadd
: accum
+= next
; break;
1743 if (!argnum
&& nargs
!= 1)
1747 case Amult
: accum
*= next
; break;
1749 if (!argnum
) accum
= next
;
1753 Fsignal (Qarith_error
, Qnil
);
1757 case Alogand
: accum
&= next
; break;
1758 case Alogior
: accum
|= next
; break;
1759 case Alogxor
: accum
^= next
; break;
1760 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1761 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1765 XSETINT (val
, accum
);
1769 #ifdef LISP_FLOAT_TYPE
1772 #define isnan(x) ((x) != (x))
1775 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1777 register int argnum
;
1780 register Lisp_Object
*args
;
1782 register Lisp_Object val
;
1785 for (; argnum
< nargs
; argnum
++)
1787 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1788 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1792 next
= XFLOAT (val
)->data
;
1796 args
[argnum
] = val
; /* runs into a compiler bug. */
1797 next
= XINT (args
[argnum
]);
1799 switch (SWITCH_ENUM_CAST (code
))
1805 if (!argnum
&& nargs
!= 1)
1818 Fsignal (Qarith_error
, Qnil
);
1825 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1827 if (!argnum
|| isnan (next
) || next
> accum
)
1831 if (!argnum
|| isnan (next
) || next
< accum
)
1837 return make_float (accum
);
1839 #endif /* LISP_FLOAT_TYPE */
1841 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1842 "Return sum of any number of arguments, which are numbers or markers.")
1847 return arith_driver (Aadd
, nargs
, args
);
1850 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1851 "Negate number or subtract numbers or markers.\n\
1852 With one arg, negates it. With more than one arg,\n\
1853 subtracts all but the first from the first.")
1858 return arith_driver (Asub
, nargs
, args
);
1861 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1862 "Returns product of any number of arguments, which are numbers or markers.")
1867 return arith_driver (Amult
, nargs
, args
);
1870 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1871 "Returns first argument divided by all the remaining arguments.\n\
1872 The arguments must be numbers or markers.")
1877 return arith_driver (Adiv
, nargs
, args
);
1880 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1881 "Returns remainder of first arg divided by second.\n\
1882 Both must be integers or markers.")
1884 register Lisp_Object num1
, num2
;
1888 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1889 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1891 if (XFASTINT (num2
) == 0)
1892 Fsignal (Qarith_error
, Qnil
);
1894 XSETINT (val
, XINT (num1
) % XINT (num2
));
1903 #ifdef HAVE_DREM /* Some systems use this non-standard name. */
1904 return (drem (f1
, f2
));
1905 #else /* Other systems don't seem to have it at all. */
1906 return (f1
- f2
* floor (f1
/f2
));
1909 #endif /* ! HAVE_FMOD */
1911 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1912 "Returns X modulo Y.\n\
1913 The result falls between zero (inclusive) and Y (exclusive).\n\
1914 Both X and Y must be numbers or markers.")
1916 register Lisp_Object num1
, num2
;
1921 #ifdef LISP_FLOAT_TYPE
1922 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1923 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
1925 if (FLOATP (num1
) || FLOATP (num2
))
1929 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
1930 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
1932 Fsignal (Qarith_error
, Qnil
);
1935 /* If the "remainder" comes out with the wrong sign, fix it. */
1936 if ((f1
< 0) != (f2
< 0))
1938 return (make_float (f1
));
1940 #else /* not LISP_FLOAT_TYPE */
1941 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1942 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1943 #endif /* not LISP_FLOAT_TYPE */
1949 Fsignal (Qarith_error
, Qnil
);
1953 /* If the "remainder" comes out with the wrong sign, fix it. */
1954 if (i2
< 0 ? i1
> 0 : i1
< 0)
1961 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1962 "Return largest of all the arguments (which must be numbers or markers).\n\
1963 The value is always a number; markers are converted to numbers.")
1968 return arith_driver (Amax
, nargs
, args
);
1971 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1972 "Return smallest of all the arguments (which must be numbers or markers).\n\
1973 The value is always a number; markers are converted to numbers.")
1978 return arith_driver (Amin
, nargs
, args
);
1981 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1982 "Return bitwise-and of all the arguments.\n\
1983 Arguments may be integers, or markers converted to integers.")
1988 return arith_driver (Alogand
, nargs
, args
);
1991 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1992 "Return bitwise-or of all the arguments.\n\
1993 Arguments may be integers, or markers converted to integers.")
1998 return arith_driver (Alogior
, nargs
, args
);
2001 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2002 "Return bitwise-exclusive-or of all the arguments.\n\
2003 Arguments may be integers, or markers converted to integers.")
2008 return arith_driver (Alogxor
, nargs
, args
);
2011 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2012 "Return VALUE with its bits shifted left by COUNT.\n\
2013 If COUNT is negative, shifting is actually to the right.\n\
2014 In this case, the sign bit is duplicated.")
2016 register Lisp_Object value
, count
;
2018 register Lisp_Object val
;
2020 CHECK_NUMBER (value
, 0);
2021 CHECK_NUMBER (count
, 1);
2023 if (XINT (count
) > 0)
2024 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2026 XSETINT (val
, XINT (value
) >> -XINT (count
));
2030 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2031 "Return VALUE with its bits shifted left by COUNT.\n\
2032 If COUNT is negative, shifting is actually to the right.\n\
2033 In this case, zeros are shifted in on the left.")
2035 register Lisp_Object value
, count
;
2037 register Lisp_Object val
;
2039 CHECK_NUMBER (value
, 0);
2040 CHECK_NUMBER (count
, 1);
2042 if (XINT (count
) > 0)
2043 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2045 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2049 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2050 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2051 Markers are converted to integers.")
2053 register Lisp_Object num
;
2055 #ifdef LISP_FLOAT_TYPE
2056 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2059 return (make_float (1.0 + XFLOAT (num
)->data
));
2061 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2062 #endif /* LISP_FLOAT_TYPE */
2064 XSETINT (num
, XINT (num
) + 1);
2068 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2069 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2070 Markers are converted to integers.")
2072 register Lisp_Object num
;
2074 #ifdef LISP_FLOAT_TYPE
2075 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2078 return (make_float (-1.0 + XFLOAT (num
)->data
));
2080 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2081 #endif /* LISP_FLOAT_TYPE */
2083 XSETINT (num
, XINT (num
) - 1);
2087 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2088 "Return the bitwise complement of ARG. ARG must be an integer.")
2090 register Lisp_Object num
;
2092 CHECK_NUMBER (num
, 0);
2093 XSETINT (num
, ~XINT (num
));
2100 Lisp_Object error_tail
, arith_tail
;
2102 Qquote
= intern ("quote");
2103 Qlambda
= intern ("lambda");
2104 Qsubr
= intern ("subr");
2105 Qerror_conditions
= intern ("error-conditions");
2106 Qerror_message
= intern ("error-message");
2107 Qtop_level
= intern ("top-level");
2109 Qerror
= intern ("error");
2110 Qquit
= intern ("quit");
2111 Qwrong_type_argument
= intern ("wrong-type-argument");
2112 Qargs_out_of_range
= intern ("args-out-of-range");
2113 Qvoid_function
= intern ("void-function");
2114 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2115 Qvoid_variable
= intern ("void-variable");
2116 Qsetting_constant
= intern ("setting-constant");
2117 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2119 Qinvalid_function
= intern ("invalid-function");
2120 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2121 Qno_catch
= intern ("no-catch");
2122 Qend_of_file
= intern ("end-of-file");
2123 Qarith_error
= intern ("arith-error");
2124 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2125 Qend_of_buffer
= intern ("end-of-buffer");
2126 Qbuffer_read_only
= intern ("buffer-read-only");
2127 Qmark_inactive
= intern ("mark-inactive");
2129 Qlistp
= intern ("listp");
2130 Qconsp
= intern ("consp");
2131 Qsymbolp
= intern ("symbolp");
2132 Qintegerp
= intern ("integerp");
2133 Qnatnump
= intern ("natnump");
2134 Qwholenump
= intern ("wholenump");
2135 Qstringp
= intern ("stringp");
2136 Qarrayp
= intern ("arrayp");
2137 Qsequencep
= intern ("sequencep");
2138 Qbufferp
= intern ("bufferp");
2139 Qvectorp
= intern ("vectorp");
2140 Qchar_or_string_p
= intern ("char-or-string-p");
2141 Qmarkerp
= intern ("markerp");
2142 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2143 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2144 Qboundp
= intern ("boundp");
2145 Qfboundp
= intern ("fboundp");
2147 #ifdef LISP_FLOAT_TYPE
2148 Qfloatp
= intern ("floatp");
2149 Qnumberp
= intern ("numberp");
2150 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2151 #endif /* LISP_FLOAT_TYPE */
2153 Qcdr
= intern ("cdr");
2155 /* Handle automatic advice activation */
2156 Qad_advice_info
= intern ("ad-advice-info");
2157 Qad_activate
= intern ("ad-activate");
2159 error_tail
= Fcons (Qerror
, Qnil
);
2161 /* ERROR is used as a signaler for random errors for which nothing else is right */
2163 Fput (Qerror
, Qerror_conditions
,
2165 Fput (Qerror
, Qerror_message
,
2166 build_string ("error"));
2168 Fput (Qquit
, Qerror_conditions
,
2169 Fcons (Qquit
, Qnil
));
2170 Fput (Qquit
, Qerror_message
,
2171 build_string ("Quit"));
2173 Fput (Qwrong_type_argument
, Qerror_conditions
,
2174 Fcons (Qwrong_type_argument
, error_tail
));
2175 Fput (Qwrong_type_argument
, Qerror_message
,
2176 build_string ("Wrong type argument"));
2178 Fput (Qargs_out_of_range
, Qerror_conditions
,
2179 Fcons (Qargs_out_of_range
, error_tail
));
2180 Fput (Qargs_out_of_range
, Qerror_message
,
2181 build_string ("Args out of range"));
2183 Fput (Qvoid_function
, Qerror_conditions
,
2184 Fcons (Qvoid_function
, error_tail
));
2185 Fput (Qvoid_function
, Qerror_message
,
2186 build_string ("Symbol's function definition is void"));
2188 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2189 Fcons (Qcyclic_function_indirection
, error_tail
));
2190 Fput (Qcyclic_function_indirection
, Qerror_message
,
2191 build_string ("Symbol's chain of function indirections contains a loop"));
2193 Fput (Qvoid_variable
, Qerror_conditions
,
2194 Fcons (Qvoid_variable
, error_tail
));
2195 Fput (Qvoid_variable
, Qerror_message
,
2196 build_string ("Symbol's value as variable is void"));
2198 Fput (Qsetting_constant
, Qerror_conditions
,
2199 Fcons (Qsetting_constant
, error_tail
));
2200 Fput (Qsetting_constant
, Qerror_message
,
2201 build_string ("Attempt to set a constant symbol"));
2203 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2204 Fcons (Qinvalid_read_syntax
, error_tail
));
2205 Fput (Qinvalid_read_syntax
, Qerror_message
,
2206 build_string ("Invalid read syntax"));
2208 Fput (Qinvalid_function
, Qerror_conditions
,
2209 Fcons (Qinvalid_function
, error_tail
));
2210 Fput (Qinvalid_function
, Qerror_message
,
2211 build_string ("Invalid function"));
2213 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2214 Fcons (Qwrong_number_of_arguments
, error_tail
));
2215 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2216 build_string ("Wrong number of arguments"));
2218 Fput (Qno_catch
, Qerror_conditions
,
2219 Fcons (Qno_catch
, error_tail
));
2220 Fput (Qno_catch
, Qerror_message
,
2221 build_string ("No catch for tag"));
2223 Fput (Qend_of_file
, Qerror_conditions
,
2224 Fcons (Qend_of_file
, error_tail
));
2225 Fput (Qend_of_file
, Qerror_message
,
2226 build_string ("End of file during parsing"));
2228 arith_tail
= Fcons (Qarith_error
, error_tail
);
2229 Fput (Qarith_error
, Qerror_conditions
,
2231 Fput (Qarith_error
, Qerror_message
,
2232 build_string ("Arithmetic error"));
2234 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2235 Fcons (Qbeginning_of_buffer
, error_tail
));
2236 Fput (Qbeginning_of_buffer
, Qerror_message
,
2237 build_string ("Beginning of buffer"));
2239 Fput (Qend_of_buffer
, Qerror_conditions
,
2240 Fcons (Qend_of_buffer
, error_tail
));
2241 Fput (Qend_of_buffer
, Qerror_message
,
2242 build_string ("End of buffer"));
2244 Fput (Qbuffer_read_only
, Qerror_conditions
,
2245 Fcons (Qbuffer_read_only
, error_tail
));
2246 Fput (Qbuffer_read_only
, Qerror_message
,
2247 build_string ("Buffer is read-only"));
2249 #ifdef LISP_FLOAT_TYPE
2250 Qrange_error
= intern ("range-error");
2251 Qdomain_error
= intern ("domain-error");
2252 Qsingularity_error
= intern ("singularity-error");
2253 Qoverflow_error
= intern ("overflow-error");
2254 Qunderflow_error
= intern ("underflow-error");
2256 Fput (Qdomain_error
, Qerror_conditions
,
2257 Fcons (Qdomain_error
, arith_tail
));
2258 Fput (Qdomain_error
, Qerror_message
,
2259 build_string ("Arithmetic domain error"));
2261 Fput (Qrange_error
, Qerror_conditions
,
2262 Fcons (Qrange_error
, arith_tail
));
2263 Fput (Qrange_error
, Qerror_message
,
2264 build_string ("Arithmetic range error"));
2266 Fput (Qsingularity_error
, Qerror_conditions
,
2267 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2268 Fput (Qsingularity_error
, Qerror_message
,
2269 build_string ("Arithmetic singularity error"));
2271 Fput (Qoverflow_error
, Qerror_conditions
,
2272 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2273 Fput (Qoverflow_error
, Qerror_message
,
2274 build_string ("Arithmetic overflow error"));
2276 Fput (Qunderflow_error
, Qerror_conditions
,
2277 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2278 Fput (Qunderflow_error
, Qerror_message
,
2279 build_string ("Arithmetic underflow error"));
2281 staticpro (&Qrange_error
);
2282 staticpro (&Qdomain_error
);
2283 staticpro (&Qsingularity_error
);
2284 staticpro (&Qoverflow_error
);
2285 staticpro (&Qunderflow_error
);
2286 #endif /* LISP_FLOAT_TYPE */
2290 staticpro (&Qquote
);
2291 staticpro (&Qlambda
);
2293 staticpro (&Qunbound
);
2294 staticpro (&Qerror_conditions
);
2295 staticpro (&Qerror_message
);
2296 staticpro (&Qtop_level
);
2298 staticpro (&Qerror
);
2300 staticpro (&Qwrong_type_argument
);
2301 staticpro (&Qargs_out_of_range
);
2302 staticpro (&Qvoid_function
);
2303 staticpro (&Qcyclic_function_indirection
);
2304 staticpro (&Qvoid_variable
);
2305 staticpro (&Qsetting_constant
);
2306 staticpro (&Qinvalid_read_syntax
);
2307 staticpro (&Qwrong_number_of_arguments
);
2308 staticpro (&Qinvalid_function
);
2309 staticpro (&Qno_catch
);
2310 staticpro (&Qend_of_file
);
2311 staticpro (&Qarith_error
);
2312 staticpro (&Qbeginning_of_buffer
);
2313 staticpro (&Qend_of_buffer
);
2314 staticpro (&Qbuffer_read_only
);
2315 staticpro (&Qmark_inactive
);
2317 staticpro (&Qlistp
);
2318 staticpro (&Qconsp
);
2319 staticpro (&Qsymbolp
);
2320 staticpro (&Qintegerp
);
2321 staticpro (&Qnatnump
);
2322 staticpro (&Qwholenump
);
2323 staticpro (&Qstringp
);
2324 staticpro (&Qarrayp
);
2325 staticpro (&Qsequencep
);
2326 staticpro (&Qbufferp
);
2327 staticpro (&Qvectorp
);
2328 staticpro (&Qchar_or_string_p
);
2329 staticpro (&Qmarkerp
);
2330 staticpro (&Qbuffer_or_string_p
);
2331 staticpro (&Qinteger_or_marker_p
);
2332 #ifdef LISP_FLOAT_TYPE
2333 staticpro (&Qfloatp
);
2334 staticpro (&Qnumberp
);
2335 staticpro (&Qnumber_or_marker_p
);
2336 #endif /* LISP_FLOAT_TYPE */
2338 staticpro (&Qboundp
);
2339 staticpro (&Qfboundp
);
2341 staticpro (&Qad_advice_info
);
2342 staticpro (&Qad_activate
);
2344 /* Types that type-of returns. */
2345 Qinteger
= intern ("integer");
2346 Qsymbol
= intern ("symbol");
2347 Qstring
= intern ("string");
2348 Qcons
= intern ("cons");
2349 Qmarker
= intern ("marker");
2350 Qoverlay
= intern ("overlay");
2351 Qfloat
= intern ("float");
2352 Qwindow_configuration
= intern ("window-configuration");
2353 Qprocess
= intern ("process");
2354 Qwindow
= intern ("window");
2355 /* Qsubr = intern ("subr"); */
2356 Qcompiled_function
= intern ("compiled-function");
2357 Qbuffer
= intern ("buffer");
2358 Qframe
= intern ("frame");
2359 Qvector
= intern ("vector");
2361 staticpro (&Qinteger
);
2362 staticpro (&Qsymbol
);
2363 staticpro (&Qstring
);
2365 staticpro (&Qmarker
);
2366 staticpro (&Qoverlay
);
2367 staticpro (&Qfloat
);
2368 staticpro (&Qwindow_configuration
);
2369 staticpro (&Qprocess
);
2370 staticpro (&Qwindow
);
2371 /* staticpro (&Qsubr); */
2372 staticpro (&Qcompiled_function
);
2373 staticpro (&Qbuffer
);
2374 staticpro (&Qframe
);
2375 staticpro (&Qvector
);
2379 defsubr (&Stype_of
);
2384 defsubr (&Sintegerp
);
2385 defsubr (&Sinteger_or_marker_p
);
2386 defsubr (&Snumberp
);
2387 defsubr (&Snumber_or_marker_p
);
2388 #ifdef LISP_FLOAT_TYPE
2390 #endif /* LISP_FLOAT_TYPE */
2391 defsubr (&Snatnump
);
2392 defsubr (&Ssymbolp
);
2393 defsubr (&Sstringp
);
2394 defsubr (&Svectorp
);
2396 defsubr (&Ssequencep
);
2397 defsubr (&Sbufferp
);
2398 defsubr (&Smarkerp
);
2400 defsubr (&Sbyte_code_function_p
);
2401 defsubr (&Schar_or_string_p
);
2404 defsubr (&Scar_safe
);
2405 defsubr (&Scdr_safe
);
2408 defsubr (&Ssymbol_function
);
2409 defsubr (&Sindirect_function
);
2410 defsubr (&Ssymbol_plist
);
2411 defsubr (&Ssymbol_name
);
2412 defsubr (&Smakunbound
);
2413 defsubr (&Sfmakunbound
);
2415 defsubr (&Sfboundp
);
2417 defsubr (&Sdefalias
);
2418 defsubr (&Sdefine_function
);
2419 defsubr (&Ssetplist
);
2420 defsubr (&Ssymbol_value
);
2422 defsubr (&Sdefault_boundp
);
2423 defsubr (&Sdefault_value
);
2424 defsubr (&Sset_default
);
2425 defsubr (&Ssetq_default
);
2426 defsubr (&Smake_variable_buffer_local
);
2427 defsubr (&Smake_local_variable
);
2428 defsubr (&Skill_local_variable
);
2429 defsubr (&Slocal_variable_p
);
2432 defsubr (&Snumber_to_string
);
2433 defsubr (&Sstring_to_number
);
2434 defsubr (&Seqlsign
);
2458 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2466 /* USG systems forget handlers when they are used;
2467 must reestablish each time */
2468 signal (signo
, arith_error
);
2471 /* VMS systems are like USG. */
2472 signal (signo
, arith_error
);
2476 #else /* not BSD4_1 */
2477 sigsetmask (SIGEMPTYMASK
);
2478 #endif /* not BSD4_1 */
2480 Fsignal (Qarith_error
, Qnil
);
2485 /* Don't do this if just dumping out.
2486 We don't want to call `signal' in this case
2487 so that we don't have trouble with dumping
2488 signal-delivering routines in an inconsistent state. */
2492 #endif /* CANNOT_DUMP */
2493 signal (SIGFPE
, arith_error
);
2496 signal (SIGEMT
, arith_error
);