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 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
64 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
65 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
66 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
67 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
68 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
69 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
70 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
71 Lisp_Object Qtext_read_only
;
72 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
73 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
74 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
75 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
76 Lisp_Object Qboundp
, Qfboundp
;
77 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
80 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
82 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
83 Lisp_Object Qoverflow_error
, Qunderflow_error
;
86 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
88 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
89 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
91 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
92 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
94 static Lisp_Object
swap_in_symval_forwarding ();
96 Lisp_Object
set_internal ();
99 wrong_type_argument (predicate
, value
)
100 register Lisp_Object predicate
, value
;
102 register Lisp_Object tem
;
105 if (!EQ (Vmocklisp_arguments
, Qt
))
107 if (STRINGP (value
) &&
108 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
109 return Fstring_to_number (value
, Qnil
);
110 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
111 return Fnumber_to_string (value
);
114 /* If VALUE is not even a valid Lisp object, abort here
115 where we can get a backtrace showing where it came from. */
116 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
119 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
120 tem
= call1 (predicate
, value
);
129 error ("Attempt to modify read-only object");
133 args_out_of_range (a1
, a2
)
137 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
141 args_out_of_range_3 (a1
, a2
, a3
)
142 Lisp_Object a1
, a2
, a3
;
145 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
148 /* On some machines, XINT needs a temporary location.
149 Here it is, in case it is needed. */
151 int sign_extend_temp
;
153 /* On a few machines, XINT can only be done by calling this. */
156 sign_extend_lisp_int (num
)
159 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
160 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
162 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
165 /* Data type predicates */
167 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
168 "Return t if the two args are the same Lisp object.")
170 Lisp_Object obj1
, obj2
;
177 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
186 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
187 "Return a symbol representing the type of OBJECT.\n\
188 The symbol returned names the object's basic type;\n\
189 for example, (type-of 1) returns `integer'.")
193 switch (XGCTYPE (object
))
208 switch (XMISCTYPE (object
))
210 case Lisp_Misc_Marker
:
212 case Lisp_Misc_Overlay
:
214 case Lisp_Misc_Float
:
219 case Lisp_Vectorlike
:
220 if (GC_WINDOW_CONFIGURATIONP (object
))
221 return Qwindow_configuration
;
222 if (GC_PROCESSP (object
))
224 if (GC_WINDOWP (object
))
226 if (GC_SUBRP (object
))
228 if (GC_COMPILEDP (object
))
229 return Qcompiled_function
;
230 if (GC_BUFFERP (object
))
232 if (GC_CHAR_TABLE_P (object
))
234 if (GC_BOOL_VECTOR_P (object
))
236 if (GC_FRAMEP (object
))
238 if (GC_HASH_TABLE_P (object
))
250 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
259 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
260 "Return t if OBJECT is not a cons cell. This includes nil.")
269 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
270 "Return t if OBJECT is a list. This includes nil.")
274 if (CONSP (object
) || NILP (object
))
279 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
280 "Return t if OBJECT is not a list. Lists include nil.")
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
290 "Return t if OBJECT is a symbol.")
294 if (SYMBOLP (object
))
299 /* Define this in C to avoid unnecessarily consing up the symbol
301 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
302 "Return t if OBJECT is a keyword.\n\
303 This means that it is a symbol with a print name beginning with `:'\n\
304 interned in the initial obarray.")
309 && XSYMBOL (object
)->name
->data
[0] == ':'
310 && EQ (XSYMBOL (object
)->obarray
, initial_obarray
))
315 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
316 "Return t if OBJECT is a vector.")
320 if (VECTORP (object
))
325 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
326 "Return t if OBJECT is a string.")
330 if (STRINGP (object
))
335 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
336 1, 1, 0, "Return t if OBJECT is a multibyte string.")
340 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
345 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
346 "Return t if OBJECT is a char-table.")
350 if (CHAR_TABLE_P (object
))
355 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
356 Svector_or_char_table_p
, 1, 1, 0,
357 "Return t if OBJECT is a char-table or vector.")
361 if (VECTORP (object
) || CHAR_TABLE_P (object
))
366 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
370 if (BOOL_VECTOR_P (object
))
375 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
379 if (VECTORP (object
) || STRINGP (object
)
380 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
385 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
386 "Return t if OBJECT is a sequence (list or array).")
388 register Lisp_Object object
;
390 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
391 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
396 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
400 if (BUFFERP (object
))
405 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
409 if (MARKERP (object
))
414 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
423 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
424 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
428 if (COMPILEDP (object
))
433 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
434 "Return t if OBJECT is a character (an integer) or a string.")
436 register Lisp_Object object
;
438 if (INTEGERP (object
) || STRINGP (object
))
443 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
447 if (INTEGERP (object
))
452 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
453 "Return t if OBJECT is an integer or a marker (editor pointer).")
455 register Lisp_Object object
;
457 if (MARKERP (object
) || INTEGERP (object
))
462 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
463 "Return t if OBJECT is a nonnegative integer.")
467 if (NATNUMP (object
))
472 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
473 "Return t if OBJECT is a number (floating point or integer).")
477 if (NUMBERP (object
))
483 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
484 Snumber_or_marker_p
, 1, 1, 0,
485 "Return t if OBJECT is a number or a marker.")
489 if (NUMBERP (object
) || MARKERP (object
))
494 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
495 "Return t if OBJECT is a floating point number.")
505 /* Extract and set components of lists */
507 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
508 "Return the car of LIST. If arg is nil, return nil.\n\
509 Error if arg is not nil and not a cons cell. See also `car-safe'.")
511 register Lisp_Object list
;
517 else if (EQ (list
, Qnil
))
520 list
= wrong_type_argument (Qlistp
, list
);
524 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
525 "Return the car of OBJECT if it is a cons cell, or else nil.")
530 return XCAR (object
);
535 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
536 "Return the cdr of LIST. If arg is nil, return nil.\n\
537 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
540 register Lisp_Object list
;
546 else if (EQ (list
, Qnil
))
549 list
= wrong_type_argument (Qlistp
, list
);
553 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
554 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
559 return XCDR (object
);
564 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
565 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
567 register Lisp_Object cell
, newcar
;
570 cell
= wrong_type_argument (Qconsp
, cell
);
573 XCAR (cell
) = newcar
;
577 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
578 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
580 register Lisp_Object cell
, newcdr
;
583 cell
= wrong_type_argument (Qconsp
, cell
);
586 XCDR (cell
) = newcdr
;
590 /* Extract and set components of symbols */
592 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
594 register Lisp_Object symbol
;
596 Lisp_Object valcontents
;
597 CHECK_SYMBOL (symbol
, 0);
599 valcontents
= XSYMBOL (symbol
)->value
;
601 if (BUFFER_LOCAL_VALUEP (valcontents
)
602 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
603 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
605 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
608 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
610 register Lisp_Object symbol
;
612 CHECK_SYMBOL (symbol
, 0);
613 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
616 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
618 register Lisp_Object symbol
;
620 CHECK_SYMBOL (symbol
, 0);
621 if (NILP (symbol
) || EQ (symbol
, Qt
)
622 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
623 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)))
624 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
625 Fset (symbol
, Qunbound
);
629 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
, 0);
634 if (NILP (symbol
) || EQ (symbol
, Qt
))
635 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
636 XSYMBOL (symbol
)->function
= Qunbound
;
640 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
641 "Return SYMBOL's function definition. Error if that is void.")
643 register Lisp_Object symbol
;
645 CHECK_SYMBOL (symbol
, 0);
646 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
647 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
648 return XSYMBOL (symbol
)->function
;
651 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
653 register Lisp_Object symbol
;
655 CHECK_SYMBOL (symbol
, 0);
656 return XSYMBOL (symbol
)->plist
;
659 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
661 register Lisp_Object symbol
;
663 register Lisp_Object name
;
665 CHECK_SYMBOL (symbol
, 0);
666 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
670 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
671 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
673 register Lisp_Object symbol
, definition
;
675 CHECK_SYMBOL (symbol
, 0);
676 if (NILP (symbol
) || EQ (symbol
, Qt
))
677 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
678 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
679 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
681 XSYMBOL (symbol
)->function
= definition
;
682 /* Handle automatic advice activation */
683 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
685 call2 (Qad_activate_internal
, symbol
, Qnil
);
686 definition
= XSYMBOL (symbol
)->function
;
691 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
692 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
693 Associates the function with the current load file, if any.")
695 register Lisp_Object symbol
, definition
;
697 definition
= Ffset (symbol
, definition
);
698 LOADHIST_ATTACH (symbol
);
702 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
703 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
705 register Lisp_Object symbol
, newplist
;
707 CHECK_SYMBOL (symbol
, 0);
708 XSYMBOL (symbol
)->plist
= newplist
;
713 /* Getting and setting values of symbols */
715 /* Given the raw contents of a symbol value cell,
716 return the Lisp value of the symbol.
717 This does not handle buffer-local variables; use
718 swap_in_symval_forwarding for that. */
721 do_symval_forwarding (valcontents
)
722 register Lisp_Object valcontents
;
724 register Lisp_Object val
;
726 if (MISCP (valcontents
))
727 switch (XMISCTYPE (valcontents
))
729 case Lisp_Misc_Intfwd
:
730 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
733 case Lisp_Misc_Boolfwd
:
734 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
736 case Lisp_Misc_Objfwd
:
737 return *XOBJFWD (valcontents
)->objvar
;
739 case Lisp_Misc_Buffer_Objfwd
:
740 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
741 return PER_BUFFER_VALUE (current_buffer
, offset
);
743 case Lisp_Misc_Kboard_Objfwd
:
744 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
745 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
750 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
751 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
752 buffer-independent contents of the value cell: forwarded just one
753 step past the buffer-localness. */
756 store_symval_forwarding (symbol
, valcontents
, newval
)
758 register Lisp_Object valcontents
, newval
;
760 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
763 switch (XMISCTYPE (valcontents
))
765 case Lisp_Misc_Intfwd
:
766 CHECK_NUMBER (newval
, 1);
767 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
768 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
769 error ("Value out of range for variable `%s'",
770 XSYMBOL (symbol
)->name
->data
);
773 case Lisp_Misc_Boolfwd
:
774 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
777 case Lisp_Misc_Objfwd
:
778 *XOBJFWD (valcontents
)->objvar
= newval
;
781 case Lisp_Misc_Buffer_Objfwd
:
783 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
786 type
= PER_BUFFER_TYPE (offset
);
787 if (XINT (type
) == -1)
788 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
790 if (! NILP (type
) && ! NILP (newval
)
791 && XTYPE (newval
) != XINT (type
))
792 buffer_slot_type_mismatch (offset
);
794 PER_BUFFER_VALUE (current_buffer
, offset
) = newval
;
798 case Lisp_Misc_Kboard_Objfwd
:
799 (*(Lisp_Object
*)((char *)current_kboard
800 + XKBOARD_OBJFWD (valcontents
)->offset
))
811 valcontents
= XSYMBOL (symbol
)->value
;
812 if (BUFFER_LOCAL_VALUEP (valcontents
)
813 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
814 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
816 XSYMBOL (symbol
)->value
= newval
;
820 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
821 VALCONTENTS is the contents of its value cell,
822 which points to a struct Lisp_Buffer_Local_Value.
824 Return the value forwarded one step past the buffer-local stage.
825 This could be another forwarding pointer. */
828 swap_in_symval_forwarding (symbol
, valcontents
)
829 Lisp_Object symbol
, valcontents
;
831 register Lisp_Object tem1
;
832 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
835 || current_buffer
!= XBUFFER (tem1
)
836 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
837 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
839 /* Unload the previously loaded binding. */
840 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
842 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
843 /* Choose the new binding. */
844 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
845 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
846 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
849 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
850 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
852 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
854 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
857 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
859 /* Load the new binding. */
860 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = tem1
;
861 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
862 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
863 store_symval_forwarding (symbol
,
864 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
867 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
870 /* Find the value of a symbol, returning Qunbound if it's not bound.
871 This is helpful for code which just wants to get a variable's value
872 if it has one, without signaling an error.
873 Note that it must not be possible to quit
874 within this function. Great care is required for this. */
877 find_symbol_value (symbol
)
880 register Lisp_Object valcontents
;
881 register Lisp_Object val
;
882 CHECK_SYMBOL (symbol
, 0);
883 valcontents
= XSYMBOL (symbol
)->value
;
885 if (BUFFER_LOCAL_VALUEP (valcontents
)
886 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
887 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
,
890 if (MISCP (valcontents
))
892 switch (XMISCTYPE (valcontents
))
894 case Lisp_Misc_Intfwd
:
895 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
898 case Lisp_Misc_Boolfwd
:
899 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
901 case Lisp_Misc_Objfwd
:
902 return *XOBJFWD (valcontents
)->objvar
;
904 case Lisp_Misc_Buffer_Objfwd
:
905 return PER_BUFFER_VALUE (current_buffer
,
906 XBUFFER_OBJFWD (valcontents
)->offset
);
908 case Lisp_Misc_Kboard_Objfwd
:
909 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
910 + (char *)current_kboard
);
917 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
918 "Return SYMBOL's value. Error if that is void.")
924 val
= find_symbol_value (symbol
);
925 if (EQ (val
, Qunbound
))
926 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
931 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
932 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
934 register Lisp_Object symbol
, newval
;
936 return set_internal (symbol
, newval
, current_buffer
, 0);
939 /* Return 1 if SYMBOL currently has a let-binding
940 which was made in the buffer that is now current. */
943 let_shadows_buffer_binding_p (symbol
)
946 struct specbinding
*p
;
948 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
951 && EQ (symbol
, XCAR (p
->symbol
))
952 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
958 /* Store the value NEWVAL into SYMBOL.
959 If buffer-locality is an issue, BUF specifies which buffer to use.
960 (0 stands for the current buffer.)
962 If BINDFLAG is zero, then if this symbol is supposed to become
963 local in every buffer where it is set, then we make it local.
964 If BINDFLAG is nonzero, we don't do that. */
967 set_internal (symbol
, newval
, buf
, bindflag
)
968 register Lisp_Object symbol
, newval
;
972 int voide
= EQ (newval
, Qunbound
);
974 register Lisp_Object valcontents
, tem1
, current_alist_element
;
977 buf
= current_buffer
;
979 /* If restoring in a dead buffer, do nothing. */
980 if (NILP (buf
->name
))
983 CHECK_SYMBOL (symbol
, 0);
984 if (NILP (symbol
) || EQ (symbol
, Qt
)
985 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
986 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
987 && !EQ (newval
, symbol
)))
988 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
989 valcontents
= XSYMBOL (symbol
)->value
;
991 if (BUFFER_OBJFWDP (valcontents
))
993 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
994 int idx
= PER_BUFFER_IDX (offset
);
997 && !let_shadows_buffer_binding_p (symbol
))
998 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1001 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1002 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1004 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1006 /* What binding is loaded right now? */
1007 current_alist_element
1008 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1010 /* If the current buffer is not the buffer whose binding is
1011 loaded, or if there may be frame-local bindings and the frame
1012 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1013 the default binding is loaded, the loaded binding may be the
1015 if (buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1016 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1017 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1018 || (BUFFER_LOCAL_VALUEP (valcontents
)
1019 && EQ (XCAR (current_alist_element
),
1020 current_alist_element
)))
1022 /* The currently loaded binding is not necessarily valid.
1023 We need to unload it, and choose a new binding. */
1025 /* Write out `realvalue' to the old loaded binding. */
1026 Fsetcdr (current_alist_element
,
1027 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1029 /* Find the new binding. */
1030 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1031 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1032 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1036 /* This buffer still sees the default value. */
1038 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1039 or if this is `let' rather than `set',
1040 make CURRENT-ALIST-ELEMENT point to itself,
1041 indicating that we're seeing the default value.
1042 Likewise if the variable has been let-bound
1043 in the current buffer. */
1044 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1045 || let_shadows_buffer_binding_p (symbol
))
1047 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1049 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1050 tem1
= Fassq (symbol
,
1051 XFRAME (selected_frame
)->param_alist
);
1054 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1056 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1058 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1059 and we're not within a let that was made for this buffer,
1060 create a new buffer-local binding for the variable.
1061 That means, give this buffer a new assoc for a local value
1062 and load that binding. */
1065 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1066 buf
->local_var_alist
1067 = Fcons (tem1
, buf
->local_var_alist
);
1071 /* Record which binding is now loaded. */
1072 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1075 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1076 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1077 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1079 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1082 /* If storing void (making the symbol void), forward only through
1083 buffer-local indicator, not through Lisp_Objfwd, etc. */
1085 store_symval_forwarding (symbol
, Qnil
, newval
);
1087 store_symval_forwarding (symbol
, valcontents
, newval
);
1092 /* Access or set a buffer-local symbol's default value. */
1094 /* Return the default value of SYMBOL, but don't check for voidness.
1095 Return Qunbound if it is void. */
1098 default_value (symbol
)
1101 register Lisp_Object valcontents
;
1103 CHECK_SYMBOL (symbol
, 0);
1104 valcontents
= XSYMBOL (symbol
)->value
;
1106 /* For a built-in buffer-local variable, get the default value
1107 rather than letting do_symval_forwarding get the current value. */
1108 if (BUFFER_OBJFWDP (valcontents
))
1110 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1111 if (PER_BUFFER_IDX (offset
) != 0)
1112 return PER_BUFFER_DEFAULT (offset
);
1115 /* Handle user-created local variables. */
1116 if (BUFFER_LOCAL_VALUEP (valcontents
)
1117 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1119 /* If var is set up for a buffer that lacks a local value for it,
1120 the current value is nominally the default value.
1121 But the `realvalue' slot may be more up to date, since
1122 ordinary setq stores just that slot. So use that. */
1123 Lisp_Object current_alist_element
, alist_element_car
;
1124 current_alist_element
1125 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1126 alist_element_car
= XCAR (current_alist_element
);
1127 if (EQ (alist_element_car
, current_alist_element
))
1128 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1130 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1132 /* For other variables, get the current value. */
1133 return do_symval_forwarding (valcontents
);
1136 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1137 "Return t if SYMBOL has a non-void default value.\n\
1138 This is the value that is seen in buffers that do not have their own values\n\
1139 for this variable.")
1143 register Lisp_Object value
;
1145 value
= default_value (symbol
);
1146 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1149 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1150 "Return SYMBOL's default value.\n\
1151 This is the value that is seen in buffers that do not have their own values\n\
1152 for this variable. The default value is meaningful for variables with\n\
1153 local bindings in certain buffers.")
1157 register Lisp_Object value
;
1159 value
= default_value (symbol
);
1160 if (EQ (value
, Qunbound
))
1161 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1165 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1166 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1167 The default value is seen in buffers that do not have their own values\n\
1168 for this variable.")
1170 Lisp_Object symbol
, value
;
1172 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1174 CHECK_SYMBOL (symbol
, 0);
1175 valcontents
= XSYMBOL (symbol
)->value
;
1177 /* Handle variables like case-fold-search that have special slots
1178 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1180 if (BUFFER_OBJFWDP (valcontents
))
1182 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1183 int idx
= PER_BUFFER_IDX (offset
);
1185 PER_BUFFER_DEFAULT (offset
) = value
;
1187 /* If this variable is not always local in all buffers,
1188 set it in the buffers that don't nominally have a local value. */
1193 for (b
= all_buffers
; b
; b
= b
->next
)
1194 if (!PER_BUFFER_VALUE_P (b
, idx
))
1195 PER_BUFFER_VALUE (b
, offset
) = value
;
1200 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1201 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1202 return Fset (symbol
, value
);
1204 /* Store new value into the DEFAULT-VALUE slot. */
1205 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1207 /* If the default binding is now loaded, set the REALVALUE slot too. */
1208 current_alist_element
1209 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1210 alist_element_buffer
= Fcar (current_alist_element
);
1211 if (EQ (alist_element_buffer
, current_alist_element
))
1212 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1218 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1219 "Set the default value of variable VAR to VALUE.\n\
1220 VAR, the variable name, is literal (not evaluated);\n\
1221 VALUE is an expression and it is evaluated.\n\
1222 The default value of a variable is seen in buffers\n\
1223 that do not have their own values for the variable.\n\
1225 More generally, you can use multiple variables and values, as in\n\
1226 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1227 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1228 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1233 register Lisp_Object args_left
;
1234 register Lisp_Object val
, symbol
;
1235 struct gcpro gcpro1
;
1245 val
= Feval (Fcar (Fcdr (args_left
)));
1246 symbol
= Fcar (args_left
);
1247 Fset_default (symbol
, val
);
1248 args_left
= Fcdr (Fcdr (args_left
));
1250 while (!NILP (args_left
));
1256 /* Lisp functions for creating and removing buffer-local variables. */
1258 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1259 1, 1, "vMake Variable Buffer Local: ",
1260 "Make VARIABLE become buffer-local whenever it is set.\n\
1261 At any time, the value for the current buffer is in effect,\n\
1262 unless the variable has never been set in this buffer,\n\
1263 in which case the default value is in effect.\n\
1264 Note that binding the variable with `let', or setting it while\n\
1265 a `let'-style binding made in this buffer is in effect,\n\
1266 does not make the variable buffer-local.\n\
1268 The function `default-value' gets the default value and `set-default' sets it.")
1270 register Lisp_Object variable
;
1272 register Lisp_Object tem
, valcontents
, newval
;
1274 CHECK_SYMBOL (variable
, 0);
1276 valcontents
= XSYMBOL (variable
)->value
;
1277 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1278 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1280 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1282 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1284 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1287 if (EQ (valcontents
, Qunbound
))
1288 XSYMBOL (variable
)->value
= Qnil
;
1289 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1291 newval
= allocate_misc ();
1292 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1293 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1294 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1295 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1296 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1297 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1298 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1299 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1300 XSYMBOL (variable
)->value
= newval
;
1304 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1305 1, 1, "vMake Local Variable: ",
1306 "Make VARIABLE have a separate value in the current buffer.\n\
1307 Other buffers will continue to share a common default value.\n\
1308 \(The buffer-local value of VARIABLE starts out as the same value\n\
1309 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1310 See also `make-variable-buffer-local'.\n\
1312 If the variable is already arranged to become local when set,\n\
1313 this function causes a local value to exist for this buffer,\n\
1314 just as setting the variable would do.\n\
1316 This function returns VARIABLE, and therefore\n\
1317 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1320 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1321 Use `make-local-hook' instead.")
1323 register Lisp_Object variable
;
1325 register Lisp_Object tem
, valcontents
;
1327 CHECK_SYMBOL (variable
, 0);
1329 valcontents
= XSYMBOL (variable
)->value
;
1330 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1331 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1333 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1335 tem
= Fboundp (variable
);
1337 /* Make sure the symbol has a local value in this particular buffer,
1338 by setting it to the same value it already has. */
1339 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1342 /* Make sure symbol is set up to hold per-buffer values. */
1343 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1346 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1348 newval
= allocate_misc ();
1349 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1350 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1351 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1352 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1353 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1354 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1355 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1356 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1357 XSYMBOL (variable
)->value
= newval
;
1359 /* Make sure this buffer has its own value of symbol. */
1360 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1363 /* Swap out any local binding for some other buffer, and make
1364 sure the current value is permanently recorded, if it's the
1366 find_symbol_value (variable
);
1368 current_buffer
->local_var_alist
1369 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1370 current_buffer
->local_var_alist
);
1372 /* Make sure symbol does not think it is set up for this buffer;
1373 force it to look once again for this buffer's value. */
1375 Lisp_Object
*pvalbuf
;
1377 valcontents
= XSYMBOL (variable
)->value
;
1379 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1380 if (current_buffer
== XBUFFER (*pvalbuf
))
1382 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1386 /* If the symbol forwards into a C variable, then load the binding
1387 for this buffer now. If C code modifies the variable before we
1388 load the binding in, then that new value will clobber the default
1389 binding the next time we unload it. */
1390 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1391 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1392 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1397 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1398 1, 1, "vKill Local Variable: ",
1399 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1400 From now on the default value will apply in this buffer.")
1402 register Lisp_Object variable
;
1404 register Lisp_Object tem
, valcontents
;
1406 CHECK_SYMBOL (variable
, 0);
1408 valcontents
= XSYMBOL (variable
)->value
;
1410 if (BUFFER_OBJFWDP (valcontents
))
1412 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1413 int idx
= PER_BUFFER_IDX (offset
);
1417 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1418 PER_BUFFER_VALUE (current_buffer
, offset
)
1419 = PER_BUFFER_DEFAULT (offset
);
1424 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1425 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1428 /* Get rid of this buffer's alist element, if any. */
1430 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1432 current_buffer
->local_var_alist
1433 = Fdelq (tem
, current_buffer
->local_var_alist
);
1435 /* If the symbol is set up with the current buffer's binding
1436 loaded, recompute its value. We have to do it now, or else
1437 forwarded objects won't work right. */
1439 Lisp_Object
*pvalbuf
;
1440 valcontents
= XSYMBOL (variable
)->value
;
1441 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1442 if (current_buffer
== XBUFFER (*pvalbuf
))
1445 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1446 find_symbol_value (variable
);
1453 /* Lisp functions for creating and removing buffer-local variables. */
1455 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1456 1, 1, "vMake Variable Frame Local: ",
1457 "Enable VARIABLE to have frame-local bindings.\n\
1458 When a frame-local binding exists in the current frame,\n\
1459 it is in effect whenever the current buffer has no buffer-local binding.\n\
1460 A frame-local binding is actual a frame parameter value;\n\
1461 thus, any given frame has a local binding for VARIABLE\n\
1462 if it has a value for the frame parameter named VARIABLE.\n\
1463 See `modify-frame-parameters'.")
1465 register Lisp_Object variable
;
1467 register Lisp_Object tem
, valcontents
, newval
;
1469 CHECK_SYMBOL (variable
, 0);
1471 valcontents
= XSYMBOL (variable
)->value
;
1472 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1473 || BUFFER_OBJFWDP (valcontents
))
1474 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1476 if (BUFFER_LOCAL_VALUEP (valcontents
)
1477 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1479 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1483 if (EQ (valcontents
, Qunbound
))
1484 XSYMBOL (variable
)->value
= Qnil
;
1485 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1487 newval
= allocate_misc ();
1488 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1489 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1490 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1491 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1492 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1493 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1494 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1495 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1496 XSYMBOL (variable
)->value
= newval
;
1500 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1502 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1503 BUFFER defaults to the current buffer.")
1505 register Lisp_Object variable
, buffer
;
1507 Lisp_Object valcontents
;
1508 register struct buffer
*buf
;
1511 buf
= current_buffer
;
1514 CHECK_BUFFER (buffer
, 0);
1515 buf
= XBUFFER (buffer
);
1518 CHECK_SYMBOL (variable
, 0);
1520 valcontents
= XSYMBOL (variable
)->value
;
1521 if (BUFFER_LOCAL_VALUEP (valcontents
)
1522 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1524 Lisp_Object tail
, elt
;
1525 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1528 if (EQ (variable
, XCAR (elt
)))
1532 if (BUFFER_OBJFWDP (valcontents
))
1534 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1535 int idx
= PER_BUFFER_IDX (offset
);
1536 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1542 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1544 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1545 BUFFER defaults to the current buffer.")
1547 register Lisp_Object variable
, buffer
;
1549 Lisp_Object valcontents
;
1550 register struct buffer
*buf
;
1553 buf
= current_buffer
;
1556 CHECK_BUFFER (buffer
, 0);
1557 buf
= XBUFFER (buffer
);
1560 CHECK_SYMBOL (variable
, 0);
1562 valcontents
= XSYMBOL (variable
)->value
;
1564 /* This means that make-variable-buffer-local was done. */
1565 if (BUFFER_LOCAL_VALUEP (valcontents
))
1567 /* All these slots become local if they are set. */
1568 if (BUFFER_OBJFWDP (valcontents
))
1570 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1572 Lisp_Object tail
, elt
;
1573 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1576 if (EQ (variable
, XCAR (elt
)))
1583 /* Find the function at the end of a chain of symbol function indirections. */
1585 /* If OBJECT is a symbol, find the end of its function chain and
1586 return the value found there. If OBJECT is not a symbol, just
1587 return it. If there is a cycle in the function chain, signal a
1588 cyclic-function-indirection error.
1590 This is like Findirect_function, except that it doesn't signal an
1591 error if the chain ends up unbound. */
1593 indirect_function (object
)
1594 register Lisp_Object object
;
1596 Lisp_Object tortoise
, hare
;
1598 hare
= tortoise
= object
;
1602 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1604 hare
= XSYMBOL (hare
)->function
;
1605 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1607 hare
= XSYMBOL (hare
)->function
;
1609 tortoise
= XSYMBOL (tortoise
)->function
;
1611 if (EQ (hare
, tortoise
))
1612 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1618 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1619 "Return the function at the end of OBJECT's function chain.\n\
1620 If OBJECT is a symbol, follow all function indirections and return the final\n\
1621 function binding.\n\
1622 If OBJECT is not a symbol, just return it.\n\
1623 Signal a void-function error if the final symbol is unbound.\n\
1624 Signal a cyclic-function-indirection error if there is a loop in the\n\
1625 function chain of symbols.")
1627 register Lisp_Object object
;
1631 result
= indirect_function (object
);
1633 if (EQ (result
, Qunbound
))
1634 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1638 /* Extract and set vector and string elements */
1640 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1641 "Return the element of ARRAY at index IDX.\n\
1642 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1643 or a byte-code object. IDX starts at 0.")
1645 register Lisp_Object array
;
1648 register int idxval
;
1650 CHECK_NUMBER (idx
, 1);
1651 idxval
= XINT (idx
);
1652 if (STRINGP (array
))
1656 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1657 args_out_of_range (array
, idx
);
1658 if (! STRING_MULTIBYTE (array
))
1659 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1660 idxval_byte
= string_char_to_byte (array
, idxval
);
1662 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1663 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1664 return make_number (c
);
1666 else if (BOOL_VECTOR_P (array
))
1670 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1671 args_out_of_range (array
, idx
);
1673 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1674 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1676 else if (CHAR_TABLE_P (array
))
1681 args_out_of_range (array
, idx
);
1682 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1684 /* For ASCII and 8-bit European characters, the element is
1685 stored in the top table. */
1686 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1688 val
= XCHAR_TABLE (array
)->defalt
;
1689 while (NILP (val
)) /* Follow parents until we find some value. */
1691 array
= XCHAR_TABLE (array
)->parent
;
1694 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1696 val
= XCHAR_TABLE (array
)->defalt
;
1703 Lisp_Object sub_table
;
1705 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1706 if (code
[1] < 32) code
[1] = -1;
1707 else if (code
[2] < 32) code
[2] = -1;
1709 /* Here, the possible range of CODE[0] (== charset ID) is
1710 128..MAX_CHARSET. Since the top level char table contains
1711 data for multibyte characters after 256th element, we must
1712 increment CODE[0] by 128 to get a correct index. */
1714 code
[3] = -1; /* anchor */
1716 try_parent_char_table
:
1718 for (i
= 0; code
[i
] >= 0; i
++)
1720 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1721 if (SUB_CHAR_TABLE_P (val
))
1726 val
= XCHAR_TABLE (sub_table
)->defalt
;
1729 array
= XCHAR_TABLE (array
)->parent
;
1731 goto try_parent_char_table
;
1736 /* Here, VAL is a sub char table. We try the default value
1738 val
= XCHAR_TABLE (val
)->defalt
;
1741 array
= XCHAR_TABLE (array
)->parent
;
1743 goto try_parent_char_table
;
1751 if (VECTORP (array
))
1752 size
= XVECTOR (array
)->size
;
1753 else if (COMPILEDP (array
))
1754 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1756 wrong_type_argument (Qarrayp
, array
);
1758 if (idxval
< 0 || idxval
>= size
)
1759 args_out_of_range (array
, idx
);
1760 return XVECTOR (array
)->contents
[idxval
];
1764 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1765 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1766 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1768 (array
, idx
, newelt
)
1769 register Lisp_Object array
;
1770 Lisp_Object idx
, newelt
;
1772 register int idxval
;
1774 CHECK_NUMBER (idx
, 1);
1775 idxval
= XINT (idx
);
1776 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1777 && ! CHAR_TABLE_P (array
))
1778 array
= wrong_type_argument (Qarrayp
, array
);
1779 CHECK_IMPURE (array
);
1781 if (VECTORP (array
))
1783 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1784 args_out_of_range (array
, idx
);
1785 XVECTOR (array
)->contents
[idxval
] = newelt
;
1787 else if (BOOL_VECTOR_P (array
))
1791 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1792 args_out_of_range (array
, idx
);
1794 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1796 if (! NILP (newelt
))
1797 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1799 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1800 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1802 else if (CHAR_TABLE_P (array
))
1805 args_out_of_range (array
, idx
);
1806 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1807 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1813 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1814 if (code
[1] < 32) code
[1] = -1;
1815 else if (code
[2] < 32) code
[2] = -1;
1817 /* See the comment of the corresponding part in Faref. */
1819 code
[3] = -1; /* anchor */
1820 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1822 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1823 if (SUB_CHAR_TABLE_P (val
))
1829 /* VAL is a leaf. Create a sub char table with the
1830 default value VAL or XCHAR_TABLE (array)->defalt
1831 and look into it. */
1833 temp
= make_sub_char_table (NILP (val
)
1834 ? XCHAR_TABLE (array
)->defalt
1836 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1840 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1843 else if (STRING_MULTIBYTE (array
))
1845 int idxval_byte
, new_len
, actual_len
;
1847 unsigned char *p
, workbuf
[MAX_MULTIBYTE_LENGTH
], *str
= workbuf
;
1849 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1850 args_out_of_range (array
, idx
);
1852 idxval_byte
= string_char_to_byte (array
, idxval
);
1853 p
= &XSTRING (array
)->data
[idxval_byte
];
1855 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1856 CHECK_NUMBER (newelt
, 2);
1857 new_len
= CHAR_STRING (XINT (newelt
), str
);
1858 if (actual_len
!= new_len
)
1859 error ("Attempt to change byte length of a string");
1861 /* We can't accept a change causing byte combining. */
1862 if (!ASCII_BYTE_P (*str
)
1863 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1864 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1865 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1866 > idxval_byte
- prev_byte
))
1867 || (idxval
< XSTRING (array
)->size
- 1
1868 && !CHAR_HEAD_P (p
[actual_len
])
1869 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1870 error ("Attempt to change char length of a string");
1876 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1877 args_out_of_range (array
, idx
);
1878 CHECK_NUMBER (newelt
, 2);
1879 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1885 /* Arithmetic functions */
1887 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1890 arithcompare (num1
, num2
, comparison
)
1891 Lisp_Object num1
, num2
;
1892 enum comparison comparison
;
1897 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1898 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1900 if (FLOATP (num1
) || FLOATP (num2
))
1903 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1904 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1910 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1915 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1920 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1925 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1930 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1935 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1944 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1945 "Return t if two args, both numbers or markers, are equal.")
1947 register Lisp_Object num1
, num2
;
1949 return arithcompare (num1
, num2
, equal
);
1952 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1953 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1955 register Lisp_Object num1
, num2
;
1957 return arithcompare (num1
, num2
, less
);
1960 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1961 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1963 register Lisp_Object num1
, num2
;
1965 return arithcompare (num1
, num2
, grtr
);
1968 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1969 "Return t if first arg is less than or equal to second arg.\n\
1970 Both must be numbers or markers.")
1972 register Lisp_Object num1
, num2
;
1974 return arithcompare (num1
, num2
, less_or_equal
);
1977 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1978 "Return t if first arg is greater than or equal to second arg.\n\
1979 Both must be numbers or markers.")
1981 register Lisp_Object num1
, num2
;
1983 return arithcompare (num1
, num2
, grtr_or_equal
);
1986 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1987 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1989 register Lisp_Object num1
, num2
;
1991 return arithcompare (num1
, num2
, notequal
);
1994 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1996 register Lisp_Object number
;
1998 CHECK_NUMBER_OR_FLOAT (number
, 0);
2000 if (FLOATP (number
))
2002 if (XFLOAT_DATA (number
) == 0.0)
2012 /* Convert between long values and pairs of Lisp integers. */
2018 unsigned int top
= i
>> 16;
2019 unsigned int bot
= i
& 0xFFFF;
2021 return make_number (bot
);
2022 if (top
== (unsigned long)-1 >> 16)
2023 return Fcons (make_number (-1), make_number (bot
));
2024 return Fcons (make_number (top
), make_number (bot
));
2031 Lisp_Object top
, bot
;
2038 return ((XINT (top
) << 16) | XINT (bot
));
2041 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2042 "Convert NUMBER to a string by printing it in decimal.\n\
2043 Uses a minus sign if negative.\n\
2044 NUMBER may be an integer or a floating point number.")
2048 char buffer
[VALBITS
];
2050 CHECK_NUMBER_OR_FLOAT (number
, 0);
2052 if (FLOATP (number
))
2054 char pigbuf
[350]; /* see comments in float_to_string */
2056 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2057 return build_string (pigbuf
);
2060 if (sizeof (int) == sizeof (EMACS_INT
))
2061 sprintf (buffer
, "%d", XINT (number
));
2062 else if (sizeof (long) == sizeof (EMACS_INT
))
2063 sprintf (buffer
, "%ld", (long) XINT (number
));
2066 return build_string (buffer
);
2070 digit_to_number (character
, base
)
2071 int character
, base
;
2075 if (character
>= '0' && character
<= '9')
2076 digit
= character
- '0';
2077 else if (character
>= 'a' && character
<= 'z')
2078 digit
= character
- 'a' + 10;
2079 else if (character
>= 'A' && character
<= 'Z')
2080 digit
= character
- 'A' + 10;
2090 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2091 "Convert STRING to a number by parsing it as a decimal number.\n\
2092 This parses both integers and floating point numbers.\n\
2093 It ignores leading spaces and tabs.\n\
2095 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2096 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2097 If the base used is not 10, floating point is not recognized.")
2099 register Lisp_Object string
, base
;
2101 register unsigned char *p
;
2106 CHECK_STRING (string
, 0);
2112 CHECK_NUMBER (base
, 1);
2114 if (b
< 2 || b
> 16)
2115 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2118 /* Skip any whitespace at the front of the number. Some versions of
2119 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2120 p
= XSTRING (string
)->data
;
2121 while (*p
== ' ' || *p
== '\t')
2132 if (isfloat_string (p
) && b
== 10)
2133 val
= make_float (sign
* atof (p
));
2140 int digit
= digit_to_number (*p
++, b
);
2146 if (v
> (EMACS_UINT
) (VALMASK
>> 1))
2147 val
= make_float (sign
* v
);
2149 val
= make_number (sign
* (int) v
);
2157 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2159 extern Lisp_Object
float_arith_driver ();
2160 extern Lisp_Object
fmod_float ();
2163 arith_driver (code
, nargs
, args
)
2166 register Lisp_Object
*args
;
2168 register Lisp_Object val
;
2169 register int argnum
;
2170 register EMACS_INT accum
;
2171 register EMACS_INT next
;
2173 switch (SWITCH_ENUM_CAST (code
))
2186 for (argnum
= 0; argnum
< nargs
; argnum
++)
2188 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2189 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2191 if (FLOATP (val
)) /* time to do serious math */
2192 return (float_arith_driver ((double) accum
, argnum
, code
,
2194 args
[argnum
] = val
; /* runs into a compiler bug. */
2195 next
= XINT (args
[argnum
]);
2196 switch (SWITCH_ENUM_CAST (code
))
2198 case Aadd
: accum
+= next
; break;
2200 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2202 case Amult
: accum
*= next
; break;
2204 if (!argnum
) accum
= next
;
2208 Fsignal (Qarith_error
, Qnil
);
2212 case Alogand
: accum
&= next
; break;
2213 case Alogior
: accum
|= next
; break;
2214 case Alogxor
: accum
^= next
; break;
2215 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2216 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2220 XSETINT (val
, accum
);
2225 #define isnan(x) ((x) != (x))
2228 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2230 register int argnum
;
2233 register Lisp_Object
*args
;
2235 register Lisp_Object val
;
2238 for (; argnum
< nargs
; argnum
++)
2240 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2241 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2245 next
= XFLOAT_DATA (val
);
2249 args
[argnum
] = val
; /* runs into a compiler bug. */
2250 next
= XINT (args
[argnum
]);
2252 switch (SWITCH_ENUM_CAST (code
))
2258 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2268 if (! IEEE_FLOATING_POINT
&& next
== 0)
2269 Fsignal (Qarith_error
, Qnil
);
2276 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2278 if (!argnum
|| isnan (next
) || next
> accum
)
2282 if (!argnum
|| isnan (next
) || next
< accum
)
2288 return make_float (accum
);
2292 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2293 "Return sum of any number of arguments, which are numbers or markers.")
2298 return arith_driver (Aadd
, nargs
, args
);
2301 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2302 "Negate number or subtract numbers or markers.\n\
2303 With one arg, negates it. With more than one arg,\n\
2304 subtracts all but the first from the first.")
2309 return arith_driver (Asub
, nargs
, args
);
2312 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2313 "Returns product of any number of arguments, which are numbers or markers.")
2318 return arith_driver (Amult
, nargs
, args
);
2321 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2322 "Returns first argument divided by all the remaining arguments.\n\
2323 The arguments must be numbers or markers.")
2328 return arith_driver (Adiv
, nargs
, args
);
2331 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2332 "Returns remainder of X divided by Y.\n\
2333 Both must be integers or markers.")
2335 register Lisp_Object x
, y
;
2339 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2340 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2342 if (XFASTINT (y
) == 0)
2343 Fsignal (Qarith_error
, Qnil
);
2345 XSETINT (val
, XINT (x
) % XINT (y
));
2359 /* If the magnitude of the result exceeds that of the divisor, or
2360 the sign of the result does not agree with that of the dividend,
2361 iterate with the reduced value. This does not yield a
2362 particularly accurate result, but at least it will be in the
2363 range promised by fmod. */
2365 r
-= f2
* floor (r
/ f2
);
2366 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2370 #endif /* ! HAVE_FMOD */
2372 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2373 "Returns X modulo Y.\n\
2374 The result falls between zero (inclusive) and Y (exclusive).\n\
2375 Both X and Y must be numbers or markers.")
2377 register Lisp_Object x
, y
;
2382 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2383 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2385 if (FLOATP (x
) || FLOATP (y
))
2386 return fmod_float (x
, y
);
2392 Fsignal (Qarith_error
, Qnil
);
2396 /* If the "remainder" comes out with the wrong sign, fix it. */
2397 if (i2
< 0 ? i1
> 0 : i1
< 0)
2404 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2405 "Return largest of all the arguments (which must be numbers or markers).\n\
2406 The value is always a number; markers are converted to numbers.")
2411 return arith_driver (Amax
, nargs
, args
);
2414 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2415 "Return smallest of all the arguments (which must be numbers or markers).\n\
2416 The value is always a number; markers are converted to numbers.")
2421 return arith_driver (Amin
, nargs
, args
);
2424 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2425 "Return bitwise-and of all the arguments.\n\
2426 Arguments may be integers, or markers converted to integers.")
2431 return arith_driver (Alogand
, nargs
, args
);
2434 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2435 "Return bitwise-or of all the arguments.\n\
2436 Arguments may be integers, or markers converted to integers.")
2441 return arith_driver (Alogior
, nargs
, args
);
2444 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2445 "Return bitwise-exclusive-or of all the arguments.\n\
2446 Arguments may be integers, or markers converted to integers.")
2451 return arith_driver (Alogxor
, nargs
, args
);
2454 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2455 "Return VALUE with its bits shifted left by COUNT.\n\
2456 If COUNT is negative, shifting is actually to the right.\n\
2457 In this case, the sign bit is duplicated.")
2459 register Lisp_Object value
, count
;
2461 register Lisp_Object val
;
2463 CHECK_NUMBER (value
, 0);
2464 CHECK_NUMBER (count
, 1);
2466 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2468 else if (XINT (count
) > 0)
2469 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2470 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2471 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2473 XSETINT (val
, XINT (value
) >> -XINT (count
));
2477 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2478 "Return VALUE with its bits shifted left by COUNT.\n\
2479 If COUNT is negative, shifting is actually to the right.\n\
2480 In this case, zeros are shifted in on the left.")
2482 register Lisp_Object value
, count
;
2484 register Lisp_Object val
;
2486 CHECK_NUMBER (value
, 0);
2487 CHECK_NUMBER (count
, 1);
2489 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2491 else if (XINT (count
) > 0)
2492 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2493 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2496 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2500 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2501 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2502 Markers are converted to integers.")
2504 register Lisp_Object number
;
2506 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2508 if (FLOATP (number
))
2509 return (make_float (1.0 + XFLOAT_DATA (number
)));
2511 XSETINT (number
, XINT (number
) + 1);
2515 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2516 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2517 Markers are converted to integers.")
2519 register Lisp_Object number
;
2521 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2523 if (FLOATP (number
))
2524 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2526 XSETINT (number
, XINT (number
) - 1);
2530 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2531 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2533 register Lisp_Object number
;
2535 CHECK_NUMBER (number
, 0);
2536 XSETINT (number
, ~XINT (number
));
2543 Lisp_Object error_tail
, arith_tail
;
2545 Qquote
= intern ("quote");
2546 Qlambda
= intern ("lambda");
2547 Qsubr
= intern ("subr");
2548 Qerror_conditions
= intern ("error-conditions");
2549 Qerror_message
= intern ("error-message");
2550 Qtop_level
= intern ("top-level");
2552 Qerror
= intern ("error");
2553 Qquit
= intern ("quit");
2554 Qwrong_type_argument
= intern ("wrong-type-argument");
2555 Qargs_out_of_range
= intern ("args-out-of-range");
2556 Qvoid_function
= intern ("void-function");
2557 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2558 Qvoid_variable
= intern ("void-variable");
2559 Qsetting_constant
= intern ("setting-constant");
2560 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2562 Qinvalid_function
= intern ("invalid-function");
2563 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2564 Qno_catch
= intern ("no-catch");
2565 Qend_of_file
= intern ("end-of-file");
2566 Qarith_error
= intern ("arith-error");
2567 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2568 Qend_of_buffer
= intern ("end-of-buffer");
2569 Qbuffer_read_only
= intern ("buffer-read-only");
2570 Qtext_read_only
= intern ("text-read-only");
2571 Qmark_inactive
= intern ("mark-inactive");
2573 Qlistp
= intern ("listp");
2574 Qconsp
= intern ("consp");
2575 Qsymbolp
= intern ("symbolp");
2576 Qkeywordp
= intern ("keywordp");
2577 Qintegerp
= intern ("integerp");
2578 Qnatnump
= intern ("natnump");
2579 Qwholenump
= intern ("wholenump");
2580 Qstringp
= intern ("stringp");
2581 Qarrayp
= intern ("arrayp");
2582 Qsequencep
= intern ("sequencep");
2583 Qbufferp
= intern ("bufferp");
2584 Qvectorp
= intern ("vectorp");
2585 Qchar_or_string_p
= intern ("char-or-string-p");
2586 Qmarkerp
= intern ("markerp");
2587 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2588 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2589 Qboundp
= intern ("boundp");
2590 Qfboundp
= intern ("fboundp");
2592 Qfloatp
= intern ("floatp");
2593 Qnumberp
= intern ("numberp");
2594 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2596 Qchar_table_p
= intern ("char-table-p");
2597 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2599 Qcdr
= intern ("cdr");
2601 /* Handle automatic advice activation */
2602 Qad_advice_info
= intern ("ad-advice-info");
2603 Qad_activate_internal
= intern ("ad-activate-internal");
2605 error_tail
= Fcons (Qerror
, Qnil
);
2607 /* ERROR is used as a signaler for random errors for which nothing else is right */
2609 Fput (Qerror
, Qerror_conditions
,
2611 Fput (Qerror
, Qerror_message
,
2612 build_string ("error"));
2614 Fput (Qquit
, Qerror_conditions
,
2615 Fcons (Qquit
, Qnil
));
2616 Fput (Qquit
, Qerror_message
,
2617 build_string ("Quit"));
2619 Fput (Qwrong_type_argument
, Qerror_conditions
,
2620 Fcons (Qwrong_type_argument
, error_tail
));
2621 Fput (Qwrong_type_argument
, Qerror_message
,
2622 build_string ("Wrong type argument"));
2624 Fput (Qargs_out_of_range
, Qerror_conditions
,
2625 Fcons (Qargs_out_of_range
, error_tail
));
2626 Fput (Qargs_out_of_range
, Qerror_message
,
2627 build_string ("Args out of range"));
2629 Fput (Qvoid_function
, Qerror_conditions
,
2630 Fcons (Qvoid_function
, error_tail
));
2631 Fput (Qvoid_function
, Qerror_message
,
2632 build_string ("Symbol's function definition is void"));
2634 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2635 Fcons (Qcyclic_function_indirection
, error_tail
));
2636 Fput (Qcyclic_function_indirection
, Qerror_message
,
2637 build_string ("Symbol's chain of function indirections contains a loop"));
2639 Fput (Qvoid_variable
, Qerror_conditions
,
2640 Fcons (Qvoid_variable
, error_tail
));
2641 Fput (Qvoid_variable
, Qerror_message
,
2642 build_string ("Symbol's value as variable is void"));
2644 Fput (Qsetting_constant
, Qerror_conditions
,
2645 Fcons (Qsetting_constant
, error_tail
));
2646 Fput (Qsetting_constant
, Qerror_message
,
2647 build_string ("Attempt to set a constant symbol"));
2649 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2650 Fcons (Qinvalid_read_syntax
, error_tail
));
2651 Fput (Qinvalid_read_syntax
, Qerror_message
,
2652 build_string ("Invalid read syntax"));
2654 Fput (Qinvalid_function
, Qerror_conditions
,
2655 Fcons (Qinvalid_function
, error_tail
));
2656 Fput (Qinvalid_function
, Qerror_message
,
2657 build_string ("Invalid function"));
2659 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2660 Fcons (Qwrong_number_of_arguments
, error_tail
));
2661 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2662 build_string ("Wrong number of arguments"));
2664 Fput (Qno_catch
, Qerror_conditions
,
2665 Fcons (Qno_catch
, error_tail
));
2666 Fput (Qno_catch
, Qerror_message
,
2667 build_string ("No catch for tag"));
2669 Fput (Qend_of_file
, Qerror_conditions
,
2670 Fcons (Qend_of_file
, error_tail
));
2671 Fput (Qend_of_file
, Qerror_message
,
2672 build_string ("End of file during parsing"));
2674 arith_tail
= Fcons (Qarith_error
, error_tail
);
2675 Fput (Qarith_error
, Qerror_conditions
,
2677 Fput (Qarith_error
, Qerror_message
,
2678 build_string ("Arithmetic error"));
2680 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2681 Fcons (Qbeginning_of_buffer
, error_tail
));
2682 Fput (Qbeginning_of_buffer
, Qerror_message
,
2683 build_string ("Beginning of buffer"));
2685 Fput (Qend_of_buffer
, Qerror_conditions
,
2686 Fcons (Qend_of_buffer
, error_tail
));
2687 Fput (Qend_of_buffer
, Qerror_message
,
2688 build_string ("End of buffer"));
2690 Fput (Qbuffer_read_only
, Qerror_conditions
,
2691 Fcons (Qbuffer_read_only
, error_tail
));
2692 Fput (Qbuffer_read_only
, Qerror_message
,
2693 build_string ("Buffer is read-only"));
2695 Fput (Qtext_read_only
, Qerror_conditions
,
2696 Fcons (Qtext_read_only
, error_tail
));
2697 Fput (Qtext_read_only
, Qerror_message
,
2698 build_string ("Text is read-only"));
2700 Qrange_error
= intern ("range-error");
2701 Qdomain_error
= intern ("domain-error");
2702 Qsingularity_error
= intern ("singularity-error");
2703 Qoverflow_error
= intern ("overflow-error");
2704 Qunderflow_error
= intern ("underflow-error");
2706 Fput (Qdomain_error
, Qerror_conditions
,
2707 Fcons (Qdomain_error
, arith_tail
));
2708 Fput (Qdomain_error
, Qerror_message
,
2709 build_string ("Arithmetic domain error"));
2711 Fput (Qrange_error
, Qerror_conditions
,
2712 Fcons (Qrange_error
, arith_tail
));
2713 Fput (Qrange_error
, Qerror_message
,
2714 build_string ("Arithmetic range error"));
2716 Fput (Qsingularity_error
, Qerror_conditions
,
2717 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2718 Fput (Qsingularity_error
, Qerror_message
,
2719 build_string ("Arithmetic singularity error"));
2721 Fput (Qoverflow_error
, Qerror_conditions
,
2722 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2723 Fput (Qoverflow_error
, Qerror_message
,
2724 build_string ("Arithmetic overflow error"));
2726 Fput (Qunderflow_error
, Qerror_conditions
,
2727 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2728 Fput (Qunderflow_error
, Qerror_message
,
2729 build_string ("Arithmetic underflow error"));
2731 staticpro (&Qrange_error
);
2732 staticpro (&Qdomain_error
);
2733 staticpro (&Qsingularity_error
);
2734 staticpro (&Qoverflow_error
);
2735 staticpro (&Qunderflow_error
);
2739 staticpro (&Qquote
);
2740 staticpro (&Qlambda
);
2742 staticpro (&Qunbound
);
2743 staticpro (&Qerror_conditions
);
2744 staticpro (&Qerror_message
);
2745 staticpro (&Qtop_level
);
2747 staticpro (&Qerror
);
2749 staticpro (&Qwrong_type_argument
);
2750 staticpro (&Qargs_out_of_range
);
2751 staticpro (&Qvoid_function
);
2752 staticpro (&Qcyclic_function_indirection
);
2753 staticpro (&Qvoid_variable
);
2754 staticpro (&Qsetting_constant
);
2755 staticpro (&Qinvalid_read_syntax
);
2756 staticpro (&Qwrong_number_of_arguments
);
2757 staticpro (&Qinvalid_function
);
2758 staticpro (&Qno_catch
);
2759 staticpro (&Qend_of_file
);
2760 staticpro (&Qarith_error
);
2761 staticpro (&Qbeginning_of_buffer
);
2762 staticpro (&Qend_of_buffer
);
2763 staticpro (&Qbuffer_read_only
);
2764 staticpro (&Qtext_read_only
);
2765 staticpro (&Qmark_inactive
);
2767 staticpro (&Qlistp
);
2768 staticpro (&Qconsp
);
2769 staticpro (&Qsymbolp
);
2770 staticpro (&Qkeywordp
);
2771 staticpro (&Qintegerp
);
2772 staticpro (&Qnatnump
);
2773 staticpro (&Qwholenump
);
2774 staticpro (&Qstringp
);
2775 staticpro (&Qarrayp
);
2776 staticpro (&Qsequencep
);
2777 staticpro (&Qbufferp
);
2778 staticpro (&Qvectorp
);
2779 staticpro (&Qchar_or_string_p
);
2780 staticpro (&Qmarkerp
);
2781 staticpro (&Qbuffer_or_string_p
);
2782 staticpro (&Qinteger_or_marker_p
);
2783 staticpro (&Qfloatp
);
2784 staticpro (&Qnumberp
);
2785 staticpro (&Qnumber_or_marker_p
);
2786 staticpro (&Qchar_table_p
);
2787 staticpro (&Qvector_or_char_table_p
);
2789 staticpro (&Qboundp
);
2790 staticpro (&Qfboundp
);
2792 staticpro (&Qad_advice_info
);
2793 staticpro (&Qad_activate_internal
);
2795 /* Types that type-of returns. */
2796 Qinteger
= intern ("integer");
2797 Qsymbol
= intern ("symbol");
2798 Qstring
= intern ("string");
2799 Qcons
= intern ("cons");
2800 Qmarker
= intern ("marker");
2801 Qoverlay
= intern ("overlay");
2802 Qfloat
= intern ("float");
2803 Qwindow_configuration
= intern ("window-configuration");
2804 Qprocess
= intern ("process");
2805 Qwindow
= intern ("window");
2806 /* Qsubr = intern ("subr"); */
2807 Qcompiled_function
= intern ("compiled-function");
2808 Qbuffer
= intern ("buffer");
2809 Qframe
= intern ("frame");
2810 Qvector
= intern ("vector");
2811 Qchar_table
= intern ("char-table");
2812 Qbool_vector
= intern ("bool-vector");
2813 Qhash_table
= intern ("hash-table");
2815 staticpro (&Qinteger
);
2816 staticpro (&Qsymbol
);
2817 staticpro (&Qstring
);
2819 staticpro (&Qmarker
);
2820 staticpro (&Qoverlay
);
2821 staticpro (&Qfloat
);
2822 staticpro (&Qwindow_configuration
);
2823 staticpro (&Qprocess
);
2824 staticpro (&Qwindow
);
2825 /* staticpro (&Qsubr); */
2826 staticpro (&Qcompiled_function
);
2827 staticpro (&Qbuffer
);
2828 staticpro (&Qframe
);
2829 staticpro (&Qvector
);
2830 staticpro (&Qchar_table
);
2831 staticpro (&Qbool_vector
);
2832 staticpro (&Qhash_table
);
2836 defsubr (&Stype_of
);
2841 defsubr (&Sintegerp
);
2842 defsubr (&Sinteger_or_marker_p
);
2843 defsubr (&Snumberp
);
2844 defsubr (&Snumber_or_marker_p
);
2846 defsubr (&Snatnump
);
2847 defsubr (&Ssymbolp
);
2848 defsubr (&Skeywordp
);
2849 defsubr (&Sstringp
);
2850 defsubr (&Smultibyte_string_p
);
2851 defsubr (&Svectorp
);
2852 defsubr (&Schar_table_p
);
2853 defsubr (&Svector_or_char_table_p
);
2854 defsubr (&Sbool_vector_p
);
2856 defsubr (&Ssequencep
);
2857 defsubr (&Sbufferp
);
2858 defsubr (&Smarkerp
);
2860 defsubr (&Sbyte_code_function_p
);
2861 defsubr (&Schar_or_string_p
);
2864 defsubr (&Scar_safe
);
2865 defsubr (&Scdr_safe
);
2868 defsubr (&Ssymbol_function
);
2869 defsubr (&Sindirect_function
);
2870 defsubr (&Ssymbol_plist
);
2871 defsubr (&Ssymbol_name
);
2872 defsubr (&Smakunbound
);
2873 defsubr (&Sfmakunbound
);
2875 defsubr (&Sfboundp
);
2877 defsubr (&Sdefalias
);
2878 defsubr (&Ssetplist
);
2879 defsubr (&Ssymbol_value
);
2881 defsubr (&Sdefault_boundp
);
2882 defsubr (&Sdefault_value
);
2883 defsubr (&Sset_default
);
2884 defsubr (&Ssetq_default
);
2885 defsubr (&Smake_variable_buffer_local
);
2886 defsubr (&Smake_local_variable
);
2887 defsubr (&Skill_local_variable
);
2888 defsubr (&Smake_variable_frame_local
);
2889 defsubr (&Slocal_variable_p
);
2890 defsubr (&Slocal_variable_if_set_p
);
2893 defsubr (&Snumber_to_string
);
2894 defsubr (&Sstring_to_number
);
2895 defsubr (&Seqlsign
);
2919 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2926 #if defined(USG) && !defined(POSIX_SIGNALS)
2927 /* USG systems forget handlers when they are used;
2928 must reestablish each time */
2929 signal (signo
, arith_error
);
2932 /* VMS systems are like USG. */
2933 signal (signo
, arith_error
);
2937 #else /* not BSD4_1 */
2938 sigsetmask (SIGEMPTYMASK
);
2939 #endif /* not BSD4_1 */
2941 Fsignal (Qarith_error
, Qnil
);
2947 /* Don't do this if just dumping out.
2948 We don't want to call `signal' in this case
2949 so that we don't have trouble with dumping
2950 signal-delivering routines in an inconsistent state. */
2954 #endif /* CANNOT_DUMP */
2955 signal (SIGFPE
, arith_error
);
2958 signal (SIGEMT
, arith_error
);