1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98, 1999 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. */
31 #include "syssignal.h"
37 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
38 #ifndef IEEE_FLOATING_POINT
39 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
40 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
41 #define IEEE_FLOATING_POINT 1
43 #define IEEE_FLOATING_POINT 0
47 /* Work around a problem that happens because math.h on hpux 7
48 defines two static variables--which, in Emacs, are not really static,
49 because `static' is defined as nothing. The problem is that they are
50 here, in floatfns.c, and in lread.c.
51 These macros prevent the name conflict. */
52 #if defined (HPUX) && !defined (HPUX8)
53 #define _MAXLDBL data_c_maxldbl
54 #define _NMAXLDBL data_c_nmaxldbl
60 extern double atof ();
63 /* Nonzero means it is an error to set a symbol whose name starts with
65 int keyword_symbols_constant_flag
;
67 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
68 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
69 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
70 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
71 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
72 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
73 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
74 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
75 Lisp_Object Qtext_read_only
;
76 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
77 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
78 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
79 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
80 Lisp_Object Qboundp
, Qfboundp
;
81 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
84 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
86 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
87 Lisp_Object Qoverflow_error
, Qunderflow_error
;
90 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
92 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
93 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
95 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
96 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
98 static Lisp_Object
swap_in_symval_forwarding ();
100 Lisp_Object
set_internal ();
103 wrong_type_argument (predicate
, value
)
104 register Lisp_Object predicate
, value
;
106 register Lisp_Object tem
;
109 if (!EQ (Vmocklisp_arguments
, Qt
))
111 if (STRINGP (value
) &&
112 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
113 return Fstring_to_number (value
, Qnil
);
114 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
115 return Fnumber_to_string (value
);
118 /* If VALUE is not even a valid Lisp object, abort here
119 where we can get a backtrace showing where it came from. */
120 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
123 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
124 tem
= call1 (predicate
, value
);
133 error ("Attempt to modify read-only object");
137 args_out_of_range (a1
, a2
)
141 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
145 args_out_of_range_3 (a1
, a2
, a3
)
146 Lisp_Object a1
, a2
, a3
;
149 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
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 "Return t if the two args are the same Lisp object.")
174 Lisp_Object obj1
, obj2
;
181 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
190 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
191 "Return a symbol representing the type of OBJECT.\n\
192 The symbol returned names the object's basic type;\n\
193 for example, (type-of 1) returns `integer'.")
197 switch (XGCTYPE (object
))
212 switch (XMISCTYPE (object
))
214 case Lisp_Misc_Marker
:
216 case Lisp_Misc_Overlay
:
218 case Lisp_Misc_Float
:
223 case Lisp_Vectorlike
:
224 if (GC_WINDOW_CONFIGURATIONP (object
))
225 return Qwindow_configuration
;
226 if (GC_PROCESSP (object
))
228 if (GC_WINDOWP (object
))
230 if (GC_SUBRP (object
))
232 if (GC_COMPILEDP (object
))
233 return Qcompiled_function
;
234 if (GC_BUFFERP (object
))
236 if (GC_CHAR_TABLE_P (object
))
238 if (GC_BOOL_VECTOR_P (object
))
240 if (GC_FRAMEP (object
))
242 if (GC_HASH_TABLE_P (object
))
254 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
263 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
264 "Return t if OBJECT is not a cons cell. This includes nil.")
273 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
274 "Return t if OBJECT is a list. This includes nil.")
278 if (CONSP (object
) || NILP (object
))
283 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
284 "Return t if OBJECT is not a list. Lists include nil.")
288 if (CONSP (object
) || NILP (object
))
293 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
294 "Return t if OBJECT is a symbol.")
298 if (SYMBOLP (object
))
303 /* Define this in C to avoid unnecessarily consing up the symbol
305 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
306 "Return t if OBJECT is a keyword.\n\
307 This means that it is a symbol with a print name beginning with `:'\n\
308 interned in the initial obarray.")
313 && XSYMBOL (object
)->name
->data
[0] == ':'
314 && EQ (XSYMBOL (object
)->obarray
, initial_obarray
))
319 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
320 "Return t if OBJECT is a vector.")
324 if (VECTORP (object
))
329 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
330 "Return t if OBJECT is a string.")
334 if (STRINGP (object
))
339 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
340 1, 1, 0, "Return t if OBJECT is a multibyte string.")
344 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
349 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
350 "Return t if OBJECT is a char-table.")
354 if (CHAR_TABLE_P (object
))
359 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
360 Svector_or_char_table_p
, 1, 1, 0,
361 "Return t if OBJECT is a char-table or vector.")
365 if (VECTORP (object
) || CHAR_TABLE_P (object
))
370 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
374 if (BOOL_VECTOR_P (object
))
379 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
383 if (VECTORP (object
) || STRINGP (object
)
384 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
389 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
390 "Return t if OBJECT is a sequence (list or array).")
392 register Lisp_Object object
;
394 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
395 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
400 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
404 if (BUFFERP (object
))
409 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
413 if (MARKERP (object
))
418 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
427 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
428 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
432 if (COMPILEDP (object
))
437 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
438 "Return t if OBJECT is a character (an integer) or a string.")
440 register Lisp_Object object
;
442 if (INTEGERP (object
) || STRINGP (object
))
447 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
451 if (INTEGERP (object
))
456 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
457 "Return t if OBJECT is an integer or a marker (editor pointer).")
459 register Lisp_Object object
;
461 if (MARKERP (object
) || INTEGERP (object
))
466 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
467 "Return t if OBJECT is a nonnegative integer.")
471 if (NATNUMP (object
))
476 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
477 "Return t if OBJECT is a number (floating point or integer).")
481 if (NUMBERP (object
))
487 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
488 Snumber_or_marker_p
, 1, 1, 0,
489 "Return t if OBJECT is a number or a marker.")
493 if (NUMBERP (object
) || MARKERP (object
))
498 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
499 "Return t if OBJECT is a floating point number.")
509 /* Extract and set components of lists */
511 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
512 "Return the car of LIST. If arg is nil, return nil.\n\
513 Error if arg is not nil and not a cons cell. See also `car-safe'.")
515 register Lisp_Object list
;
521 else if (EQ (list
, Qnil
))
524 list
= wrong_type_argument (Qlistp
, list
);
528 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
529 "Return the car of OBJECT if it is a cons cell, or else nil.")
534 return XCAR (object
);
539 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
540 "Return the cdr of LIST. If arg is nil, return nil.\n\
541 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
544 register Lisp_Object list
;
550 else if (EQ (list
, Qnil
))
553 list
= wrong_type_argument (Qlistp
, list
);
557 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
558 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
563 return XCDR (object
);
568 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
569 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
571 register Lisp_Object cell
, newcar
;
574 cell
= wrong_type_argument (Qconsp
, cell
);
577 XCAR (cell
) = newcar
;
581 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
582 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
584 register Lisp_Object cell
, newcdr
;
587 cell
= wrong_type_argument (Qconsp
, cell
);
590 XCDR (cell
) = newcdr
;
594 /* Extract and set components of symbols */
596 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
598 register Lisp_Object symbol
;
600 Lisp_Object valcontents
;
601 CHECK_SYMBOL (symbol
, 0);
603 valcontents
= XSYMBOL (symbol
)->value
;
605 if (BUFFER_LOCAL_VALUEP (valcontents
)
606 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
607 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
609 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
612 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
614 register Lisp_Object symbol
;
616 CHECK_SYMBOL (symbol
, 0);
617 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
620 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
622 register Lisp_Object symbol
;
624 CHECK_SYMBOL (symbol
, 0);
625 if (NILP (symbol
) || EQ (symbol
, Qt
)
626 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
627 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
628 && keyword_symbols_constant_flag
))
629 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
630 Fset (symbol
, Qunbound
);
634 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
636 register Lisp_Object symbol
;
638 CHECK_SYMBOL (symbol
, 0);
639 if (NILP (symbol
) || EQ (symbol
, Qt
))
640 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
641 XSYMBOL (symbol
)->function
= Qunbound
;
645 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
646 "Return SYMBOL's function definition. Error if that is void.")
648 register Lisp_Object symbol
;
650 CHECK_SYMBOL (symbol
, 0);
651 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
652 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
653 return XSYMBOL (symbol
)->function
;
656 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
658 register Lisp_Object symbol
;
660 CHECK_SYMBOL (symbol
, 0);
661 return XSYMBOL (symbol
)->plist
;
664 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
666 register Lisp_Object symbol
;
668 register Lisp_Object name
;
670 CHECK_SYMBOL (symbol
, 0);
671 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
675 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
676 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
678 register Lisp_Object symbol
, definition
;
680 CHECK_SYMBOL (symbol
, 0);
681 if (NILP (symbol
) || EQ (symbol
, Qt
))
682 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
683 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
684 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
686 XSYMBOL (symbol
)->function
= definition
;
687 /* Handle automatic advice activation */
688 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
690 call2 (Qad_activate_internal
, symbol
, Qnil
);
691 definition
= XSYMBOL (symbol
)->function
;
696 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
697 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
698 Associates the function with the current load file, if any.")
700 register Lisp_Object symbol
, definition
;
702 definition
= Ffset (symbol
, definition
);
703 LOADHIST_ATTACH (symbol
);
707 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
708 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
710 register Lisp_Object symbol
, newplist
;
712 CHECK_SYMBOL (symbol
, 0);
713 XSYMBOL (symbol
)->plist
= newplist
;
718 /* Getting and setting values of symbols */
720 /* Given the raw contents of a symbol value cell,
721 return the Lisp value of the symbol.
722 This does not handle buffer-local variables; use
723 swap_in_symval_forwarding for that. */
726 do_symval_forwarding (valcontents
)
727 register Lisp_Object valcontents
;
729 register Lisp_Object val
;
731 if (MISCP (valcontents
))
732 switch (XMISCTYPE (valcontents
))
734 case Lisp_Misc_Intfwd
:
735 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
738 case Lisp_Misc_Boolfwd
:
739 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
741 case Lisp_Misc_Objfwd
:
742 return *XOBJFWD (valcontents
)->objvar
;
744 case Lisp_Misc_Buffer_Objfwd
:
745 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
746 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
748 case Lisp_Misc_Kboard_Objfwd
:
749 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
750 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
755 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
756 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
757 buffer-independent contents of the value cell: forwarded just one
758 step past the buffer-localness. */
761 store_symval_forwarding (symbol
, valcontents
, newval
)
763 register Lisp_Object valcontents
, newval
;
765 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
768 switch (XMISCTYPE (valcontents
))
770 case Lisp_Misc_Intfwd
:
771 CHECK_NUMBER (newval
, 1);
772 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
773 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
774 error ("Value out of range for variable `%s'",
775 XSYMBOL (symbol
)->name
->data
);
778 case Lisp_Misc_Boolfwd
:
779 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
782 case Lisp_Misc_Objfwd
:
783 *XOBJFWD (valcontents
)->objvar
= newval
;
786 case Lisp_Misc_Buffer_Objfwd
:
788 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
791 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
792 if (XINT (type
) == -1)
793 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
795 if (! NILP (type
) && ! NILP (newval
)
796 && XTYPE (newval
) != XINT (type
))
797 buffer_slot_type_mismatch (offset
);
799 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
803 case Lisp_Misc_Kboard_Objfwd
:
804 (*(Lisp_Object
*)((char *)current_kboard
805 + XKBOARD_OBJFWD (valcontents
)->offset
))
816 valcontents
= XSYMBOL (symbol
)->value
;
817 if (BUFFER_LOCAL_VALUEP (valcontents
)
818 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
819 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
821 XSYMBOL (symbol
)->value
= newval
;
825 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
826 VALCONTENTS is the contents of its value cell.
827 Return the value forwarded one step past the buffer-local indicator. */
830 swap_in_symval_forwarding (symbol
, valcontents
)
831 Lisp_Object symbol
, valcontents
;
833 /* valcontents is a pointer to a struct resembling the cons
834 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
836 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
837 local_var_alist, that being the element whose car is this
838 variable. Or it can be a pointer to the
839 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
840 an element in its alist for this variable.
842 If the current buffer is not BUFFER, we store the current
843 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
844 appropriate alist element for the buffer now current and set up
845 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
846 element, and store into BUFFER.
848 Note that REALVALUE can be a forwarding pointer. */
850 register Lisp_Object tem1
;
851 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
853 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
)
854 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
856 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
858 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
859 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
860 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
861 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
864 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
865 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
867 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
869 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
872 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
874 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = tem1
;
875 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
876 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
877 store_symval_forwarding (symbol
,
878 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
881 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
884 /* Find the value of a symbol, returning Qunbound if it's not bound.
885 This is helpful for code which just wants to get a variable's value
886 if it has one, without signaling an error.
887 Note that it must not be possible to quit
888 within this function. Great care is required for this. */
891 find_symbol_value (symbol
)
894 register Lisp_Object valcontents
;
895 register Lisp_Object val
;
896 CHECK_SYMBOL (symbol
, 0);
897 valcontents
= XSYMBOL (symbol
)->value
;
899 if (BUFFER_LOCAL_VALUEP (valcontents
)
900 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
901 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
,
904 if (MISCP (valcontents
))
906 switch (XMISCTYPE (valcontents
))
908 case Lisp_Misc_Intfwd
:
909 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
912 case Lisp_Misc_Boolfwd
:
913 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
915 case Lisp_Misc_Objfwd
:
916 return *XOBJFWD (valcontents
)->objvar
;
918 case Lisp_Misc_Buffer_Objfwd
:
919 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
920 + (char *)current_buffer
);
922 case Lisp_Misc_Kboard_Objfwd
:
923 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
924 + (char *)current_kboard
);
931 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
932 "Return SYMBOL's value. Error if that is void.")
938 val
= find_symbol_value (symbol
);
939 if (EQ (val
, Qunbound
))
940 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
945 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
946 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
948 register Lisp_Object symbol
, newval
;
950 return set_internal (symbol
, newval
, current_buffer
, 0);
953 /* Return 1 if SYMBOL currently has a let-binding
954 which was made in the buffer that is now current. */
957 let_shadows_buffer_binding_p (symbol
)
960 struct specbinding
*p
;
962 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
965 && EQ (symbol
, XCAR (p
->symbol
))
966 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
972 /* Store the value NEWVAL into SYMBOL.
973 If buffer-locality is an issue, BUF specifies which buffer to use.
974 (0 stands for the current buffer.)
976 If BINDFLAG is zero, then if this symbol is supposed to become
977 local in every buffer where it is set, then we make it local.
978 If BINDFLAG is nonzero, we don't do that. */
981 set_internal (symbol
, newval
, buf
, bindflag
)
982 register Lisp_Object symbol
, newval
;
986 int voide
= EQ (newval
, Qunbound
);
988 register Lisp_Object valcontents
, tem1
, current_alist_element
;
991 buf
= current_buffer
;
993 /* If restoring in a dead buffer, do nothing. */
994 if (NILP (buf
->name
))
997 CHECK_SYMBOL (symbol
, 0);
998 if (NILP (symbol
) || EQ (symbol
, Qt
)
999 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
1000 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
1001 && keyword_symbols_constant_flag
&& ! EQ (newval
, symbol
)))
1002 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1003 valcontents
= XSYMBOL (symbol
)->value
;
1005 if (BUFFER_OBJFWDP (valcontents
))
1007 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1008 register int mask
= XINT (*((Lisp_Object
*)
1009 (idx
+ (char *)&buffer_local_flags
)));
1010 if (mask
> 0 && ! bindflag
1011 && ! let_shadows_buffer_binding_p (symbol
))
1012 buf
->local_var_flags
|= mask
;
1015 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1016 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1018 /* valcontents is actually a pointer to a struct resembling a cons,
1019 with contents something like:
1020 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
1022 BUFFER is the last buffer for which this symbol's value was
1025 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
1026 local_var_alist, that being the element whose car is this
1027 variable. Or it can be a pointer to the
1028 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
1029 have an element in its alist for this variable (that is, if
1030 BUFFER sees the default value of this variable).
1032 If we want to examine or set the value and BUFFER is current,
1033 we just examine or set REALVALUE. If BUFFER is not current, we
1034 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
1035 then find the appropriate alist element for the buffer now
1036 current and set up CURRENT-ALIST-ELEMENT. Then we set
1037 REALVALUE out of that element, and store into BUFFER.
1039 If we are setting the variable and the current buffer does
1040 not have an alist entry for this variable, an alist entry is
1043 Note that REALVALUE can be a forwarding pointer. Each time
1044 it is examined or set, forwarding must be done. */
1046 /* What value are we caching right now? */
1047 current_alist_element
1048 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1050 /* If the current buffer is not the buffer whose binding is
1051 currently cached, or if it's a Lisp_Buffer_Local_Value and
1052 we're looking at the default value, the cache is invalid; we
1053 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
1054 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
1055 ? !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)
1056 : (buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1057 || (BUFFER_LOCAL_VALUEP (valcontents
)
1058 && EQ (XCAR (current_alist_element
),
1059 current_alist_element
))))
1061 /* Write out the cached value for the old buffer; copy it
1062 back to its alist element. This works if the current
1063 buffer only sees the default value, too. */
1064 Fsetcdr (current_alist_element
,
1065 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1067 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1068 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1069 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1070 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1074 /* This buffer still sees the default value. */
1076 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1077 or if this is `let' rather than `set',
1078 make CURRENT-ALIST-ELEMENT point to itself,
1079 indicating that we're seeing the default value.
1080 Likewise if the variable has been let-bound
1081 in the current buffer. */
1082 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1083 || let_shadows_buffer_binding_p (symbol
))
1085 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1087 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1088 tem1
= Fassq (symbol
,
1089 XFRAME (selected_frame
)->param_alist
);
1092 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1094 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1096 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1097 and we're not within a let that was made for this buffer,
1098 create a new buffer-local binding for the variable.
1099 That means, give this buffer a new assoc for a local value
1100 and set CURRENT-ALIST-ELEMENT to point to that. */
1103 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1104 buf
->local_var_alist
1105 = Fcons (tem1
, buf
->local_var_alist
);
1109 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1110 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1113 /* Set BUFFER and FRAME for binding now loaded. */
1114 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1115 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1117 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1120 /* If storing void (making the symbol void), forward only through
1121 buffer-local indicator, not through Lisp_Objfwd, etc. */
1123 store_symval_forwarding (symbol
, Qnil
, newval
);
1125 store_symval_forwarding (symbol
, valcontents
, newval
);
1130 /* Access or set a buffer-local symbol's default value. */
1132 /* Return the default value of SYMBOL, but don't check for voidness.
1133 Return Qunbound if it is void. */
1136 default_value (symbol
)
1139 register Lisp_Object valcontents
;
1141 CHECK_SYMBOL (symbol
, 0);
1142 valcontents
= XSYMBOL (symbol
)->value
;
1144 /* For a built-in buffer-local variable, get the default value
1145 rather than letting do_symval_forwarding get the current value. */
1146 if (BUFFER_OBJFWDP (valcontents
))
1148 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1150 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1151 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1154 /* Handle user-created local variables. */
1155 if (BUFFER_LOCAL_VALUEP (valcontents
)
1156 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1158 /* If var is set up for a buffer that lacks a local value for it,
1159 the current value is nominally the default value.
1160 But the current value slot may be more up to date, since
1161 ordinary setq stores just that slot. So use that. */
1162 Lisp_Object current_alist_element
, alist_element_car
;
1163 current_alist_element
1164 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1165 alist_element_car
= XCAR (current_alist_element
);
1166 if (EQ (alist_element_car
, current_alist_element
))
1167 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1169 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1171 /* For other variables, get the current value. */
1172 return do_symval_forwarding (valcontents
);
1175 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1176 "Return t if SYMBOL has a non-void default value.\n\
1177 This is the value that is seen in buffers that do not have their own values\n\
1178 for this variable.")
1182 register Lisp_Object value
;
1184 value
= default_value (symbol
);
1185 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1188 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1189 "Return SYMBOL's default value.\n\
1190 This is the value that is seen in buffers that do not have their own values\n\
1191 for this variable. The default value is meaningful for variables with\n\
1192 local bindings in certain buffers.")
1196 register Lisp_Object value
;
1198 value
= default_value (symbol
);
1199 if (EQ (value
, Qunbound
))
1200 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1204 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1205 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1206 The default value is seen in buffers that do not have their own values\n\
1207 for this variable.")
1209 Lisp_Object symbol
, value
;
1211 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1213 CHECK_SYMBOL (symbol
, 0);
1214 valcontents
= XSYMBOL (symbol
)->value
;
1216 /* Handle variables like case-fold-search that have special slots
1217 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1219 if (BUFFER_OBJFWDP (valcontents
))
1221 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1222 register struct buffer
*b
;
1223 register int mask
= XINT (*((Lisp_Object
*)
1224 (idx
+ (char *)&buffer_local_flags
)));
1226 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1228 /* If this variable is not always local in all buffers,
1229 set it in the buffers that don't nominally have a local value. */
1232 for (b
= all_buffers
; b
; b
= b
->next
)
1233 if (!(b
->local_var_flags
& mask
))
1234 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1239 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1240 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1241 return Fset (symbol
, value
);
1243 /* Store new value into the DEFAULT-VALUE slot */
1244 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1246 /* If that slot is current, we must set the REALVALUE slot too */
1247 current_alist_element
1248 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1249 alist_element_buffer
= Fcar (current_alist_element
);
1250 if (EQ (alist_element_buffer
, current_alist_element
))
1251 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1257 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1258 "Set the default value of variable VAR to VALUE.\n\
1259 VAR, the variable name, is literal (not evaluated);\n\
1260 VALUE is an expression and it is evaluated.\n\
1261 The default value of a variable is seen in buffers\n\
1262 that do not have their own values for the variable.\n\
1264 More generally, you can use multiple variables and values, as in\n\
1265 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1266 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1267 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1272 register Lisp_Object args_left
;
1273 register Lisp_Object val
, symbol
;
1274 struct gcpro gcpro1
;
1284 val
= Feval (Fcar (Fcdr (args_left
)));
1285 symbol
= Fcar (args_left
);
1286 Fset_default (symbol
, val
);
1287 args_left
= Fcdr (Fcdr (args_left
));
1289 while (!NILP (args_left
));
1295 /* Lisp functions for creating and removing buffer-local variables. */
1297 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1298 1, 1, "vMake Variable Buffer Local: ",
1299 "Make VARIABLE have a separate value for each buffer.\n\
1300 At any time, the value for the current buffer is in effect.\n\
1301 There is also a default value which is seen in any buffer which has not yet\n\
1302 set its own value.\n\
1303 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1304 for the current buffer if it was previously using the default value.\n\
1305 The function `default-value' gets the default value and `set-default' sets it.")
1307 register Lisp_Object variable
;
1309 register Lisp_Object tem
, valcontents
, newval
;
1311 CHECK_SYMBOL (variable
, 0);
1313 valcontents
= XSYMBOL (variable
)->value
;
1314 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1315 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1317 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1319 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1321 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1324 if (EQ (valcontents
, Qunbound
))
1325 XSYMBOL (variable
)->value
= Qnil
;
1326 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1328 newval
= allocate_misc ();
1329 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1330 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1331 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1332 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1333 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 1;
1334 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1335 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1336 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1337 XSYMBOL (variable
)->value
= newval
;
1341 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1342 1, 1, "vMake Local Variable: ",
1343 "Make VARIABLE have a separate value in the current buffer.\n\
1344 Other buffers will continue to share a common default value.\n\
1345 \(The buffer-local value of VARIABLE starts out as the same value\n\
1346 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1347 See also `make-variable-buffer-local'.\n\
1349 If the variable is already arranged to become local when set,\n\
1350 this function causes a local value to exist for this buffer,\n\
1351 just as setting the variable would do.\n\
1353 This function returns VARIABLE, and therefore\n\
1354 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1357 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1358 Use `make-local-hook' instead.")
1360 register Lisp_Object variable
;
1362 register Lisp_Object tem
, valcontents
;
1364 CHECK_SYMBOL (variable
, 0);
1366 valcontents
= XSYMBOL (variable
)->value
;
1367 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1368 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1370 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1372 tem
= Fboundp (variable
);
1374 /* Make sure the symbol has a local value in this particular buffer,
1375 by setting it to the same value it already has. */
1376 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1379 /* Make sure symbol is set up to hold per-buffer values */
1380 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1383 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1385 newval
= allocate_misc ();
1386 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1387 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1388 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1389 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1390 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1391 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1392 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1393 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1394 XSYMBOL (variable
)->value
= newval
;
1396 /* Make sure this buffer has its own value of symbol */
1397 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1400 /* Swap out any local binding for some other buffer, and make
1401 sure the current value is permanently recorded, if it's the
1403 find_symbol_value (variable
);
1405 current_buffer
->local_var_alist
1406 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1407 current_buffer
->local_var_alist
);
1409 /* Make sure symbol does not think it is set up for this buffer;
1410 force it to look once again for this buffer's value */
1412 Lisp_Object
*pvalbuf
;
1414 valcontents
= XSYMBOL (variable
)->value
;
1416 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1417 if (current_buffer
== XBUFFER (*pvalbuf
))
1419 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1423 /* If the symbol forwards into a C variable, then swap in the
1424 variable for this buffer immediately. If C code modifies the
1425 variable before we swap in, then that new value will clobber the
1426 default value the next time we swap. */
1427 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1428 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1429 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1434 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1435 1, 1, "vKill Local Variable: ",
1436 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1437 From now on the default value will apply in this buffer.")
1439 register Lisp_Object variable
;
1441 register Lisp_Object tem
, valcontents
;
1443 CHECK_SYMBOL (variable
, 0);
1445 valcontents
= XSYMBOL (variable
)->value
;
1447 if (BUFFER_OBJFWDP (valcontents
))
1449 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1450 register int mask
= XINT (*((Lisp_Object
*)
1451 (idx
+ (char *)&buffer_local_flags
)));
1455 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1456 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1457 current_buffer
->local_var_flags
&= ~mask
;
1462 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1463 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1466 /* Get rid of this buffer's alist element, if any */
1468 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1470 current_buffer
->local_var_alist
1471 = Fdelq (tem
, current_buffer
->local_var_alist
);
1473 /* If the symbol is set up for the current buffer, recompute its
1474 value. We have to do it now, or else forwarded objects won't
1477 Lisp_Object
*pvalbuf
;
1478 valcontents
= XSYMBOL (variable
)->value
;
1479 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1480 if (current_buffer
== XBUFFER (*pvalbuf
))
1483 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1484 find_symbol_value (variable
);
1491 /* Lisp functions for creating and removing buffer-local variables. */
1493 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1494 1, 1, "vMake Variable Frame Local: ",
1495 "Enable VARIABLE to have frame-local bindings.\n\
1496 When a frame-local binding exists in the current frame,\n\
1497 it is in effect whenever the current buffer has no buffer-local binding.\n\
1498 A frame-local binding is actual a frame parameter value;\n\
1499 thus, any given frame has a local binding for VARIABLE\n\
1500 if it has a value for the frame parameter named VARIABLE.\n\
1501 See `modify-frame-parameters'.")
1503 register Lisp_Object variable
;
1505 register Lisp_Object tem
, valcontents
, newval
;
1507 CHECK_SYMBOL (variable
, 0);
1509 valcontents
= XSYMBOL (variable
)->value
;
1510 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1511 || BUFFER_OBJFWDP (valcontents
))
1512 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1514 if (BUFFER_LOCAL_VALUEP (valcontents
)
1515 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1518 if (EQ (valcontents
, Qunbound
))
1519 XSYMBOL (variable
)->value
= Qnil
;
1520 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1522 newval
= allocate_misc ();
1523 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1524 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1525 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1526 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1527 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1528 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1529 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1530 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1531 XSYMBOL (variable
)->value
= newval
;
1535 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1537 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1538 BUFFER defaults to the current buffer.")
1540 register Lisp_Object variable
, buffer
;
1542 Lisp_Object valcontents
;
1543 register struct buffer
*buf
;
1546 buf
= current_buffer
;
1549 CHECK_BUFFER (buffer
, 0);
1550 buf
= XBUFFER (buffer
);
1553 CHECK_SYMBOL (variable
, 0);
1555 valcontents
= XSYMBOL (variable
)->value
;
1556 if (BUFFER_LOCAL_VALUEP (valcontents
)
1557 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1559 Lisp_Object tail
, elt
;
1560 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1563 if (EQ (variable
, XCAR (elt
)))
1567 if (BUFFER_OBJFWDP (valcontents
))
1569 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1570 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1571 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1577 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1579 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1580 BUFFER defaults to the current buffer.")
1582 register Lisp_Object variable
, buffer
;
1584 Lisp_Object valcontents
;
1585 register struct buffer
*buf
;
1588 buf
= current_buffer
;
1591 CHECK_BUFFER (buffer
, 0);
1592 buf
= XBUFFER (buffer
);
1595 CHECK_SYMBOL (variable
, 0);
1597 valcontents
= XSYMBOL (variable
)->value
;
1599 /* This means that make-variable-buffer-local was done. */
1600 if (BUFFER_LOCAL_VALUEP (valcontents
))
1602 /* All these slots become local if they are set. */
1603 if (BUFFER_OBJFWDP (valcontents
))
1605 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1607 Lisp_Object tail
, elt
;
1608 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1611 if (EQ (variable
, XCAR (elt
)))
1618 /* Find the function at the end of a chain of symbol function indirections. */
1620 /* If OBJECT is a symbol, find the end of its function chain and
1621 return the value found there. If OBJECT is not a symbol, just
1622 return it. If there is a cycle in the function chain, signal a
1623 cyclic-function-indirection error.
1625 This is like Findirect_function, except that it doesn't signal an
1626 error if the chain ends up unbound. */
1628 indirect_function (object
)
1629 register Lisp_Object object
;
1631 Lisp_Object tortoise
, hare
;
1633 hare
= tortoise
= object
;
1637 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1639 hare
= XSYMBOL (hare
)->function
;
1640 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1642 hare
= XSYMBOL (hare
)->function
;
1644 tortoise
= XSYMBOL (tortoise
)->function
;
1646 if (EQ (hare
, tortoise
))
1647 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1653 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1654 "Return the function at the end of OBJECT's function chain.\n\
1655 If OBJECT is a symbol, follow all function indirections and return the final\n\
1656 function binding.\n\
1657 If OBJECT is not a symbol, just return it.\n\
1658 Signal a void-function error if the final symbol is unbound.\n\
1659 Signal a cyclic-function-indirection error if there is a loop in the\n\
1660 function chain of symbols.")
1662 register Lisp_Object object
;
1666 result
= indirect_function (object
);
1668 if (EQ (result
, Qunbound
))
1669 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1673 /* Extract and set vector and string elements */
1675 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1676 "Return the element of ARRAY at index IDX.\n\
1677 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1678 or a byte-code object. IDX starts at 0.")
1680 register Lisp_Object array
;
1683 register int idxval
;
1685 CHECK_NUMBER (idx
, 1);
1686 idxval
= XINT (idx
);
1687 if (STRINGP (array
))
1691 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1692 args_out_of_range (array
, idx
);
1693 if (! STRING_MULTIBYTE (array
))
1694 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1695 idxval_byte
= string_char_to_byte (array
, idxval
);
1697 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1698 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1699 return make_number (c
);
1701 else if (BOOL_VECTOR_P (array
))
1705 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1706 args_out_of_range (array
, idx
);
1708 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1709 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1711 else if (CHAR_TABLE_P (array
))
1716 args_out_of_range (array
, idx
);
1717 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1719 /* For ASCII and 8-bit European characters, the element is
1720 stored in the top table. */
1721 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1723 val
= XCHAR_TABLE (array
)->defalt
;
1724 while (NILP (val
)) /* Follow parents until we find some value. */
1726 array
= XCHAR_TABLE (array
)->parent
;
1729 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1731 val
= XCHAR_TABLE (array
)->defalt
;
1738 Lisp_Object sub_table
;
1740 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1741 if (code
[1] < 32) code
[1] = -1;
1742 else if (code
[2] < 32) code
[2] = -1;
1744 /* Here, the possible range of CODE[0] (== charset ID) is
1745 128..MAX_CHARSET. Since the top level char table contains
1746 data for multibyte characters after 256th element, we must
1747 increment CODE[0] by 128 to get a correct index. */
1749 code
[3] = -1; /* anchor */
1751 try_parent_char_table
:
1753 for (i
= 0; code
[i
] >= 0; i
++)
1755 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1756 if (SUB_CHAR_TABLE_P (val
))
1761 val
= XCHAR_TABLE (sub_table
)->defalt
;
1764 array
= XCHAR_TABLE (array
)->parent
;
1766 goto try_parent_char_table
;
1771 /* Here, VAL is a sub char table. We try the default value
1773 val
= XCHAR_TABLE (val
)->defalt
;
1776 array
= XCHAR_TABLE (array
)->parent
;
1778 goto try_parent_char_table
;
1786 if (VECTORP (array
))
1787 size
= XVECTOR (array
)->size
;
1788 else if (COMPILEDP (array
))
1789 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1791 wrong_type_argument (Qarrayp
, array
);
1793 if (idxval
< 0 || idxval
>= size
)
1794 args_out_of_range (array
, idx
);
1795 return XVECTOR (array
)->contents
[idxval
];
1799 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1800 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1801 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1803 (array
, idx
, newelt
)
1804 register Lisp_Object array
;
1805 Lisp_Object idx
, newelt
;
1807 register int idxval
;
1809 CHECK_NUMBER (idx
, 1);
1810 idxval
= XINT (idx
);
1811 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1812 && ! CHAR_TABLE_P (array
))
1813 array
= wrong_type_argument (Qarrayp
, array
);
1814 CHECK_IMPURE (array
);
1816 if (VECTORP (array
))
1818 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1819 args_out_of_range (array
, idx
);
1820 XVECTOR (array
)->contents
[idxval
] = newelt
;
1822 else if (BOOL_VECTOR_P (array
))
1826 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1827 args_out_of_range (array
, idx
);
1829 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1831 if (! NILP (newelt
))
1832 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1834 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1835 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1837 else if (CHAR_TABLE_P (array
))
1840 args_out_of_range (array
, idx
);
1841 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1842 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1848 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1849 if (code
[1] < 32) code
[1] = -1;
1850 else if (code
[2] < 32) code
[2] = -1;
1852 /* See the comment of the corresponding part in Faref. */
1854 code
[3] = -1; /* anchor */
1855 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1857 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1858 if (SUB_CHAR_TABLE_P (val
))
1864 /* VAL is a leaf. Create a sub char table with the
1865 default value VAL or XCHAR_TABLE (array)->defalt
1866 and look into it. */
1868 temp
= make_sub_char_table (NILP (val
)
1869 ? XCHAR_TABLE (array
)->defalt
1871 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1875 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1878 else if (STRING_MULTIBYTE (array
))
1880 int idxval_byte
, new_len
, actual_len
;
1882 unsigned char *p
, workbuf
[MAX_MULTIBYTE_LENGTH
], *str
= workbuf
;
1884 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1885 args_out_of_range (array
, idx
);
1887 idxval_byte
= string_char_to_byte (array
, idxval
);
1888 p
= &XSTRING (array
)->data
[idxval_byte
];
1890 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1891 CHECK_NUMBER (newelt
, 2);
1892 new_len
= CHAR_STRING (XINT (newelt
), str
);
1893 if (actual_len
!= new_len
)
1894 error ("Attempt to change byte length of a string");
1896 /* We can't accept a change causing byte combining. */
1897 if (!ASCII_BYTE_P (*str
)
1898 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1899 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1900 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1901 > idxval_byte
- prev_byte
))
1902 || (idxval
< XSTRING (array
)->size
- 1
1903 && !CHAR_HEAD_P (p
[actual_len
])
1904 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1905 error ("Attempt to change char length of a string");
1911 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1912 args_out_of_range (array
, idx
);
1913 CHECK_NUMBER (newelt
, 2);
1914 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1920 /* Arithmetic functions */
1922 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1925 arithcompare (num1
, num2
, comparison
)
1926 Lisp_Object num1
, num2
;
1927 enum comparison comparison
;
1932 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1933 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1935 if (FLOATP (num1
) || FLOATP (num2
))
1938 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1939 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1945 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1950 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1955 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1960 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1965 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1970 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1979 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1980 "Return t if two args, both numbers or markers, are equal.")
1982 register Lisp_Object num1
, num2
;
1984 return arithcompare (num1
, num2
, equal
);
1987 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1988 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1990 register Lisp_Object num1
, num2
;
1992 return arithcompare (num1
, num2
, less
);
1995 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1996 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1998 register Lisp_Object num1
, num2
;
2000 return arithcompare (num1
, num2
, grtr
);
2003 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2004 "Return t if first arg is less than or equal to second arg.\n\
2005 Both must be numbers or markers.")
2007 register Lisp_Object num1
, num2
;
2009 return arithcompare (num1
, num2
, less_or_equal
);
2012 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2013 "Return t if first arg is greater than or equal to second arg.\n\
2014 Both must be numbers or markers.")
2016 register Lisp_Object num1
, num2
;
2018 return arithcompare (num1
, num2
, grtr_or_equal
);
2021 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2022 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
2024 register Lisp_Object num1
, num2
;
2026 return arithcompare (num1
, num2
, notequal
);
2029 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2031 register Lisp_Object number
;
2033 CHECK_NUMBER_OR_FLOAT (number
, 0);
2035 if (FLOATP (number
))
2037 if (XFLOAT_DATA (number
) == 0.0)
2047 /* Convert between long values and pairs of Lisp integers. */
2053 unsigned int top
= i
>> 16;
2054 unsigned int bot
= i
& 0xFFFF;
2056 return make_number (bot
);
2057 if (top
== (unsigned long)-1 >> 16)
2058 return Fcons (make_number (-1), make_number (bot
));
2059 return Fcons (make_number (top
), make_number (bot
));
2066 Lisp_Object top
, bot
;
2073 return ((XINT (top
) << 16) | XINT (bot
));
2076 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2077 "Convert NUMBER to a string by printing it in decimal.\n\
2078 Uses a minus sign if negative.\n\
2079 NUMBER may be an integer or a floating point number.")
2083 char buffer
[VALBITS
];
2085 CHECK_NUMBER_OR_FLOAT (number
, 0);
2087 if (FLOATP (number
))
2089 char pigbuf
[350]; /* see comments in float_to_string */
2091 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2092 return build_string (pigbuf
);
2095 if (sizeof (int) == sizeof (EMACS_INT
))
2096 sprintf (buffer
, "%d", XINT (number
));
2097 else if (sizeof (long) == sizeof (EMACS_INT
))
2098 sprintf (buffer
, "%ld", (long) XINT (number
));
2101 return build_string (buffer
);
2105 digit_to_number (character
, base
)
2106 int character
, base
;
2110 if (character
>= '0' && character
<= '9')
2111 digit
= character
- '0';
2112 else if (character
>= 'a' && character
<= 'z')
2113 digit
= character
- 'a' + 10;
2114 else if (character
>= 'A' && character
<= 'Z')
2115 digit
= character
- 'A' + 10;
2125 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2126 "Convert STRING to a number by parsing it as a decimal number.\n\
2127 This parses both integers and floating point numbers.\n\
2128 It ignores leading spaces and tabs.\n\
2130 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2131 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2132 If the base used is not 10, floating point is not recognized.")
2134 register Lisp_Object string
, base
;
2136 register unsigned char *p
;
2137 register int b
, v
= 0;
2140 CHECK_STRING (string
, 0);
2146 CHECK_NUMBER (base
, 1);
2148 if (b
< 2 || b
> 16)
2149 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2152 p
= XSTRING (string
)->data
;
2154 /* Skip any whitespace at the front of the number. Some versions of
2155 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2156 while (*p
== ' ' || *p
== '\t')
2167 if (isfloat_string (p
) && b
== 10)
2168 return make_float (negative
* atof (p
));
2172 int digit
= digit_to_number (*p
++, b
);
2178 return make_number (negative
* v
);
2183 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2185 extern Lisp_Object
float_arith_driver ();
2186 extern Lisp_Object
fmod_float ();
2189 arith_driver (code
, nargs
, args
)
2192 register Lisp_Object
*args
;
2194 register Lisp_Object val
;
2195 register int argnum
;
2196 register EMACS_INT accum
;
2197 register EMACS_INT next
;
2199 switch (SWITCH_ENUM_CAST (code
))
2212 for (argnum
= 0; argnum
< nargs
; argnum
++)
2214 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2215 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2217 if (FLOATP (val
)) /* time to do serious math */
2218 return (float_arith_driver ((double) accum
, argnum
, code
,
2220 args
[argnum
] = val
; /* runs into a compiler bug. */
2221 next
= XINT (args
[argnum
]);
2222 switch (SWITCH_ENUM_CAST (code
))
2224 case Aadd
: accum
+= next
; break;
2226 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2228 case Amult
: accum
*= next
; break;
2230 if (!argnum
) accum
= next
;
2234 Fsignal (Qarith_error
, Qnil
);
2238 case Alogand
: accum
&= next
; break;
2239 case Alogior
: accum
|= next
; break;
2240 case Alogxor
: accum
^= next
; break;
2241 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2242 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2246 XSETINT (val
, accum
);
2251 #define isnan(x) ((x) != (x))
2254 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2256 register int argnum
;
2259 register Lisp_Object
*args
;
2261 register Lisp_Object val
;
2264 for (; argnum
< nargs
; argnum
++)
2266 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2267 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2271 next
= XFLOAT_DATA (val
);
2275 args
[argnum
] = val
; /* runs into a compiler bug. */
2276 next
= XINT (args
[argnum
]);
2278 switch (SWITCH_ENUM_CAST (code
))
2284 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2294 if (! IEEE_FLOATING_POINT
&& next
== 0)
2295 Fsignal (Qarith_error
, Qnil
);
2302 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2304 if (!argnum
|| isnan (next
) || next
> accum
)
2308 if (!argnum
|| isnan (next
) || next
< accum
)
2314 return make_float (accum
);
2318 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2319 "Return sum of any number of arguments, which are numbers or markers.")
2324 return arith_driver (Aadd
, nargs
, args
);
2327 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2328 "Negate number or subtract numbers or markers.\n\
2329 With one arg, negates it. With more than one arg,\n\
2330 subtracts all but the first from the first.")
2335 return arith_driver (Asub
, nargs
, args
);
2338 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2339 "Returns product of any number of arguments, which are numbers or markers.")
2344 return arith_driver (Amult
, nargs
, args
);
2347 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2348 "Returns first argument divided by all the remaining arguments.\n\
2349 The arguments must be numbers or markers.")
2354 return arith_driver (Adiv
, nargs
, args
);
2357 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2358 "Returns remainder of X divided by Y.\n\
2359 Both must be integers or markers.")
2361 register Lisp_Object x
, y
;
2365 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2366 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2368 if (XFASTINT (y
) == 0)
2369 Fsignal (Qarith_error
, Qnil
);
2371 XSETINT (val
, XINT (x
) % XINT (y
));
2385 /* If the magnitude of the result exceeds that of the divisor, or
2386 the sign of the result does not agree with that of the dividend,
2387 iterate with the reduced value. This does not yield a
2388 particularly accurate result, but at least it will be in the
2389 range promised by fmod. */
2391 r
-= f2
* floor (r
/ f2
);
2392 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2396 #endif /* ! HAVE_FMOD */
2398 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2399 "Returns X modulo Y.\n\
2400 The result falls between zero (inclusive) and Y (exclusive).\n\
2401 Both X and Y must be numbers or markers.")
2403 register Lisp_Object x
, y
;
2408 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2409 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2411 if (FLOATP (x
) || FLOATP (y
))
2412 return fmod_float (x
, y
);
2418 Fsignal (Qarith_error
, Qnil
);
2422 /* If the "remainder" comes out with the wrong sign, fix it. */
2423 if (i2
< 0 ? i1
> 0 : i1
< 0)
2430 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2431 "Return largest of all the arguments (which must be numbers or markers).\n\
2432 The value is always a number; markers are converted to numbers.")
2437 return arith_driver (Amax
, nargs
, args
);
2440 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2441 "Return smallest of all the arguments (which must be numbers or markers).\n\
2442 The value is always a number; markers are converted to numbers.")
2447 return arith_driver (Amin
, nargs
, args
);
2450 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2451 "Return bitwise-and of all the arguments.\n\
2452 Arguments may be integers, or markers converted to integers.")
2457 return arith_driver (Alogand
, nargs
, args
);
2460 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2461 "Return bitwise-or of all the arguments.\n\
2462 Arguments may be integers, or markers converted to integers.")
2467 return arith_driver (Alogior
, nargs
, args
);
2470 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2471 "Return bitwise-exclusive-or of all the arguments.\n\
2472 Arguments may be integers, or markers converted to integers.")
2477 return arith_driver (Alogxor
, nargs
, args
);
2480 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2481 "Return VALUE with its bits shifted left by COUNT.\n\
2482 If COUNT is negative, shifting is actually to the right.\n\
2483 In this case, the sign bit is duplicated.")
2485 register Lisp_Object value
, count
;
2487 register Lisp_Object val
;
2489 CHECK_NUMBER (value
, 0);
2490 CHECK_NUMBER (count
, 1);
2492 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2494 else if (XINT (count
) > 0)
2495 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2496 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2497 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2499 XSETINT (val
, XINT (value
) >> -XINT (count
));
2503 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2504 "Return VALUE with its bits shifted left by COUNT.\n\
2505 If COUNT is negative, shifting is actually to the right.\n\
2506 In this case, zeros are shifted in on the left.")
2508 register Lisp_Object value
, count
;
2510 register Lisp_Object val
;
2512 CHECK_NUMBER (value
, 0);
2513 CHECK_NUMBER (count
, 1);
2515 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2517 else if (XINT (count
) > 0)
2518 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2519 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2522 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2526 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2527 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2528 Markers are converted to integers.")
2530 register Lisp_Object number
;
2532 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2534 if (FLOATP (number
))
2535 return (make_float (1.0 + XFLOAT_DATA (number
)));
2537 XSETINT (number
, XINT (number
) + 1);
2541 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2542 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2543 Markers are converted to integers.")
2545 register Lisp_Object number
;
2547 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2549 if (FLOATP (number
))
2550 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2552 XSETINT (number
, XINT (number
) - 1);
2556 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2557 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2559 register Lisp_Object number
;
2561 CHECK_NUMBER (number
, 0);
2562 XSETINT (number
, ~XINT (number
));
2569 Lisp_Object error_tail
, arith_tail
;
2571 Qquote
= intern ("quote");
2572 Qlambda
= intern ("lambda");
2573 Qsubr
= intern ("subr");
2574 Qerror_conditions
= intern ("error-conditions");
2575 Qerror_message
= intern ("error-message");
2576 Qtop_level
= intern ("top-level");
2578 Qerror
= intern ("error");
2579 Qquit
= intern ("quit");
2580 Qwrong_type_argument
= intern ("wrong-type-argument");
2581 Qargs_out_of_range
= intern ("args-out-of-range");
2582 Qvoid_function
= intern ("void-function");
2583 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2584 Qvoid_variable
= intern ("void-variable");
2585 Qsetting_constant
= intern ("setting-constant");
2586 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2588 Qinvalid_function
= intern ("invalid-function");
2589 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2590 Qno_catch
= intern ("no-catch");
2591 Qend_of_file
= intern ("end-of-file");
2592 Qarith_error
= intern ("arith-error");
2593 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2594 Qend_of_buffer
= intern ("end-of-buffer");
2595 Qbuffer_read_only
= intern ("buffer-read-only");
2596 Qtext_read_only
= intern ("text-read-only");
2597 Qmark_inactive
= intern ("mark-inactive");
2599 Qlistp
= intern ("listp");
2600 Qconsp
= intern ("consp");
2601 Qsymbolp
= intern ("symbolp");
2602 Qkeywordp
= intern ("keywordp");
2603 Qintegerp
= intern ("integerp");
2604 Qnatnump
= intern ("natnump");
2605 Qwholenump
= intern ("wholenump");
2606 Qstringp
= intern ("stringp");
2607 Qarrayp
= intern ("arrayp");
2608 Qsequencep
= intern ("sequencep");
2609 Qbufferp
= intern ("bufferp");
2610 Qvectorp
= intern ("vectorp");
2611 Qchar_or_string_p
= intern ("char-or-string-p");
2612 Qmarkerp
= intern ("markerp");
2613 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2614 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2615 Qboundp
= intern ("boundp");
2616 Qfboundp
= intern ("fboundp");
2618 Qfloatp
= intern ("floatp");
2619 Qnumberp
= intern ("numberp");
2620 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2622 Qchar_table_p
= intern ("char-table-p");
2623 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2625 Qcdr
= intern ("cdr");
2627 /* Handle automatic advice activation */
2628 Qad_advice_info
= intern ("ad-advice-info");
2629 Qad_activate_internal
= intern ("ad-activate-internal");
2631 error_tail
= Fcons (Qerror
, Qnil
);
2633 /* ERROR is used as a signaler for random errors for which nothing else is right */
2635 Fput (Qerror
, Qerror_conditions
,
2637 Fput (Qerror
, Qerror_message
,
2638 build_string ("error"));
2640 Fput (Qquit
, Qerror_conditions
,
2641 Fcons (Qquit
, Qnil
));
2642 Fput (Qquit
, Qerror_message
,
2643 build_string ("Quit"));
2645 Fput (Qwrong_type_argument
, Qerror_conditions
,
2646 Fcons (Qwrong_type_argument
, error_tail
));
2647 Fput (Qwrong_type_argument
, Qerror_message
,
2648 build_string ("Wrong type argument"));
2650 Fput (Qargs_out_of_range
, Qerror_conditions
,
2651 Fcons (Qargs_out_of_range
, error_tail
));
2652 Fput (Qargs_out_of_range
, Qerror_message
,
2653 build_string ("Args out of range"));
2655 Fput (Qvoid_function
, Qerror_conditions
,
2656 Fcons (Qvoid_function
, error_tail
));
2657 Fput (Qvoid_function
, Qerror_message
,
2658 build_string ("Symbol's function definition is void"));
2660 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2661 Fcons (Qcyclic_function_indirection
, error_tail
));
2662 Fput (Qcyclic_function_indirection
, Qerror_message
,
2663 build_string ("Symbol's chain of function indirections contains a loop"));
2665 Fput (Qvoid_variable
, Qerror_conditions
,
2666 Fcons (Qvoid_variable
, error_tail
));
2667 Fput (Qvoid_variable
, Qerror_message
,
2668 build_string ("Symbol's value as variable is void"));
2670 Fput (Qsetting_constant
, Qerror_conditions
,
2671 Fcons (Qsetting_constant
, error_tail
));
2672 Fput (Qsetting_constant
, Qerror_message
,
2673 build_string ("Attempt to set a constant symbol"));
2675 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2676 Fcons (Qinvalid_read_syntax
, error_tail
));
2677 Fput (Qinvalid_read_syntax
, Qerror_message
,
2678 build_string ("Invalid read syntax"));
2680 Fput (Qinvalid_function
, Qerror_conditions
,
2681 Fcons (Qinvalid_function
, error_tail
));
2682 Fput (Qinvalid_function
, Qerror_message
,
2683 build_string ("Invalid function"));
2685 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2686 Fcons (Qwrong_number_of_arguments
, error_tail
));
2687 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2688 build_string ("Wrong number of arguments"));
2690 Fput (Qno_catch
, Qerror_conditions
,
2691 Fcons (Qno_catch
, error_tail
));
2692 Fput (Qno_catch
, Qerror_message
,
2693 build_string ("No catch for tag"));
2695 Fput (Qend_of_file
, Qerror_conditions
,
2696 Fcons (Qend_of_file
, error_tail
));
2697 Fput (Qend_of_file
, Qerror_message
,
2698 build_string ("End of file during parsing"));
2700 arith_tail
= Fcons (Qarith_error
, error_tail
);
2701 Fput (Qarith_error
, Qerror_conditions
,
2703 Fput (Qarith_error
, Qerror_message
,
2704 build_string ("Arithmetic error"));
2706 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2707 Fcons (Qbeginning_of_buffer
, error_tail
));
2708 Fput (Qbeginning_of_buffer
, Qerror_message
,
2709 build_string ("Beginning of buffer"));
2711 Fput (Qend_of_buffer
, Qerror_conditions
,
2712 Fcons (Qend_of_buffer
, error_tail
));
2713 Fput (Qend_of_buffer
, Qerror_message
,
2714 build_string ("End of buffer"));
2716 Fput (Qbuffer_read_only
, Qerror_conditions
,
2717 Fcons (Qbuffer_read_only
, error_tail
));
2718 Fput (Qbuffer_read_only
, Qerror_message
,
2719 build_string ("Buffer is read-only"));
2721 Fput (Qtext_read_only
, Qerror_conditions
,
2722 Fcons (Qtext_read_only
, error_tail
));
2723 Fput (Qtext_read_only
, Qerror_message
,
2724 build_string ("Text is read-only"));
2726 Qrange_error
= intern ("range-error");
2727 Qdomain_error
= intern ("domain-error");
2728 Qsingularity_error
= intern ("singularity-error");
2729 Qoverflow_error
= intern ("overflow-error");
2730 Qunderflow_error
= intern ("underflow-error");
2732 Fput (Qdomain_error
, Qerror_conditions
,
2733 Fcons (Qdomain_error
, arith_tail
));
2734 Fput (Qdomain_error
, Qerror_message
,
2735 build_string ("Arithmetic domain error"));
2737 Fput (Qrange_error
, Qerror_conditions
,
2738 Fcons (Qrange_error
, arith_tail
));
2739 Fput (Qrange_error
, Qerror_message
,
2740 build_string ("Arithmetic range error"));
2742 Fput (Qsingularity_error
, Qerror_conditions
,
2743 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2744 Fput (Qsingularity_error
, Qerror_message
,
2745 build_string ("Arithmetic singularity error"));
2747 Fput (Qoverflow_error
, Qerror_conditions
,
2748 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2749 Fput (Qoverflow_error
, Qerror_message
,
2750 build_string ("Arithmetic overflow error"));
2752 Fput (Qunderflow_error
, Qerror_conditions
,
2753 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2754 Fput (Qunderflow_error
, Qerror_message
,
2755 build_string ("Arithmetic underflow error"));
2757 staticpro (&Qrange_error
);
2758 staticpro (&Qdomain_error
);
2759 staticpro (&Qsingularity_error
);
2760 staticpro (&Qoverflow_error
);
2761 staticpro (&Qunderflow_error
);
2765 staticpro (&Qquote
);
2766 staticpro (&Qlambda
);
2768 staticpro (&Qunbound
);
2769 staticpro (&Qerror_conditions
);
2770 staticpro (&Qerror_message
);
2771 staticpro (&Qtop_level
);
2773 staticpro (&Qerror
);
2775 staticpro (&Qwrong_type_argument
);
2776 staticpro (&Qargs_out_of_range
);
2777 staticpro (&Qvoid_function
);
2778 staticpro (&Qcyclic_function_indirection
);
2779 staticpro (&Qvoid_variable
);
2780 staticpro (&Qsetting_constant
);
2781 staticpro (&Qinvalid_read_syntax
);
2782 staticpro (&Qwrong_number_of_arguments
);
2783 staticpro (&Qinvalid_function
);
2784 staticpro (&Qno_catch
);
2785 staticpro (&Qend_of_file
);
2786 staticpro (&Qarith_error
);
2787 staticpro (&Qbeginning_of_buffer
);
2788 staticpro (&Qend_of_buffer
);
2789 staticpro (&Qbuffer_read_only
);
2790 staticpro (&Qtext_read_only
);
2791 staticpro (&Qmark_inactive
);
2793 staticpro (&Qlistp
);
2794 staticpro (&Qconsp
);
2795 staticpro (&Qsymbolp
);
2796 staticpro (&Qkeywordp
);
2797 staticpro (&Qintegerp
);
2798 staticpro (&Qnatnump
);
2799 staticpro (&Qwholenump
);
2800 staticpro (&Qstringp
);
2801 staticpro (&Qarrayp
);
2802 staticpro (&Qsequencep
);
2803 staticpro (&Qbufferp
);
2804 staticpro (&Qvectorp
);
2805 staticpro (&Qchar_or_string_p
);
2806 staticpro (&Qmarkerp
);
2807 staticpro (&Qbuffer_or_string_p
);
2808 staticpro (&Qinteger_or_marker_p
);
2809 staticpro (&Qfloatp
);
2810 staticpro (&Qnumberp
);
2811 staticpro (&Qnumber_or_marker_p
);
2812 staticpro (&Qchar_table_p
);
2813 staticpro (&Qvector_or_char_table_p
);
2815 staticpro (&Qboundp
);
2816 staticpro (&Qfboundp
);
2818 staticpro (&Qad_advice_info
);
2819 staticpro (&Qad_activate_internal
);
2821 /* Types that type-of returns. */
2822 Qinteger
= intern ("integer");
2823 Qsymbol
= intern ("symbol");
2824 Qstring
= intern ("string");
2825 Qcons
= intern ("cons");
2826 Qmarker
= intern ("marker");
2827 Qoverlay
= intern ("overlay");
2828 Qfloat
= intern ("float");
2829 Qwindow_configuration
= intern ("window-configuration");
2830 Qprocess
= intern ("process");
2831 Qwindow
= intern ("window");
2832 /* Qsubr = intern ("subr"); */
2833 Qcompiled_function
= intern ("compiled-function");
2834 Qbuffer
= intern ("buffer");
2835 Qframe
= intern ("frame");
2836 Qvector
= intern ("vector");
2837 Qchar_table
= intern ("char-table");
2838 Qbool_vector
= intern ("bool-vector");
2839 Qhash_table
= intern ("hash-table");
2841 staticpro (&Qinteger
);
2842 staticpro (&Qsymbol
);
2843 staticpro (&Qstring
);
2845 staticpro (&Qmarker
);
2846 staticpro (&Qoverlay
);
2847 staticpro (&Qfloat
);
2848 staticpro (&Qwindow_configuration
);
2849 staticpro (&Qprocess
);
2850 staticpro (&Qwindow
);
2851 /* staticpro (&Qsubr); */
2852 staticpro (&Qcompiled_function
);
2853 staticpro (&Qbuffer
);
2854 staticpro (&Qframe
);
2855 staticpro (&Qvector
);
2856 staticpro (&Qchar_table
);
2857 staticpro (&Qbool_vector
);
2858 staticpro (&Qhash_table
);
2860 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2861 "Non-nil means it is an error to set a keyword symbol.\n\
2862 A keyword symbol is a symbol whose name starts with a colon (`:').");
2863 keyword_symbols_constant_flag
= 1;
2867 defsubr (&Stype_of
);
2872 defsubr (&Sintegerp
);
2873 defsubr (&Sinteger_or_marker_p
);
2874 defsubr (&Snumberp
);
2875 defsubr (&Snumber_or_marker_p
);
2877 defsubr (&Snatnump
);
2878 defsubr (&Ssymbolp
);
2879 defsubr (&Skeywordp
);
2880 defsubr (&Sstringp
);
2881 defsubr (&Smultibyte_string_p
);
2882 defsubr (&Svectorp
);
2883 defsubr (&Schar_table_p
);
2884 defsubr (&Svector_or_char_table_p
);
2885 defsubr (&Sbool_vector_p
);
2887 defsubr (&Ssequencep
);
2888 defsubr (&Sbufferp
);
2889 defsubr (&Smarkerp
);
2891 defsubr (&Sbyte_code_function_p
);
2892 defsubr (&Schar_or_string_p
);
2895 defsubr (&Scar_safe
);
2896 defsubr (&Scdr_safe
);
2899 defsubr (&Ssymbol_function
);
2900 defsubr (&Sindirect_function
);
2901 defsubr (&Ssymbol_plist
);
2902 defsubr (&Ssymbol_name
);
2903 defsubr (&Smakunbound
);
2904 defsubr (&Sfmakunbound
);
2906 defsubr (&Sfboundp
);
2908 defsubr (&Sdefalias
);
2909 defsubr (&Ssetplist
);
2910 defsubr (&Ssymbol_value
);
2912 defsubr (&Sdefault_boundp
);
2913 defsubr (&Sdefault_value
);
2914 defsubr (&Sset_default
);
2915 defsubr (&Ssetq_default
);
2916 defsubr (&Smake_variable_buffer_local
);
2917 defsubr (&Smake_local_variable
);
2918 defsubr (&Skill_local_variable
);
2919 defsubr (&Smake_variable_frame_local
);
2920 defsubr (&Slocal_variable_p
);
2921 defsubr (&Slocal_variable_if_set_p
);
2924 defsubr (&Snumber_to_string
);
2925 defsubr (&Sstring_to_number
);
2926 defsubr (&Seqlsign
);
2950 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2957 #if defined(USG) && !defined(POSIX_SIGNALS)
2958 /* USG systems forget handlers when they are used;
2959 must reestablish each time */
2960 signal (signo
, arith_error
);
2963 /* VMS systems are like USG. */
2964 signal (signo
, arith_error
);
2968 #else /* not BSD4_1 */
2969 sigsetmask (SIGEMPTYMASK
);
2970 #endif /* not BSD4_1 */
2972 Fsignal (Qarith_error
, Qnil
);
2978 /* Don't do this if just dumping out.
2979 We don't want to call `signal' in this case
2980 so that we don't have trouble with dumping
2981 signal-delivering routines in an inconsistent state. */
2985 #endif /* CANNOT_DUMP */
2986 signal (SIGFPE
, arith_error
);
2989 signal (SIGEMT
, arith_error
);