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 which points to a struct Lisp_Buffer_Local_Value.
829 Return the value forwarded one step past the buffer-local stage.
830 This could be another forwarding pointer. */
833 swap_in_symval_forwarding (symbol
, valcontents
)
834 Lisp_Object symbol
, valcontents
;
836 register Lisp_Object tem1
;
837 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
840 || current_buffer
!= XBUFFER (tem1
)
841 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
842 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
844 /* Unload the previously loaded binding. */
845 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
847 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
848 /* Choose the new binding. */
849 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
850 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
851 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
854 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
855 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
857 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
859 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
862 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
864 /* Load the new binding. */
865 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = tem1
;
866 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
867 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
868 store_symval_forwarding (symbol
,
869 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
872 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
875 /* Find the value of a symbol, returning Qunbound if it's not bound.
876 This is helpful for code which just wants to get a variable's value
877 if it has one, without signaling an error.
878 Note that it must not be possible to quit
879 within this function. Great care is required for this. */
882 find_symbol_value (symbol
)
885 register Lisp_Object valcontents
;
886 register Lisp_Object val
;
887 CHECK_SYMBOL (symbol
, 0);
888 valcontents
= XSYMBOL (symbol
)->value
;
890 if (BUFFER_LOCAL_VALUEP (valcontents
)
891 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
892 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
,
895 if (MISCP (valcontents
))
897 switch (XMISCTYPE (valcontents
))
899 case Lisp_Misc_Intfwd
:
900 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
903 case Lisp_Misc_Boolfwd
:
904 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
906 case Lisp_Misc_Objfwd
:
907 return *XOBJFWD (valcontents
)->objvar
;
909 case Lisp_Misc_Buffer_Objfwd
:
910 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
911 + (char *)current_buffer
);
913 case Lisp_Misc_Kboard_Objfwd
:
914 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
915 + (char *)current_kboard
);
922 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
923 "Return SYMBOL's value. Error if that is void.")
929 val
= find_symbol_value (symbol
);
930 if (EQ (val
, Qunbound
))
931 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
936 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
937 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
939 register Lisp_Object symbol
, newval
;
941 return set_internal (symbol
, newval
, current_buffer
, 0);
944 /* Return 1 if SYMBOL currently has a let-binding
945 which was made in the buffer that is now current. */
948 let_shadows_buffer_binding_p (symbol
)
951 struct specbinding
*p
;
953 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
956 && EQ (symbol
, XCAR (p
->symbol
))
957 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
963 /* Store the value NEWVAL into SYMBOL.
964 If buffer-locality is an issue, BUF specifies which buffer to use.
965 (0 stands for the current buffer.)
967 If BINDFLAG is zero, then if this symbol is supposed to become
968 local in every buffer where it is set, then we make it local.
969 If BINDFLAG is nonzero, we don't do that. */
972 set_internal (symbol
, newval
, buf
, bindflag
)
973 register Lisp_Object symbol
, newval
;
977 int voide
= EQ (newval
, Qunbound
);
979 register Lisp_Object valcontents
, tem1
, current_alist_element
;
982 buf
= current_buffer
;
984 /* If restoring in a dead buffer, do nothing. */
985 if (NILP (buf
->name
))
988 CHECK_SYMBOL (symbol
, 0);
989 if (NILP (symbol
) || EQ (symbol
, Qt
)
990 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
991 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
992 && keyword_symbols_constant_flag
&& ! EQ (newval
, symbol
)))
993 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
994 valcontents
= XSYMBOL (symbol
)->value
;
996 if (BUFFER_OBJFWDP (valcontents
))
998 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
999 register int mask
= XINT (*((Lisp_Object
*)
1000 (idx
+ (char *)&buffer_local_flags
)));
1001 if (mask
> 0 && ! bindflag
1002 && ! let_shadows_buffer_binding_p (symbol
))
1003 buf
->local_var_flags
|= mask
;
1006 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1007 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1009 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1011 /* What binding is loaded right now? */
1012 current_alist_element
1013 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1015 /* If the current buffer is not the buffer whose binding is
1016 loaded, or if there may be frame-local bindings and the frame
1017 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1018 the default binding is loaded, the loaded binding may be the
1020 if (buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1021 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1022 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1023 || (BUFFER_LOCAL_VALUEP (valcontents
)
1024 && EQ (XCAR (current_alist_element
),
1025 current_alist_element
)))
1027 /* The currently loaded binding is not necessarily valid.
1028 We need to unload it, and choose a new binding. */
1030 /* Write out `realvalue' to the old loaded binding. */
1031 Fsetcdr (current_alist_element
,
1032 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1034 /* Find the new binding. */
1035 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1036 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1037 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1041 /* This buffer still sees the default value. */
1043 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1044 or if this is `let' rather than `set',
1045 make CURRENT-ALIST-ELEMENT point to itself,
1046 indicating that we're seeing the default value.
1047 Likewise if the variable has been let-bound
1048 in the current buffer. */
1049 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1050 || let_shadows_buffer_binding_p (symbol
))
1052 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1054 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1055 tem1
= Fassq (symbol
,
1056 XFRAME (selected_frame
)->param_alist
);
1059 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1061 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1063 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1064 and we're not within a let that was made for this buffer,
1065 create a new buffer-local binding for the variable.
1066 That means, give this buffer a new assoc for a local value
1067 and load that binding. */
1070 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1071 buf
->local_var_alist
1072 = Fcons (tem1
, buf
->local_var_alist
);
1076 /* Record which binding is now loaded. */
1077 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1080 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1081 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1082 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1084 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1087 /* If storing void (making the symbol void), forward only through
1088 buffer-local indicator, not through Lisp_Objfwd, etc. */
1090 store_symval_forwarding (symbol
, Qnil
, newval
);
1092 store_symval_forwarding (symbol
, valcontents
, newval
);
1097 /* Access or set a buffer-local symbol's default value. */
1099 /* Return the default value of SYMBOL, but don't check for voidness.
1100 Return Qunbound if it is void. */
1103 default_value (symbol
)
1106 register Lisp_Object valcontents
;
1108 CHECK_SYMBOL (symbol
, 0);
1109 valcontents
= XSYMBOL (symbol
)->value
;
1111 /* For a built-in buffer-local variable, get the default value
1112 rather than letting do_symval_forwarding get the current value. */
1113 if (BUFFER_OBJFWDP (valcontents
))
1115 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1117 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1118 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1121 /* Handle user-created local variables. */
1122 if (BUFFER_LOCAL_VALUEP (valcontents
)
1123 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1125 /* If var is set up for a buffer that lacks a local value for it,
1126 the current value is nominally the default value.
1127 But the `realvalue' slot may be more up to date, since
1128 ordinary setq stores just that slot. So use that. */
1129 Lisp_Object current_alist_element
, alist_element_car
;
1130 current_alist_element
1131 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1132 alist_element_car
= XCAR (current_alist_element
);
1133 if (EQ (alist_element_car
, current_alist_element
))
1134 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1136 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1138 /* For other variables, get the current value. */
1139 return do_symval_forwarding (valcontents
);
1142 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1143 "Return t if SYMBOL has a non-void default value.\n\
1144 This is the value that is seen in buffers that do not have their own values\n\
1145 for this variable.")
1149 register Lisp_Object value
;
1151 value
= default_value (symbol
);
1152 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1155 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1156 "Return SYMBOL's default value.\n\
1157 This is the value that is seen in buffers that do not have their own values\n\
1158 for this variable. The default value is meaningful for variables with\n\
1159 local bindings in certain buffers.")
1163 register Lisp_Object value
;
1165 value
= default_value (symbol
);
1166 if (EQ (value
, Qunbound
))
1167 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1171 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1172 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1173 The default value is seen in buffers that do not have their own values\n\
1174 for this variable.")
1176 Lisp_Object symbol
, value
;
1178 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1180 CHECK_SYMBOL (symbol
, 0);
1181 valcontents
= XSYMBOL (symbol
)->value
;
1183 /* Handle variables like case-fold-search that have special slots
1184 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1186 if (BUFFER_OBJFWDP (valcontents
))
1188 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1189 register struct buffer
*b
;
1190 register int mask
= XINT (*((Lisp_Object
*)
1191 (idx
+ (char *)&buffer_local_flags
)));
1193 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1195 /* If this variable is not always local in all buffers,
1196 set it in the buffers that don't nominally have a local value. */
1199 for (b
= all_buffers
; b
; b
= b
->next
)
1200 if (!(b
->local_var_flags
& mask
))
1201 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1206 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1207 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1208 return Fset (symbol
, value
);
1210 /* Store new value into the DEFAULT-VALUE slot. */
1211 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1213 /* If the default binding is now loaded, set the REALVALUE slot too. */
1214 current_alist_element
1215 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1216 alist_element_buffer
= Fcar (current_alist_element
);
1217 if (EQ (alist_element_buffer
, current_alist_element
))
1218 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1224 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1225 "Set the default value of variable VAR to VALUE.\n\
1226 VAR, the variable name, is literal (not evaluated);\n\
1227 VALUE is an expression and it is evaluated.\n\
1228 The default value of a variable is seen in buffers\n\
1229 that do not have their own values for the variable.\n\
1231 More generally, you can use multiple variables and values, as in\n\
1232 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1233 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1234 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1239 register Lisp_Object args_left
;
1240 register Lisp_Object val
, symbol
;
1241 struct gcpro gcpro1
;
1251 val
= Feval (Fcar (Fcdr (args_left
)));
1252 symbol
= Fcar (args_left
);
1253 Fset_default (symbol
, val
);
1254 args_left
= Fcdr (Fcdr (args_left
));
1256 while (!NILP (args_left
));
1262 /* Lisp functions for creating and removing buffer-local variables. */
1264 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1265 1, 1, "vMake Variable Buffer Local: ",
1266 "Make VARIABLE become buffer-local whenever it is set.\n\
1267 At any time, the value for the current buffer is in effect,\n\
1268 unless the variable has never been set in this buffer,\n\
1269 in which case the default value is in effect.\n\
1270 Note that binding the variable with `let', or setting it while\n\
1271 a `let'-style binding made in this buffer is in effect,\n\
1272 does not make the variable buffer-local.\n\
1274 The function `default-value' gets the default value and `set-default' sets it.")
1276 register Lisp_Object variable
;
1278 register Lisp_Object tem
, valcontents
, newval
;
1280 CHECK_SYMBOL (variable
, 0);
1282 valcontents
= XSYMBOL (variable
)->value
;
1283 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1284 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1286 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1288 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1290 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1293 if (EQ (valcontents
, Qunbound
))
1294 XSYMBOL (variable
)->value
= Qnil
;
1295 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1297 newval
= allocate_misc ();
1298 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1299 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1300 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1301 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1302 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1303 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1304 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1305 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1306 XSYMBOL (variable
)->value
= newval
;
1310 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1311 1, 1, "vMake Local Variable: ",
1312 "Make VARIABLE have a separate value in the current buffer.\n\
1313 Other buffers will continue to share a common default value.\n\
1314 \(The buffer-local value of VARIABLE starts out as the same value\n\
1315 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1316 See also `make-variable-buffer-local'.\n\
1318 If the variable is already arranged to become local when set,\n\
1319 this function causes a local value to exist for this buffer,\n\
1320 just as setting the variable would do.\n\
1322 This function returns VARIABLE, and therefore\n\
1323 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1326 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1327 Use `make-local-hook' instead.")
1329 register Lisp_Object variable
;
1331 register Lisp_Object tem
, valcontents
;
1333 CHECK_SYMBOL (variable
, 0);
1335 valcontents
= XSYMBOL (variable
)->value
;
1336 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1337 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1339 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1341 tem
= Fboundp (variable
);
1343 /* Make sure the symbol has a local value in this particular buffer,
1344 by setting it to the same value it already has. */
1345 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1348 /* Make sure symbol is set up to hold per-buffer values. */
1349 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1352 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1354 newval
= allocate_misc ();
1355 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1356 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1357 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1358 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1359 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1360 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1361 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1362 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1363 XSYMBOL (variable
)->value
= newval
;
1365 /* Make sure this buffer has its own value of symbol. */
1366 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1369 /* Swap out any local binding for some other buffer, and make
1370 sure the current value is permanently recorded, if it's the
1372 find_symbol_value (variable
);
1374 current_buffer
->local_var_alist
1375 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1376 current_buffer
->local_var_alist
);
1378 /* Make sure symbol does not think it is set up for this buffer;
1379 force it to look once again for this buffer's value. */
1381 Lisp_Object
*pvalbuf
;
1383 valcontents
= XSYMBOL (variable
)->value
;
1385 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1386 if (current_buffer
== XBUFFER (*pvalbuf
))
1388 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1392 /* If the symbol forwards into a C variable, then load the binding
1393 for this buffer now. If C code modifies the variable before we
1394 load the binding in, then that new value will clobber the default
1395 binding the next time we unload it. */
1396 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1397 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1398 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1403 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1404 1, 1, "vKill Local Variable: ",
1405 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1406 From now on the default value will apply in this buffer.")
1408 register Lisp_Object variable
;
1410 register Lisp_Object tem
, valcontents
;
1412 CHECK_SYMBOL (variable
, 0);
1414 valcontents
= XSYMBOL (variable
)->value
;
1416 if (BUFFER_OBJFWDP (valcontents
))
1418 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1419 register int mask
= XINT (*((Lisp_Object
*)
1420 (idx
+ (char *)&buffer_local_flags
)));
1424 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1425 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1426 current_buffer
->local_var_flags
&= ~mask
;
1431 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1432 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1435 /* Get rid of this buffer's alist element, if any. */
1437 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1439 current_buffer
->local_var_alist
1440 = Fdelq (tem
, current_buffer
->local_var_alist
);
1442 /* If the symbol is set up with the current buffer's binding
1443 loaded, recompute its value. We have to do it now, or else
1444 forwarded objects won't work right. */
1446 Lisp_Object
*pvalbuf
;
1447 valcontents
= XSYMBOL (variable
)->value
;
1448 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1449 if (current_buffer
== XBUFFER (*pvalbuf
))
1452 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1453 find_symbol_value (variable
);
1460 /* Lisp functions for creating and removing buffer-local variables. */
1462 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1463 1, 1, "vMake Variable Frame Local: ",
1464 "Enable VARIABLE to have frame-local bindings.\n\
1465 When a frame-local binding exists in the current frame,\n\
1466 it is in effect whenever the current buffer has no buffer-local binding.\n\
1467 A frame-local binding is actual a frame parameter value;\n\
1468 thus, any given frame has a local binding for VARIABLE\n\
1469 if it has a value for the frame parameter named VARIABLE.\n\
1470 See `modify-frame-parameters'.")
1472 register Lisp_Object variable
;
1474 register Lisp_Object tem
, valcontents
, newval
;
1476 CHECK_SYMBOL (variable
, 0);
1478 valcontents
= XSYMBOL (variable
)->value
;
1479 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1480 || BUFFER_OBJFWDP (valcontents
))
1481 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1483 if (BUFFER_LOCAL_VALUEP (valcontents
)
1484 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1486 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1490 if (EQ (valcontents
, Qunbound
))
1491 XSYMBOL (variable
)->value
= Qnil
;
1492 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1494 newval
= allocate_misc ();
1495 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1496 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1497 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1498 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1499 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1500 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1501 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1502 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1503 XSYMBOL (variable
)->value
= newval
;
1507 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1509 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1510 BUFFER defaults to the current buffer.")
1512 register Lisp_Object variable
, buffer
;
1514 Lisp_Object valcontents
;
1515 register struct buffer
*buf
;
1518 buf
= current_buffer
;
1521 CHECK_BUFFER (buffer
, 0);
1522 buf
= XBUFFER (buffer
);
1525 CHECK_SYMBOL (variable
, 0);
1527 valcontents
= XSYMBOL (variable
)->value
;
1528 if (BUFFER_LOCAL_VALUEP (valcontents
)
1529 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1531 Lisp_Object tail
, elt
;
1532 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1535 if (EQ (variable
, XCAR (elt
)))
1539 if (BUFFER_OBJFWDP (valcontents
))
1541 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1542 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1543 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1549 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1551 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1552 BUFFER defaults to the current buffer.")
1554 register Lisp_Object variable
, buffer
;
1556 Lisp_Object valcontents
;
1557 register struct buffer
*buf
;
1560 buf
= current_buffer
;
1563 CHECK_BUFFER (buffer
, 0);
1564 buf
= XBUFFER (buffer
);
1567 CHECK_SYMBOL (variable
, 0);
1569 valcontents
= XSYMBOL (variable
)->value
;
1571 /* This means that make-variable-buffer-local was done. */
1572 if (BUFFER_LOCAL_VALUEP (valcontents
))
1574 /* All these slots become local if they are set. */
1575 if (BUFFER_OBJFWDP (valcontents
))
1577 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1579 Lisp_Object tail
, elt
;
1580 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1583 if (EQ (variable
, XCAR (elt
)))
1590 /* Find the function at the end of a chain of symbol function indirections. */
1592 /* If OBJECT is a symbol, find the end of its function chain and
1593 return the value found there. If OBJECT is not a symbol, just
1594 return it. If there is a cycle in the function chain, signal a
1595 cyclic-function-indirection error.
1597 This is like Findirect_function, except that it doesn't signal an
1598 error if the chain ends up unbound. */
1600 indirect_function (object
)
1601 register Lisp_Object object
;
1603 Lisp_Object tortoise
, hare
;
1605 hare
= tortoise
= object
;
1609 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1611 hare
= XSYMBOL (hare
)->function
;
1612 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1614 hare
= XSYMBOL (hare
)->function
;
1616 tortoise
= XSYMBOL (tortoise
)->function
;
1618 if (EQ (hare
, tortoise
))
1619 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1625 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1626 "Return the function at the end of OBJECT's function chain.\n\
1627 If OBJECT is a symbol, follow all function indirections and return the final\n\
1628 function binding.\n\
1629 If OBJECT is not a symbol, just return it.\n\
1630 Signal a void-function error if the final symbol is unbound.\n\
1631 Signal a cyclic-function-indirection error if there is a loop in the\n\
1632 function chain of symbols.")
1634 register Lisp_Object object
;
1638 result
= indirect_function (object
);
1640 if (EQ (result
, Qunbound
))
1641 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1645 /* Extract and set vector and string elements */
1647 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1648 "Return the element of ARRAY at index IDX.\n\
1649 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1650 or a byte-code object. IDX starts at 0.")
1652 register Lisp_Object array
;
1655 register int idxval
;
1657 CHECK_NUMBER (idx
, 1);
1658 idxval
= XINT (idx
);
1659 if (STRINGP (array
))
1663 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1664 args_out_of_range (array
, idx
);
1665 if (! STRING_MULTIBYTE (array
))
1666 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1667 idxval_byte
= string_char_to_byte (array
, idxval
);
1669 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1670 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1671 return make_number (c
);
1673 else if (BOOL_VECTOR_P (array
))
1677 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1678 args_out_of_range (array
, idx
);
1680 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1681 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1683 else if (CHAR_TABLE_P (array
))
1688 args_out_of_range (array
, idx
);
1689 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1691 /* For ASCII and 8-bit European characters, the element is
1692 stored in the top table. */
1693 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1695 val
= XCHAR_TABLE (array
)->defalt
;
1696 while (NILP (val
)) /* Follow parents until we find some value. */
1698 array
= XCHAR_TABLE (array
)->parent
;
1701 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1703 val
= XCHAR_TABLE (array
)->defalt
;
1710 Lisp_Object sub_table
;
1712 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1713 if (code
[1] < 32) code
[1] = -1;
1714 else if (code
[2] < 32) code
[2] = -1;
1716 /* Here, the possible range of CODE[0] (== charset ID) is
1717 128..MAX_CHARSET. Since the top level char table contains
1718 data for multibyte characters after 256th element, we must
1719 increment CODE[0] by 128 to get a correct index. */
1721 code
[3] = -1; /* anchor */
1723 try_parent_char_table
:
1725 for (i
= 0; code
[i
] >= 0; i
++)
1727 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1728 if (SUB_CHAR_TABLE_P (val
))
1733 val
= XCHAR_TABLE (sub_table
)->defalt
;
1736 array
= XCHAR_TABLE (array
)->parent
;
1738 goto try_parent_char_table
;
1743 /* Here, VAL is a sub char table. We try the default value
1745 val
= XCHAR_TABLE (val
)->defalt
;
1748 array
= XCHAR_TABLE (array
)->parent
;
1750 goto try_parent_char_table
;
1758 if (VECTORP (array
))
1759 size
= XVECTOR (array
)->size
;
1760 else if (COMPILEDP (array
))
1761 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1763 wrong_type_argument (Qarrayp
, array
);
1765 if (idxval
< 0 || idxval
>= size
)
1766 args_out_of_range (array
, idx
);
1767 return XVECTOR (array
)->contents
[idxval
];
1771 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1772 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1773 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1775 (array
, idx
, newelt
)
1776 register Lisp_Object array
;
1777 Lisp_Object idx
, newelt
;
1779 register int idxval
;
1781 CHECK_NUMBER (idx
, 1);
1782 idxval
= XINT (idx
);
1783 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1784 && ! CHAR_TABLE_P (array
))
1785 array
= wrong_type_argument (Qarrayp
, array
);
1786 CHECK_IMPURE (array
);
1788 if (VECTORP (array
))
1790 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1791 args_out_of_range (array
, idx
);
1792 XVECTOR (array
)->contents
[idxval
] = newelt
;
1794 else if (BOOL_VECTOR_P (array
))
1798 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1799 args_out_of_range (array
, idx
);
1801 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1803 if (! NILP (newelt
))
1804 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1806 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1807 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1809 else if (CHAR_TABLE_P (array
))
1812 args_out_of_range (array
, idx
);
1813 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1814 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1820 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1821 if (code
[1] < 32) code
[1] = -1;
1822 else if (code
[2] < 32) code
[2] = -1;
1824 /* See the comment of the corresponding part in Faref. */
1826 code
[3] = -1; /* anchor */
1827 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1829 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1830 if (SUB_CHAR_TABLE_P (val
))
1836 /* VAL is a leaf. Create a sub char table with the
1837 default value VAL or XCHAR_TABLE (array)->defalt
1838 and look into it. */
1840 temp
= make_sub_char_table (NILP (val
)
1841 ? XCHAR_TABLE (array
)->defalt
1843 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1847 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1850 else if (STRING_MULTIBYTE (array
))
1852 int idxval_byte
, new_len
, actual_len
;
1854 unsigned char *p
, workbuf
[MAX_MULTIBYTE_LENGTH
], *str
= workbuf
;
1856 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1857 args_out_of_range (array
, idx
);
1859 idxval_byte
= string_char_to_byte (array
, idxval
);
1860 p
= &XSTRING (array
)->data
[idxval_byte
];
1862 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1863 CHECK_NUMBER (newelt
, 2);
1864 new_len
= CHAR_STRING (XINT (newelt
), str
);
1865 if (actual_len
!= new_len
)
1866 error ("Attempt to change byte length of a string");
1868 /* We can't accept a change causing byte combining. */
1869 if (!ASCII_BYTE_P (*str
)
1870 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1871 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1872 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1873 > idxval_byte
- prev_byte
))
1874 || (idxval
< XSTRING (array
)->size
- 1
1875 && !CHAR_HEAD_P (p
[actual_len
])
1876 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1877 error ("Attempt to change char length of a string");
1883 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1884 args_out_of_range (array
, idx
);
1885 CHECK_NUMBER (newelt
, 2);
1886 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1892 /* Arithmetic functions */
1894 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1897 arithcompare (num1
, num2
, comparison
)
1898 Lisp_Object num1
, num2
;
1899 enum comparison comparison
;
1904 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1905 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1907 if (FLOATP (num1
) || FLOATP (num2
))
1910 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1911 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1917 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1922 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1927 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1932 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1937 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1942 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1951 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1952 "Return t if two args, both numbers or markers, are equal.")
1954 register Lisp_Object num1
, num2
;
1956 return arithcompare (num1
, num2
, equal
);
1959 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1960 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1962 register Lisp_Object num1
, num2
;
1964 return arithcompare (num1
, num2
, less
);
1967 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1968 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1970 register Lisp_Object num1
, num2
;
1972 return arithcompare (num1
, num2
, grtr
);
1975 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1976 "Return t if first arg is less than or equal to second arg.\n\
1977 Both must be numbers or markers.")
1979 register Lisp_Object num1
, num2
;
1981 return arithcompare (num1
, num2
, less_or_equal
);
1984 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1985 "Return t if first arg is greater than or equal to second arg.\n\
1986 Both must be numbers or markers.")
1988 register Lisp_Object num1
, num2
;
1990 return arithcompare (num1
, num2
, grtr_or_equal
);
1993 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1994 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1996 register Lisp_Object num1
, num2
;
1998 return arithcompare (num1
, num2
, notequal
);
2001 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2003 register Lisp_Object number
;
2005 CHECK_NUMBER_OR_FLOAT (number
, 0);
2007 if (FLOATP (number
))
2009 if (XFLOAT_DATA (number
) == 0.0)
2019 /* Convert between long values and pairs of Lisp integers. */
2025 unsigned int top
= i
>> 16;
2026 unsigned int bot
= i
& 0xFFFF;
2028 return make_number (bot
);
2029 if (top
== (unsigned long)-1 >> 16)
2030 return Fcons (make_number (-1), make_number (bot
));
2031 return Fcons (make_number (top
), make_number (bot
));
2038 Lisp_Object top
, bot
;
2045 return ((XINT (top
) << 16) | XINT (bot
));
2048 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2049 "Convert NUMBER to a string by printing it in decimal.\n\
2050 Uses a minus sign if negative.\n\
2051 NUMBER may be an integer or a floating point number.")
2055 char buffer
[VALBITS
];
2057 CHECK_NUMBER_OR_FLOAT (number
, 0);
2059 if (FLOATP (number
))
2061 char pigbuf
[350]; /* see comments in float_to_string */
2063 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2064 return build_string (pigbuf
);
2067 if (sizeof (int) == sizeof (EMACS_INT
))
2068 sprintf (buffer
, "%d", XINT (number
));
2069 else if (sizeof (long) == sizeof (EMACS_INT
))
2070 sprintf (buffer
, "%ld", (long) XINT (number
));
2073 return build_string (buffer
);
2077 digit_to_number (character
, base
)
2078 int character
, base
;
2082 if (character
>= '0' && character
<= '9')
2083 digit
= character
- '0';
2084 else if (character
>= 'a' && character
<= 'z')
2085 digit
= character
- 'a' + 10;
2086 else if (character
>= 'A' && character
<= 'Z')
2087 digit
= character
- 'A' + 10;
2097 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2098 "Convert STRING to a number by parsing it as a decimal number.\n\
2099 This parses both integers and floating point numbers.\n\
2100 It ignores leading spaces and tabs.\n\
2102 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2103 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2104 If the base used is not 10, floating point is not recognized.")
2106 register Lisp_Object string
, base
;
2108 register unsigned char *p
;
2109 register int b
, v
= 0;
2112 CHECK_STRING (string
, 0);
2118 CHECK_NUMBER (base
, 1);
2120 if (b
< 2 || b
> 16)
2121 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2124 p
= XSTRING (string
)->data
;
2126 /* Skip any whitespace at the front of the number. Some versions of
2127 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2128 while (*p
== ' ' || *p
== '\t')
2139 if (isfloat_string (p
) && b
== 10)
2140 return make_float (negative
* atof (p
));
2144 int digit
= digit_to_number (*p
++, b
);
2150 return make_number (negative
* v
);
2155 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2157 extern Lisp_Object
float_arith_driver ();
2158 extern Lisp_Object
fmod_float ();
2161 arith_driver (code
, nargs
, args
)
2164 register Lisp_Object
*args
;
2166 register Lisp_Object val
;
2167 register int argnum
;
2168 register EMACS_INT accum
;
2169 register EMACS_INT next
;
2171 switch (SWITCH_ENUM_CAST (code
))
2184 for (argnum
= 0; argnum
< nargs
; argnum
++)
2186 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2187 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2189 if (FLOATP (val
)) /* time to do serious math */
2190 return (float_arith_driver ((double) accum
, argnum
, code
,
2192 args
[argnum
] = val
; /* runs into a compiler bug. */
2193 next
= XINT (args
[argnum
]);
2194 switch (SWITCH_ENUM_CAST (code
))
2196 case Aadd
: accum
+= next
; break;
2198 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2200 case Amult
: accum
*= next
; break;
2202 if (!argnum
) accum
= next
;
2206 Fsignal (Qarith_error
, Qnil
);
2210 case Alogand
: accum
&= next
; break;
2211 case Alogior
: accum
|= next
; break;
2212 case Alogxor
: accum
^= next
; break;
2213 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2214 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2218 XSETINT (val
, accum
);
2223 #define isnan(x) ((x) != (x))
2226 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2228 register int argnum
;
2231 register Lisp_Object
*args
;
2233 register Lisp_Object val
;
2236 for (; argnum
< nargs
; argnum
++)
2238 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2239 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2243 next
= XFLOAT_DATA (val
);
2247 args
[argnum
] = val
; /* runs into a compiler bug. */
2248 next
= XINT (args
[argnum
]);
2250 switch (SWITCH_ENUM_CAST (code
))
2256 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2266 if (! IEEE_FLOATING_POINT
&& next
== 0)
2267 Fsignal (Qarith_error
, Qnil
);
2274 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2276 if (!argnum
|| isnan (next
) || next
> accum
)
2280 if (!argnum
|| isnan (next
) || next
< accum
)
2286 return make_float (accum
);
2290 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2291 "Return sum of any number of arguments, which are numbers or markers.")
2296 return arith_driver (Aadd
, nargs
, args
);
2299 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2300 "Negate number or subtract numbers or markers.\n\
2301 With one arg, negates it. With more than one arg,\n\
2302 subtracts all but the first from the first.")
2307 return arith_driver (Asub
, nargs
, args
);
2310 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2311 "Returns product of any number of arguments, which are numbers or markers.")
2316 return arith_driver (Amult
, nargs
, args
);
2319 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2320 "Returns first argument divided by all the remaining arguments.\n\
2321 The arguments must be numbers or markers.")
2326 return arith_driver (Adiv
, nargs
, args
);
2329 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2330 "Returns remainder of X divided by Y.\n\
2331 Both must be integers or markers.")
2333 register Lisp_Object x
, y
;
2337 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2338 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2340 if (XFASTINT (y
) == 0)
2341 Fsignal (Qarith_error
, Qnil
);
2343 XSETINT (val
, XINT (x
) % XINT (y
));
2357 /* If the magnitude of the result exceeds that of the divisor, or
2358 the sign of the result does not agree with that of the dividend,
2359 iterate with the reduced value. This does not yield a
2360 particularly accurate result, but at least it will be in the
2361 range promised by fmod. */
2363 r
-= f2
* floor (r
/ f2
);
2364 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2368 #endif /* ! HAVE_FMOD */
2370 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2371 "Returns X modulo Y.\n\
2372 The result falls between zero (inclusive) and Y (exclusive).\n\
2373 Both X and Y must be numbers or markers.")
2375 register Lisp_Object x
, y
;
2380 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2381 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2383 if (FLOATP (x
) || FLOATP (y
))
2384 return fmod_float (x
, y
);
2390 Fsignal (Qarith_error
, Qnil
);
2394 /* If the "remainder" comes out with the wrong sign, fix it. */
2395 if (i2
< 0 ? i1
> 0 : i1
< 0)
2402 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2403 "Return largest of all the arguments (which must be numbers or markers).\n\
2404 The value is always a number; markers are converted to numbers.")
2409 return arith_driver (Amax
, nargs
, args
);
2412 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2413 "Return smallest of all the arguments (which must be numbers or markers).\n\
2414 The value is always a number; markers are converted to numbers.")
2419 return arith_driver (Amin
, nargs
, args
);
2422 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2423 "Return bitwise-and of all the arguments.\n\
2424 Arguments may be integers, or markers converted to integers.")
2429 return arith_driver (Alogand
, nargs
, args
);
2432 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2433 "Return bitwise-or of all the arguments.\n\
2434 Arguments may be integers, or markers converted to integers.")
2439 return arith_driver (Alogior
, nargs
, args
);
2442 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2443 "Return bitwise-exclusive-or of all the arguments.\n\
2444 Arguments may be integers, or markers converted to integers.")
2449 return arith_driver (Alogxor
, nargs
, args
);
2452 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2453 "Return VALUE with its bits shifted left by COUNT.\n\
2454 If COUNT is negative, shifting is actually to the right.\n\
2455 In this case, the sign bit is duplicated.")
2457 register Lisp_Object value
, count
;
2459 register Lisp_Object val
;
2461 CHECK_NUMBER (value
, 0);
2462 CHECK_NUMBER (count
, 1);
2464 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2466 else if (XINT (count
) > 0)
2467 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2468 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2469 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2471 XSETINT (val
, XINT (value
) >> -XINT (count
));
2475 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2476 "Return VALUE with its bits shifted left by COUNT.\n\
2477 If COUNT is negative, shifting is actually to the right.\n\
2478 In this case, zeros are shifted in on the left.")
2480 register Lisp_Object value
, count
;
2482 register Lisp_Object val
;
2484 CHECK_NUMBER (value
, 0);
2485 CHECK_NUMBER (count
, 1);
2487 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2489 else if (XINT (count
) > 0)
2490 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2491 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2494 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2498 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2499 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2500 Markers are converted to integers.")
2502 register Lisp_Object number
;
2504 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2506 if (FLOATP (number
))
2507 return (make_float (1.0 + XFLOAT_DATA (number
)));
2509 XSETINT (number
, XINT (number
) + 1);
2513 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2514 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2515 Markers are converted to integers.")
2517 register Lisp_Object number
;
2519 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2521 if (FLOATP (number
))
2522 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2524 XSETINT (number
, XINT (number
) - 1);
2528 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2529 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2531 register Lisp_Object number
;
2533 CHECK_NUMBER (number
, 0);
2534 XSETINT (number
, ~XINT (number
));
2541 Lisp_Object error_tail
, arith_tail
;
2543 Qquote
= intern ("quote");
2544 Qlambda
= intern ("lambda");
2545 Qsubr
= intern ("subr");
2546 Qerror_conditions
= intern ("error-conditions");
2547 Qerror_message
= intern ("error-message");
2548 Qtop_level
= intern ("top-level");
2550 Qerror
= intern ("error");
2551 Qquit
= intern ("quit");
2552 Qwrong_type_argument
= intern ("wrong-type-argument");
2553 Qargs_out_of_range
= intern ("args-out-of-range");
2554 Qvoid_function
= intern ("void-function");
2555 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2556 Qvoid_variable
= intern ("void-variable");
2557 Qsetting_constant
= intern ("setting-constant");
2558 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2560 Qinvalid_function
= intern ("invalid-function");
2561 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2562 Qno_catch
= intern ("no-catch");
2563 Qend_of_file
= intern ("end-of-file");
2564 Qarith_error
= intern ("arith-error");
2565 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2566 Qend_of_buffer
= intern ("end-of-buffer");
2567 Qbuffer_read_only
= intern ("buffer-read-only");
2568 Qtext_read_only
= intern ("text-read-only");
2569 Qmark_inactive
= intern ("mark-inactive");
2571 Qlistp
= intern ("listp");
2572 Qconsp
= intern ("consp");
2573 Qsymbolp
= intern ("symbolp");
2574 Qkeywordp
= intern ("keywordp");
2575 Qintegerp
= intern ("integerp");
2576 Qnatnump
= intern ("natnump");
2577 Qwholenump
= intern ("wholenump");
2578 Qstringp
= intern ("stringp");
2579 Qarrayp
= intern ("arrayp");
2580 Qsequencep
= intern ("sequencep");
2581 Qbufferp
= intern ("bufferp");
2582 Qvectorp
= intern ("vectorp");
2583 Qchar_or_string_p
= intern ("char-or-string-p");
2584 Qmarkerp
= intern ("markerp");
2585 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2586 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2587 Qboundp
= intern ("boundp");
2588 Qfboundp
= intern ("fboundp");
2590 Qfloatp
= intern ("floatp");
2591 Qnumberp
= intern ("numberp");
2592 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2594 Qchar_table_p
= intern ("char-table-p");
2595 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2597 Qcdr
= intern ("cdr");
2599 /* Handle automatic advice activation */
2600 Qad_advice_info
= intern ("ad-advice-info");
2601 Qad_activate_internal
= intern ("ad-activate-internal");
2603 error_tail
= Fcons (Qerror
, Qnil
);
2605 /* ERROR is used as a signaler for random errors for which nothing else is right */
2607 Fput (Qerror
, Qerror_conditions
,
2609 Fput (Qerror
, Qerror_message
,
2610 build_string ("error"));
2612 Fput (Qquit
, Qerror_conditions
,
2613 Fcons (Qquit
, Qnil
));
2614 Fput (Qquit
, Qerror_message
,
2615 build_string ("Quit"));
2617 Fput (Qwrong_type_argument
, Qerror_conditions
,
2618 Fcons (Qwrong_type_argument
, error_tail
));
2619 Fput (Qwrong_type_argument
, Qerror_message
,
2620 build_string ("Wrong type argument"));
2622 Fput (Qargs_out_of_range
, Qerror_conditions
,
2623 Fcons (Qargs_out_of_range
, error_tail
));
2624 Fput (Qargs_out_of_range
, Qerror_message
,
2625 build_string ("Args out of range"));
2627 Fput (Qvoid_function
, Qerror_conditions
,
2628 Fcons (Qvoid_function
, error_tail
));
2629 Fput (Qvoid_function
, Qerror_message
,
2630 build_string ("Symbol's function definition is void"));
2632 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2633 Fcons (Qcyclic_function_indirection
, error_tail
));
2634 Fput (Qcyclic_function_indirection
, Qerror_message
,
2635 build_string ("Symbol's chain of function indirections contains a loop"));
2637 Fput (Qvoid_variable
, Qerror_conditions
,
2638 Fcons (Qvoid_variable
, error_tail
));
2639 Fput (Qvoid_variable
, Qerror_message
,
2640 build_string ("Symbol's value as variable is void"));
2642 Fput (Qsetting_constant
, Qerror_conditions
,
2643 Fcons (Qsetting_constant
, error_tail
));
2644 Fput (Qsetting_constant
, Qerror_message
,
2645 build_string ("Attempt to set a constant symbol"));
2647 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2648 Fcons (Qinvalid_read_syntax
, error_tail
));
2649 Fput (Qinvalid_read_syntax
, Qerror_message
,
2650 build_string ("Invalid read syntax"));
2652 Fput (Qinvalid_function
, Qerror_conditions
,
2653 Fcons (Qinvalid_function
, error_tail
));
2654 Fput (Qinvalid_function
, Qerror_message
,
2655 build_string ("Invalid function"));
2657 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2658 Fcons (Qwrong_number_of_arguments
, error_tail
));
2659 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2660 build_string ("Wrong number of arguments"));
2662 Fput (Qno_catch
, Qerror_conditions
,
2663 Fcons (Qno_catch
, error_tail
));
2664 Fput (Qno_catch
, Qerror_message
,
2665 build_string ("No catch for tag"));
2667 Fput (Qend_of_file
, Qerror_conditions
,
2668 Fcons (Qend_of_file
, error_tail
));
2669 Fput (Qend_of_file
, Qerror_message
,
2670 build_string ("End of file during parsing"));
2672 arith_tail
= Fcons (Qarith_error
, error_tail
);
2673 Fput (Qarith_error
, Qerror_conditions
,
2675 Fput (Qarith_error
, Qerror_message
,
2676 build_string ("Arithmetic error"));
2678 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2679 Fcons (Qbeginning_of_buffer
, error_tail
));
2680 Fput (Qbeginning_of_buffer
, Qerror_message
,
2681 build_string ("Beginning of buffer"));
2683 Fput (Qend_of_buffer
, Qerror_conditions
,
2684 Fcons (Qend_of_buffer
, error_tail
));
2685 Fput (Qend_of_buffer
, Qerror_message
,
2686 build_string ("End of buffer"));
2688 Fput (Qbuffer_read_only
, Qerror_conditions
,
2689 Fcons (Qbuffer_read_only
, error_tail
));
2690 Fput (Qbuffer_read_only
, Qerror_message
,
2691 build_string ("Buffer is read-only"));
2693 Fput (Qtext_read_only
, Qerror_conditions
,
2694 Fcons (Qtext_read_only
, error_tail
));
2695 Fput (Qtext_read_only
, Qerror_message
,
2696 build_string ("Text is read-only"));
2698 Qrange_error
= intern ("range-error");
2699 Qdomain_error
= intern ("domain-error");
2700 Qsingularity_error
= intern ("singularity-error");
2701 Qoverflow_error
= intern ("overflow-error");
2702 Qunderflow_error
= intern ("underflow-error");
2704 Fput (Qdomain_error
, Qerror_conditions
,
2705 Fcons (Qdomain_error
, arith_tail
));
2706 Fput (Qdomain_error
, Qerror_message
,
2707 build_string ("Arithmetic domain error"));
2709 Fput (Qrange_error
, Qerror_conditions
,
2710 Fcons (Qrange_error
, arith_tail
));
2711 Fput (Qrange_error
, Qerror_message
,
2712 build_string ("Arithmetic range error"));
2714 Fput (Qsingularity_error
, Qerror_conditions
,
2715 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2716 Fput (Qsingularity_error
, Qerror_message
,
2717 build_string ("Arithmetic singularity error"));
2719 Fput (Qoverflow_error
, Qerror_conditions
,
2720 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2721 Fput (Qoverflow_error
, Qerror_message
,
2722 build_string ("Arithmetic overflow error"));
2724 Fput (Qunderflow_error
, Qerror_conditions
,
2725 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2726 Fput (Qunderflow_error
, Qerror_message
,
2727 build_string ("Arithmetic underflow error"));
2729 staticpro (&Qrange_error
);
2730 staticpro (&Qdomain_error
);
2731 staticpro (&Qsingularity_error
);
2732 staticpro (&Qoverflow_error
);
2733 staticpro (&Qunderflow_error
);
2737 staticpro (&Qquote
);
2738 staticpro (&Qlambda
);
2740 staticpro (&Qunbound
);
2741 staticpro (&Qerror_conditions
);
2742 staticpro (&Qerror_message
);
2743 staticpro (&Qtop_level
);
2745 staticpro (&Qerror
);
2747 staticpro (&Qwrong_type_argument
);
2748 staticpro (&Qargs_out_of_range
);
2749 staticpro (&Qvoid_function
);
2750 staticpro (&Qcyclic_function_indirection
);
2751 staticpro (&Qvoid_variable
);
2752 staticpro (&Qsetting_constant
);
2753 staticpro (&Qinvalid_read_syntax
);
2754 staticpro (&Qwrong_number_of_arguments
);
2755 staticpro (&Qinvalid_function
);
2756 staticpro (&Qno_catch
);
2757 staticpro (&Qend_of_file
);
2758 staticpro (&Qarith_error
);
2759 staticpro (&Qbeginning_of_buffer
);
2760 staticpro (&Qend_of_buffer
);
2761 staticpro (&Qbuffer_read_only
);
2762 staticpro (&Qtext_read_only
);
2763 staticpro (&Qmark_inactive
);
2765 staticpro (&Qlistp
);
2766 staticpro (&Qconsp
);
2767 staticpro (&Qsymbolp
);
2768 staticpro (&Qkeywordp
);
2769 staticpro (&Qintegerp
);
2770 staticpro (&Qnatnump
);
2771 staticpro (&Qwholenump
);
2772 staticpro (&Qstringp
);
2773 staticpro (&Qarrayp
);
2774 staticpro (&Qsequencep
);
2775 staticpro (&Qbufferp
);
2776 staticpro (&Qvectorp
);
2777 staticpro (&Qchar_or_string_p
);
2778 staticpro (&Qmarkerp
);
2779 staticpro (&Qbuffer_or_string_p
);
2780 staticpro (&Qinteger_or_marker_p
);
2781 staticpro (&Qfloatp
);
2782 staticpro (&Qnumberp
);
2783 staticpro (&Qnumber_or_marker_p
);
2784 staticpro (&Qchar_table_p
);
2785 staticpro (&Qvector_or_char_table_p
);
2787 staticpro (&Qboundp
);
2788 staticpro (&Qfboundp
);
2790 staticpro (&Qad_advice_info
);
2791 staticpro (&Qad_activate_internal
);
2793 /* Types that type-of returns. */
2794 Qinteger
= intern ("integer");
2795 Qsymbol
= intern ("symbol");
2796 Qstring
= intern ("string");
2797 Qcons
= intern ("cons");
2798 Qmarker
= intern ("marker");
2799 Qoverlay
= intern ("overlay");
2800 Qfloat
= intern ("float");
2801 Qwindow_configuration
= intern ("window-configuration");
2802 Qprocess
= intern ("process");
2803 Qwindow
= intern ("window");
2804 /* Qsubr = intern ("subr"); */
2805 Qcompiled_function
= intern ("compiled-function");
2806 Qbuffer
= intern ("buffer");
2807 Qframe
= intern ("frame");
2808 Qvector
= intern ("vector");
2809 Qchar_table
= intern ("char-table");
2810 Qbool_vector
= intern ("bool-vector");
2811 Qhash_table
= intern ("hash-table");
2813 staticpro (&Qinteger
);
2814 staticpro (&Qsymbol
);
2815 staticpro (&Qstring
);
2817 staticpro (&Qmarker
);
2818 staticpro (&Qoverlay
);
2819 staticpro (&Qfloat
);
2820 staticpro (&Qwindow_configuration
);
2821 staticpro (&Qprocess
);
2822 staticpro (&Qwindow
);
2823 /* staticpro (&Qsubr); */
2824 staticpro (&Qcompiled_function
);
2825 staticpro (&Qbuffer
);
2826 staticpro (&Qframe
);
2827 staticpro (&Qvector
);
2828 staticpro (&Qchar_table
);
2829 staticpro (&Qbool_vector
);
2830 staticpro (&Qhash_table
);
2832 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2833 "Non-nil means it is an error to set a keyword symbol.\n\
2834 A keyword symbol is a symbol whose name starts with a colon (`:').");
2835 keyword_symbols_constant_flag
= 1;
2839 defsubr (&Stype_of
);
2844 defsubr (&Sintegerp
);
2845 defsubr (&Sinteger_or_marker_p
);
2846 defsubr (&Snumberp
);
2847 defsubr (&Snumber_or_marker_p
);
2849 defsubr (&Snatnump
);
2850 defsubr (&Ssymbolp
);
2851 defsubr (&Skeywordp
);
2852 defsubr (&Sstringp
);
2853 defsubr (&Smultibyte_string_p
);
2854 defsubr (&Svectorp
);
2855 defsubr (&Schar_table_p
);
2856 defsubr (&Svector_or_char_table_p
);
2857 defsubr (&Sbool_vector_p
);
2859 defsubr (&Ssequencep
);
2860 defsubr (&Sbufferp
);
2861 defsubr (&Smarkerp
);
2863 defsubr (&Sbyte_code_function_p
);
2864 defsubr (&Schar_or_string_p
);
2867 defsubr (&Scar_safe
);
2868 defsubr (&Scdr_safe
);
2871 defsubr (&Ssymbol_function
);
2872 defsubr (&Sindirect_function
);
2873 defsubr (&Ssymbol_plist
);
2874 defsubr (&Ssymbol_name
);
2875 defsubr (&Smakunbound
);
2876 defsubr (&Sfmakunbound
);
2878 defsubr (&Sfboundp
);
2880 defsubr (&Sdefalias
);
2881 defsubr (&Ssetplist
);
2882 defsubr (&Ssymbol_value
);
2884 defsubr (&Sdefault_boundp
);
2885 defsubr (&Sdefault_value
);
2886 defsubr (&Sset_default
);
2887 defsubr (&Ssetq_default
);
2888 defsubr (&Smake_variable_buffer_local
);
2889 defsubr (&Smake_local_variable
);
2890 defsubr (&Skill_local_variable
);
2891 defsubr (&Smake_variable_frame_local
);
2892 defsubr (&Slocal_variable_p
);
2893 defsubr (&Slocal_variable_if_set_p
);
2896 defsubr (&Snumber_to_string
);
2897 defsubr (&Sstring_to_number
);
2898 defsubr (&Seqlsign
);
2922 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2929 #if defined(USG) && !defined(POSIX_SIGNALS)
2930 /* USG systems forget handlers when they are used;
2931 must reestablish each time */
2932 signal (signo
, arith_error
);
2935 /* VMS systems are like USG. */
2936 signal (signo
, arith_error
);
2940 #else /* not BSD4_1 */
2941 sigsetmask (SIGEMPTYMASK
);
2942 #endif /* not BSD4_1 */
2944 Fsignal (Qarith_error
, Qnil
);
2950 /* Don't do this if just dumping out.
2951 We don't want to call `signal' in this case
2952 so that we don't have trouble with dumping
2953 signal-delivering routines in an inconsistent state. */
2957 #endif /* CANNOT_DUMP */
2958 signal (SIGFPE
, arith_error
);
2961 signal (SIGEMT
, arith_error
);