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 2, 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, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
34 #include "syssignal.h"
36 #ifdef LISP_FLOAT_TYPE
43 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
44 #ifndef IEEE_FLOATING_POINT
45 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
46 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
47 #define IEEE_FLOATING_POINT 1
49 #define IEEE_FLOATING_POINT 0
53 /* Work around a problem that happens because math.h on hpux 7
54 defines two static variables--which, in Emacs, are not really static,
55 because `static' is defined as nothing. The problem is that they are
56 here, in floatfns.c, and in lread.c.
57 These macros prevent the name conflict. */
58 #if defined (HPUX) && !defined (HPUX8)
59 #define _MAXLDBL data_c_maxldbl
60 #define _NMAXLDBL data_c_nmaxldbl
64 #endif /* LISP_FLOAT_TYPE */
67 extern double atof ();
70 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
71 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
72 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
73 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
74 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
75 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
76 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
77 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
78 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
79 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
80 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
81 Lisp_Object Qbuffer_or_string_p
;
82 Lisp_Object Qboundp
, Qfboundp
;
83 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
86 Lisp_Object Qad_advice_info
, Qad_activate
;
88 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
89 Lisp_Object Qoverflow_error
, Qunderflow_error
;
91 #ifdef LISP_FLOAT_TYPE
93 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
96 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
97 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
99 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
100 static Lisp_Object Qchar_table
, Qbool_vector
;
102 static Lisp_Object
swap_in_symval_forwarding ();
104 Lisp_Object
set_internal ();
107 wrong_type_argument (predicate
, value
)
108 register Lisp_Object predicate
, value
;
110 register Lisp_Object tem
;
113 if (!EQ (Vmocklisp_arguments
, Qt
))
115 if (STRINGP (value
) &&
116 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
117 return Fstring_to_number (value
, Qnil
);
118 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
119 return Fnumber_to_string (value
);
122 /* If VALUE is not even a valid Lisp object, abort here
123 where we can get a backtrace showing where it came from. */
124 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
127 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
128 tem
= call1 (predicate
, value
);
136 error ("Attempt to modify read-only object");
140 args_out_of_range (a1
, a2
)
144 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
148 args_out_of_range_3 (a1
, a2
, a3
)
149 Lisp_Object a1
, a2
, a3
;
152 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
155 /* On some machines, XINT needs a temporary location.
156 Here it is, in case it is needed. */
158 int sign_extend_temp
;
160 /* On a few machines, XINT can only be done by calling this. */
163 sign_extend_lisp_int (num
)
166 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
167 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
169 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
172 /* Data type predicates */
174 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
175 "T if the two args are the same Lisp object.")
177 Lisp_Object obj1
, obj2
;
184 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
193 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
194 "Return a symbol representing the type of OBJECT.\n\
195 The symbol returned names the object's basic type;\n\
196 for example, (type-of 1) returns `integer'.")
200 switch (XGCTYPE (object
))
215 switch (XMISCTYPE (object
))
217 case Lisp_Misc_Marker
:
219 case Lisp_Misc_Overlay
:
221 case Lisp_Misc_Float
:
226 case Lisp_Vectorlike
:
227 if (GC_WINDOW_CONFIGURATIONP (object
))
228 return Qwindow_configuration
;
229 if (GC_PROCESSP (object
))
231 if (GC_WINDOWP (object
))
233 if (GC_SUBRP (object
))
235 if (GC_COMPILEDP (object
))
236 return Qcompiled_function
;
237 if (GC_BUFFERP (object
))
239 if (GC_CHAR_TABLE_P (object
))
241 if (GC_BOOL_VECTOR_P (object
))
243 if (GC_FRAMEP (object
))
247 #ifdef LISP_FLOAT_TYPE
257 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
266 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
275 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
279 if (CONSP (object
) || NILP (object
))
284 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
288 if (CONSP (object
) || NILP (object
))
293 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
297 if (SYMBOLP (object
))
302 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
306 if (VECTORP (object
))
311 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
315 if (STRINGP (object
))
320 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0, "T if OBJECT is a char-table.")
324 if (CHAR_TABLE_P (object
))
329 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
330 Svector_or_char_table_p
, 1, 1, 0,
331 "T if OBJECT is a char-table or vector.")
335 if (VECTORP (object
) || CHAR_TABLE_P (object
))
340 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "T if OBJECT is a bool-vector.")
344 if (BOOL_VECTOR_P (object
))
349 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
353 if (VECTORP (object
) || STRINGP (object
))
358 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
359 "T if OBJECT is a sequence (list or array).")
361 register Lisp_Object object
;
363 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
364 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
369 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
373 if (BUFFERP (object
))
378 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
382 if (MARKERP (object
))
387 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
396 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
397 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
401 if (COMPILEDP (object
))
406 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
407 "T if OBJECT is a character (an integer) or a string.")
409 register Lisp_Object object
;
411 if (INTEGERP (object
) || STRINGP (object
))
416 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
420 if (INTEGERP (object
))
425 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
426 "T if OBJECT is an integer or a marker (editor pointer).")
428 register Lisp_Object object
;
430 if (MARKERP (object
) || INTEGERP (object
))
435 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
436 "T if OBJECT is a nonnegative integer.")
440 if (NATNUMP (object
))
445 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
446 "T if OBJECT is a number (floating point or integer).")
450 if (NUMBERP (object
))
456 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
457 Snumber_or_marker_p
, 1, 1, 0,
458 "T if OBJECT is a number or a marker.")
462 if (NUMBERP (object
) || MARKERP (object
))
467 #ifdef LISP_FLOAT_TYPE
468 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
469 "T if OBJECT is a floating point number.")
477 #endif /* LISP_FLOAT_TYPE */
479 /* Extract and set components of lists */
481 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
482 "Return the car of LIST. If arg is nil, return nil.\n\
483 Error if arg is not nil and not a cons cell. See also `car-safe'.")
485 register Lisp_Object list
;
490 return XCONS (list
)->car
;
491 else if (EQ (list
, Qnil
))
494 list
= wrong_type_argument (Qlistp
, list
);
498 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
499 "Return the car of OBJECT if it is a cons cell, or else nil.")
504 return XCONS (object
)->car
;
509 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
510 "Return the cdr of LIST. If arg is nil, return nil.\n\
511 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
514 register Lisp_Object list
;
519 return XCONS (list
)->cdr
;
520 else if (EQ (list
, Qnil
))
523 list
= wrong_type_argument (Qlistp
, list
);
527 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
528 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
533 return XCONS (object
)->cdr
;
538 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
539 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
541 register Lisp_Object cell
, newcar
;
544 cell
= wrong_type_argument (Qconsp
, cell
);
547 XCONS (cell
)->car
= newcar
;
551 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
552 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
554 register Lisp_Object cell
, newcdr
;
557 cell
= wrong_type_argument (Qconsp
, cell
);
560 XCONS (cell
)->cdr
= newcdr
;
564 /* Extract and set components of symbols */
566 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
568 register Lisp_Object symbol
;
570 Lisp_Object valcontents
;
571 CHECK_SYMBOL (symbol
, 0);
573 valcontents
= XSYMBOL (symbol
)->value
;
575 if (BUFFER_LOCAL_VALUEP (valcontents
)
576 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
577 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
579 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
582 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
584 register Lisp_Object symbol
;
586 CHECK_SYMBOL (symbol
, 0);
587 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
590 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
592 register Lisp_Object symbol
;
594 CHECK_SYMBOL (symbol
, 0);
595 if (NILP (symbol
) || EQ (symbol
, Qt
))
596 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
597 Fset (symbol
, Qunbound
);
601 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
603 register Lisp_Object symbol
;
605 CHECK_SYMBOL (symbol
, 0);
606 if (NILP (symbol
) || EQ (symbol
, Qt
))
607 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
608 XSYMBOL (symbol
)->function
= Qunbound
;
612 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
613 "Return SYMBOL's function definition. Error if that is void.")
615 register Lisp_Object symbol
;
617 CHECK_SYMBOL (symbol
, 0);
618 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
619 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
620 return XSYMBOL (symbol
)->function
;
623 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
625 register Lisp_Object symbol
;
627 CHECK_SYMBOL (symbol
, 0);
628 return XSYMBOL (symbol
)->plist
;
631 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
633 register Lisp_Object symbol
;
635 register Lisp_Object name
;
637 CHECK_SYMBOL (symbol
, 0);
638 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
642 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
643 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
645 register Lisp_Object symbol
, definition
;
647 CHECK_SYMBOL (symbol
, 0);
648 if (NILP (symbol
) || EQ (symbol
, Qt
))
649 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
650 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
651 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
653 XSYMBOL (symbol
)->function
= definition
;
654 /* Handle automatic advice activation */
655 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
657 call2 (Qad_activate
, symbol
, Qnil
);
658 definition
= XSYMBOL (symbol
)->function
;
663 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
664 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
665 Associates the function with the current load file, if any.")
667 register Lisp_Object symbol
, definition
;
669 CHECK_SYMBOL (symbol
, 0);
670 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
671 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
673 XSYMBOL (symbol
)->function
= definition
;
674 /* Handle automatic advice activation */
675 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
677 call2 (Qad_activate
, symbol
, Qnil
);
678 definition
= XSYMBOL (symbol
)->function
;
680 LOADHIST_ATTACH (symbol
);
684 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
685 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
687 register Lisp_Object symbol
, newplist
;
689 CHECK_SYMBOL (symbol
, 0);
690 XSYMBOL (symbol
)->plist
= newplist
;
695 /* Getting and setting values of symbols */
697 /* Given the raw contents of a symbol value cell,
698 return the Lisp value of the symbol.
699 This does not handle buffer-local variables; use
700 swap_in_symval_forwarding for that. */
703 do_symval_forwarding (valcontents
)
704 register Lisp_Object valcontents
;
706 register Lisp_Object val
;
708 if (MISCP (valcontents
))
709 switch (XMISCTYPE (valcontents
))
711 case Lisp_Misc_Intfwd
:
712 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
715 case Lisp_Misc_Boolfwd
:
716 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
718 case Lisp_Misc_Objfwd
:
719 return *XOBJFWD (valcontents
)->objvar
;
721 case Lisp_Misc_Buffer_Objfwd
:
722 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
723 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
725 case Lisp_Misc_Kboard_Objfwd
:
726 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
727 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
732 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
733 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
734 buffer-independent contents of the value cell: forwarded just one
735 step past the buffer-localness. */
738 store_symval_forwarding (symbol
, valcontents
, newval
)
740 register Lisp_Object valcontents
, newval
;
742 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
745 switch (XMISCTYPE (valcontents
))
747 case Lisp_Misc_Intfwd
:
748 CHECK_NUMBER (newval
, 1);
749 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
750 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
751 error ("Value out of range for variable `%s'",
752 XSYMBOL (symbol
)->name
->data
);
755 case Lisp_Misc_Boolfwd
:
756 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
759 case Lisp_Misc_Objfwd
:
760 *XOBJFWD (valcontents
)->objvar
= newval
;
763 case Lisp_Misc_Buffer_Objfwd
:
765 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
768 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
769 if (! NILP (type
) && ! NILP (newval
)
770 && XTYPE (newval
) != XINT (type
))
771 buffer_slot_type_mismatch (offset
);
773 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
777 case Lisp_Misc_Kboard_Objfwd
:
778 (*(Lisp_Object
*)((char *)current_kboard
779 + XKBOARD_OBJFWD (valcontents
)->offset
))
790 valcontents
= XSYMBOL (symbol
)->value
;
791 if (BUFFER_LOCAL_VALUEP (valcontents
)
792 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
793 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
795 XSYMBOL (symbol
)->value
= newval
;
799 /* Set up the buffer-local symbol SYMBOL for validity in the current
800 buffer. VALCONTENTS is the contents of its value cell.
801 Return the value forwarded one step past the buffer-local indicator. */
804 swap_in_symval_forwarding (symbol
, valcontents
)
805 Lisp_Object symbol
, valcontents
;
807 /* valcontents is a pointer to a struct resembling the cons
808 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
810 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
811 local_var_alist, that being the element whose car is this
812 variable. Or it can be a pointer to the
813 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
814 an element in its alist for this variable.
816 If the current buffer is not BUFFER, we store the current
817 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
818 appropriate alist element for the buffer now current and set up
819 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
820 element, and store into BUFFER.
822 Note that REALVALUE can be a forwarding pointer. */
824 register Lisp_Object tem1
;
825 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
827 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
829 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
831 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
832 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
834 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
835 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
836 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
838 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
841 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
844 /* Find the value of a symbol, returning Qunbound if it's not bound.
845 This is helpful for code which just wants to get a variable's value
846 if it has one, without signaling an error.
847 Note that it must not be possible to quit
848 within this function. Great care is required for this. */
851 find_symbol_value (symbol
)
854 register Lisp_Object valcontents
, tem1
;
855 register Lisp_Object val
;
856 CHECK_SYMBOL (symbol
, 0);
857 valcontents
= XSYMBOL (symbol
)->value
;
859 if (BUFFER_LOCAL_VALUEP (valcontents
)
860 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
861 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
863 if (MISCP (valcontents
))
865 switch (XMISCTYPE (valcontents
))
867 case Lisp_Misc_Intfwd
:
868 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
871 case Lisp_Misc_Boolfwd
:
872 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
874 case Lisp_Misc_Objfwd
:
875 return *XOBJFWD (valcontents
)->objvar
;
877 case Lisp_Misc_Buffer_Objfwd
:
878 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
879 + (char *)current_buffer
);
881 case Lisp_Misc_Kboard_Objfwd
:
882 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
883 + (char *)current_kboard
);
890 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
891 "Return SYMBOL's value. Error if that is void.")
897 val
= find_symbol_value (symbol
);
898 if (EQ (val
, Qunbound
))
899 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
904 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
905 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
907 register Lisp_Object symbol
, newval
;
909 return set_internal (symbol
, newval
, 0);
912 /* Stpre the value NEWVAL into SYMBOL.
913 If BINDFLAG is zero, then if this symbol is supposed to become
914 local in every buffer where it is set, then we make it local.
915 If BINDFLAG is nonzero, we don't do that. */
918 set_internal (symbol
, newval
, bindflag
)
919 register Lisp_Object symbol
, newval
;
922 int voide
= EQ (newval
, Qunbound
);
924 register Lisp_Object valcontents
, tem1
, current_alist_element
;
926 CHECK_SYMBOL (symbol
, 0);
927 if (NILP (symbol
) || EQ (symbol
, Qt
))
928 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
929 valcontents
= XSYMBOL (symbol
)->value
;
931 if (BUFFER_OBJFWDP (valcontents
))
933 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
934 register int mask
= XINT (*((Lisp_Object
*)
935 (idx
+ (char *)&buffer_local_flags
)));
937 current_buffer
->local_var_flags
|= mask
;
940 else if (BUFFER_LOCAL_VALUEP (valcontents
)
941 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
943 /* valcontents is actually a pointer to a struct resembling a cons,
944 with contents something like:
945 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
947 BUFFER is the last buffer for which this symbol's value was
950 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
951 local_var_alist, that being the element whose car is this
952 variable. Or it can be a pointer to the
953 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
954 have an element in its alist for this variable (that is, if
955 BUFFER sees the default value of this variable).
957 If we want to examine or set the value and BUFFER is current,
958 we just examine or set REALVALUE. If BUFFER is not current, we
959 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
960 then find the appropriate alist element for the buffer now
961 current and set up CURRENT-ALIST-ELEMENT. Then we set
962 REALVALUE out of that element, and store into BUFFER.
964 If we are setting the variable and the current buffer does
965 not have an alist entry for this variable, an alist entry is
968 Note that REALVALUE can be a forwarding pointer. Each time
969 it is examined or set, forwarding must be done. */
971 /* What value are we caching right now? */
972 current_alist_element
=
973 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
975 /* If the current buffer is not the buffer whose binding is
976 currently cached, or if it's a Lisp_Buffer_Local_Value and
977 we're looking at the default value, the cache is invalid; we
978 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
980 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
981 || (BUFFER_LOCAL_VALUEP (valcontents
)
982 && EQ (XCONS (current_alist_element
)->car
,
983 current_alist_element
)))
985 /* Write out the cached value for the old buffer; copy it
986 back to its alist element. This works if the current
987 buffer only sees the default value, too. */
988 Fsetcdr (current_alist_element
,
989 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
991 /* Find the new value for CURRENT-ALIST-ELEMENT. */
992 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
995 /* This buffer still sees the default value. */
997 /* If the variable is a Lisp_Some_Buffer_Local_Value,
998 or if this is `let' rather than `set',
999 make CURRENT-ALIST-ELEMENT point to itself,
1000 indicating that we're seeing the default value. */
1001 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1002 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1004 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1005 give this buffer a new assoc for a local value and set
1006 CURRENT-ALIST-ELEMENT to point to that. */
1009 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1010 current_buffer
->local_var_alist
=
1011 Fcons (tem1
, current_buffer
->local_var_alist
);
1014 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1015 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
1018 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1019 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
1022 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1025 /* If storing void (making the symbol void), forward only through
1026 buffer-local indicator, not through Lisp_Objfwd, etc. */
1028 store_symval_forwarding (symbol
, Qnil
, newval
);
1030 store_symval_forwarding (symbol
, valcontents
, newval
);
1035 /* Access or set a buffer-local symbol's default value. */
1037 /* Return the default value of SYMBOL, but don't check for voidness.
1038 Return Qunbound if it is void. */
1041 default_value (symbol
)
1044 register Lisp_Object valcontents
;
1046 CHECK_SYMBOL (symbol
, 0);
1047 valcontents
= XSYMBOL (symbol
)->value
;
1049 /* For a built-in buffer-local variable, get the default value
1050 rather than letting do_symval_forwarding get the current value. */
1051 if (BUFFER_OBJFWDP (valcontents
))
1053 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1055 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1056 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1059 /* Handle user-created local variables. */
1060 if (BUFFER_LOCAL_VALUEP (valcontents
)
1061 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1063 /* If var is set up for a buffer that lacks a local value for it,
1064 the current value is nominally the default value.
1065 But the current value slot may be more up to date, since
1066 ordinary setq stores just that slot. So use that. */
1067 Lisp_Object current_alist_element
, alist_element_car
;
1068 current_alist_element
1069 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1070 alist_element_car
= XCONS (current_alist_element
)->car
;
1071 if (EQ (alist_element_car
, current_alist_element
))
1072 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1074 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1076 /* For other variables, get the current value. */
1077 return do_symval_forwarding (valcontents
);
1080 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1081 "Return T if SYMBOL has a non-void default value.\n\
1082 This is the value that is seen in buffers that do not have their own values\n\
1083 for this variable.")
1087 register Lisp_Object value
;
1089 value
= default_value (symbol
);
1090 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1093 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1094 "Return SYMBOL's default value.\n\
1095 This is the value that is seen in buffers that do not have their own values\n\
1096 for this variable. The default value is meaningful for variables with\n\
1097 local bindings in certain buffers.")
1101 register Lisp_Object value
;
1103 value
= default_value (symbol
);
1104 if (EQ (value
, Qunbound
))
1105 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1109 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1110 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1111 The default value is seen in buffers that do not have their own values\n\
1112 for this variable.")
1114 Lisp_Object symbol
, value
;
1116 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1118 CHECK_SYMBOL (symbol
, 0);
1119 valcontents
= XSYMBOL (symbol
)->value
;
1121 /* Handle variables like case-fold-search that have special slots
1122 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1124 if (BUFFER_OBJFWDP (valcontents
))
1126 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1127 register struct buffer
*b
;
1128 register int mask
= XINT (*((Lisp_Object
*)
1129 (idx
+ (char *)&buffer_local_flags
)));
1133 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1134 for (b
= all_buffers
; b
; b
= b
->next
)
1135 if (!(b
->local_var_flags
& mask
))
1136 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1141 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1142 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1143 return Fset (symbol
, value
);
1145 /* Store new value into the DEFAULT-VALUE slot */
1146 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1148 /* If that slot is current, we must set the REALVALUE slot too */
1149 current_alist_element
1150 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1151 alist_element_buffer
= Fcar (current_alist_element
);
1152 if (EQ (alist_element_buffer
, current_alist_element
))
1153 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1159 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1160 "Set the default value of variable VAR to VALUE.\n\
1161 VAR, the variable name, is literal (not evaluated);\n\
1162 VALUE is an expression and it is evaluated.\n\
1163 The default value of a variable is seen in buffers\n\
1164 that do not have their own values for the variable.\n\
1166 More generally, you can use multiple variables and values, as in\n\
1167 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1168 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1169 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1174 register Lisp_Object args_left
;
1175 register Lisp_Object val
, symbol
;
1176 struct gcpro gcpro1
;
1186 val
= Feval (Fcar (Fcdr (args_left
)));
1187 symbol
= Fcar (args_left
);
1188 Fset_default (symbol
, val
);
1189 args_left
= Fcdr (Fcdr (args_left
));
1191 while (!NILP (args_left
));
1197 /* Lisp functions for creating and removing buffer-local variables. */
1199 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1200 1, 1, "vMake Variable Buffer Local: ",
1201 "Make VARIABLE have a separate value for each buffer.\n\
1202 At any time, the value for the current buffer is in effect.\n\
1203 There is also a default value which is seen in any buffer which has not yet\n\
1204 set its own value.\n\
1205 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1206 for the current buffer if it was previously using the default value.\n\
1207 The function `default-value' gets the default value and `set-default' sets it.")
1209 register Lisp_Object variable
;
1211 register Lisp_Object tem
, valcontents
, newval
;
1213 CHECK_SYMBOL (variable
, 0);
1215 valcontents
= XSYMBOL (variable
)->value
;
1216 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1217 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1219 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1221 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1223 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1226 if (EQ (valcontents
, Qunbound
))
1227 XSYMBOL (variable
)->value
= Qnil
;
1228 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1229 XCONS (tem
)->car
= tem
;
1230 newval
= allocate_misc ();
1231 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1232 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1233 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1234 XSYMBOL (variable
)->value
= newval
;
1238 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1239 1, 1, "vMake Local Variable: ",
1240 "Make VARIABLE have a separate value in the current buffer.\n\
1241 Other buffers will continue to share a common default value.\n\
1242 \(The buffer-local value of VARIABLE starts out as the same value\n\
1243 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1244 See also `make-variable-buffer-local'.\n\n\
1245 If the variable is already arranged to become local when set,\n\
1246 this function causes a local value to exist for this buffer,\n\
1247 just as setting the variable would do.\n\
1249 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1250 Use `make-local-hook' instead.")
1252 register Lisp_Object variable
;
1254 register Lisp_Object tem
, valcontents
;
1256 CHECK_SYMBOL (variable
, 0);
1258 valcontents
= XSYMBOL (variable
)->value
;
1259 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1260 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1262 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1264 tem
= Fboundp (variable
);
1266 /* Make sure the symbol has a local value in this particular buffer,
1267 by setting it to the same value it already has. */
1268 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1271 /* Make sure symbol is set up to hold per-buffer values */
1272 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1275 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1276 XCONS (tem
)->car
= tem
;
1277 newval
= allocate_misc ();
1278 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1279 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1280 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1281 XSYMBOL (variable
)->value
= newval
;
1283 /* Make sure this buffer has its own value of symbol */
1284 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1287 /* Swap out any local binding for some other buffer, and make
1288 sure the current value is permanently recorded, if it's the
1290 find_symbol_value (variable
);
1292 current_buffer
->local_var_alist
1293 = Fcons (Fcons (variable
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
)->cdr
),
1294 current_buffer
->local_var_alist
);
1296 /* Make sure symbol does not think it is set up for this buffer;
1297 force it to look once again for this buffer's value */
1299 Lisp_Object
*pvalbuf
;
1301 valcontents
= XSYMBOL (variable
)->value
;
1303 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1304 if (current_buffer
== XBUFFER (*pvalbuf
))
1309 /* If the symbol forwards into a C variable, then swap in the
1310 variable for this buffer immediately. If C code modifies the
1311 variable before we swap in, then that new value will clobber the
1312 default value the next time we swap. */
1313 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->car
;
1314 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1315 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1320 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1321 1, 1, "vKill Local Variable: ",
1322 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1323 From now on the default value will apply in this buffer.")
1325 register Lisp_Object variable
;
1327 register Lisp_Object tem
, valcontents
;
1329 CHECK_SYMBOL (variable
, 0);
1331 valcontents
= XSYMBOL (variable
)->value
;
1333 if (BUFFER_OBJFWDP (valcontents
))
1335 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1336 register int mask
= XINT (*((Lisp_Object
*)
1337 (idx
+ (char *)&buffer_local_flags
)));
1341 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1342 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1343 current_buffer
->local_var_flags
&= ~mask
;
1348 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1349 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1352 /* Get rid of this buffer's alist element, if any */
1354 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1356 current_buffer
->local_var_alist
1357 = Fdelq (tem
, current_buffer
->local_var_alist
);
1359 /* If the symbol is set up for the current buffer, recompute its
1360 value. We have to do it now, or else forwarded objects won't
1363 Lisp_Object
*pvalbuf
;
1364 valcontents
= XSYMBOL (variable
)->value
;
1365 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1366 if (current_buffer
== XBUFFER (*pvalbuf
))
1369 find_symbol_value (variable
);
1376 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1378 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1379 BUFFER defaults to the current buffer.")
1381 register Lisp_Object variable
, buffer
;
1383 Lisp_Object valcontents
;
1384 register struct buffer
*buf
;
1387 buf
= current_buffer
;
1390 CHECK_BUFFER (buffer
, 0);
1391 buf
= XBUFFER (buffer
);
1394 CHECK_SYMBOL (variable
, 0);
1396 valcontents
= XSYMBOL (variable
)->value
;
1397 if (BUFFER_LOCAL_VALUEP (valcontents
)
1398 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1400 Lisp_Object tail
, elt
;
1401 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1403 elt
= XCONS (tail
)->car
;
1404 if (EQ (variable
, XCONS (elt
)->car
))
1408 if (BUFFER_OBJFWDP (valcontents
))
1410 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1411 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1412 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1418 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1420 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1421 BUFFER defaults to the current buffer.")
1423 register Lisp_Object variable
, buffer
;
1425 Lisp_Object valcontents
;
1426 register struct buffer
*buf
;
1429 buf
= current_buffer
;
1432 CHECK_BUFFER (buffer
, 0);
1433 buf
= XBUFFER (buffer
);
1436 CHECK_SYMBOL (variable
, 0);
1438 valcontents
= XSYMBOL (variable
)->value
;
1440 /* This means that make-variable-buffer-local was done. */
1441 if (BUFFER_LOCAL_VALUEP (valcontents
))
1443 /* All these slots become local if they are set. */
1444 if (BUFFER_OBJFWDP (valcontents
))
1446 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1448 Lisp_Object tail
, elt
;
1449 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1451 elt
= XCONS (tail
)->car
;
1452 if (EQ (variable
, XCONS (elt
)->car
))
1459 /* Find the function at the end of a chain of symbol function indirections. */
1461 /* If OBJECT is a symbol, find the end of its function chain and
1462 return the value found there. If OBJECT is not a symbol, just
1463 return it. If there is a cycle in the function chain, signal a
1464 cyclic-function-indirection error.
1466 This is like Findirect_function, except that it doesn't signal an
1467 error if the chain ends up unbound. */
1469 indirect_function (object
)
1470 register Lisp_Object object
;
1472 Lisp_Object tortoise
, hare
;
1474 hare
= tortoise
= object
;
1478 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1480 hare
= XSYMBOL (hare
)->function
;
1481 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1483 hare
= XSYMBOL (hare
)->function
;
1485 tortoise
= XSYMBOL (tortoise
)->function
;
1487 if (EQ (hare
, tortoise
))
1488 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1494 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1495 "Return the function at the end of OBJECT's function chain.\n\
1496 If OBJECT is a symbol, follow all function indirections and return the final\n\
1497 function binding.\n\
1498 If OBJECT is not a symbol, just return it.\n\
1499 Signal a void-function error if the final symbol is unbound.\n\
1500 Signal a cyclic-function-indirection error if there is a loop in the\n\
1501 function chain of symbols.")
1503 register Lisp_Object object
;
1507 result
= indirect_function (object
);
1509 if (EQ (result
, Qunbound
))
1510 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1514 /* Extract and set vector and string elements */
1516 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1517 "Return the element of ARRAY at index IDX.\n\
1518 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1519 or a byte-code object. IDX starts at 0.")
1521 register Lisp_Object array
;
1524 register int idxval
;
1526 CHECK_NUMBER (idx
, 1);
1527 idxval
= XINT (idx
);
1528 if (STRINGP (array
))
1531 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1532 args_out_of_range (array
, idx
);
1533 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1536 else if (BOOL_VECTOR_P (array
))
1540 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1541 args_out_of_range (array
, idx
);
1543 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1544 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1546 else if (CHAR_TABLE_P (array
))
1551 args_out_of_range (array
, idx
);
1552 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1554 /* For ASCII and 8-bit European characters, the element is
1555 stored in the top table. */
1556 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1558 val
= XCHAR_TABLE (array
)->defalt
;
1559 while (NILP (val
)) /* Follow parents until we find some value. */
1561 array
= XCHAR_TABLE (array
)->parent
;
1564 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1566 val
= XCHAR_TABLE (array
)->defalt
;
1573 Lisp_Object sub_table
;
1575 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1576 if (code
[0] != CHARSET_COMPOSITION
)
1578 if (code
[1] < 32) code
[1] = -1;
1579 else if (code
[2] < 32) code
[2] = -1;
1581 /* Here, the possible range of CODE[0] (== charset ID) is
1582 128..MAX_CHARSET. Since the top level char table contains
1583 data for multibyte characters after 256th element, we must
1584 increment CODE[0] by 128 to get a correct index. */
1586 code
[3] = -1; /* anchor */
1588 try_parent_char_table
:
1590 for (i
= 0; code
[i
] >= 0; i
++)
1592 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1593 if (SUB_CHAR_TABLE_P (val
))
1598 val
= XCHAR_TABLE (sub_table
)->defalt
;
1601 array
= XCHAR_TABLE (array
)->parent
;
1603 goto try_parent_char_table
;
1608 /* Here, VAL is a sub char table. We try the default value
1610 val
= XCHAR_TABLE (val
)->defalt
;
1613 array
= XCHAR_TABLE (array
)->parent
;
1615 goto try_parent_char_table
;
1623 if (VECTORP (array
))
1624 size
= XVECTOR (array
)->size
;
1625 else if (COMPILEDP (array
))
1626 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1628 wrong_type_argument (Qarrayp
, array
);
1630 if (idxval
< 0 || idxval
>= size
)
1631 args_out_of_range (array
, idx
);
1632 return XVECTOR (array
)->contents
[idxval
];
1636 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1637 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1638 ARRAY may be a vector or a string. IDX starts at 0.")
1639 (array
, idx
, newelt
)
1640 register Lisp_Object array
;
1641 Lisp_Object idx
, newelt
;
1643 register int idxval
;
1645 CHECK_NUMBER (idx
, 1);
1646 idxval
= XINT (idx
);
1647 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1648 && ! CHAR_TABLE_P (array
))
1649 array
= wrong_type_argument (Qarrayp
, array
);
1650 CHECK_IMPURE (array
);
1652 if (VECTORP (array
))
1654 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1655 args_out_of_range (array
, idx
);
1656 XVECTOR (array
)->contents
[idxval
] = newelt
;
1658 else if (BOOL_VECTOR_P (array
))
1662 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1663 args_out_of_range (array
, idx
);
1665 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1667 if (! NILP (newelt
))
1668 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1670 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1671 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1673 else if (CHAR_TABLE_P (array
))
1678 args_out_of_range (array
, idx
);
1679 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1680 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1686 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1687 if (code
[0] != CHARSET_COMPOSITION
)
1689 if (code
[1] < 32) code
[1] = -1;
1690 else if (code
[2] < 32) code
[2] = -1;
1692 /* See the comment of the corresponding part in Faref. */
1694 code
[3] = -1; /* anchor */
1695 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1697 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1698 if (SUB_CHAR_TABLE_P (val
))
1701 /* VAL is a leaf. Create a sub char table with the
1702 default value VAL here and look into it. */
1703 array
= (XCHAR_TABLE (array
)->contents
[code
[i
]]
1704 = make_sub_char_table (val
));
1706 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1711 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1712 args_out_of_range (array
, idx
);
1713 CHECK_NUMBER (newelt
, 2);
1714 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1720 /* Arithmetic functions */
1722 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1725 arithcompare (num1
, num2
, comparison
)
1726 Lisp_Object num1
, num2
;
1727 enum comparison comparison
;
1732 #ifdef LISP_FLOAT_TYPE
1733 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1734 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1736 if (FLOATP (num1
) || FLOATP (num2
))
1739 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1740 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1743 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1744 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1745 #endif /* LISP_FLOAT_TYPE */
1750 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1755 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1760 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1765 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1770 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1775 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1784 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1785 "T if two args, both numbers or markers, are equal.")
1787 register Lisp_Object num1
, num2
;
1789 return arithcompare (num1
, num2
, equal
);
1792 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1793 "T if first arg is less than second arg. Both must be numbers or markers.")
1795 register Lisp_Object num1
, num2
;
1797 return arithcompare (num1
, num2
, less
);
1800 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1801 "T if first arg is greater than second arg. Both must be numbers or markers.")
1803 register Lisp_Object num1
, num2
;
1805 return arithcompare (num1
, num2
, grtr
);
1808 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1809 "T if first arg is less than or equal to second arg.\n\
1810 Both must be numbers or markers.")
1812 register Lisp_Object num1
, num2
;
1814 return arithcompare (num1
, num2
, less_or_equal
);
1817 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1818 "T if first arg is greater than or equal to second arg.\n\
1819 Both must be numbers or markers.")
1821 register Lisp_Object num1
, num2
;
1823 return arithcompare (num1
, num2
, grtr_or_equal
);
1826 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1827 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1829 register Lisp_Object num1
, num2
;
1831 return arithcompare (num1
, num2
, notequal
);
1834 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1836 register Lisp_Object number
;
1838 #ifdef LISP_FLOAT_TYPE
1839 CHECK_NUMBER_OR_FLOAT (number
, 0);
1841 if (FLOATP (number
))
1843 if (XFLOAT(number
)->data
== 0.0)
1848 CHECK_NUMBER (number
, 0);
1849 #endif /* LISP_FLOAT_TYPE */
1856 /* Convert between long values and pairs of Lisp integers. */
1862 unsigned int top
= i
>> 16;
1863 unsigned int bot
= i
& 0xFFFF;
1865 return make_number (bot
);
1866 if (top
== (unsigned long)-1 >> 16)
1867 return Fcons (make_number (-1), make_number (bot
));
1868 return Fcons (make_number (top
), make_number (bot
));
1875 Lisp_Object top
, bot
;
1878 top
= XCONS (c
)->car
;
1879 bot
= XCONS (c
)->cdr
;
1881 bot
= XCONS (bot
)->car
;
1882 return ((XINT (top
) << 16) | XINT (bot
));
1885 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1886 "Convert NUMBER to a string by printing it in decimal.\n\
1887 Uses a minus sign if negative.\n\
1888 NUMBER may be an integer or a floating point number.")
1892 char buffer
[VALBITS
];
1894 #ifndef LISP_FLOAT_TYPE
1895 CHECK_NUMBER (number
, 0);
1897 CHECK_NUMBER_OR_FLOAT (number
, 0);
1899 if (FLOATP (number
))
1901 char pigbuf
[350]; /* see comments in float_to_string */
1903 float_to_string (pigbuf
, XFLOAT(number
)->data
);
1904 return build_string (pigbuf
);
1906 #endif /* LISP_FLOAT_TYPE */
1908 if (sizeof (int) == sizeof (EMACS_INT
))
1909 sprintf (buffer
, "%d", XINT (number
));
1910 else if (sizeof (long) == sizeof (EMACS_INT
))
1911 sprintf (buffer
, "%ld", XINT (number
));
1914 return build_string (buffer
);
1918 digit_to_number (character
, base
)
1919 int character
, base
;
1923 if (character
>= '0' && character
<= '9')
1924 digit
= character
- '0';
1925 else if (character
>= 'a' && character
<= 'z')
1926 digit
= character
- 'a' + 10;
1927 else if (character
>= 'A' && character
<= 'Z')
1928 digit
= character
- 'A' + 10;
1938 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
1939 "Convert STRING to a number by parsing it as a decimal number.\n\
1940 This parses both integers and floating point numbers.\n\
1941 It ignores leading spaces and tabs.\n\
1943 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
1944 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
1945 Floating point numbers always use base 10.")
1947 register Lisp_Object string
, base
;
1949 register unsigned char *p
;
1950 register int b
, digit
, v
= 0;
1953 CHECK_STRING (string
, 0);
1959 CHECK_NUMBER (base
, 1);
1961 if (b
< 2 || b
> 16)
1962 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
1965 p
= XSTRING (string
)->data
;
1967 /* Skip any whitespace at the front of the number. Some versions of
1968 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1969 while (*p
== ' ' || *p
== '\t')
1980 #ifdef LISP_FLOAT_TYPE
1981 if (isfloat_string (p
))
1982 return make_float (atof (p
));
1983 #endif /* LISP_FLOAT_TYPE */
1987 int digit
= digit_to_number (*p
++, b
);
1993 return make_number (negative
* v
);
1998 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2000 extern Lisp_Object
float_arith_driver ();
2001 extern Lisp_Object
fmod_float ();
2004 arith_driver (code
, nargs
, args
)
2007 register Lisp_Object
*args
;
2009 register Lisp_Object val
;
2010 register int argnum
;
2011 register EMACS_INT accum
;
2012 register EMACS_INT next
;
2014 switch (SWITCH_ENUM_CAST (code
))
2027 for (argnum
= 0; argnum
< nargs
; argnum
++)
2029 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2030 #ifdef LISP_FLOAT_TYPE
2031 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2033 if (FLOATP (val
)) /* time to do serious math */
2034 return (float_arith_driver ((double) accum
, argnum
, code
,
2037 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2038 #endif /* LISP_FLOAT_TYPE */
2039 args
[argnum
] = val
; /* runs into a compiler bug. */
2040 next
= XINT (args
[argnum
]);
2041 switch (SWITCH_ENUM_CAST (code
))
2043 case Aadd
: accum
+= next
; break;
2045 if (!argnum
&& nargs
!= 1)
2049 case Amult
: accum
*= next
; break;
2051 if (!argnum
) accum
= next
;
2055 Fsignal (Qarith_error
, Qnil
);
2059 case Alogand
: accum
&= next
; break;
2060 case Alogior
: accum
|= next
; break;
2061 case Alogxor
: accum
^= next
; break;
2062 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2063 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2067 XSETINT (val
, accum
);
2072 #define isnan(x) ((x) != (x))
2074 #ifdef LISP_FLOAT_TYPE
2077 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2079 register int argnum
;
2082 register Lisp_Object
*args
;
2084 register Lisp_Object val
;
2087 for (; argnum
< nargs
; argnum
++)
2089 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2090 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2094 next
= XFLOAT (val
)->data
;
2098 args
[argnum
] = val
; /* runs into a compiler bug. */
2099 next
= XINT (args
[argnum
]);
2101 switch (SWITCH_ENUM_CAST (code
))
2107 if (!argnum
&& nargs
!= 1)
2119 if (! IEEE_FLOATING_POINT
&& next
== 0)
2120 Fsignal (Qarith_error
, Qnil
);
2127 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2129 if (!argnum
|| isnan (next
) || next
> accum
)
2133 if (!argnum
|| isnan (next
) || next
< accum
)
2139 return make_float (accum
);
2141 #endif /* LISP_FLOAT_TYPE */
2143 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2144 "Return sum of any number of arguments, which are numbers or markers.")
2149 return arith_driver (Aadd
, nargs
, args
);
2152 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2153 "Negate number or subtract numbers or markers.\n\
2154 With one arg, negates it. With more than one arg,\n\
2155 subtracts all but the first from the first.")
2160 return arith_driver (Asub
, nargs
, args
);
2163 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2164 "Returns product of any number of arguments, which are numbers or markers.")
2169 return arith_driver (Amult
, nargs
, args
);
2172 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2173 "Returns first argument divided by all the remaining arguments.\n\
2174 The arguments must be numbers or markers.")
2179 return arith_driver (Adiv
, nargs
, args
);
2182 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2183 "Returns remainder of X divided by Y.\n\
2184 Both must be integers or markers.")
2186 register Lisp_Object x
, y
;
2190 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2191 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2193 if (XFASTINT (y
) == 0)
2194 Fsignal (Qarith_error
, Qnil
);
2196 XSETINT (val
, XINT (x
) % XINT (y
));
2210 /* If the magnitude of the result exceeds that of the divisor, or
2211 the sign of the result does not agree with that of the dividend,
2212 iterate with the reduced value. This does not yield a
2213 particularly accurate result, but at least it will be in the
2214 range promised by fmod. */
2216 r
-= f2
* floor (r
/ f2
);
2217 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2221 #endif /* ! HAVE_FMOD */
2223 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2224 "Returns X modulo Y.\n\
2225 The result falls between zero (inclusive) and Y (exclusive).\n\
2226 Both X and Y must be numbers or markers.")
2228 register Lisp_Object x
, y
;
2233 #ifdef LISP_FLOAT_TYPE
2234 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2235 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2237 if (FLOATP (x
) || FLOATP (y
))
2238 return fmod_float (x
, y
);
2240 #else /* not LISP_FLOAT_TYPE */
2241 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2242 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2243 #endif /* not LISP_FLOAT_TYPE */
2249 Fsignal (Qarith_error
, Qnil
);
2253 /* If the "remainder" comes out with the wrong sign, fix it. */
2254 if (i2
< 0 ? i1
> 0 : i1
< 0)
2261 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2262 "Return largest of all the arguments (which must be numbers or markers).\n\
2263 The value is always a number; markers are converted to numbers.")
2268 return arith_driver (Amax
, nargs
, args
);
2271 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2272 "Return smallest of all the arguments (which must be numbers or markers).\n\
2273 The value is always a number; markers are converted to numbers.")
2278 return arith_driver (Amin
, nargs
, args
);
2281 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2282 "Return bitwise-and of all the arguments.\n\
2283 Arguments may be integers, or markers converted to integers.")
2288 return arith_driver (Alogand
, nargs
, args
);
2291 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2292 "Return bitwise-or of all the arguments.\n\
2293 Arguments may be integers, or markers converted to integers.")
2298 return arith_driver (Alogior
, nargs
, args
);
2301 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2302 "Return bitwise-exclusive-or of all the arguments.\n\
2303 Arguments may be integers, or markers converted to integers.")
2308 return arith_driver (Alogxor
, nargs
, args
);
2311 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2312 "Return VALUE with its bits shifted left by COUNT.\n\
2313 If COUNT is negative, shifting is actually to the right.\n\
2314 In this case, the sign bit is duplicated.")
2316 register Lisp_Object value
, count
;
2318 register Lisp_Object val
;
2320 CHECK_NUMBER (value
, 0);
2321 CHECK_NUMBER (count
, 1);
2323 if (XINT (count
) > 0)
2324 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2326 XSETINT (val
, XINT (value
) >> -XINT (count
));
2330 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2331 "Return VALUE with its bits shifted left by COUNT.\n\
2332 If COUNT is negative, shifting is actually to the right.\n\
2333 In this case, zeros are shifted in on the left.")
2335 register Lisp_Object value
, count
;
2337 register Lisp_Object val
;
2339 CHECK_NUMBER (value
, 0);
2340 CHECK_NUMBER (count
, 1);
2342 if (XINT (count
) > 0)
2343 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2345 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2349 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2350 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2351 Markers are converted to integers.")
2353 register Lisp_Object number
;
2355 #ifdef LISP_FLOAT_TYPE
2356 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2358 if (FLOATP (number
))
2359 return (make_float (1.0 + XFLOAT (number
)->data
));
2361 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2362 #endif /* LISP_FLOAT_TYPE */
2364 XSETINT (number
, XINT (number
) + 1);
2368 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2369 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2370 Markers are converted to integers.")
2372 register Lisp_Object number
;
2374 #ifdef LISP_FLOAT_TYPE
2375 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2377 if (FLOATP (number
))
2378 return (make_float (-1.0 + XFLOAT (number
)->data
));
2380 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2381 #endif /* LISP_FLOAT_TYPE */
2383 XSETINT (number
, XINT (number
) - 1);
2387 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2388 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2390 register Lisp_Object number
;
2392 CHECK_NUMBER (number
, 0);
2393 XSETINT (number
, ~XINT (number
));
2400 Lisp_Object error_tail
, arith_tail
;
2402 Qquote
= intern ("quote");
2403 Qlambda
= intern ("lambda");
2404 Qsubr
= intern ("subr");
2405 Qerror_conditions
= intern ("error-conditions");
2406 Qerror_message
= intern ("error-message");
2407 Qtop_level
= intern ("top-level");
2409 Qerror
= intern ("error");
2410 Qquit
= intern ("quit");
2411 Qwrong_type_argument
= intern ("wrong-type-argument");
2412 Qargs_out_of_range
= intern ("args-out-of-range");
2413 Qvoid_function
= intern ("void-function");
2414 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2415 Qvoid_variable
= intern ("void-variable");
2416 Qsetting_constant
= intern ("setting-constant");
2417 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2419 Qinvalid_function
= intern ("invalid-function");
2420 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2421 Qno_catch
= intern ("no-catch");
2422 Qend_of_file
= intern ("end-of-file");
2423 Qarith_error
= intern ("arith-error");
2424 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2425 Qend_of_buffer
= intern ("end-of-buffer");
2426 Qbuffer_read_only
= intern ("buffer-read-only");
2427 Qmark_inactive
= intern ("mark-inactive");
2429 Qlistp
= intern ("listp");
2430 Qconsp
= intern ("consp");
2431 Qsymbolp
= intern ("symbolp");
2432 Qintegerp
= intern ("integerp");
2433 Qnatnump
= intern ("natnump");
2434 Qwholenump
= intern ("wholenump");
2435 Qstringp
= intern ("stringp");
2436 Qarrayp
= intern ("arrayp");
2437 Qsequencep
= intern ("sequencep");
2438 Qbufferp
= intern ("bufferp");
2439 Qvectorp
= intern ("vectorp");
2440 Qchar_or_string_p
= intern ("char-or-string-p");
2441 Qmarkerp
= intern ("markerp");
2442 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2443 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2444 Qboundp
= intern ("boundp");
2445 Qfboundp
= intern ("fboundp");
2447 #ifdef LISP_FLOAT_TYPE
2448 Qfloatp
= intern ("floatp");
2449 Qnumberp
= intern ("numberp");
2450 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2451 #endif /* LISP_FLOAT_TYPE */
2453 Qchar_table_p
= intern ("char-table-p");
2454 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2456 Qcdr
= intern ("cdr");
2458 /* Handle automatic advice activation */
2459 Qad_advice_info
= intern ("ad-advice-info");
2460 Qad_activate
= intern ("ad-activate");
2462 error_tail
= Fcons (Qerror
, Qnil
);
2464 /* ERROR is used as a signaler for random errors for which nothing else is right */
2466 Fput (Qerror
, Qerror_conditions
,
2468 Fput (Qerror
, Qerror_message
,
2469 build_string ("error"));
2471 Fput (Qquit
, Qerror_conditions
,
2472 Fcons (Qquit
, Qnil
));
2473 Fput (Qquit
, Qerror_message
,
2474 build_string ("Quit"));
2476 Fput (Qwrong_type_argument
, Qerror_conditions
,
2477 Fcons (Qwrong_type_argument
, error_tail
));
2478 Fput (Qwrong_type_argument
, Qerror_message
,
2479 build_string ("Wrong type argument"));
2481 Fput (Qargs_out_of_range
, Qerror_conditions
,
2482 Fcons (Qargs_out_of_range
, error_tail
));
2483 Fput (Qargs_out_of_range
, Qerror_message
,
2484 build_string ("Args out of range"));
2486 Fput (Qvoid_function
, Qerror_conditions
,
2487 Fcons (Qvoid_function
, error_tail
));
2488 Fput (Qvoid_function
, Qerror_message
,
2489 build_string ("Symbol's function definition is void"));
2491 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2492 Fcons (Qcyclic_function_indirection
, error_tail
));
2493 Fput (Qcyclic_function_indirection
, Qerror_message
,
2494 build_string ("Symbol's chain of function indirections contains a loop"));
2496 Fput (Qvoid_variable
, Qerror_conditions
,
2497 Fcons (Qvoid_variable
, error_tail
));
2498 Fput (Qvoid_variable
, Qerror_message
,
2499 build_string ("Symbol's value as variable is void"));
2501 Fput (Qsetting_constant
, Qerror_conditions
,
2502 Fcons (Qsetting_constant
, error_tail
));
2503 Fput (Qsetting_constant
, Qerror_message
,
2504 build_string ("Attempt to set a constant symbol"));
2506 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2507 Fcons (Qinvalid_read_syntax
, error_tail
));
2508 Fput (Qinvalid_read_syntax
, Qerror_message
,
2509 build_string ("Invalid read syntax"));
2511 Fput (Qinvalid_function
, Qerror_conditions
,
2512 Fcons (Qinvalid_function
, error_tail
));
2513 Fput (Qinvalid_function
, Qerror_message
,
2514 build_string ("Invalid function"));
2516 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2517 Fcons (Qwrong_number_of_arguments
, error_tail
));
2518 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2519 build_string ("Wrong number of arguments"));
2521 Fput (Qno_catch
, Qerror_conditions
,
2522 Fcons (Qno_catch
, error_tail
));
2523 Fput (Qno_catch
, Qerror_message
,
2524 build_string ("No catch for tag"));
2526 Fput (Qend_of_file
, Qerror_conditions
,
2527 Fcons (Qend_of_file
, error_tail
));
2528 Fput (Qend_of_file
, Qerror_message
,
2529 build_string ("End of file during parsing"));
2531 arith_tail
= Fcons (Qarith_error
, error_tail
);
2532 Fput (Qarith_error
, Qerror_conditions
,
2534 Fput (Qarith_error
, Qerror_message
,
2535 build_string ("Arithmetic error"));
2537 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2538 Fcons (Qbeginning_of_buffer
, error_tail
));
2539 Fput (Qbeginning_of_buffer
, Qerror_message
,
2540 build_string ("Beginning of buffer"));
2542 Fput (Qend_of_buffer
, Qerror_conditions
,
2543 Fcons (Qend_of_buffer
, error_tail
));
2544 Fput (Qend_of_buffer
, Qerror_message
,
2545 build_string ("End of buffer"));
2547 Fput (Qbuffer_read_only
, Qerror_conditions
,
2548 Fcons (Qbuffer_read_only
, error_tail
));
2549 Fput (Qbuffer_read_only
, Qerror_message
,
2550 build_string ("Buffer is read-only"));
2552 #ifdef LISP_FLOAT_TYPE
2553 Qrange_error
= intern ("range-error");
2554 Qdomain_error
= intern ("domain-error");
2555 Qsingularity_error
= intern ("singularity-error");
2556 Qoverflow_error
= intern ("overflow-error");
2557 Qunderflow_error
= intern ("underflow-error");
2559 Fput (Qdomain_error
, Qerror_conditions
,
2560 Fcons (Qdomain_error
, arith_tail
));
2561 Fput (Qdomain_error
, Qerror_message
,
2562 build_string ("Arithmetic domain error"));
2564 Fput (Qrange_error
, Qerror_conditions
,
2565 Fcons (Qrange_error
, arith_tail
));
2566 Fput (Qrange_error
, Qerror_message
,
2567 build_string ("Arithmetic range error"));
2569 Fput (Qsingularity_error
, Qerror_conditions
,
2570 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2571 Fput (Qsingularity_error
, Qerror_message
,
2572 build_string ("Arithmetic singularity error"));
2574 Fput (Qoverflow_error
, Qerror_conditions
,
2575 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2576 Fput (Qoverflow_error
, Qerror_message
,
2577 build_string ("Arithmetic overflow error"));
2579 Fput (Qunderflow_error
, Qerror_conditions
,
2580 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2581 Fput (Qunderflow_error
, Qerror_message
,
2582 build_string ("Arithmetic underflow error"));
2584 staticpro (&Qrange_error
);
2585 staticpro (&Qdomain_error
);
2586 staticpro (&Qsingularity_error
);
2587 staticpro (&Qoverflow_error
);
2588 staticpro (&Qunderflow_error
);
2589 #endif /* LISP_FLOAT_TYPE */
2593 staticpro (&Qquote
);
2594 staticpro (&Qlambda
);
2596 staticpro (&Qunbound
);
2597 staticpro (&Qerror_conditions
);
2598 staticpro (&Qerror_message
);
2599 staticpro (&Qtop_level
);
2601 staticpro (&Qerror
);
2603 staticpro (&Qwrong_type_argument
);
2604 staticpro (&Qargs_out_of_range
);
2605 staticpro (&Qvoid_function
);
2606 staticpro (&Qcyclic_function_indirection
);
2607 staticpro (&Qvoid_variable
);
2608 staticpro (&Qsetting_constant
);
2609 staticpro (&Qinvalid_read_syntax
);
2610 staticpro (&Qwrong_number_of_arguments
);
2611 staticpro (&Qinvalid_function
);
2612 staticpro (&Qno_catch
);
2613 staticpro (&Qend_of_file
);
2614 staticpro (&Qarith_error
);
2615 staticpro (&Qbeginning_of_buffer
);
2616 staticpro (&Qend_of_buffer
);
2617 staticpro (&Qbuffer_read_only
);
2618 staticpro (&Qmark_inactive
);
2620 staticpro (&Qlistp
);
2621 staticpro (&Qconsp
);
2622 staticpro (&Qsymbolp
);
2623 staticpro (&Qintegerp
);
2624 staticpro (&Qnatnump
);
2625 staticpro (&Qwholenump
);
2626 staticpro (&Qstringp
);
2627 staticpro (&Qarrayp
);
2628 staticpro (&Qsequencep
);
2629 staticpro (&Qbufferp
);
2630 staticpro (&Qvectorp
);
2631 staticpro (&Qchar_or_string_p
);
2632 staticpro (&Qmarkerp
);
2633 staticpro (&Qbuffer_or_string_p
);
2634 staticpro (&Qinteger_or_marker_p
);
2635 #ifdef LISP_FLOAT_TYPE
2636 staticpro (&Qfloatp
);
2637 staticpro (&Qnumberp
);
2638 staticpro (&Qnumber_or_marker_p
);
2639 #endif /* LISP_FLOAT_TYPE */
2640 staticpro (&Qchar_table_p
);
2641 staticpro (&Qvector_or_char_table_p
);
2643 staticpro (&Qboundp
);
2644 staticpro (&Qfboundp
);
2646 staticpro (&Qad_advice_info
);
2647 staticpro (&Qad_activate
);
2649 /* Types that type-of returns. */
2650 Qinteger
= intern ("integer");
2651 Qsymbol
= intern ("symbol");
2652 Qstring
= intern ("string");
2653 Qcons
= intern ("cons");
2654 Qmarker
= intern ("marker");
2655 Qoverlay
= intern ("overlay");
2656 Qfloat
= intern ("float");
2657 Qwindow_configuration
= intern ("window-configuration");
2658 Qprocess
= intern ("process");
2659 Qwindow
= intern ("window");
2660 /* Qsubr = intern ("subr"); */
2661 Qcompiled_function
= intern ("compiled-function");
2662 Qbuffer
= intern ("buffer");
2663 Qframe
= intern ("frame");
2664 Qvector
= intern ("vector");
2665 Qchar_table
= intern ("char-table");
2666 Qbool_vector
= intern ("bool-vector");
2668 staticpro (&Qinteger
);
2669 staticpro (&Qsymbol
);
2670 staticpro (&Qstring
);
2672 staticpro (&Qmarker
);
2673 staticpro (&Qoverlay
);
2674 staticpro (&Qfloat
);
2675 staticpro (&Qwindow_configuration
);
2676 staticpro (&Qprocess
);
2677 staticpro (&Qwindow
);
2678 /* staticpro (&Qsubr); */
2679 staticpro (&Qcompiled_function
);
2680 staticpro (&Qbuffer
);
2681 staticpro (&Qframe
);
2682 staticpro (&Qvector
);
2683 staticpro (&Qchar_table
);
2684 staticpro (&Qbool_vector
);
2688 defsubr (&Stype_of
);
2693 defsubr (&Sintegerp
);
2694 defsubr (&Sinteger_or_marker_p
);
2695 defsubr (&Snumberp
);
2696 defsubr (&Snumber_or_marker_p
);
2697 #ifdef LISP_FLOAT_TYPE
2699 #endif /* LISP_FLOAT_TYPE */
2700 defsubr (&Snatnump
);
2701 defsubr (&Ssymbolp
);
2702 defsubr (&Sstringp
);
2703 defsubr (&Svectorp
);
2704 defsubr (&Schar_table_p
);
2705 defsubr (&Svector_or_char_table_p
);
2706 defsubr (&Sbool_vector_p
);
2708 defsubr (&Ssequencep
);
2709 defsubr (&Sbufferp
);
2710 defsubr (&Smarkerp
);
2712 defsubr (&Sbyte_code_function_p
);
2713 defsubr (&Schar_or_string_p
);
2716 defsubr (&Scar_safe
);
2717 defsubr (&Scdr_safe
);
2720 defsubr (&Ssymbol_function
);
2721 defsubr (&Sindirect_function
);
2722 defsubr (&Ssymbol_plist
);
2723 defsubr (&Ssymbol_name
);
2724 defsubr (&Smakunbound
);
2725 defsubr (&Sfmakunbound
);
2727 defsubr (&Sfboundp
);
2729 defsubr (&Sdefalias
);
2730 defsubr (&Ssetplist
);
2731 defsubr (&Ssymbol_value
);
2733 defsubr (&Sdefault_boundp
);
2734 defsubr (&Sdefault_value
);
2735 defsubr (&Sset_default
);
2736 defsubr (&Ssetq_default
);
2737 defsubr (&Smake_variable_buffer_local
);
2738 defsubr (&Smake_local_variable
);
2739 defsubr (&Skill_local_variable
);
2740 defsubr (&Slocal_variable_p
);
2741 defsubr (&Slocal_variable_if_set_p
);
2744 defsubr (&Snumber_to_string
);
2745 defsubr (&Sstring_to_number
);
2746 defsubr (&Seqlsign
);
2770 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2777 #if defined(USG) && !defined(POSIX_SIGNALS)
2778 /* USG systems forget handlers when they are used;
2779 must reestablish each time */
2780 signal (signo
, arith_error
);
2783 /* VMS systems are like USG. */
2784 signal (signo
, arith_error
);
2788 #else /* not BSD4_1 */
2789 sigsetmask (SIGEMPTYMASK
);
2790 #endif /* not BSD4_1 */
2792 Fsignal (Qarith_error
, Qnil
);
2797 /* Don't do this if just dumping out.
2798 We don't want to call `signal' in this case
2799 so that we don't have trouble with dumping
2800 signal-delivering routines in an inconsistent state. */
2804 #endif /* CANNOT_DUMP */
2805 signal (SIGFPE
, arith_error
);
2808 signal (SIGEMT
, arith_error
);