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 (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1016 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1017 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1018 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1019 || (BUFFER_LOCAL_VALUEP (valcontents
)
1020 && EQ (XCAR (current_alist_element
),
1021 current_alist_element
)))
1023 /* The currently loaded binding is not necessarily valid.
1024 We need to unload it, and choose a new binding. */
1026 /* Write out `realvalue' to the old loaded binding. */
1027 Fsetcdr (current_alist_element
,
1028 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1030 /* Find the new binding. */
1031 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1032 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1033 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1037 /* This buffer still sees the default value. */
1039 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1040 or if this is `let' rather than `set',
1041 make CURRENT-ALIST-ELEMENT point to itself,
1042 indicating that we're seeing the default value.
1043 Likewise if the variable has been let-bound
1044 in the current buffer. */
1045 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1046 || let_shadows_buffer_binding_p (symbol
))
1048 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1050 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1051 tem1
= Fassq (symbol
,
1052 XFRAME (selected_frame
)->param_alist
);
1055 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1057 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1059 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1060 and we're not within a let that was made for this buffer,
1061 create a new buffer-local binding for the variable.
1062 That means, give this buffer a new assoc for a local value
1063 and load that binding. */
1066 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1067 buf
->local_var_alist
1068 = Fcons (tem1
, buf
->local_var_alist
);
1072 /* Record which binding is now loaded. */
1073 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1076 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1077 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1078 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1080 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1083 /* If storing void (making the symbol void), forward only through
1084 buffer-local indicator, not through Lisp_Objfwd, etc. */
1086 store_symval_forwarding (symbol
, Qnil
, newval
);
1088 store_symval_forwarding (symbol
, valcontents
, newval
);
1093 /* Access or set a buffer-local symbol's default value. */
1095 /* Return the default value of SYMBOL, but don't check for voidness.
1096 Return Qunbound if it is void. */
1099 default_value (symbol
)
1102 register Lisp_Object valcontents
;
1104 CHECK_SYMBOL (symbol
, 0);
1105 valcontents
= XSYMBOL (symbol
)->value
;
1107 /* For a built-in buffer-local variable, get the default value
1108 rather than letting do_symval_forwarding get the current value. */
1109 if (BUFFER_OBJFWDP (valcontents
))
1111 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1112 if (PER_BUFFER_IDX (offset
) != 0)
1113 return PER_BUFFER_DEFAULT (offset
);
1116 /* Handle user-created local variables. */
1117 if (BUFFER_LOCAL_VALUEP (valcontents
)
1118 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1120 /* If var is set up for a buffer that lacks a local value for it,
1121 the current value is nominally the default value.
1122 But the `realvalue' slot may be more up to date, since
1123 ordinary setq stores just that slot. So use that. */
1124 Lisp_Object current_alist_element
, alist_element_car
;
1125 current_alist_element
1126 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1127 alist_element_car
= XCAR (current_alist_element
);
1128 if (EQ (alist_element_car
, current_alist_element
))
1129 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1131 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1133 /* For other variables, get the current value. */
1134 return do_symval_forwarding (valcontents
);
1137 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1138 "Return t if SYMBOL has a non-void default value.\n\
1139 This is the value that is seen in buffers that do not have their own values\n\
1140 for this variable.")
1144 register Lisp_Object value
;
1146 value
= default_value (symbol
);
1147 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1150 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1151 "Return SYMBOL's default value.\n\
1152 This is the value that is seen in buffers that do not have their own values\n\
1153 for this variable. The default value is meaningful for variables with\n\
1154 local bindings in certain buffers.")
1158 register Lisp_Object value
;
1160 value
= default_value (symbol
);
1161 if (EQ (value
, Qunbound
))
1162 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1166 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1167 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1168 The default value is seen in buffers that do not have their own values\n\
1169 for this variable.")
1171 Lisp_Object symbol
, value
;
1173 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1175 CHECK_SYMBOL (symbol
, 0);
1176 valcontents
= XSYMBOL (symbol
)->value
;
1178 /* Handle variables like case-fold-search that have special slots
1179 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1181 if (BUFFER_OBJFWDP (valcontents
))
1183 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1184 int idx
= PER_BUFFER_IDX (offset
);
1186 PER_BUFFER_DEFAULT (offset
) = value
;
1188 /* If this variable is not always local in all buffers,
1189 set it in the buffers that don't nominally have a local value. */
1194 for (b
= all_buffers
; b
; b
= b
->next
)
1195 if (!PER_BUFFER_VALUE_P (b
, idx
))
1196 PER_BUFFER_VALUE (b
, offset
) = value
;
1201 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1202 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1203 return Fset (symbol
, value
);
1205 /* Store new value into the DEFAULT-VALUE slot. */
1206 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1208 /* If the default binding is now loaded, set the REALVALUE slot too. */
1209 current_alist_element
1210 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1211 alist_element_buffer
= Fcar (current_alist_element
);
1212 if (EQ (alist_element_buffer
, current_alist_element
))
1213 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1219 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1220 "Set the default value of variable VAR to VALUE.\n\
1221 VAR, the variable name, is literal (not evaluated);\n\
1222 VALUE is an expression and it is evaluated.\n\
1223 The default value of a variable is seen in buffers\n\
1224 that do not have their own values for the variable.\n\
1226 More generally, you can use multiple variables and values, as in\n\
1227 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1228 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1229 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1234 register Lisp_Object args_left
;
1235 register Lisp_Object val
, symbol
;
1236 struct gcpro gcpro1
;
1246 val
= Feval (Fcar (Fcdr (args_left
)));
1247 symbol
= Fcar (args_left
);
1248 Fset_default (symbol
, val
);
1249 args_left
= Fcdr (Fcdr (args_left
));
1251 while (!NILP (args_left
));
1257 /* Lisp functions for creating and removing buffer-local variables. */
1259 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1260 1, 1, "vMake Variable Buffer Local: ",
1261 "Make VARIABLE become buffer-local whenever it is set.\n\
1262 At any time, the value for the current buffer is in effect,\n\
1263 unless the variable has never been set in this buffer,\n\
1264 in which case the default value is in effect.\n\
1265 Note that binding the variable with `let', or setting it while\n\
1266 a `let'-style binding made in this buffer is in effect,\n\
1267 does not make the variable buffer-local.\n\
1269 The function `default-value' gets the default value and `set-default' sets it.")
1271 register Lisp_Object variable
;
1273 register Lisp_Object tem
, valcontents
, newval
;
1275 CHECK_SYMBOL (variable
, 0);
1277 valcontents
= XSYMBOL (variable
)->value
;
1278 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1279 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1281 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1283 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1285 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1288 if (EQ (valcontents
, Qunbound
))
1289 XSYMBOL (variable
)->value
= Qnil
;
1290 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1292 newval
= allocate_misc ();
1293 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1294 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1295 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1296 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1297 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1298 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1299 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1300 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1301 XSYMBOL (variable
)->value
= newval
;
1305 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1306 1, 1, "vMake Local Variable: ",
1307 "Make VARIABLE have a separate value in the current buffer.\n\
1308 Other buffers will continue to share a common default value.\n\
1309 \(The buffer-local value of VARIABLE starts out as the same value\n\
1310 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1311 See also `make-variable-buffer-local'.\n\
1313 If the variable is already arranged to become local when set,\n\
1314 this function causes a local value to exist for this buffer,\n\
1315 just as setting the variable would do.\n\
1317 This function returns VARIABLE, and therefore\n\
1318 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1321 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1322 Use `make-local-hook' instead.")
1324 register Lisp_Object variable
;
1326 register Lisp_Object tem
, valcontents
;
1328 CHECK_SYMBOL (variable
, 0);
1330 valcontents
= XSYMBOL (variable
)->value
;
1331 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1332 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1334 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1336 tem
= Fboundp (variable
);
1338 /* Make sure the symbol has a local value in this particular buffer,
1339 by setting it to the same value it already has. */
1340 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1343 /* Make sure symbol is set up to hold per-buffer values. */
1344 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1347 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1349 newval
= allocate_misc ();
1350 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1351 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1352 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1353 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1354 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1355 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1356 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1357 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1358 XSYMBOL (variable
)->value
= newval
;
1360 /* Make sure this buffer has its own value of symbol. */
1361 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1364 /* Swap out any local binding for some other buffer, and make
1365 sure the current value is permanently recorded, if it's the
1367 find_symbol_value (variable
);
1369 current_buffer
->local_var_alist
1370 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1371 current_buffer
->local_var_alist
);
1373 /* Make sure symbol does not think it is set up for this buffer;
1374 force it to look once again for this buffer's value. */
1376 Lisp_Object
*pvalbuf
;
1378 valcontents
= XSYMBOL (variable
)->value
;
1380 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1381 if (current_buffer
== XBUFFER (*pvalbuf
))
1383 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1387 /* If the symbol forwards into a C variable, then load the binding
1388 for this buffer now. If C code modifies the variable before we
1389 load the binding in, then that new value will clobber the default
1390 binding the next time we unload it. */
1391 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1392 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1393 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1398 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1399 1, 1, "vKill Local Variable: ",
1400 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1401 From now on the default value will apply in this buffer.")
1403 register Lisp_Object variable
;
1405 register Lisp_Object tem
, valcontents
;
1407 CHECK_SYMBOL (variable
, 0);
1409 valcontents
= XSYMBOL (variable
)->value
;
1411 if (BUFFER_OBJFWDP (valcontents
))
1413 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1414 int idx
= PER_BUFFER_IDX (offset
);
1418 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1419 PER_BUFFER_VALUE (current_buffer
, offset
)
1420 = PER_BUFFER_DEFAULT (offset
);
1425 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1426 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1429 /* Get rid of this buffer's alist element, if any. */
1431 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1433 current_buffer
->local_var_alist
1434 = Fdelq (tem
, current_buffer
->local_var_alist
);
1436 /* If the symbol is set up with the current buffer's binding
1437 loaded, recompute its value. We have to do it now, or else
1438 forwarded objects won't work right. */
1440 Lisp_Object
*pvalbuf
;
1441 valcontents
= XSYMBOL (variable
)->value
;
1442 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1443 if (current_buffer
== XBUFFER (*pvalbuf
))
1446 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1447 find_symbol_value (variable
);
1454 /* Lisp functions for creating and removing buffer-local variables. */
1456 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1457 1, 1, "vMake Variable Frame Local: ",
1458 "Enable VARIABLE to have frame-local bindings.\n\
1459 When a frame-local binding exists in the current frame,\n\
1460 it is in effect whenever the current buffer has no buffer-local binding.\n\
1461 A frame-local binding is actual a frame parameter value;\n\
1462 thus, any given frame has a local binding for VARIABLE\n\
1463 if it has a value for the frame parameter named VARIABLE.\n\
1464 See `modify-frame-parameters'.")
1466 register Lisp_Object variable
;
1468 register Lisp_Object tem
, valcontents
, newval
;
1470 CHECK_SYMBOL (variable
, 0);
1472 valcontents
= XSYMBOL (variable
)->value
;
1473 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1474 || BUFFER_OBJFWDP (valcontents
))
1475 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1477 if (BUFFER_LOCAL_VALUEP (valcontents
)
1478 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1480 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1484 if (EQ (valcontents
, Qunbound
))
1485 XSYMBOL (variable
)->value
= Qnil
;
1486 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1488 newval
= allocate_misc ();
1489 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1490 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1491 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1492 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1493 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1494 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1495 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1496 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1497 XSYMBOL (variable
)->value
= newval
;
1501 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1503 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1504 BUFFER defaults to the current buffer.")
1506 register Lisp_Object variable
, buffer
;
1508 Lisp_Object valcontents
;
1509 register struct buffer
*buf
;
1512 buf
= current_buffer
;
1515 CHECK_BUFFER (buffer
, 0);
1516 buf
= XBUFFER (buffer
);
1519 CHECK_SYMBOL (variable
, 0);
1521 valcontents
= XSYMBOL (variable
)->value
;
1522 if (BUFFER_LOCAL_VALUEP (valcontents
)
1523 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1525 Lisp_Object tail
, elt
;
1526 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1529 if (EQ (variable
, XCAR (elt
)))
1533 if (BUFFER_OBJFWDP (valcontents
))
1535 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1536 int idx
= PER_BUFFER_IDX (offset
);
1537 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1543 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1545 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1546 BUFFER defaults to the current buffer.")
1548 register Lisp_Object variable
, buffer
;
1550 Lisp_Object valcontents
;
1551 register struct buffer
*buf
;
1554 buf
= current_buffer
;
1557 CHECK_BUFFER (buffer
, 0);
1558 buf
= XBUFFER (buffer
);
1561 CHECK_SYMBOL (variable
, 0);
1563 valcontents
= XSYMBOL (variable
)->value
;
1565 /* This means that make-variable-buffer-local was done. */
1566 if (BUFFER_LOCAL_VALUEP (valcontents
))
1568 /* All these slots become local if they are set. */
1569 if (BUFFER_OBJFWDP (valcontents
))
1571 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1573 Lisp_Object tail
, elt
;
1574 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1577 if (EQ (variable
, XCAR (elt
)))
1584 /* Find the function at the end of a chain of symbol function indirections. */
1586 /* If OBJECT is a symbol, find the end of its function chain and
1587 return the value found there. If OBJECT is not a symbol, just
1588 return it. If there is a cycle in the function chain, signal a
1589 cyclic-function-indirection error.
1591 This is like Findirect_function, except that it doesn't signal an
1592 error if the chain ends up unbound. */
1594 indirect_function (object
)
1595 register Lisp_Object object
;
1597 Lisp_Object tortoise
, hare
;
1599 hare
= tortoise
= object
;
1603 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1605 hare
= XSYMBOL (hare
)->function
;
1606 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1608 hare
= XSYMBOL (hare
)->function
;
1610 tortoise
= XSYMBOL (tortoise
)->function
;
1612 if (EQ (hare
, tortoise
))
1613 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1619 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1620 "Return the function at the end of OBJECT's function chain.\n\
1621 If OBJECT is a symbol, follow all function indirections and return the final\n\
1622 function binding.\n\
1623 If OBJECT is not a symbol, just return it.\n\
1624 Signal a void-function error if the final symbol is unbound.\n\
1625 Signal a cyclic-function-indirection error if there is a loop in the\n\
1626 function chain of symbols.")
1628 register Lisp_Object object
;
1632 result
= indirect_function (object
);
1634 if (EQ (result
, Qunbound
))
1635 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1639 /* Extract and set vector and string elements */
1641 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1642 "Return the element of ARRAY at index IDX.\n\
1643 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1644 or a byte-code object. IDX starts at 0.")
1646 register Lisp_Object array
;
1649 register int idxval
;
1651 CHECK_NUMBER (idx
, 1);
1652 idxval
= XINT (idx
);
1653 if (STRINGP (array
))
1657 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1658 args_out_of_range (array
, idx
);
1659 if (! STRING_MULTIBYTE (array
))
1660 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1661 idxval_byte
= string_char_to_byte (array
, idxval
);
1663 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1664 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1665 return make_number (c
);
1667 else if (BOOL_VECTOR_P (array
))
1671 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1672 args_out_of_range (array
, idx
);
1674 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1675 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1677 else if (CHAR_TABLE_P (array
))
1682 args_out_of_range (array
, idx
);
1683 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1685 /* For ASCII and 8-bit European characters, the element is
1686 stored in the top table. */
1687 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1689 val
= XCHAR_TABLE (array
)->defalt
;
1690 while (NILP (val
)) /* Follow parents until we find some value. */
1692 array
= XCHAR_TABLE (array
)->parent
;
1695 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1697 val
= XCHAR_TABLE (array
)->defalt
;
1704 Lisp_Object sub_table
;
1706 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1707 if (code
[1] < 32) code
[1] = -1;
1708 else if (code
[2] < 32) code
[2] = -1;
1710 /* Here, the possible range of CODE[0] (== charset ID) is
1711 128..MAX_CHARSET. Since the top level char table contains
1712 data for multibyte characters after 256th element, we must
1713 increment CODE[0] by 128 to get a correct index. */
1715 code
[3] = -1; /* anchor */
1717 try_parent_char_table
:
1719 for (i
= 0; code
[i
] >= 0; i
++)
1721 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1722 if (SUB_CHAR_TABLE_P (val
))
1727 val
= XCHAR_TABLE (sub_table
)->defalt
;
1730 array
= XCHAR_TABLE (array
)->parent
;
1732 goto try_parent_char_table
;
1737 /* Here, VAL is a sub char table. We try the default value
1739 val
= XCHAR_TABLE (val
)->defalt
;
1742 array
= XCHAR_TABLE (array
)->parent
;
1744 goto try_parent_char_table
;
1752 if (VECTORP (array
))
1753 size
= XVECTOR (array
)->size
;
1754 else if (COMPILEDP (array
))
1755 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1757 wrong_type_argument (Qarrayp
, array
);
1759 if (idxval
< 0 || idxval
>= size
)
1760 args_out_of_range (array
, idx
);
1761 return XVECTOR (array
)->contents
[idxval
];
1765 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1766 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1767 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1769 (array
, idx
, newelt
)
1770 register Lisp_Object array
;
1771 Lisp_Object idx
, newelt
;
1773 register int idxval
;
1775 CHECK_NUMBER (idx
, 1);
1776 idxval
= XINT (idx
);
1777 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1778 && ! CHAR_TABLE_P (array
))
1779 array
= wrong_type_argument (Qarrayp
, array
);
1780 CHECK_IMPURE (array
);
1782 if (VECTORP (array
))
1784 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1785 args_out_of_range (array
, idx
);
1786 XVECTOR (array
)->contents
[idxval
] = newelt
;
1788 else if (BOOL_VECTOR_P (array
))
1792 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1793 args_out_of_range (array
, idx
);
1795 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1797 if (! NILP (newelt
))
1798 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1800 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1801 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1803 else if (CHAR_TABLE_P (array
))
1806 args_out_of_range (array
, idx
);
1807 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1808 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1814 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1815 if (code
[1] < 32) code
[1] = -1;
1816 else if (code
[2] < 32) code
[2] = -1;
1818 /* See the comment of the corresponding part in Faref. */
1820 code
[3] = -1; /* anchor */
1821 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1823 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1824 if (SUB_CHAR_TABLE_P (val
))
1830 /* VAL is a leaf. Create a sub char table with the
1831 default value VAL or XCHAR_TABLE (array)->defalt
1832 and look into it. */
1834 temp
= make_sub_char_table (NILP (val
)
1835 ? XCHAR_TABLE (array
)->defalt
1837 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1841 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1844 else if (STRING_MULTIBYTE (array
))
1846 int idxval_byte
, new_len
, actual_len
;
1848 unsigned char *p
, workbuf
[MAX_MULTIBYTE_LENGTH
], *str
= workbuf
;
1850 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1851 args_out_of_range (array
, idx
);
1853 idxval_byte
= string_char_to_byte (array
, idxval
);
1854 p
= &XSTRING (array
)->data
[idxval_byte
];
1856 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1857 CHECK_NUMBER (newelt
, 2);
1858 new_len
= CHAR_STRING (XINT (newelt
), str
);
1859 if (actual_len
!= new_len
)
1860 error ("Attempt to change byte length of a string");
1862 /* We can't accept a change causing byte combining. */
1863 if (!ASCII_BYTE_P (*str
)
1864 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1865 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1866 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1867 > idxval_byte
- prev_byte
))
1868 || (idxval
< XSTRING (array
)->size
- 1
1869 && !CHAR_HEAD_P (p
[actual_len
])
1870 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1871 error ("Attempt to change char length of a string");
1877 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1878 args_out_of_range (array
, idx
);
1879 CHECK_NUMBER (newelt
, 2);
1880 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1886 /* Arithmetic functions */
1888 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1891 arithcompare (num1
, num2
, comparison
)
1892 Lisp_Object num1
, num2
;
1893 enum comparison comparison
;
1898 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1899 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1901 if (FLOATP (num1
) || FLOATP (num2
))
1904 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1905 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1911 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1916 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1921 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1926 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1931 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1936 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1945 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1946 "Return t if two args, both numbers or markers, are equal.")
1948 register Lisp_Object num1
, num2
;
1950 return arithcompare (num1
, num2
, equal
);
1953 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1954 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1956 register Lisp_Object num1
, num2
;
1958 return arithcompare (num1
, num2
, less
);
1961 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1962 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1964 register Lisp_Object num1
, num2
;
1966 return arithcompare (num1
, num2
, grtr
);
1969 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1970 "Return t if first arg is less than or equal to second arg.\n\
1971 Both must be numbers or markers.")
1973 register Lisp_Object num1
, num2
;
1975 return arithcompare (num1
, num2
, less_or_equal
);
1978 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1979 "Return t if first arg is greater than or equal to second arg.\n\
1980 Both must be numbers or markers.")
1982 register Lisp_Object num1
, num2
;
1984 return arithcompare (num1
, num2
, grtr_or_equal
);
1987 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1988 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1990 register Lisp_Object num1
, num2
;
1992 return arithcompare (num1
, num2
, notequal
);
1995 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1997 register Lisp_Object number
;
1999 CHECK_NUMBER_OR_FLOAT (number
, 0);
2001 if (FLOATP (number
))
2003 if (XFLOAT_DATA (number
) == 0.0)
2013 /* Convert between long values and pairs of Lisp integers. */
2019 unsigned int top
= i
>> 16;
2020 unsigned int bot
= i
& 0xFFFF;
2022 return make_number (bot
);
2023 if (top
== (unsigned long)-1 >> 16)
2024 return Fcons (make_number (-1), make_number (bot
));
2025 return Fcons (make_number (top
), make_number (bot
));
2032 Lisp_Object top
, bot
;
2039 return ((XINT (top
) << 16) | XINT (bot
));
2042 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2043 "Convert NUMBER to a string by printing it in decimal.\n\
2044 Uses a minus sign if negative.\n\
2045 NUMBER may be an integer or a floating point number.")
2049 char buffer
[VALBITS
];
2051 CHECK_NUMBER_OR_FLOAT (number
, 0);
2053 if (FLOATP (number
))
2055 char pigbuf
[350]; /* see comments in float_to_string */
2057 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2058 return build_string (pigbuf
);
2061 if (sizeof (int) == sizeof (EMACS_INT
))
2062 sprintf (buffer
, "%d", XINT (number
));
2063 else if (sizeof (long) == sizeof (EMACS_INT
))
2064 sprintf (buffer
, "%ld", (long) XINT (number
));
2067 return build_string (buffer
);
2071 digit_to_number (character
, base
)
2072 int character
, base
;
2076 if (character
>= '0' && character
<= '9')
2077 digit
= character
- '0';
2078 else if (character
>= 'a' && character
<= 'z')
2079 digit
= character
- 'a' + 10;
2080 else if (character
>= 'A' && character
<= 'Z')
2081 digit
= character
- 'A' + 10;
2091 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2092 "Convert STRING to a number by parsing it as a decimal number.\n\
2093 This parses both integers and floating point numbers.\n\
2094 It ignores leading spaces and tabs.\n\
2096 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2097 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2098 If the base used is not 10, floating point is not recognized.")
2100 register Lisp_Object string
, base
;
2102 register unsigned char *p
;
2107 CHECK_STRING (string
, 0);
2113 CHECK_NUMBER (base
, 1);
2115 if (b
< 2 || b
> 16)
2116 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2119 /* Skip any whitespace at the front of the number. Some versions of
2120 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2121 p
= XSTRING (string
)->data
;
2122 while (*p
== ' ' || *p
== '\t')
2133 if (isfloat_string (p
) && b
== 10)
2134 val
= make_float (sign
* atof (p
));
2141 int digit
= digit_to_number (*p
++, b
);
2147 if (v
> (EMACS_UINT
) (VALMASK
>> 1))
2148 val
= make_float (sign
* v
);
2150 val
= make_number (sign
* (int) v
);
2158 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2160 extern Lisp_Object
float_arith_driver ();
2161 extern Lisp_Object
fmod_float ();
2164 arith_driver (code
, nargs
, args
)
2167 register Lisp_Object
*args
;
2169 register Lisp_Object val
;
2170 register int argnum
;
2171 register EMACS_INT accum
;
2172 register EMACS_INT next
;
2174 switch (SWITCH_ENUM_CAST (code
))
2187 for (argnum
= 0; argnum
< nargs
; argnum
++)
2189 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2190 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2192 if (FLOATP (val
)) /* time to do serious math */
2193 return (float_arith_driver ((double) accum
, argnum
, code
,
2195 args
[argnum
] = val
; /* runs into a compiler bug. */
2196 next
= XINT (args
[argnum
]);
2197 switch (SWITCH_ENUM_CAST (code
))
2199 case Aadd
: accum
+= next
; break;
2201 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2203 case Amult
: accum
*= next
; break;
2205 if (!argnum
) accum
= next
;
2209 Fsignal (Qarith_error
, Qnil
);
2213 case Alogand
: accum
&= next
; break;
2214 case Alogior
: accum
|= next
; break;
2215 case Alogxor
: accum
^= next
; break;
2216 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2217 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2221 XSETINT (val
, accum
);
2226 #define isnan(x) ((x) != (x))
2229 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2231 register int argnum
;
2234 register Lisp_Object
*args
;
2236 register Lisp_Object val
;
2239 for (; argnum
< nargs
; argnum
++)
2241 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2242 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2246 next
= XFLOAT_DATA (val
);
2250 args
[argnum
] = val
; /* runs into a compiler bug. */
2251 next
= XINT (args
[argnum
]);
2253 switch (SWITCH_ENUM_CAST (code
))
2259 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2269 if (! IEEE_FLOATING_POINT
&& next
== 0)
2270 Fsignal (Qarith_error
, Qnil
);
2277 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2279 if (!argnum
|| isnan (next
) || next
> accum
)
2283 if (!argnum
|| isnan (next
) || next
< accum
)
2289 return make_float (accum
);
2293 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2294 "Return sum of any number of arguments, which are numbers or markers.")
2299 return arith_driver (Aadd
, nargs
, args
);
2302 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2303 "Negate number or subtract numbers or markers.\n\
2304 With one arg, negates it. With more than one arg,\n\
2305 subtracts all but the first from the first.")
2310 return arith_driver (Asub
, nargs
, args
);
2313 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2314 "Returns product of any number of arguments, which are numbers or markers.")
2319 return arith_driver (Amult
, nargs
, args
);
2322 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2323 "Returns first argument divided by all the remaining arguments.\n\
2324 The arguments must be numbers or markers.")
2329 return arith_driver (Adiv
, nargs
, args
);
2332 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2333 "Returns remainder of X divided by Y.\n\
2334 Both must be integers or markers.")
2336 register Lisp_Object x
, y
;
2340 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2341 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2343 if (XFASTINT (y
) == 0)
2344 Fsignal (Qarith_error
, Qnil
);
2346 XSETINT (val
, XINT (x
) % XINT (y
));
2360 /* If the magnitude of the result exceeds that of the divisor, or
2361 the sign of the result does not agree with that of the dividend,
2362 iterate with the reduced value. This does not yield a
2363 particularly accurate result, but at least it will be in the
2364 range promised by fmod. */
2366 r
-= f2
* floor (r
/ f2
);
2367 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2371 #endif /* ! HAVE_FMOD */
2373 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2374 "Returns X modulo Y.\n\
2375 The result falls between zero (inclusive) and Y (exclusive).\n\
2376 Both X and Y must be numbers or markers.")
2378 register Lisp_Object x
, y
;
2383 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2384 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2386 if (FLOATP (x
) || FLOATP (y
))
2387 return fmod_float (x
, y
);
2393 Fsignal (Qarith_error
, Qnil
);
2397 /* If the "remainder" comes out with the wrong sign, fix it. */
2398 if (i2
< 0 ? i1
> 0 : i1
< 0)
2405 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2406 "Return largest of all the arguments (which must be numbers or markers).\n\
2407 The value is always a number; markers are converted to numbers.")
2412 return arith_driver (Amax
, nargs
, args
);
2415 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2416 "Return smallest of all the arguments (which must be numbers or markers).\n\
2417 The value is always a number; markers are converted to numbers.")
2422 return arith_driver (Amin
, nargs
, args
);
2425 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2426 "Return bitwise-and of all the arguments.\n\
2427 Arguments may be integers, or markers converted to integers.")
2432 return arith_driver (Alogand
, nargs
, args
);
2435 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2436 "Return bitwise-or of all the arguments.\n\
2437 Arguments may be integers, or markers converted to integers.")
2442 return arith_driver (Alogior
, nargs
, args
);
2445 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2446 "Return bitwise-exclusive-or of all the arguments.\n\
2447 Arguments may be integers, or markers converted to integers.")
2452 return arith_driver (Alogxor
, nargs
, args
);
2455 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2456 "Return VALUE with its bits shifted left by COUNT.\n\
2457 If COUNT is negative, shifting is actually to the right.\n\
2458 In this case, the sign bit is duplicated.")
2460 register Lisp_Object value
, count
;
2462 register Lisp_Object val
;
2464 CHECK_NUMBER (value
, 0);
2465 CHECK_NUMBER (count
, 1);
2467 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2469 else if (XINT (count
) > 0)
2470 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2471 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2472 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2474 XSETINT (val
, XINT (value
) >> -XINT (count
));
2478 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2479 "Return VALUE with its bits shifted left by COUNT.\n\
2480 If COUNT is negative, shifting is actually to the right.\n\
2481 In this case, zeros are shifted in on the left.")
2483 register Lisp_Object value
, count
;
2485 register Lisp_Object val
;
2487 CHECK_NUMBER (value
, 0);
2488 CHECK_NUMBER (count
, 1);
2490 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2492 else if (XINT (count
) > 0)
2493 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2494 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2497 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2501 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2502 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2503 Markers are converted to integers.")
2505 register Lisp_Object number
;
2507 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2509 if (FLOATP (number
))
2510 return (make_float (1.0 + XFLOAT_DATA (number
)));
2512 XSETINT (number
, XINT (number
) + 1);
2516 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2517 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2518 Markers are converted to integers.")
2520 register Lisp_Object number
;
2522 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2524 if (FLOATP (number
))
2525 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2527 XSETINT (number
, XINT (number
) - 1);
2531 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2532 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2534 register Lisp_Object number
;
2536 CHECK_NUMBER (number
, 0);
2537 XSETINT (number
, ~XINT (number
));
2544 Lisp_Object error_tail
, arith_tail
;
2546 Qquote
= intern ("quote");
2547 Qlambda
= intern ("lambda");
2548 Qsubr
= intern ("subr");
2549 Qerror_conditions
= intern ("error-conditions");
2550 Qerror_message
= intern ("error-message");
2551 Qtop_level
= intern ("top-level");
2553 Qerror
= intern ("error");
2554 Qquit
= intern ("quit");
2555 Qwrong_type_argument
= intern ("wrong-type-argument");
2556 Qargs_out_of_range
= intern ("args-out-of-range");
2557 Qvoid_function
= intern ("void-function");
2558 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2559 Qvoid_variable
= intern ("void-variable");
2560 Qsetting_constant
= intern ("setting-constant");
2561 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2563 Qinvalid_function
= intern ("invalid-function");
2564 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2565 Qno_catch
= intern ("no-catch");
2566 Qend_of_file
= intern ("end-of-file");
2567 Qarith_error
= intern ("arith-error");
2568 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2569 Qend_of_buffer
= intern ("end-of-buffer");
2570 Qbuffer_read_only
= intern ("buffer-read-only");
2571 Qtext_read_only
= intern ("text-read-only");
2572 Qmark_inactive
= intern ("mark-inactive");
2574 Qlistp
= intern ("listp");
2575 Qconsp
= intern ("consp");
2576 Qsymbolp
= intern ("symbolp");
2577 Qkeywordp
= intern ("keywordp");
2578 Qintegerp
= intern ("integerp");
2579 Qnatnump
= intern ("natnump");
2580 Qwholenump
= intern ("wholenump");
2581 Qstringp
= intern ("stringp");
2582 Qarrayp
= intern ("arrayp");
2583 Qsequencep
= intern ("sequencep");
2584 Qbufferp
= intern ("bufferp");
2585 Qvectorp
= intern ("vectorp");
2586 Qchar_or_string_p
= intern ("char-or-string-p");
2587 Qmarkerp
= intern ("markerp");
2588 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2589 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2590 Qboundp
= intern ("boundp");
2591 Qfboundp
= intern ("fboundp");
2593 Qfloatp
= intern ("floatp");
2594 Qnumberp
= intern ("numberp");
2595 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2597 Qchar_table_p
= intern ("char-table-p");
2598 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2600 Qcdr
= intern ("cdr");
2602 /* Handle automatic advice activation */
2603 Qad_advice_info
= intern ("ad-advice-info");
2604 Qad_activate_internal
= intern ("ad-activate-internal");
2606 error_tail
= Fcons (Qerror
, Qnil
);
2608 /* ERROR is used as a signaler for random errors for which nothing else is right */
2610 Fput (Qerror
, Qerror_conditions
,
2612 Fput (Qerror
, Qerror_message
,
2613 build_string ("error"));
2615 Fput (Qquit
, Qerror_conditions
,
2616 Fcons (Qquit
, Qnil
));
2617 Fput (Qquit
, Qerror_message
,
2618 build_string ("Quit"));
2620 Fput (Qwrong_type_argument
, Qerror_conditions
,
2621 Fcons (Qwrong_type_argument
, error_tail
));
2622 Fput (Qwrong_type_argument
, Qerror_message
,
2623 build_string ("Wrong type argument"));
2625 Fput (Qargs_out_of_range
, Qerror_conditions
,
2626 Fcons (Qargs_out_of_range
, error_tail
));
2627 Fput (Qargs_out_of_range
, Qerror_message
,
2628 build_string ("Args out of range"));
2630 Fput (Qvoid_function
, Qerror_conditions
,
2631 Fcons (Qvoid_function
, error_tail
));
2632 Fput (Qvoid_function
, Qerror_message
,
2633 build_string ("Symbol's function definition is void"));
2635 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2636 Fcons (Qcyclic_function_indirection
, error_tail
));
2637 Fput (Qcyclic_function_indirection
, Qerror_message
,
2638 build_string ("Symbol's chain of function indirections contains a loop"));
2640 Fput (Qvoid_variable
, Qerror_conditions
,
2641 Fcons (Qvoid_variable
, error_tail
));
2642 Fput (Qvoid_variable
, Qerror_message
,
2643 build_string ("Symbol's value as variable is void"));
2645 Fput (Qsetting_constant
, Qerror_conditions
,
2646 Fcons (Qsetting_constant
, error_tail
));
2647 Fput (Qsetting_constant
, Qerror_message
,
2648 build_string ("Attempt to set a constant symbol"));
2650 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2651 Fcons (Qinvalid_read_syntax
, error_tail
));
2652 Fput (Qinvalid_read_syntax
, Qerror_message
,
2653 build_string ("Invalid read syntax"));
2655 Fput (Qinvalid_function
, Qerror_conditions
,
2656 Fcons (Qinvalid_function
, error_tail
));
2657 Fput (Qinvalid_function
, Qerror_message
,
2658 build_string ("Invalid function"));
2660 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2661 Fcons (Qwrong_number_of_arguments
, error_tail
));
2662 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2663 build_string ("Wrong number of arguments"));
2665 Fput (Qno_catch
, Qerror_conditions
,
2666 Fcons (Qno_catch
, error_tail
));
2667 Fput (Qno_catch
, Qerror_message
,
2668 build_string ("No catch for tag"));
2670 Fput (Qend_of_file
, Qerror_conditions
,
2671 Fcons (Qend_of_file
, error_tail
));
2672 Fput (Qend_of_file
, Qerror_message
,
2673 build_string ("End of file during parsing"));
2675 arith_tail
= Fcons (Qarith_error
, error_tail
);
2676 Fput (Qarith_error
, Qerror_conditions
,
2678 Fput (Qarith_error
, Qerror_message
,
2679 build_string ("Arithmetic error"));
2681 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2682 Fcons (Qbeginning_of_buffer
, error_tail
));
2683 Fput (Qbeginning_of_buffer
, Qerror_message
,
2684 build_string ("Beginning of buffer"));
2686 Fput (Qend_of_buffer
, Qerror_conditions
,
2687 Fcons (Qend_of_buffer
, error_tail
));
2688 Fput (Qend_of_buffer
, Qerror_message
,
2689 build_string ("End of buffer"));
2691 Fput (Qbuffer_read_only
, Qerror_conditions
,
2692 Fcons (Qbuffer_read_only
, error_tail
));
2693 Fput (Qbuffer_read_only
, Qerror_message
,
2694 build_string ("Buffer is read-only"));
2696 Fput (Qtext_read_only
, Qerror_conditions
,
2697 Fcons (Qtext_read_only
, error_tail
));
2698 Fput (Qtext_read_only
, Qerror_message
,
2699 build_string ("Text is read-only"));
2701 Qrange_error
= intern ("range-error");
2702 Qdomain_error
= intern ("domain-error");
2703 Qsingularity_error
= intern ("singularity-error");
2704 Qoverflow_error
= intern ("overflow-error");
2705 Qunderflow_error
= intern ("underflow-error");
2707 Fput (Qdomain_error
, Qerror_conditions
,
2708 Fcons (Qdomain_error
, arith_tail
));
2709 Fput (Qdomain_error
, Qerror_message
,
2710 build_string ("Arithmetic domain error"));
2712 Fput (Qrange_error
, Qerror_conditions
,
2713 Fcons (Qrange_error
, arith_tail
));
2714 Fput (Qrange_error
, Qerror_message
,
2715 build_string ("Arithmetic range error"));
2717 Fput (Qsingularity_error
, Qerror_conditions
,
2718 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2719 Fput (Qsingularity_error
, Qerror_message
,
2720 build_string ("Arithmetic singularity error"));
2722 Fput (Qoverflow_error
, Qerror_conditions
,
2723 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2724 Fput (Qoverflow_error
, Qerror_message
,
2725 build_string ("Arithmetic overflow error"));
2727 Fput (Qunderflow_error
, Qerror_conditions
,
2728 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2729 Fput (Qunderflow_error
, Qerror_message
,
2730 build_string ("Arithmetic underflow error"));
2732 staticpro (&Qrange_error
);
2733 staticpro (&Qdomain_error
);
2734 staticpro (&Qsingularity_error
);
2735 staticpro (&Qoverflow_error
);
2736 staticpro (&Qunderflow_error
);
2740 staticpro (&Qquote
);
2741 staticpro (&Qlambda
);
2743 staticpro (&Qunbound
);
2744 staticpro (&Qerror_conditions
);
2745 staticpro (&Qerror_message
);
2746 staticpro (&Qtop_level
);
2748 staticpro (&Qerror
);
2750 staticpro (&Qwrong_type_argument
);
2751 staticpro (&Qargs_out_of_range
);
2752 staticpro (&Qvoid_function
);
2753 staticpro (&Qcyclic_function_indirection
);
2754 staticpro (&Qvoid_variable
);
2755 staticpro (&Qsetting_constant
);
2756 staticpro (&Qinvalid_read_syntax
);
2757 staticpro (&Qwrong_number_of_arguments
);
2758 staticpro (&Qinvalid_function
);
2759 staticpro (&Qno_catch
);
2760 staticpro (&Qend_of_file
);
2761 staticpro (&Qarith_error
);
2762 staticpro (&Qbeginning_of_buffer
);
2763 staticpro (&Qend_of_buffer
);
2764 staticpro (&Qbuffer_read_only
);
2765 staticpro (&Qtext_read_only
);
2766 staticpro (&Qmark_inactive
);
2768 staticpro (&Qlistp
);
2769 staticpro (&Qconsp
);
2770 staticpro (&Qsymbolp
);
2771 staticpro (&Qkeywordp
);
2772 staticpro (&Qintegerp
);
2773 staticpro (&Qnatnump
);
2774 staticpro (&Qwholenump
);
2775 staticpro (&Qstringp
);
2776 staticpro (&Qarrayp
);
2777 staticpro (&Qsequencep
);
2778 staticpro (&Qbufferp
);
2779 staticpro (&Qvectorp
);
2780 staticpro (&Qchar_or_string_p
);
2781 staticpro (&Qmarkerp
);
2782 staticpro (&Qbuffer_or_string_p
);
2783 staticpro (&Qinteger_or_marker_p
);
2784 staticpro (&Qfloatp
);
2785 staticpro (&Qnumberp
);
2786 staticpro (&Qnumber_or_marker_p
);
2787 staticpro (&Qchar_table_p
);
2788 staticpro (&Qvector_or_char_table_p
);
2790 staticpro (&Qboundp
);
2791 staticpro (&Qfboundp
);
2793 staticpro (&Qad_advice_info
);
2794 staticpro (&Qad_activate_internal
);
2796 /* Types that type-of returns. */
2797 Qinteger
= intern ("integer");
2798 Qsymbol
= intern ("symbol");
2799 Qstring
= intern ("string");
2800 Qcons
= intern ("cons");
2801 Qmarker
= intern ("marker");
2802 Qoverlay
= intern ("overlay");
2803 Qfloat
= intern ("float");
2804 Qwindow_configuration
= intern ("window-configuration");
2805 Qprocess
= intern ("process");
2806 Qwindow
= intern ("window");
2807 /* Qsubr = intern ("subr"); */
2808 Qcompiled_function
= intern ("compiled-function");
2809 Qbuffer
= intern ("buffer");
2810 Qframe
= intern ("frame");
2811 Qvector
= intern ("vector");
2812 Qchar_table
= intern ("char-table");
2813 Qbool_vector
= intern ("bool-vector");
2814 Qhash_table
= intern ("hash-table");
2816 staticpro (&Qinteger
);
2817 staticpro (&Qsymbol
);
2818 staticpro (&Qstring
);
2820 staticpro (&Qmarker
);
2821 staticpro (&Qoverlay
);
2822 staticpro (&Qfloat
);
2823 staticpro (&Qwindow_configuration
);
2824 staticpro (&Qprocess
);
2825 staticpro (&Qwindow
);
2826 /* staticpro (&Qsubr); */
2827 staticpro (&Qcompiled_function
);
2828 staticpro (&Qbuffer
);
2829 staticpro (&Qframe
);
2830 staticpro (&Qvector
);
2831 staticpro (&Qchar_table
);
2832 staticpro (&Qbool_vector
);
2833 staticpro (&Qhash_table
);
2837 defsubr (&Stype_of
);
2842 defsubr (&Sintegerp
);
2843 defsubr (&Sinteger_or_marker_p
);
2844 defsubr (&Snumberp
);
2845 defsubr (&Snumber_or_marker_p
);
2847 defsubr (&Snatnump
);
2848 defsubr (&Ssymbolp
);
2849 defsubr (&Skeywordp
);
2850 defsubr (&Sstringp
);
2851 defsubr (&Smultibyte_string_p
);
2852 defsubr (&Svectorp
);
2853 defsubr (&Schar_table_p
);
2854 defsubr (&Svector_or_char_table_p
);
2855 defsubr (&Sbool_vector_p
);
2857 defsubr (&Ssequencep
);
2858 defsubr (&Sbufferp
);
2859 defsubr (&Smarkerp
);
2861 defsubr (&Sbyte_code_function_p
);
2862 defsubr (&Schar_or_string_p
);
2865 defsubr (&Scar_safe
);
2866 defsubr (&Scdr_safe
);
2869 defsubr (&Ssymbol_function
);
2870 defsubr (&Sindirect_function
);
2871 defsubr (&Ssymbol_plist
);
2872 defsubr (&Ssymbol_name
);
2873 defsubr (&Smakunbound
);
2874 defsubr (&Sfmakunbound
);
2876 defsubr (&Sfboundp
);
2878 defsubr (&Sdefalias
);
2879 defsubr (&Ssetplist
);
2880 defsubr (&Ssymbol_value
);
2882 defsubr (&Sdefault_boundp
);
2883 defsubr (&Sdefault_value
);
2884 defsubr (&Sset_default
);
2885 defsubr (&Ssetq_default
);
2886 defsubr (&Smake_variable_buffer_local
);
2887 defsubr (&Smake_local_variable
);
2888 defsubr (&Skill_local_variable
);
2889 defsubr (&Smake_variable_frame_local
);
2890 defsubr (&Slocal_variable_p
);
2891 defsubr (&Slocal_variable_if_set_p
);
2894 defsubr (&Snumber_to_string
);
2895 defsubr (&Sstring_to_number
);
2896 defsubr (&Seqlsign
);
2920 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2927 #if defined(USG) && !defined(POSIX_SIGNALS)
2928 /* USG systems forget handlers when they are used;
2929 must reestablish each time */
2930 signal (signo
, arith_error
);
2933 /* VMS systems are like USG. */
2934 signal (signo
, arith_error
);
2938 #else /* not BSD4_1 */
2939 sigsetmask (SIGEMPTYMASK
);
2940 #endif /* not BSD4_1 */
2942 Fsignal (Qarith_error
, Qnil
);
2948 /* Don't do this if just dumping out.
2949 We don't want to call `signal' in this case
2950 so that we don't have trouble with dumping
2951 signal-delivering routines in an inconsistent state. */
2955 #endif /* CANNOT_DUMP */
2956 signal (SIGFPE
, arith_error
);
2959 signal (SIGEMT
, arith_error
);