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 (XMISC (object
)->type
)
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 CONSCELL. 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 CONSCELL. 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 CONSCELL 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 CONSCELL 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 (XMISC (valcontents
)->type
)
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_Display_Objfwd
:
715 if (!current_perdisplay
)
717 offset
= XDISPLAY_OBJFWD (valcontents
)->offset
;
718 return *(Lisp_Object
*)(offset
+ (char *)current_perdisplay
);
723 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
724 of SYM. If SYM is buffer-local, VALCONTENTS should be the
725 buffer-independent contents of the value cell: forwarded just one
726 step past the buffer-localness. */
729 store_symval_forwarding (sym
, valcontents
, newval
)
731 register Lisp_Object valcontents
, newval
;
733 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
736 switch (XMISC (valcontents
)->type
)
738 case Lisp_Misc_Intfwd
:
739 CHECK_NUMBER (newval
, 1);
740 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
743 case Lisp_Misc_Boolfwd
:
744 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
747 case Lisp_Misc_Objfwd
:
748 *XOBJFWD (valcontents
)->objvar
= newval
;
751 case Lisp_Misc_Buffer_Objfwd
:
753 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
756 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
757 if (! NILP (type
) && ! NILP (newval
)
758 && XTYPE (newval
) != XINT (type
))
759 buffer_slot_type_mismatch (offset
);
761 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
765 case Lisp_Misc_Display_Objfwd
:
766 if (!current_perdisplay
)
768 (*(Lisp_Object
*)((char *)current_perdisplay
769 + XDISPLAY_OBJFWD (valcontents
)->offset
))
780 valcontents
= XSYMBOL (sym
)->value
;
781 if (BUFFER_LOCAL_VALUEP (valcontents
)
782 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
783 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
785 XSYMBOL (sym
)->value
= newval
;
789 /* Set up the buffer-local symbol SYM for validity in the current
790 buffer. VALCONTENTS is the contents of its value cell.
791 Return the value forwarded one step past the buffer-local indicator. */
794 swap_in_symval_forwarding (sym
, valcontents
)
795 Lisp_Object sym
, valcontents
;
797 /* valcontents is a pointer to a struct resembling the cons
798 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
800 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
801 local_var_alist, that being the element whose car is this
802 variable. Or it can be a pointer to the
803 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
804 an element in its alist for this variable.
806 If the current buffer is not BUFFER, we store the current
807 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
808 appropriate alist element for the buffer now current and set up
809 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
810 element, and store into BUFFER.
812 Note that REALVALUE can be a forwarding pointer. */
814 register Lisp_Object tem1
;
815 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
817 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
819 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
821 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
822 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
824 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
825 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
826 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
828 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
831 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
834 /* Find the value of a symbol, returning Qunbound if it's not bound.
835 This is helpful for code which just wants to get a variable's value
836 if it has one, without signalling an error.
837 Note that it must not be possible to quit
838 within this function. Great care is required for this. */
841 find_symbol_value (sym
)
844 register Lisp_Object valcontents
, tem1
;
845 register Lisp_Object val
;
846 CHECK_SYMBOL (sym
, 0);
847 valcontents
= XSYMBOL (sym
)->value
;
849 if (BUFFER_LOCAL_VALUEP (valcontents
)
850 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
851 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
853 if (MISCP (valcontents
))
855 switch (XMISC (valcontents
)->type
)
857 case Lisp_Misc_Intfwd
:
858 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
861 case Lisp_Misc_Boolfwd
:
862 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
864 case Lisp_Misc_Objfwd
:
865 return *XOBJFWD (valcontents
)->objvar
;
867 case Lisp_Misc_Buffer_Objfwd
:
868 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
869 + (char *)current_buffer
);
871 case Lisp_Misc_Display_Objfwd
:
872 if (!current_perdisplay
)
874 return *(Lisp_Object
*)(XDISPLAY_OBJFWD (valcontents
)->offset
875 + (char *)current_perdisplay
);
882 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
883 "Return SYMBOL's value. Error if that is void.")
889 val
= find_symbol_value (sym
);
890 if (EQ (val
, Qunbound
))
891 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
896 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
897 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
899 register Lisp_Object sym
, newval
;
901 int voide
= EQ (newval
, Qunbound
);
903 register Lisp_Object valcontents
, tem1
, current_alist_element
;
905 CHECK_SYMBOL (sym
, 0);
906 if (NILP (sym
) || EQ (sym
, Qt
))
907 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
908 valcontents
= XSYMBOL (sym
)->value
;
910 if (BUFFER_OBJFWDP (valcontents
))
912 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
913 register int mask
= XINT (*((Lisp_Object
*)
914 (idx
+ (char *)&buffer_local_flags
)));
916 current_buffer
->local_var_flags
|= mask
;
919 else if (BUFFER_LOCAL_VALUEP (valcontents
)
920 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
922 /* valcontents is actually a pointer to a struct resembling a cons,
923 with contents something like:
924 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
926 BUFFER is the last buffer for which this symbol's value was
929 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
930 local_var_alist, that being the element whose car is this
931 variable. Or it can be a pointer to the
932 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
933 have an element in its alist for this variable (that is, if
934 BUFFER sees the default value of this variable).
936 If we want to examine or set the value and BUFFER is current,
937 we just examine or set REALVALUE. If BUFFER is not current, we
938 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
939 then find the appropriate alist element for the buffer now
940 current and set up CURRENT-ALIST-ELEMENT. Then we set
941 REALVALUE out of that element, and store into BUFFER.
943 If we are setting the variable and the current buffer does
944 not have an alist entry for this variable, an alist entry is
947 Note that REALVALUE can be a forwarding pointer. Each time
948 it is examined or set, forwarding must be done. */
950 /* What value are we caching right now? */
951 current_alist_element
=
952 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
954 /* If the current buffer is not the buffer whose binding is
955 currently cached, or if it's a Lisp_Buffer_Local_Value and
956 we're looking at the default value, the cache is invalid; we
957 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
959 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
960 || (BUFFER_LOCAL_VALUEP (valcontents
)
961 && EQ (XCONS (current_alist_element
)->car
,
962 current_alist_element
)))
964 /* Write out the cached value for the old buffer; copy it
965 back to its alist element. This works if the current
966 buffer only sees the default value, too. */
967 Fsetcdr (current_alist_element
,
968 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
970 /* Find the new value for CURRENT-ALIST-ELEMENT. */
971 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
974 /* This buffer still sees the default value. */
976 /* If the variable is a Lisp_Some_Buffer_Local_Value,
977 make CURRENT-ALIST-ELEMENT point to itself,
978 indicating that we're seeing the default value. */
979 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
980 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
982 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
983 new assoc for a local value and set
984 CURRENT-ALIST-ELEMENT to point to that. */
987 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
988 current_buffer
->local_var_alist
=
989 Fcons (tem1
, current_buffer
->local_var_alist
);
992 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
993 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
996 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
997 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
1000 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1003 /* If storing void (making the symbol void), forward only through
1004 buffer-local indicator, not through Lisp_Objfwd, etc. */
1006 store_symval_forwarding (sym
, Qnil
, newval
);
1008 store_symval_forwarding (sym
, valcontents
, newval
);
1013 /* Access or set a buffer-local symbol's default value. */
1015 /* Return the default value of SYM, but don't check for voidness.
1016 Return Qunbound if it is void. */
1022 register Lisp_Object valcontents
;
1024 CHECK_SYMBOL (sym
, 0);
1025 valcontents
= XSYMBOL (sym
)->value
;
1027 /* For a built-in buffer-local variable, get the default value
1028 rather than letting do_symval_forwarding get the current value. */
1029 if (BUFFER_OBJFWDP (valcontents
))
1031 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1033 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1034 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1037 /* Handle user-created local variables. */
1038 if (BUFFER_LOCAL_VALUEP (valcontents
)
1039 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1041 /* If var is set up for a buffer that lacks a local value for it,
1042 the current value is nominally the default value.
1043 But the current value slot may be more up to date, since
1044 ordinary setq stores just that slot. So use that. */
1045 Lisp_Object current_alist_element
, alist_element_car
;
1046 current_alist_element
1047 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1048 alist_element_car
= XCONS (current_alist_element
)->car
;
1049 if (EQ (alist_element_car
, current_alist_element
))
1050 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1052 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1054 /* For other variables, get the current value. */
1055 return do_symval_forwarding (valcontents
);
1058 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1059 "Return T if SYMBOL has a non-void default value.\n\
1060 This is the value that is seen in buffers that do not have their own values\n\
1061 for this variable.")
1065 register Lisp_Object value
;
1067 value
= default_value (sym
);
1068 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1071 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1072 "Return SYMBOL's default value.\n\
1073 This is the value that is seen in buffers that do not have their own values\n\
1074 for this variable. The default value is meaningful for variables with\n\
1075 local bindings in certain buffers.")
1079 register Lisp_Object value
;
1081 value
= default_value (sym
);
1082 if (EQ (value
, Qunbound
))
1083 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1087 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1088 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1089 The default value is seen in buffers that do not have their own values\n\
1090 for this variable.")
1092 Lisp_Object sym
, value
;
1094 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1096 CHECK_SYMBOL (sym
, 0);
1097 valcontents
= XSYMBOL (sym
)->value
;
1099 /* Handle variables like case-fold-search that have special slots
1100 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1102 if (BUFFER_OBJFWDP (valcontents
))
1104 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1105 register struct buffer
*b
;
1106 register int mask
= XINT (*((Lisp_Object
*)
1107 (idx
+ (char *)&buffer_local_flags
)));
1111 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1112 for (b
= all_buffers
; b
; b
= b
->next
)
1113 if (!(b
->local_var_flags
& mask
))
1114 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1119 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1120 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1121 return Fset (sym
, value
);
1123 /* Store new value into the DEFAULT-VALUE slot */
1124 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1126 /* If that slot is current, we must set the REALVALUE slot too */
1127 current_alist_element
1128 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1129 alist_element_buffer
= Fcar (current_alist_element
);
1130 if (EQ (alist_element_buffer
, current_alist_element
))
1131 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1137 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1138 "Set the default value of variable VAR to VALUE.\n\
1139 VAR, the variable name, is literal (not evaluated);\n\
1140 VALUE is an expression and it is evaluated.\n\
1141 The default value of a variable is seen in buffers\n\
1142 that do not have their own values for the variable.\n\
1144 More generally, you can use multiple variables and values, as in\n\
1145 (setq-default SYM VALUE SYM VALUE...)\n\
1146 This sets each SYM's default value to the corresponding VALUE.\n\
1147 The VALUE for the Nth SYM can refer to the new default values\n\
1152 register Lisp_Object args_left
;
1153 register Lisp_Object val
, sym
;
1154 struct gcpro gcpro1
;
1164 val
= Feval (Fcar (Fcdr (args_left
)));
1165 sym
= Fcar (args_left
);
1166 Fset_default (sym
, val
);
1167 args_left
= Fcdr (Fcdr (args_left
));
1169 while (!NILP (args_left
));
1175 /* Lisp functions for creating and removing buffer-local variables. */
1177 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1178 1, 1, "vMake Variable Buffer Local: ",
1179 "Make VARIABLE have a separate value for each buffer.\n\
1180 At any time, the value for the current buffer is in effect.\n\
1181 There is also a default value which is seen in any buffer which has not yet\n\
1182 set its own value.\n\
1183 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1184 for the current buffer if it was previously using the default value.\n\
1185 The function `default-value' gets the default value and `set-default' sets it.")
1187 register Lisp_Object sym
;
1189 register Lisp_Object tem
, valcontents
, newval
;
1191 CHECK_SYMBOL (sym
, 0);
1193 valcontents
= XSYMBOL (sym
)->value
;
1194 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || DISPLAY_OBJFWDP (valcontents
))
1195 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1197 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1199 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1201 XMISC (XSYMBOL (sym
)->value
)->type
= Lisp_Misc_Buffer_Local_Value
;
1204 if (EQ (valcontents
, Qunbound
))
1205 XSYMBOL (sym
)->value
= Qnil
;
1206 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1207 XCONS (tem
)->car
= tem
;
1208 newval
= allocate_misc ();
1209 XMISC (newval
)->type
= Lisp_Misc_Buffer_Local_Value
;
1210 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1211 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1212 XSYMBOL (sym
)->value
= newval
;
1216 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1217 1, 1, "vMake Local Variable: ",
1218 "Make VARIABLE have a separate value in the current buffer.\n\
1219 Other buffers will continue to share a common default value.\n\
1220 \(The buffer-local value of VARIABLE starts out as the same value\n\
1221 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1222 See also `make-variable-buffer-local'.\n\n\
1223 If the variable is already arranged to become local when set,\n\
1224 this function causes a local value to exist for this buffer,\n\
1225 just as setting the variable would do.\n\
1227 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1228 Use `make-local-hook' instead.")
1230 register Lisp_Object sym
;
1232 register Lisp_Object tem
, valcontents
;
1234 CHECK_SYMBOL (sym
, 0);
1236 valcontents
= XSYMBOL (sym
)->value
;
1237 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || DISPLAY_OBJFWDP (valcontents
))
1238 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1240 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1242 tem
= Fboundp (sym
);
1244 /* Make sure the symbol has a local value in this particular buffer,
1245 by setting it to the same value it already has. */
1246 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1249 /* Make sure sym is set up to hold per-buffer values */
1250 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1253 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1254 XCONS (tem
)->car
= tem
;
1255 newval
= allocate_misc ();
1256 XMISC (newval
)->type
= Lisp_Misc_Some_Buffer_Local_Value
;
1257 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1258 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1259 XSYMBOL (sym
)->value
= newval
;
1261 /* Make sure this buffer has its own value of sym */
1262 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1265 current_buffer
->local_var_alist
1266 = Fcons (Fcons (sym
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1267 current_buffer
->local_var_alist
);
1269 /* Make sure symbol does not think it is set up for this buffer;
1270 force it to look once again for this buffer's value */
1272 Lisp_Object
*pvalbuf
;
1273 valcontents
= XSYMBOL (sym
)->value
;
1274 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1275 if (current_buffer
== XBUFFER (*pvalbuf
))
1280 /* If the symbol forwards into a C variable, then swap in the
1281 variable for this buffer immediately. If C code modifies the
1282 variable before we swap in, then that new value will clobber the
1283 default value the next time we swap. */
1284 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->car
;
1285 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1286 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1291 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1292 1, 1, "vKill Local Variable: ",
1293 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1294 From now on the default value will apply in this buffer.")
1296 register Lisp_Object sym
;
1298 register Lisp_Object tem
, valcontents
;
1300 CHECK_SYMBOL (sym
, 0);
1302 valcontents
= XSYMBOL (sym
)->value
;
1304 if (BUFFER_OBJFWDP (valcontents
))
1306 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1307 register int mask
= XINT (*((Lisp_Object
*)
1308 (idx
+ (char *)&buffer_local_flags
)));
1312 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1313 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1314 current_buffer
->local_var_flags
&= ~mask
;
1319 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1320 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1323 /* Get rid of this buffer's alist element, if any */
1325 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1327 current_buffer
->local_var_alist
1328 = Fdelq (tem
, current_buffer
->local_var_alist
);
1330 /* Make sure symbol does not think it is set up for this buffer;
1331 force it to look once again for this buffer's value */
1333 Lisp_Object
*pvalbuf
;
1334 valcontents
= XSYMBOL (sym
)->value
;
1335 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1336 if (current_buffer
== XBUFFER (*pvalbuf
))
1343 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1345 "Non-nil if VARIABLE has a local binding in the current buffer.")
1347 register Lisp_Object sym
;
1349 Lisp_Object valcontents
;
1351 CHECK_SYMBOL (sym
, 0);
1353 valcontents
= XSYMBOL (sym
)->value
;
1354 return ((BUFFER_LOCAL_VALUEP (valcontents
)
1355 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1356 || BUFFER_OBJFWDP (valcontents
))
1360 /* Find the function at the end of a chain of symbol function indirections. */
1362 /* If OBJECT is a symbol, find the end of its function chain and
1363 return the value found there. If OBJECT is not a symbol, just
1364 return it. If there is a cycle in the function chain, signal a
1365 cyclic-function-indirection error.
1367 This is like Findirect_function, except that it doesn't signal an
1368 error if the chain ends up unbound. */
1370 indirect_function (object
)
1371 register Lisp_Object object
;
1373 Lisp_Object tortoise
, hare
;
1375 hare
= tortoise
= object
;
1379 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1381 hare
= XSYMBOL (hare
)->function
;
1382 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1384 hare
= XSYMBOL (hare
)->function
;
1386 tortoise
= XSYMBOL (tortoise
)->function
;
1388 if (EQ (hare
, tortoise
))
1389 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1395 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1396 "Return the function at the end of OBJECT's function chain.\n\
1397 If OBJECT is a symbol, follow all function indirections and return the final\n\
1398 function binding.\n\
1399 If OBJECT is not a symbol, just return it.\n\
1400 Signal a void-function error if the final symbol is unbound.\n\
1401 Signal a cyclic-function-indirection error if there is a loop in the\n\
1402 function chain of symbols.")
1404 register Lisp_Object object
;
1408 result
= indirect_function (object
);
1410 if (EQ (result
, Qunbound
))
1411 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1415 /* Extract and set vector and string elements */
1417 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1418 "Return the element of ARRAY at index INDEX.\n\
1419 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1421 register Lisp_Object array
;
1424 register int idxval
;
1426 CHECK_NUMBER (idx
, 1);
1427 idxval
= XINT (idx
);
1428 if (STRINGP (array
))
1431 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1432 args_out_of_range (array
, idx
);
1433 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1439 if (VECTORP (array
))
1440 size
= XVECTOR (array
)->size
;
1441 else if (COMPILEDP (array
))
1442 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1444 wrong_type_argument (Qarrayp
, array
);
1446 if (idxval
< 0 || idxval
>= size
)
1447 args_out_of_range (array
, idx
);
1448 return XVECTOR (array
)->contents
[idxval
];
1452 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1453 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1454 ARRAY may be a vector or a string. IDX starts at 0.")
1455 (array
, idx
, newelt
)
1456 register Lisp_Object array
;
1457 Lisp_Object idx
, newelt
;
1459 register int idxval
;
1461 CHECK_NUMBER (idx
, 1);
1462 idxval
= XINT (idx
);
1463 if (!VECTORP (array
) && !STRINGP (array
))
1464 array
= wrong_type_argument (Qarrayp
, array
);
1465 CHECK_IMPURE (array
);
1467 if (VECTORP (array
))
1469 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1470 args_out_of_range (array
, idx
);
1471 XVECTOR (array
)->contents
[idxval
] = newelt
;
1475 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1476 args_out_of_range (array
, idx
);
1477 CHECK_NUMBER (newelt
, 2);
1478 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1484 /* Arithmetic functions */
1486 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1489 arithcompare (num1
, num2
, comparison
)
1490 Lisp_Object num1
, num2
;
1491 enum comparison comparison
;
1496 #ifdef LISP_FLOAT_TYPE
1497 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1498 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1500 if (FLOATP (num1
) || FLOATP (num2
))
1503 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1504 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1507 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1508 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1509 #endif /* LISP_FLOAT_TYPE */
1514 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1519 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1524 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1529 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1534 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1539 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1548 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1549 "T if two args, both numbers or markers, are equal.")
1551 register Lisp_Object num1
, num2
;
1553 return arithcompare (num1
, num2
, equal
);
1556 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1557 "T if first arg is less than second arg. Both must be numbers or markers.")
1559 register Lisp_Object num1
, num2
;
1561 return arithcompare (num1
, num2
, less
);
1564 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1565 "T if first arg is greater than second arg. Both must be numbers or markers.")
1567 register Lisp_Object num1
, num2
;
1569 return arithcompare (num1
, num2
, grtr
);
1572 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1573 "T if first arg is less than or equal to second arg.\n\
1574 Both must be numbers or markers.")
1576 register Lisp_Object num1
, num2
;
1578 return arithcompare (num1
, num2
, less_or_equal
);
1581 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1582 "T if first arg is greater than or equal to second arg.\n\
1583 Both must be numbers or markers.")
1585 register Lisp_Object num1
, num2
;
1587 return arithcompare (num1
, num2
, grtr_or_equal
);
1590 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1591 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1593 register Lisp_Object num1
, num2
;
1595 return arithcompare (num1
, num2
, notequal
);
1598 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1600 register Lisp_Object num
;
1602 #ifdef LISP_FLOAT_TYPE
1603 CHECK_NUMBER_OR_FLOAT (num
, 0);
1607 if (XFLOAT(num
)->data
== 0.0)
1612 CHECK_NUMBER (num
, 0);
1613 #endif /* LISP_FLOAT_TYPE */
1620 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1626 unsigned int top
= i
>> 16;
1627 unsigned int bot
= i
& 0xFFFF;
1629 return make_number (bot
);
1631 return Fcons (make_number (-1), make_number (bot
));
1632 return Fcons (make_number (top
), make_number (bot
));
1639 Lisp_Object top
, bot
;
1642 top
= XCONS (c
)->car
;
1643 bot
= XCONS (c
)->cdr
;
1645 bot
= XCONS (bot
)->car
;
1646 return ((XINT (top
) << 16) | XINT (bot
));
1649 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1650 "Convert NUM to a string by printing it in decimal.\n\
1651 Uses a minus sign if negative.\n\
1652 NUM may be an integer or a floating point number.")
1658 #ifndef LISP_FLOAT_TYPE
1659 CHECK_NUMBER (num
, 0);
1661 CHECK_NUMBER_OR_FLOAT (num
, 0);
1665 char pigbuf
[350]; /* see comments in float_to_string */
1667 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1668 return build_string (pigbuf
);
1670 #endif /* LISP_FLOAT_TYPE */
1672 sprintf (buffer
, "%d", XINT (num
));
1673 return build_string (buffer
);
1676 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1677 "Convert STRING to a number by parsing it as a decimal number.\n\
1678 This parses both integers and floating point numbers.\n\
1679 It ignores leading spaces and tabs.")
1681 register Lisp_Object str
;
1685 CHECK_STRING (str
, 0);
1687 p
= XSTRING (str
)->data
;
1689 /* Skip any whitespace at the front of the number. Some versions of
1690 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1691 while (*p
== ' ' || *p
== '\t')
1694 #ifdef LISP_FLOAT_TYPE
1695 if (isfloat_string (p
))
1696 return make_float (atof (p
));
1697 #endif /* LISP_FLOAT_TYPE */
1699 return make_number (atoi (p
));
1703 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1705 extern Lisp_Object
float_arith_driver ();
1708 arith_driver (code
, nargs
, args
)
1711 register Lisp_Object
*args
;
1713 register Lisp_Object val
;
1714 register int argnum
;
1718 switch (SWITCH_ENUM_CAST (code
))
1731 for (argnum
= 0; argnum
< nargs
; argnum
++)
1733 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1734 #ifdef LISP_FLOAT_TYPE
1735 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1737 if (FLOATP (val
)) /* time to do serious math */
1738 return (float_arith_driver ((double) accum
, argnum
, code
,
1741 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1742 #endif /* LISP_FLOAT_TYPE */
1743 args
[argnum
] = val
; /* runs into a compiler bug. */
1744 next
= XINT (args
[argnum
]);
1745 switch (SWITCH_ENUM_CAST (code
))
1747 case Aadd
: accum
+= next
; break;
1749 if (!argnum
&& nargs
!= 1)
1753 case Amult
: accum
*= next
; break;
1755 if (!argnum
) accum
= next
;
1759 Fsignal (Qarith_error
, Qnil
);
1763 case Alogand
: accum
&= next
; break;
1764 case Alogior
: accum
|= next
; break;
1765 case Alogxor
: accum
^= next
; break;
1766 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1767 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1771 XSETINT (val
, accum
);
1775 #ifdef LISP_FLOAT_TYPE
1778 #define isnan(x) ((x) != (x))
1781 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1783 register int argnum
;
1786 register Lisp_Object
*args
;
1788 register Lisp_Object val
;
1791 for (; argnum
< nargs
; argnum
++)
1793 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1794 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1798 next
= XFLOAT (val
)->data
;
1802 args
[argnum
] = val
; /* runs into a compiler bug. */
1803 next
= XINT (args
[argnum
]);
1805 switch (SWITCH_ENUM_CAST (code
))
1811 if (!argnum
&& nargs
!= 1)
1824 Fsignal (Qarith_error
, Qnil
);
1831 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1833 if (!argnum
|| isnan (next
) || next
> accum
)
1837 if (!argnum
|| isnan (next
) || next
< accum
)
1843 return make_float (accum
);
1845 #endif /* LISP_FLOAT_TYPE */
1847 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1848 "Return sum of any number of arguments, which are numbers or markers.")
1853 return arith_driver (Aadd
, nargs
, args
);
1856 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1857 "Negate number or subtract numbers or markers.\n\
1858 With one arg, negates it. With more than one arg,\n\
1859 subtracts all but the first from the first.")
1864 return arith_driver (Asub
, nargs
, args
);
1867 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1868 "Returns product of any number of arguments, which are numbers or markers.")
1873 return arith_driver (Amult
, nargs
, args
);
1876 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1877 "Returns first argument divided by all the remaining arguments.\n\
1878 The arguments must be numbers or markers.")
1883 return arith_driver (Adiv
, nargs
, args
);
1886 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1887 "Returns remainder of first arg divided by second.\n\
1888 Both must be integers or markers.")
1890 register Lisp_Object num1
, num2
;
1894 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1895 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1897 if (XFASTINT (num2
) == 0)
1898 Fsignal (Qarith_error
, Qnil
);
1900 XSETINT (val
, XINT (num1
) % XINT (num2
));
1909 #ifdef HAVE_DREM /* Some systems use this non-standard name. */
1910 return (drem (f1
, f2
));
1911 #else /* Other systems don't seem to have it at all. */
1912 return (f1
- f2
* floor (f1
/f2
));
1915 #endif /* ! HAVE_FMOD */
1917 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1918 "Returns X modulo Y.\n\
1919 The result falls between zero (inclusive) and Y (exclusive).\n\
1920 Both X and Y must be numbers or markers.")
1922 register Lisp_Object num1
, num2
;
1927 #ifdef LISP_FLOAT_TYPE
1928 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1929 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
1931 if (FLOATP (num1
) || FLOATP (num2
))
1935 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
1936 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
1938 Fsignal (Qarith_error
, Qnil
);
1941 /* If the "remainder" comes out with the wrong sign, fix it. */
1942 if ((f1
< 0) != (f2
< 0))
1944 return (make_float (f1
));
1946 #else /* not LISP_FLOAT_TYPE */
1947 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1948 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1949 #endif /* not LISP_FLOAT_TYPE */
1955 Fsignal (Qarith_error
, Qnil
);
1959 /* If the "remainder" comes out with the wrong sign, fix it. */
1960 if ((i1
< 0) != (i2
< 0))
1967 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1968 "Return largest of all the arguments (which must be numbers or markers).\n\
1969 The value is always a number; markers are converted to numbers.")
1974 return arith_driver (Amax
, nargs
, args
);
1977 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1978 "Return smallest of all the arguments (which must be numbers or markers).\n\
1979 The value is always a number; markers are converted to numbers.")
1984 return arith_driver (Amin
, nargs
, args
);
1987 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1988 "Return bitwise-and of all the arguments.\n\
1989 Arguments may be integers, or markers converted to integers.")
1994 return arith_driver (Alogand
, nargs
, args
);
1997 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1998 "Return bitwise-or of all the arguments.\n\
1999 Arguments may be integers, or markers converted to integers.")
2004 return arith_driver (Alogior
, nargs
, args
);
2007 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2008 "Return bitwise-exclusive-or of all the arguments.\n\
2009 Arguments may be integers, or markers converted to integers.")
2014 return arith_driver (Alogxor
, nargs
, args
);
2017 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2018 "Return VALUE with its bits shifted left by COUNT.\n\
2019 If COUNT is negative, shifting is actually to the right.\n\
2020 In this case, the sign bit is duplicated.")
2022 register Lisp_Object num1
, num2
;
2024 register Lisp_Object val
;
2026 CHECK_NUMBER (num1
, 0);
2027 CHECK_NUMBER (num2
, 1);
2029 if (XINT (num2
) > 0)
2030 XSETINT (val
, XINT (num1
) << XFASTINT (num2
));
2032 XSETINT (val
, XINT (num1
) >> -XINT (num2
));
2036 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2037 "Return VALUE with its bits shifted left by COUNT.\n\
2038 If COUNT is negative, shifting is actually to the right.\n\
2039 In this case, zeros are shifted in on the left.")
2041 register Lisp_Object num1
, num2
;
2043 register Lisp_Object val
;
2045 CHECK_NUMBER (num1
, 0);
2046 CHECK_NUMBER (num2
, 1);
2048 if (XINT (num2
) > 0)
2049 XSETINT (val
, (EMACS_UINT
) XUINT (num1
) << XFASTINT (num2
));
2051 XSETINT (val
, (EMACS_UINT
) XUINT (num1
) >> -XINT (num2
));
2055 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2056 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2057 Markers are converted to integers.")
2059 register Lisp_Object num
;
2061 #ifdef LISP_FLOAT_TYPE
2062 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2065 return (make_float (1.0 + XFLOAT (num
)->data
));
2067 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2068 #endif /* LISP_FLOAT_TYPE */
2070 XSETINT (num
, XINT (num
) + 1);
2074 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2075 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2076 Markers are converted to integers.")
2078 register Lisp_Object num
;
2080 #ifdef LISP_FLOAT_TYPE
2081 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2084 return (make_float (-1.0 + XFLOAT (num
)->data
));
2086 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2087 #endif /* LISP_FLOAT_TYPE */
2089 XSETINT (num
, XINT (num
) - 1);
2093 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2094 "Return the bitwise complement of ARG. ARG must be an integer.")
2096 register Lisp_Object num
;
2098 CHECK_NUMBER (num
, 0);
2099 XSETINT (num
, ~XINT (num
));
2106 Lisp_Object error_tail
, arith_tail
;
2108 Qquote
= intern ("quote");
2109 Qlambda
= intern ("lambda");
2110 Qsubr
= intern ("subr");
2111 Qerror_conditions
= intern ("error-conditions");
2112 Qerror_message
= intern ("error-message");
2113 Qtop_level
= intern ("top-level");
2115 Qerror
= intern ("error");
2116 Qquit
= intern ("quit");
2117 Qwrong_type_argument
= intern ("wrong-type-argument");
2118 Qargs_out_of_range
= intern ("args-out-of-range");
2119 Qvoid_function
= intern ("void-function");
2120 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2121 Qvoid_variable
= intern ("void-variable");
2122 Qsetting_constant
= intern ("setting-constant");
2123 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2125 Qinvalid_function
= intern ("invalid-function");
2126 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2127 Qno_catch
= intern ("no-catch");
2128 Qend_of_file
= intern ("end-of-file");
2129 Qarith_error
= intern ("arith-error");
2130 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2131 Qend_of_buffer
= intern ("end-of-buffer");
2132 Qbuffer_read_only
= intern ("buffer-read-only");
2133 Qmark_inactive
= intern ("mark-inactive");
2135 Qlistp
= intern ("listp");
2136 Qconsp
= intern ("consp");
2137 Qsymbolp
= intern ("symbolp");
2138 Qintegerp
= intern ("integerp");
2139 Qnatnump
= intern ("natnump");
2140 Qwholenump
= intern ("wholenump");
2141 Qstringp
= intern ("stringp");
2142 Qarrayp
= intern ("arrayp");
2143 Qsequencep
= intern ("sequencep");
2144 Qbufferp
= intern ("bufferp");
2145 Qvectorp
= intern ("vectorp");
2146 Qchar_or_string_p
= intern ("char-or-string-p");
2147 Qmarkerp
= intern ("markerp");
2148 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2149 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2150 Qboundp
= intern ("boundp");
2151 Qfboundp
= intern ("fboundp");
2153 #ifdef LISP_FLOAT_TYPE
2154 Qfloatp
= intern ("floatp");
2155 Qnumberp
= intern ("numberp");
2156 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2157 #endif /* LISP_FLOAT_TYPE */
2159 Qcdr
= intern ("cdr");
2161 /* Handle automatic advice activation */
2162 Qad_advice_info
= intern ("ad-advice-info");
2163 Qad_activate
= intern ("ad-activate");
2165 error_tail
= Fcons (Qerror
, Qnil
);
2167 /* ERROR is used as a signaler for random errors for which nothing else is right */
2169 Fput (Qerror
, Qerror_conditions
,
2171 Fput (Qerror
, Qerror_message
,
2172 build_string ("error"));
2174 Fput (Qquit
, Qerror_conditions
,
2175 Fcons (Qquit
, Qnil
));
2176 Fput (Qquit
, Qerror_message
,
2177 build_string ("Quit"));
2179 Fput (Qwrong_type_argument
, Qerror_conditions
,
2180 Fcons (Qwrong_type_argument
, error_tail
));
2181 Fput (Qwrong_type_argument
, Qerror_message
,
2182 build_string ("Wrong type argument"));
2184 Fput (Qargs_out_of_range
, Qerror_conditions
,
2185 Fcons (Qargs_out_of_range
, error_tail
));
2186 Fput (Qargs_out_of_range
, Qerror_message
,
2187 build_string ("Args out of range"));
2189 Fput (Qvoid_function
, Qerror_conditions
,
2190 Fcons (Qvoid_function
, error_tail
));
2191 Fput (Qvoid_function
, Qerror_message
,
2192 build_string ("Symbol's function definition is void"));
2194 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2195 Fcons (Qcyclic_function_indirection
, error_tail
));
2196 Fput (Qcyclic_function_indirection
, Qerror_message
,
2197 build_string ("Symbol's chain of function indirections contains a loop"));
2199 Fput (Qvoid_variable
, Qerror_conditions
,
2200 Fcons (Qvoid_variable
, error_tail
));
2201 Fput (Qvoid_variable
, Qerror_message
,
2202 build_string ("Symbol's value as variable is void"));
2204 Fput (Qsetting_constant
, Qerror_conditions
,
2205 Fcons (Qsetting_constant
, error_tail
));
2206 Fput (Qsetting_constant
, Qerror_message
,
2207 build_string ("Attempt to set a constant symbol"));
2209 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2210 Fcons (Qinvalid_read_syntax
, error_tail
));
2211 Fput (Qinvalid_read_syntax
, Qerror_message
,
2212 build_string ("Invalid read syntax"));
2214 Fput (Qinvalid_function
, Qerror_conditions
,
2215 Fcons (Qinvalid_function
, error_tail
));
2216 Fput (Qinvalid_function
, Qerror_message
,
2217 build_string ("Invalid function"));
2219 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2220 Fcons (Qwrong_number_of_arguments
, error_tail
));
2221 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2222 build_string ("Wrong number of arguments"));
2224 Fput (Qno_catch
, Qerror_conditions
,
2225 Fcons (Qno_catch
, error_tail
));
2226 Fput (Qno_catch
, Qerror_message
,
2227 build_string ("No catch for tag"));
2229 Fput (Qend_of_file
, Qerror_conditions
,
2230 Fcons (Qend_of_file
, error_tail
));
2231 Fput (Qend_of_file
, Qerror_message
,
2232 build_string ("End of file during parsing"));
2234 arith_tail
= Fcons (Qarith_error
, error_tail
);
2235 Fput (Qarith_error
, Qerror_conditions
,
2237 Fput (Qarith_error
, Qerror_message
,
2238 build_string ("Arithmetic error"));
2240 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2241 Fcons (Qbeginning_of_buffer
, error_tail
));
2242 Fput (Qbeginning_of_buffer
, Qerror_message
,
2243 build_string ("Beginning of buffer"));
2245 Fput (Qend_of_buffer
, Qerror_conditions
,
2246 Fcons (Qend_of_buffer
, error_tail
));
2247 Fput (Qend_of_buffer
, Qerror_message
,
2248 build_string ("End of buffer"));
2250 Fput (Qbuffer_read_only
, Qerror_conditions
,
2251 Fcons (Qbuffer_read_only
, error_tail
));
2252 Fput (Qbuffer_read_only
, Qerror_message
,
2253 build_string ("Buffer is read-only"));
2255 #ifdef LISP_FLOAT_TYPE
2256 Qrange_error
= intern ("range-error");
2257 Qdomain_error
= intern ("domain-error");
2258 Qsingularity_error
= intern ("singularity-error");
2259 Qoverflow_error
= intern ("overflow-error");
2260 Qunderflow_error
= intern ("underflow-error");
2262 Fput (Qdomain_error
, Qerror_conditions
,
2263 Fcons (Qdomain_error
, arith_tail
));
2264 Fput (Qdomain_error
, Qerror_message
,
2265 build_string ("Arithmetic domain error"));
2267 Fput (Qrange_error
, Qerror_conditions
,
2268 Fcons (Qrange_error
, arith_tail
));
2269 Fput (Qrange_error
, Qerror_message
,
2270 build_string ("Arithmetic range error"));
2272 Fput (Qsingularity_error
, Qerror_conditions
,
2273 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2274 Fput (Qsingularity_error
, Qerror_message
,
2275 build_string ("Arithmetic singularity error"));
2277 Fput (Qoverflow_error
, Qerror_conditions
,
2278 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2279 Fput (Qoverflow_error
, Qerror_message
,
2280 build_string ("Arithmetic overflow error"));
2282 Fput (Qunderflow_error
, Qerror_conditions
,
2283 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2284 Fput (Qunderflow_error
, Qerror_message
,
2285 build_string ("Arithmetic underflow error"));
2287 staticpro (&Qrange_error
);
2288 staticpro (&Qdomain_error
);
2289 staticpro (&Qsingularity_error
);
2290 staticpro (&Qoverflow_error
);
2291 staticpro (&Qunderflow_error
);
2292 #endif /* LISP_FLOAT_TYPE */
2296 staticpro (&Qquote
);
2297 staticpro (&Qlambda
);
2299 staticpro (&Qunbound
);
2300 staticpro (&Qerror_conditions
);
2301 staticpro (&Qerror_message
);
2302 staticpro (&Qtop_level
);
2304 staticpro (&Qerror
);
2306 staticpro (&Qwrong_type_argument
);
2307 staticpro (&Qargs_out_of_range
);
2308 staticpro (&Qvoid_function
);
2309 staticpro (&Qcyclic_function_indirection
);
2310 staticpro (&Qvoid_variable
);
2311 staticpro (&Qsetting_constant
);
2312 staticpro (&Qinvalid_read_syntax
);
2313 staticpro (&Qwrong_number_of_arguments
);
2314 staticpro (&Qinvalid_function
);
2315 staticpro (&Qno_catch
);
2316 staticpro (&Qend_of_file
);
2317 staticpro (&Qarith_error
);
2318 staticpro (&Qbeginning_of_buffer
);
2319 staticpro (&Qend_of_buffer
);
2320 staticpro (&Qbuffer_read_only
);
2321 staticpro (&Qmark_inactive
);
2323 staticpro (&Qlistp
);
2324 staticpro (&Qconsp
);
2325 staticpro (&Qsymbolp
);
2326 staticpro (&Qintegerp
);
2327 staticpro (&Qnatnump
);
2328 staticpro (&Qwholenump
);
2329 staticpro (&Qstringp
);
2330 staticpro (&Qarrayp
);
2331 staticpro (&Qsequencep
);
2332 staticpro (&Qbufferp
);
2333 staticpro (&Qvectorp
);
2334 staticpro (&Qchar_or_string_p
);
2335 staticpro (&Qmarkerp
);
2336 staticpro (&Qbuffer_or_string_p
);
2337 staticpro (&Qinteger_or_marker_p
);
2338 #ifdef LISP_FLOAT_TYPE
2339 staticpro (&Qfloatp
);
2340 staticpro (&Qnumberp
);
2341 staticpro (&Qnumber_or_marker_p
);
2342 #endif /* LISP_FLOAT_TYPE */
2344 staticpro (&Qboundp
);
2345 staticpro (&Qfboundp
);
2347 staticpro (&Qad_advice_info
);
2348 staticpro (&Qad_activate
);
2350 /* Types that type-of returns. */
2351 Qinteger
= intern ("integer");
2352 Qsymbol
= intern ("symbol");
2353 Qstring
= intern ("string");
2354 Qcons
= intern ("cons");
2355 Qmarker
= intern ("marker");
2356 Qoverlay
= intern ("overlay");
2357 Qfloat
= intern ("float");
2358 Qwindow_configuration
= intern ("window-configuration");
2359 Qprocess
= intern ("process");
2360 Qwindow
= intern ("window");
2361 /* Qsubr = intern ("subr"); */
2362 Qcompiled_function
= intern ("compiled-function");
2363 Qbuffer
= intern ("buffer");
2364 Qframe
= intern ("frame");
2365 Qvector
= intern ("vector");
2367 staticpro (&Qinteger
);
2368 staticpro (&Qsymbol
);
2369 staticpro (&Qstring
);
2371 staticpro (&Qmarker
);
2372 staticpro (&Qoverlay
);
2373 staticpro (&Qfloat
);
2374 staticpro (&Qwindow_configuration
);
2375 staticpro (&Qprocess
);
2376 staticpro (&Qwindow
);
2377 /* staticpro (&Qsubr); */
2378 staticpro (&Qcompiled_function
);
2379 staticpro (&Qbuffer
);
2380 staticpro (&Qframe
);
2381 staticpro (&Qvector
);
2385 defsubr (&Stype_of
);
2390 defsubr (&Sintegerp
);
2391 defsubr (&Sinteger_or_marker_p
);
2392 defsubr (&Snumberp
);
2393 defsubr (&Snumber_or_marker_p
);
2394 #ifdef LISP_FLOAT_TYPE
2396 #endif /* LISP_FLOAT_TYPE */
2397 defsubr (&Snatnump
);
2398 defsubr (&Ssymbolp
);
2399 defsubr (&Sstringp
);
2400 defsubr (&Svectorp
);
2402 defsubr (&Ssequencep
);
2403 defsubr (&Sbufferp
);
2404 defsubr (&Smarkerp
);
2406 defsubr (&Sbyte_code_function_p
);
2407 defsubr (&Schar_or_string_p
);
2410 defsubr (&Scar_safe
);
2411 defsubr (&Scdr_safe
);
2414 defsubr (&Ssymbol_function
);
2415 defsubr (&Sindirect_function
);
2416 defsubr (&Ssymbol_plist
);
2417 defsubr (&Ssymbol_name
);
2418 defsubr (&Smakunbound
);
2419 defsubr (&Sfmakunbound
);
2421 defsubr (&Sfboundp
);
2423 defsubr (&Sdefalias
);
2424 defsubr (&Sdefine_function
);
2425 defsubr (&Ssetplist
);
2426 defsubr (&Ssymbol_value
);
2428 defsubr (&Sdefault_boundp
);
2429 defsubr (&Sdefault_value
);
2430 defsubr (&Sset_default
);
2431 defsubr (&Ssetq_default
);
2432 defsubr (&Smake_variable_buffer_local
);
2433 defsubr (&Smake_local_variable
);
2434 defsubr (&Skill_local_variable
);
2435 defsubr (&Slocal_variable_p
);
2438 defsubr (&Snumber_to_string
);
2439 defsubr (&Sstring_to_number
);
2440 defsubr (&Seqlsign
);
2464 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2472 /* USG systems forget handlers when they are used;
2473 must reestablish each time */
2474 signal (signo
, arith_error
);
2477 /* VMS systems are like USG. */
2478 signal (signo
, arith_error
);
2482 #else /* not BSD4_1 */
2483 sigsetmask (SIGEMPTYMASK
);
2484 #endif /* not BSD4_1 */
2486 Fsignal (Qarith_error
, Qnil
);
2491 /* Don't do this if just dumping out.
2492 We don't want to call `signal' in this case
2493 so that we don't have trouble with dumping
2494 signal-delivering routines in an inconsistent state. */
2498 #endif /* CANNOT_DUMP */
2499 signal (SIGFPE
, arith_error
);
2502 signal (SIGEMT
, arith_error
);