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. */
35 #include "syssignal.h"
37 #ifdef LISP_FLOAT_TYPE
43 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
44 #ifndef IEEE_FLOATING_POINT
45 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
46 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
47 #define IEEE_FLOATING_POINT 1
49 #define IEEE_FLOATING_POINT 0
53 /* Work around a problem that happens because math.h on hpux 7
54 defines two static variables--which, in Emacs, are not really static,
55 because `static' is defined as nothing. The problem is that they are
56 here, in floatfns.c, and in lread.c.
57 These macros prevent the name conflict. */
58 #if defined (HPUX) && !defined (HPUX8)
59 #define _MAXLDBL data_c_maxldbl
60 #define _NMAXLDBL data_c_nmaxldbl
64 #endif /* LISP_FLOAT_TYPE */
67 extern double atof ();
70 /* Nonzero means it is an error to set a symbol whose name starts with
72 int keyword_symbols_constant_flag
;
74 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
75 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
76 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
77 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
78 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
79 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
80 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
81 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
82 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
83 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
84 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
85 Lisp_Object Qbuffer_or_string_p
;
86 Lisp_Object Qboundp
, Qfboundp
;
87 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
90 Lisp_Object Qad_advice_info
, Qad_activate
;
92 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
93 Lisp_Object Qoverflow_error
, Qunderflow_error
;
95 #ifdef LISP_FLOAT_TYPE
97 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
100 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
101 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
102 Lisp_Object Qprocess
;
103 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
104 static Lisp_Object Qchar_table
, Qbool_vector
;
106 static Lisp_Object
swap_in_symval_forwarding ();
108 Lisp_Object
set_internal ();
111 wrong_type_argument (predicate
, value
)
112 register Lisp_Object predicate
, value
;
114 register Lisp_Object tem
;
117 if (!EQ (Vmocklisp_arguments
, Qt
))
119 if (STRINGP (value
) &&
120 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
121 return Fstring_to_number (value
, Qnil
);
122 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
123 return Fnumber_to_string (value
);
126 /* If VALUE is not even a valid Lisp object, abort here
127 where we can get a backtrace showing where it came from. */
128 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
131 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
132 tem
= call1 (predicate
, value
);
141 error ("Attempt to modify read-only object");
145 args_out_of_range (a1
, a2
)
149 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
153 args_out_of_range_3 (a1
, a2
, a3
)
154 Lisp_Object a1
, a2
, a3
;
157 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
160 /* On some machines, XINT needs a temporary location.
161 Here it is, in case it is needed. */
163 int sign_extend_temp
;
165 /* On a few machines, XINT can only be done by calling this. */
168 sign_extend_lisp_int (num
)
171 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
172 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
174 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
177 /* Data type predicates */
179 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
180 "Return t if the two args are the same Lisp object.")
182 Lisp_Object obj1
, obj2
;
189 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
198 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
199 "Return a symbol representing the type of OBJECT.\n\
200 The symbol returned names the object's basic type;\n\
201 for example, (type-of 1) returns `integer'.")
205 switch (XGCTYPE (object
))
220 switch (XMISCTYPE (object
))
222 case Lisp_Misc_Marker
:
224 case Lisp_Misc_Overlay
:
226 case Lisp_Misc_Float
:
231 case Lisp_Vectorlike
:
232 if (GC_WINDOW_CONFIGURATIONP (object
))
233 return Qwindow_configuration
;
234 if (GC_PROCESSP (object
))
236 if (GC_WINDOWP (object
))
238 if (GC_SUBRP (object
))
240 if (GC_COMPILEDP (object
))
241 return Qcompiled_function
;
242 if (GC_BUFFERP (object
))
244 if (GC_CHAR_TABLE_P (object
))
246 if (GC_BOOL_VECTOR_P (object
))
248 if (GC_FRAMEP (object
))
252 #ifdef LISP_FLOAT_TYPE
262 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
271 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
272 "Return t if OBJECT is not a cons cell. This includes nil.")
281 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
282 "Return t if OBJECT is a list. This includes nil.")
286 if (CONSP (object
) || NILP (object
))
291 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
292 "Return t if OBJECT is not a list. Lists include nil.")
296 if (CONSP (object
) || NILP (object
))
301 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
302 "Return t if OBJECT is a symbol.")
306 if (SYMBOLP (object
))
311 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
312 "Return t if OBJECT is a vector.")
316 if (VECTORP (object
))
321 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
322 "Return t if OBJECT is a string.")
326 if (STRINGP (object
))
331 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
332 1, 1, 0, "Return t if OBJECT is a multibyte string.")
336 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
341 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
342 "Return t if OBJECT is a char-table.")
346 if (CHAR_TABLE_P (object
))
351 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
352 Svector_or_char_table_p
, 1, 1, 0,
353 "Return t if OBJECT is a char-table or vector.")
357 if (VECTORP (object
) || CHAR_TABLE_P (object
))
362 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
366 if (BOOL_VECTOR_P (object
))
371 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
375 if (VECTORP (object
) || STRINGP (object
)
376 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
381 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
382 "Return t if OBJECT is a sequence (list or array).")
384 register Lisp_Object object
;
386 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
387 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
392 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
396 if (BUFFERP (object
))
401 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
405 if (MARKERP (object
))
410 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
419 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
420 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
424 if (COMPILEDP (object
))
429 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
430 "Return t if OBJECT is a character (an integer) or a string.")
432 register Lisp_Object object
;
434 if (INTEGERP (object
) || STRINGP (object
))
439 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
443 if (INTEGERP (object
))
448 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
449 "Return t if OBJECT is an integer or a marker (editor pointer).")
451 register Lisp_Object object
;
453 if (MARKERP (object
) || INTEGERP (object
))
458 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
459 "Return t if OBJECT is a nonnegative integer.")
463 if (NATNUMP (object
))
468 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
469 "Return t if OBJECT is a number (floating point or integer).")
473 if (NUMBERP (object
))
479 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
480 Snumber_or_marker_p
, 1, 1, 0,
481 "Return t if OBJECT is a number or a marker.")
485 if (NUMBERP (object
) || MARKERP (object
))
490 #ifdef LISP_FLOAT_TYPE
491 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
492 "Return t if OBJECT is a floating point number.")
500 #endif /* LISP_FLOAT_TYPE */
502 /* Extract and set components of lists */
504 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
505 "Return the car of LIST. If arg is nil, return nil.\n\
506 Error if arg is not nil and not a cons cell. See also `car-safe'.")
508 register Lisp_Object list
;
514 else if (EQ (list
, Qnil
))
517 list
= wrong_type_argument (Qlistp
, list
);
521 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
522 "Return the car of OBJECT if it is a cons cell, or else nil.")
527 return XCAR (object
);
532 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
533 "Return the cdr of LIST. If arg is nil, return nil.\n\
534 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
537 register Lisp_Object list
;
543 else if (EQ (list
, Qnil
))
546 list
= wrong_type_argument (Qlistp
, list
);
550 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
551 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
556 return XCDR (object
);
561 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
562 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
564 register Lisp_Object cell
, newcar
;
567 cell
= wrong_type_argument (Qconsp
, cell
);
570 XCAR (cell
) = newcar
;
574 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
575 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
577 register Lisp_Object cell
, newcdr
;
580 cell
= wrong_type_argument (Qconsp
, cell
);
583 XCDR (cell
) = newcdr
;
587 /* Extract and set components of symbols */
589 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
591 register Lisp_Object symbol
;
593 Lisp_Object valcontents
;
594 CHECK_SYMBOL (symbol
, 0);
596 valcontents
= XSYMBOL (symbol
)->value
;
598 if (BUFFER_LOCAL_VALUEP (valcontents
)
599 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
600 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
602 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
605 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
607 register Lisp_Object symbol
;
609 CHECK_SYMBOL (symbol
, 0);
610 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
613 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
615 register Lisp_Object symbol
;
617 CHECK_SYMBOL (symbol
, 0);
618 if (NILP (symbol
) || EQ (symbol
, Qt
)
619 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
620 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
621 && keyword_symbols_constant_flag
))
622 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
623 Fset (symbol
, Qunbound
);
627 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
629 register Lisp_Object symbol
;
631 CHECK_SYMBOL (symbol
, 0);
632 if (NILP (symbol
) || EQ (symbol
, Qt
))
633 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
634 XSYMBOL (symbol
)->function
= Qunbound
;
638 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
639 "Return SYMBOL's function definition. Error if that is void.")
641 register Lisp_Object symbol
;
643 CHECK_SYMBOL (symbol
, 0);
644 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
645 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
646 return XSYMBOL (symbol
)->function
;
649 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
651 register Lisp_Object symbol
;
653 CHECK_SYMBOL (symbol
, 0);
654 return XSYMBOL (symbol
)->plist
;
657 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
659 register Lisp_Object symbol
;
661 register Lisp_Object name
;
663 CHECK_SYMBOL (symbol
, 0);
664 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
668 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
669 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
671 register Lisp_Object symbol
, definition
;
673 CHECK_SYMBOL (symbol
, 0);
674 if (NILP (symbol
) || EQ (symbol
, Qt
))
675 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
676 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
677 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
679 XSYMBOL (symbol
)->function
= definition
;
680 /* Handle automatic advice activation */
681 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
683 call2 (Qad_activate
, symbol
, Qnil
);
684 definition
= XSYMBOL (symbol
)->function
;
689 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
690 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
691 Associates the function with the current load file, if any.")
693 register Lisp_Object symbol
, definition
;
695 definition
= Ffset (symbol
, definition
);
696 LOADHIST_ATTACH (symbol
);
700 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
701 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
703 register Lisp_Object symbol
, newplist
;
705 CHECK_SYMBOL (symbol
, 0);
706 XSYMBOL (symbol
)->plist
= newplist
;
711 /* Getting and setting values of symbols */
713 /* Given the raw contents of a symbol value cell,
714 return the Lisp value of the symbol.
715 This does not handle buffer-local variables; use
716 swap_in_symval_forwarding for that. */
719 do_symval_forwarding (valcontents
)
720 register Lisp_Object valcontents
;
722 register Lisp_Object val
;
724 if (MISCP (valcontents
))
725 switch (XMISCTYPE (valcontents
))
727 case Lisp_Misc_Intfwd
:
728 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
731 case Lisp_Misc_Boolfwd
:
732 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
734 case Lisp_Misc_Objfwd
:
735 return *XOBJFWD (valcontents
)->objvar
;
737 case Lisp_Misc_Buffer_Objfwd
:
738 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
739 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
741 case Lisp_Misc_Kboard_Objfwd
:
742 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
743 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
748 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
749 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
750 buffer-independent contents of the value cell: forwarded just one
751 step past the buffer-localness. */
754 store_symval_forwarding (symbol
, valcontents
, newval
)
756 register Lisp_Object valcontents
, newval
;
758 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
761 switch (XMISCTYPE (valcontents
))
763 case Lisp_Misc_Intfwd
:
764 CHECK_NUMBER (newval
, 1);
765 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
766 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
767 error ("Value out of range for variable `%s'",
768 XSYMBOL (symbol
)->name
->data
);
771 case Lisp_Misc_Boolfwd
:
772 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
775 case Lisp_Misc_Objfwd
:
776 *XOBJFWD (valcontents
)->objvar
= newval
;
779 case Lisp_Misc_Buffer_Objfwd
:
781 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
784 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
785 if (XINT (type
) == -1)
786 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
788 if (! NILP (type
) && ! NILP (newval
)
789 && XTYPE (newval
) != XINT (type
))
790 buffer_slot_type_mismatch (offset
);
792 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
796 case Lisp_Misc_Kboard_Objfwd
:
797 (*(Lisp_Object
*)((char *)current_kboard
798 + XKBOARD_OBJFWD (valcontents
)->offset
))
809 valcontents
= XSYMBOL (symbol
)->value
;
810 if (BUFFER_LOCAL_VALUEP (valcontents
)
811 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
812 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
814 XSYMBOL (symbol
)->value
= newval
;
818 /* Set up the buffer-local symbol SYMBOL for validity in the current
819 buffer. VALCONTENTS is the contents of its value cell.
820 Return the value forwarded one step past the buffer-local indicator. */
823 swap_in_symval_forwarding (symbol
, valcontents
)
824 Lisp_Object symbol
, valcontents
;
826 /* valcontents is a pointer to a struct resembling the cons
827 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
829 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
830 local_var_alist, that being the element whose car is this
831 variable. Or it can be a pointer to the
832 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
833 an element in its alist for this variable.
835 If the current buffer is not BUFFER, we store the current
836 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
837 appropriate alist element for the buffer now current and set up
838 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
839 element, and store into BUFFER.
841 Note that REALVALUE can be a forwarding pointer. */
843 register Lisp_Object tem1
;
844 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
846 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
)
847 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
849 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
851 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
852 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
853 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
854 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
857 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
858 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
860 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
862 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
865 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
867 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = tem1
;
868 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
869 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
870 store_symval_forwarding (symbol
,
871 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
874 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
877 /* Find the value of a symbol, returning Qunbound if it's not bound.
878 This is helpful for code which just wants to get a variable's value
879 if it has one, without signaling an error.
880 Note that it must not be possible to quit
881 within this function. Great care is required for this. */
884 find_symbol_value (symbol
)
887 register Lisp_Object valcontents
;
888 register Lisp_Object val
;
889 CHECK_SYMBOL (symbol
, 0);
890 valcontents
= XSYMBOL (symbol
)->value
;
892 if (BUFFER_LOCAL_VALUEP (valcontents
)
893 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
894 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
896 if (MISCP (valcontents
))
898 switch (XMISCTYPE (valcontents
))
900 case Lisp_Misc_Intfwd
:
901 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
904 case Lisp_Misc_Boolfwd
:
905 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
907 case Lisp_Misc_Objfwd
:
908 return *XOBJFWD (valcontents
)->objvar
;
910 case Lisp_Misc_Buffer_Objfwd
:
911 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
912 + (char *)current_buffer
);
914 case Lisp_Misc_Kboard_Objfwd
:
915 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
916 + (char *)current_kboard
);
923 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
924 "Return SYMBOL's value. Error if that is void.")
930 val
= find_symbol_value (symbol
);
931 if (EQ (val
, Qunbound
))
932 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
937 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
938 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
940 register Lisp_Object symbol
, newval
;
942 return set_internal (symbol
, newval
, 0);
945 /* Store the value NEWVAL into SYMBOL.
946 If BINDFLAG is zero, then if this symbol is supposed to become
947 local in every buffer where it is set, then we make it local.
948 If BINDFLAG is nonzero, we don't do that. */
951 set_internal (symbol
, newval
, bindflag
)
952 register Lisp_Object symbol
, newval
;
955 int voide
= EQ (newval
, Qunbound
);
957 register Lisp_Object valcontents
, tem1
, current_alist_element
;
959 CHECK_SYMBOL (symbol
, 0);
960 if (NILP (symbol
) || EQ (symbol
, Qt
)
961 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
962 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
963 && keyword_symbols_constant_flag
&& ! EQ (newval
, symbol
)))
964 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
965 valcontents
= XSYMBOL (symbol
)->value
;
967 if (BUFFER_OBJFWDP (valcontents
))
969 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
970 register int mask
= XINT (*((Lisp_Object
*)
971 (idx
+ (char *)&buffer_local_flags
)));
972 if (mask
> 0 && ! bindflag
)
973 current_buffer
->local_var_flags
|= mask
;
976 else if (BUFFER_LOCAL_VALUEP (valcontents
)
977 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
979 /* valcontents is actually a pointer to a struct resembling a cons,
980 with contents something like:
981 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
983 BUFFER is the last buffer for which this symbol's value was
986 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
987 local_var_alist, that being the element whose car is this
988 variable. Or it can be a pointer to the
989 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
990 have an element in its alist for this variable (that is, if
991 BUFFER sees the default value of this variable).
993 If we want to examine or set the value and BUFFER is current,
994 we just examine or set REALVALUE. If BUFFER is not current, we
995 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
996 then find the appropriate alist element for the buffer now
997 current and set up CURRENT-ALIST-ELEMENT. Then we set
998 REALVALUE out of that element, and store into BUFFER.
1000 If we are setting the variable and the current buffer does
1001 not have an alist entry for this variable, an alist entry is
1004 Note that REALVALUE can be a forwarding pointer. Each time
1005 it is examined or set, forwarding must be done. */
1007 /* What value are we caching right now? */
1008 current_alist_element
1009 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1011 /* If the current buffer is not the buffer whose binding is
1012 currently cached, or if it's a Lisp_Buffer_Local_Value and
1013 we're looking at the default value, the cache is invalid; we
1014 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
1015 if (current_buffer
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1016 || !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)
1017 || (BUFFER_LOCAL_VALUEP (valcontents
)
1018 && EQ (XCAR (current_alist_element
),
1019 current_alist_element
)))
1021 /* Write out the cached value for the old buffer; copy it
1022 back to its alist element. This works if the current
1023 buffer only sees the default value, too. */
1024 Fsetcdr (current_alist_element
,
1025 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1027 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1028 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1029 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1030 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1034 /* This buffer still sees the default value. */
1036 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1037 or if this is `let' rather than `set',
1038 make CURRENT-ALIST-ELEMENT point to itself,
1039 indicating that we're seeing the default value. */
1040 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1042 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1044 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1045 tem1
= Fassq (symbol
,
1046 XFRAME (selected_frame
)->param_alist
);
1049 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1051 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1053 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1054 give this buffer a new assoc for a local value and set
1055 CURRENT-ALIST-ELEMENT to point to that. */
1058 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1059 current_buffer
->local_var_alist
1060 = Fcons (tem1
, current_buffer
->local_var_alist
);
1064 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1065 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1068 /* Set BUFFER and FRAME for binding now loaded. */
1069 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
,
1071 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1073 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1076 /* If storing void (making the symbol void), forward only through
1077 buffer-local indicator, not through Lisp_Objfwd, etc. */
1079 store_symval_forwarding (symbol
, Qnil
, newval
);
1081 store_symval_forwarding (symbol
, valcontents
, newval
);
1086 /* Access or set a buffer-local symbol's default value. */
1088 /* Return the default value of SYMBOL, but don't check for voidness.
1089 Return Qunbound if it is void. */
1092 default_value (symbol
)
1095 register Lisp_Object valcontents
;
1097 CHECK_SYMBOL (symbol
, 0);
1098 valcontents
= XSYMBOL (symbol
)->value
;
1100 /* For a built-in buffer-local variable, get the default value
1101 rather than letting do_symval_forwarding get the current value. */
1102 if (BUFFER_OBJFWDP (valcontents
))
1104 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1106 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1107 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1110 /* Handle user-created local variables. */
1111 if (BUFFER_LOCAL_VALUEP (valcontents
)
1112 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1114 /* If var is set up for a buffer that lacks a local value for it,
1115 the current value is nominally the default value.
1116 But the current value slot may be more up to date, since
1117 ordinary setq stores just that slot. So use that. */
1118 Lisp_Object current_alist_element
, alist_element_car
;
1119 current_alist_element
1120 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1121 alist_element_car
= XCAR (current_alist_element
);
1122 if (EQ (alist_element_car
, current_alist_element
))
1123 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1125 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1127 /* For other variables, get the current value. */
1128 return do_symval_forwarding (valcontents
);
1131 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1132 "Return t if SYMBOL has a non-void default value.\n\
1133 This is the value that is seen in buffers that do not have their own values\n\
1134 for this variable.")
1138 register Lisp_Object value
;
1140 value
= default_value (symbol
);
1141 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1144 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1145 "Return SYMBOL's default value.\n\
1146 This is the value that is seen in buffers that do not have their own values\n\
1147 for this variable. The default value is meaningful for variables with\n\
1148 local bindings in certain buffers.")
1152 register Lisp_Object value
;
1154 value
= default_value (symbol
);
1155 if (EQ (value
, Qunbound
))
1156 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1160 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1161 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1162 The default value is seen in buffers that do not have their own values\n\
1163 for this variable.")
1165 Lisp_Object symbol
, value
;
1167 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1169 CHECK_SYMBOL (symbol
, 0);
1170 valcontents
= XSYMBOL (symbol
)->value
;
1172 /* Handle variables like case-fold-search that have special slots
1173 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1175 if (BUFFER_OBJFWDP (valcontents
))
1177 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1178 register struct buffer
*b
;
1179 register int mask
= XINT (*((Lisp_Object
*)
1180 (idx
+ (char *)&buffer_local_flags
)));
1182 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1184 /* If this variable is not always local in all buffers,
1185 set it in the buffers that don't nominally have a local value. */
1188 for (b
= all_buffers
; b
; b
= b
->next
)
1189 if (!(b
->local_var_flags
& mask
))
1190 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1195 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1196 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1197 return Fset (symbol
, value
);
1199 /* Store new value into the DEFAULT-VALUE slot */
1200 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1202 /* If that slot is current, we must set the REALVALUE slot too */
1203 current_alist_element
1204 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1205 alist_element_buffer
= Fcar (current_alist_element
);
1206 if (EQ (alist_element_buffer
, current_alist_element
))
1207 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1213 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1214 "Set the default value of variable VAR to VALUE.\n\
1215 VAR, the variable name, is literal (not evaluated);\n\
1216 VALUE is an expression and it is evaluated.\n\
1217 The default value of a variable is seen in buffers\n\
1218 that do not have their own values for the variable.\n\
1220 More generally, you can use multiple variables and values, as in\n\
1221 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1222 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1223 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1228 register Lisp_Object args_left
;
1229 register Lisp_Object val
, symbol
;
1230 struct gcpro gcpro1
;
1240 val
= Feval (Fcar (Fcdr (args_left
)));
1241 symbol
= Fcar (args_left
);
1242 Fset_default (symbol
, val
);
1243 args_left
= Fcdr (Fcdr (args_left
));
1245 while (!NILP (args_left
));
1251 /* Lisp functions for creating and removing buffer-local variables. */
1253 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1254 1, 1, "vMake Variable Buffer Local: ",
1255 "Make VARIABLE have a separate value for each buffer.\n\
1256 At any time, the value for the current buffer is in effect.\n\
1257 There is also a default value which is seen in any buffer which has not yet\n\
1258 set its own value.\n\
1259 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1260 for the current buffer if it was previously using the default value.\n\
1261 The function `default-value' gets the default value and `set-default' sets it.")
1263 register Lisp_Object variable
;
1265 register Lisp_Object tem
, valcontents
, newval
;
1267 CHECK_SYMBOL (variable
, 0);
1269 valcontents
= XSYMBOL (variable
)->value
;
1270 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1271 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1273 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1275 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1277 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1280 if (EQ (valcontents
, Qunbound
))
1281 XSYMBOL (variable
)->value
= Qnil
;
1282 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1284 newval
= allocate_misc ();
1285 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1286 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1287 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1288 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1289 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 1;
1290 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1291 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1292 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1293 XSYMBOL (variable
)->value
= newval
;
1297 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1298 1, 1, "vMake Local Variable: ",
1299 "Make VARIABLE have a separate value in the current buffer.\n\
1300 Other buffers will continue to share a common default value.\n\
1301 \(The buffer-local value of VARIABLE starts out as the same value\n\
1302 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1303 See also `make-variable-buffer-local'.\n\
1305 If the variable is already arranged to become local when set,\n\
1306 this function causes a local value to exist for this buffer,\n\
1307 just as setting the variable would do.\n\
1309 This function returns VARIABLE, and therefore\n\
1310 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1313 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1314 Use `make-local-hook' instead.")
1316 register Lisp_Object variable
;
1318 register Lisp_Object tem
, valcontents
;
1320 CHECK_SYMBOL (variable
, 0);
1322 valcontents
= XSYMBOL (variable
)->value
;
1323 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1324 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1326 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1328 tem
= Fboundp (variable
);
1330 /* Make sure the symbol has a local value in this particular buffer,
1331 by setting it to the same value it already has. */
1332 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1335 /* Make sure symbol is set up to hold per-buffer values */
1336 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1339 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1341 newval
= allocate_misc ();
1342 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1343 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1344 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1345 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1346 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1347 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1348 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1349 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1350 XSYMBOL (variable
)->value
= newval
;
1352 /* Make sure this buffer has its own value of symbol */
1353 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1356 /* Swap out any local binding for some other buffer, and make
1357 sure the current value is permanently recorded, if it's the
1359 find_symbol_value (variable
);
1361 current_buffer
->local_var_alist
1362 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1363 current_buffer
->local_var_alist
);
1365 /* Make sure symbol does not think it is set up for this buffer;
1366 force it to look once again for this buffer's value */
1368 Lisp_Object
*pvalbuf
;
1370 valcontents
= XSYMBOL (variable
)->value
;
1372 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1373 if (current_buffer
== XBUFFER (*pvalbuf
))
1375 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1379 /* If the symbol forwards into a C variable, then swap in the
1380 variable for this buffer immediately. If C code modifies the
1381 variable before we swap in, then that new value will clobber the
1382 default value the next time we swap. */
1383 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1384 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1385 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1390 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1391 1, 1, "vKill Local Variable: ",
1392 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1393 From now on the default value will apply in this buffer.")
1395 register Lisp_Object variable
;
1397 register Lisp_Object tem
, valcontents
;
1399 CHECK_SYMBOL (variable
, 0);
1401 valcontents
= XSYMBOL (variable
)->value
;
1403 if (BUFFER_OBJFWDP (valcontents
))
1405 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1406 register int mask
= XINT (*((Lisp_Object
*)
1407 (idx
+ (char *)&buffer_local_flags
)));
1411 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1412 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1413 current_buffer
->local_var_flags
&= ~mask
;
1418 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1419 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1422 /* Get rid of this buffer's alist element, if any */
1424 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1426 current_buffer
->local_var_alist
1427 = Fdelq (tem
, current_buffer
->local_var_alist
);
1429 /* If the symbol is set up for the current buffer, recompute its
1430 value. We have to do it now, or else forwarded objects won't
1433 Lisp_Object
*pvalbuf
;
1434 valcontents
= XSYMBOL (variable
)->value
;
1435 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1436 if (current_buffer
== XBUFFER (*pvalbuf
))
1439 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1440 find_symbol_value (variable
);
1447 /* Lisp functions for creating and removing buffer-local variables. */
1449 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1450 1, 1, "vMake Variable Frame Local: ",
1451 "Enable VARIABLE to have frame-local bindings.\n\
1452 When a frame-local binding exists in the current frame,\n\
1453 it is in effect whenever the current buffer has no buffer-local binding.\n\
1454 A frame-local binding is actual a frame parameter value;\n\
1455 thus, any given frame has a local binding for VARIABLE\n\
1456 if it has a value for the frame parameter named VARIABLE.\n\
1457 See `modify-frame-parameters'.")
1459 register Lisp_Object variable
;
1461 register Lisp_Object tem
, valcontents
, newval
;
1463 CHECK_SYMBOL (variable
, 0);
1465 valcontents
= XSYMBOL (variable
)->value
;
1466 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1467 || BUFFER_OBJFWDP (valcontents
))
1468 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1470 if (BUFFER_LOCAL_VALUEP (valcontents
)
1471 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1474 if (EQ (valcontents
, Qunbound
))
1475 XSYMBOL (variable
)->value
= Qnil
;
1476 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1478 newval
= allocate_misc ();
1479 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1480 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1481 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1482 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1483 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1484 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1485 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1486 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1487 XSYMBOL (variable
)->value
= newval
;
1491 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1493 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1494 BUFFER defaults to the current buffer.")
1496 register Lisp_Object variable
, buffer
;
1498 Lisp_Object valcontents
;
1499 register struct buffer
*buf
;
1502 buf
= current_buffer
;
1505 CHECK_BUFFER (buffer
, 0);
1506 buf
= XBUFFER (buffer
);
1509 CHECK_SYMBOL (variable
, 0);
1511 valcontents
= XSYMBOL (variable
)->value
;
1512 if (BUFFER_LOCAL_VALUEP (valcontents
)
1513 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1515 Lisp_Object tail
, elt
;
1516 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1519 if (EQ (variable
, XCAR (elt
)))
1523 if (BUFFER_OBJFWDP (valcontents
))
1525 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1526 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1527 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1533 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1535 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1536 BUFFER defaults to the current buffer.")
1538 register Lisp_Object variable
, buffer
;
1540 Lisp_Object valcontents
;
1541 register struct buffer
*buf
;
1544 buf
= current_buffer
;
1547 CHECK_BUFFER (buffer
, 0);
1548 buf
= XBUFFER (buffer
);
1551 CHECK_SYMBOL (variable
, 0);
1553 valcontents
= XSYMBOL (variable
)->value
;
1555 /* This means that make-variable-buffer-local was done. */
1556 if (BUFFER_LOCAL_VALUEP (valcontents
))
1558 /* All these slots become local if they are set. */
1559 if (BUFFER_OBJFWDP (valcontents
))
1561 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1563 Lisp_Object tail
, elt
;
1564 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1567 if (EQ (variable
, XCAR (elt
)))
1574 /* Find the function at the end of a chain of symbol function indirections. */
1576 /* If OBJECT is a symbol, find the end of its function chain and
1577 return the value found there. If OBJECT is not a symbol, just
1578 return it. If there is a cycle in the function chain, signal a
1579 cyclic-function-indirection error.
1581 This is like Findirect_function, except that it doesn't signal an
1582 error if the chain ends up unbound. */
1584 indirect_function (object
)
1585 register Lisp_Object object
;
1587 Lisp_Object tortoise
, hare
;
1589 hare
= tortoise
= object
;
1593 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1595 hare
= XSYMBOL (hare
)->function
;
1596 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1598 hare
= XSYMBOL (hare
)->function
;
1600 tortoise
= XSYMBOL (tortoise
)->function
;
1602 if (EQ (hare
, tortoise
))
1603 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1609 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1610 "Return the function at the end of OBJECT's function chain.\n\
1611 If OBJECT is a symbol, follow all function indirections and return the final\n\
1612 function binding.\n\
1613 If OBJECT is not a symbol, just return it.\n\
1614 Signal a void-function error if the final symbol is unbound.\n\
1615 Signal a cyclic-function-indirection error if there is a loop in the\n\
1616 function chain of symbols.")
1618 register Lisp_Object object
;
1622 result
= indirect_function (object
);
1624 if (EQ (result
, Qunbound
))
1625 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1629 /* Extract and set vector and string elements */
1631 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1632 "Return the element of ARRAY at index IDX.\n\
1633 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1634 or a byte-code object. IDX starts at 0.")
1636 register Lisp_Object array
;
1639 register int idxval
;
1641 CHECK_NUMBER (idx
, 1);
1642 idxval
= XINT (idx
);
1643 if (STRINGP (array
))
1647 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1648 args_out_of_range (array
, idx
);
1649 if (! STRING_MULTIBYTE (array
))
1650 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1651 idxval_byte
= string_char_to_byte (array
, idxval
);
1653 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1654 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1655 return make_number (c
);
1657 else if (BOOL_VECTOR_P (array
))
1661 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1662 args_out_of_range (array
, idx
);
1664 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1665 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1667 else if (CHAR_TABLE_P (array
))
1672 args_out_of_range (array
, idx
);
1673 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1675 /* For ASCII and 8-bit European characters, the element is
1676 stored in the top table. */
1677 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1679 val
= XCHAR_TABLE (array
)->defalt
;
1680 while (NILP (val
)) /* Follow parents until we find some value. */
1682 array
= XCHAR_TABLE (array
)->parent
;
1685 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1687 val
= XCHAR_TABLE (array
)->defalt
;
1694 Lisp_Object sub_table
;
1696 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1697 if (code
[0] != CHARSET_COMPOSITION
)
1699 if (code
[1] < 32) code
[1] = -1;
1700 else if (code
[2] < 32) code
[2] = -1;
1702 /* Here, the possible range of CODE[0] (== charset ID) is
1703 128..MAX_CHARSET. Since the top level char table contains
1704 data for multibyte characters after 256th element, we must
1705 increment CODE[0] by 128 to get a correct index. */
1707 code
[3] = -1; /* anchor */
1709 try_parent_char_table
:
1711 for (i
= 0; code
[i
] >= 0; i
++)
1713 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1714 if (SUB_CHAR_TABLE_P (val
))
1719 val
= XCHAR_TABLE (sub_table
)->defalt
;
1722 array
= XCHAR_TABLE (array
)->parent
;
1724 goto try_parent_char_table
;
1729 /* Here, VAL is a sub char table. We try the default value
1731 val
= XCHAR_TABLE (val
)->defalt
;
1734 array
= XCHAR_TABLE (array
)->parent
;
1736 goto try_parent_char_table
;
1744 if (VECTORP (array
))
1745 size
= XVECTOR (array
)->size
;
1746 else if (COMPILEDP (array
))
1747 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1749 wrong_type_argument (Qarrayp
, array
);
1751 if (idxval
< 0 || idxval
>= size
)
1752 args_out_of_range (array
, idx
);
1753 return XVECTOR (array
)->contents
[idxval
];
1757 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1758 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1759 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1761 (array
, idx
, newelt
)
1762 register Lisp_Object array
;
1763 Lisp_Object idx
, newelt
;
1765 register int idxval
;
1767 CHECK_NUMBER (idx
, 1);
1768 idxval
= XINT (idx
);
1769 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1770 && ! CHAR_TABLE_P (array
))
1771 array
= wrong_type_argument (Qarrayp
, array
);
1772 CHECK_IMPURE (array
);
1774 if (VECTORP (array
))
1776 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1777 args_out_of_range (array
, idx
);
1778 XVECTOR (array
)->contents
[idxval
] = newelt
;
1780 else if (BOOL_VECTOR_P (array
))
1784 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1785 args_out_of_range (array
, idx
);
1787 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1789 if (! NILP (newelt
))
1790 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1792 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1793 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1795 else if (CHAR_TABLE_P (array
))
1798 args_out_of_range (array
, idx
);
1799 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1800 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1806 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1807 if (code
[0] != CHARSET_COMPOSITION
)
1809 if (code
[1] < 32) code
[1] = -1;
1810 else if (code
[2] < 32) code
[2] = -1;
1812 /* See the comment of the corresponding part in Faref. */
1814 code
[3] = -1; /* anchor */
1815 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1817 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1818 if (SUB_CHAR_TABLE_P (val
))
1824 /* VAL is a leaf. Create a sub char table with the
1825 default value VAL or XCHAR_TABLE (array)->defalt
1826 and look into it. */
1828 temp
= make_sub_char_table (NILP (val
)
1829 ? XCHAR_TABLE (array
)->defalt
1831 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1835 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1838 else if (STRING_MULTIBYTE (array
))
1840 int idxval_byte
, new_len
, actual_len
;
1842 unsigned char *p
, workbuf
[4], *str
;
1844 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1845 args_out_of_range (array
, idx
);
1847 idxval_byte
= string_char_to_byte (array
, idxval
);
1848 p
= &XSTRING (array
)->data
[idxval_byte
];
1850 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1851 CHECK_NUMBER (newelt
, 2);
1852 new_len
= CHAR_STRING (XINT (newelt
), workbuf
, str
);
1853 if (actual_len
!= new_len
)
1854 error ("Attempt to change byte length of a string");
1856 /* We can't accept a change causing byte combining. */
1857 if (!ASCII_BYTE_P (*str
)
1858 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1859 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1860 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1861 > idxval_byte
- prev_byte
))
1862 || (idxval
< XSTRING (array
)->size
- 1
1863 && !CHAR_HEAD_P (p
[actual_len
])
1864 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1865 error ("Attempt to change char length of a string");
1871 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1872 args_out_of_range (array
, idx
);
1873 CHECK_NUMBER (newelt
, 2);
1874 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1880 /* Arithmetic functions */
1882 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1885 arithcompare (num1
, num2
, comparison
)
1886 Lisp_Object num1
, num2
;
1887 enum comparison comparison
;
1892 #ifdef LISP_FLOAT_TYPE
1893 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1894 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1896 if (FLOATP (num1
) || FLOATP (num2
))
1899 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1900 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1903 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1904 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1905 #endif /* LISP_FLOAT_TYPE */
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 #ifdef LISP_FLOAT_TYPE
1999 CHECK_NUMBER_OR_FLOAT (number
, 0);
2001 if (FLOATP (number
))
2003 if (XFLOAT_DATA (number
) == 0.0)
2008 CHECK_NUMBER (number
, 0);
2009 #endif /* LISP_FLOAT_TYPE */
2016 /* Convert between long values and pairs of Lisp integers. */
2022 unsigned int top
= i
>> 16;
2023 unsigned int bot
= i
& 0xFFFF;
2025 return make_number (bot
);
2026 if (top
== (unsigned long)-1 >> 16)
2027 return Fcons (make_number (-1), make_number (bot
));
2028 return Fcons (make_number (top
), make_number (bot
));
2035 Lisp_Object top
, bot
;
2042 return ((XINT (top
) << 16) | XINT (bot
));
2045 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2046 "Convert NUMBER to a string by printing it in decimal.\n\
2047 Uses a minus sign if negative.\n\
2048 NUMBER may be an integer or a floating point number.")
2052 char buffer
[VALBITS
];
2054 #ifndef LISP_FLOAT_TYPE
2055 CHECK_NUMBER (number
, 0);
2057 CHECK_NUMBER_OR_FLOAT (number
, 0);
2059 if (FLOATP (number
))
2061 char pigbuf
[350]; /* see comments in float_to_string */
2063 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2064 return build_string (pigbuf
);
2066 #endif /* LISP_FLOAT_TYPE */
2068 if (sizeof (int) == sizeof (EMACS_INT
))
2069 sprintf (buffer
, "%d", XINT (number
));
2070 else if (sizeof (long) == sizeof (EMACS_INT
))
2071 sprintf (buffer
, "%ld", (long) XINT (number
));
2074 return build_string (buffer
);
2078 digit_to_number (character
, base
)
2079 int character
, base
;
2083 if (character
>= '0' && character
<= '9')
2084 digit
= character
- '0';
2085 else if (character
>= 'a' && character
<= 'z')
2086 digit
= character
- 'a' + 10;
2087 else if (character
>= 'A' && character
<= 'Z')
2088 digit
= character
- 'A' + 10;
2098 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2099 "Convert STRING to a number by parsing it as a decimal number.\n\
2100 This parses both integers and floating point numbers.\n\
2101 It ignores leading spaces and tabs.\n\
2103 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2104 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2105 If the base used is not 10, floating point is not recognized.")
2107 register Lisp_Object string
, base
;
2109 register unsigned char *p
;
2110 register int b
, v
= 0;
2113 CHECK_STRING (string
, 0);
2119 CHECK_NUMBER (base
, 1);
2121 if (b
< 2 || b
> 16)
2122 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2125 p
= XSTRING (string
)->data
;
2127 /* Skip any whitespace at the front of the number. Some versions of
2128 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2129 while (*p
== ' ' || *p
== '\t')
2140 #ifdef LISP_FLOAT_TYPE
2141 if (isfloat_string (p
) && b
== 10)
2142 return make_float (negative
* atof (p
));
2143 #endif /* LISP_FLOAT_TYPE */
2147 int digit
= digit_to_number (*p
++, b
);
2153 return make_number (negative
* 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 #ifdef LISP_FLOAT_TYPE
2191 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2193 if (FLOATP (val
)) /* time to do serious math */
2194 return (float_arith_driver ((double) accum
, argnum
, code
,
2197 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2198 #endif /* LISP_FLOAT_TYPE */
2199 args
[argnum
] = val
; /* runs into a compiler bug. */
2200 next
= XINT (args
[argnum
]);
2201 switch (SWITCH_ENUM_CAST (code
))
2203 case Aadd
: accum
+= next
; break;
2205 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2207 case Amult
: accum
*= next
; break;
2209 if (!argnum
) accum
= next
;
2213 Fsignal (Qarith_error
, Qnil
);
2217 case Alogand
: accum
&= next
; break;
2218 case Alogior
: accum
|= next
; break;
2219 case Alogxor
: accum
^= next
; break;
2220 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2221 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2225 XSETINT (val
, accum
);
2230 #define isnan(x) ((x) != (x))
2232 #ifdef LISP_FLOAT_TYPE
2235 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2237 register int argnum
;
2240 register Lisp_Object
*args
;
2242 register Lisp_Object val
;
2245 for (; argnum
< nargs
; argnum
++)
2247 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2248 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2252 next
= XFLOAT_DATA (val
);
2256 args
[argnum
] = val
; /* runs into a compiler bug. */
2257 next
= XINT (args
[argnum
]);
2259 switch (SWITCH_ENUM_CAST (code
))
2265 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2275 if (! IEEE_FLOATING_POINT
&& next
== 0)
2276 Fsignal (Qarith_error
, Qnil
);
2283 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2285 if (!argnum
|| isnan (next
) || next
> accum
)
2289 if (!argnum
|| isnan (next
) || next
< accum
)
2295 return make_float (accum
);
2297 #endif /* LISP_FLOAT_TYPE */
2299 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2300 "Return sum of any number of arguments, which are numbers or markers.")
2305 return arith_driver (Aadd
, nargs
, args
);
2308 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2309 "Negate number or subtract numbers or markers.\n\
2310 With one arg, negates it. With more than one arg,\n\
2311 subtracts all but the first from the first.")
2316 return arith_driver (Asub
, nargs
, args
);
2319 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2320 "Returns product of any number of arguments, which are numbers or markers.")
2325 return arith_driver (Amult
, nargs
, args
);
2328 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2329 "Returns first argument divided by all the remaining arguments.\n\
2330 The arguments must be numbers or markers.")
2335 return arith_driver (Adiv
, nargs
, args
);
2338 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2339 "Returns remainder of X divided by Y.\n\
2340 Both must be integers or markers.")
2342 register Lisp_Object x
, y
;
2346 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2347 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2349 if (XFASTINT (y
) == 0)
2350 Fsignal (Qarith_error
, Qnil
);
2352 XSETINT (val
, XINT (x
) % XINT (y
));
2366 /* If the magnitude of the result exceeds that of the divisor, or
2367 the sign of the result does not agree with that of the dividend,
2368 iterate with the reduced value. This does not yield a
2369 particularly accurate result, but at least it will be in the
2370 range promised by fmod. */
2372 r
-= f2
* floor (r
/ f2
);
2373 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2377 #endif /* ! HAVE_FMOD */
2379 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2380 "Returns X modulo Y.\n\
2381 The result falls between zero (inclusive) and Y (exclusive).\n\
2382 Both X and Y must be numbers or markers.")
2384 register Lisp_Object x
, y
;
2389 #ifdef LISP_FLOAT_TYPE
2390 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2391 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2393 if (FLOATP (x
) || FLOATP (y
))
2394 return fmod_float (x
, y
);
2396 #else /* not LISP_FLOAT_TYPE */
2397 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2398 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2399 #endif /* not LISP_FLOAT_TYPE */
2405 Fsignal (Qarith_error
, Qnil
);
2409 /* If the "remainder" comes out with the wrong sign, fix it. */
2410 if (i2
< 0 ? i1
> 0 : i1
< 0)
2417 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2418 "Return largest of all the arguments (which must be numbers or markers).\n\
2419 The value is always a number; markers are converted to numbers.")
2424 return arith_driver (Amax
, nargs
, args
);
2427 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2428 "Return smallest of all the arguments (which must be numbers or markers).\n\
2429 The value is always a number; markers are converted to numbers.")
2434 return arith_driver (Amin
, nargs
, args
);
2437 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2438 "Return bitwise-and of all the arguments.\n\
2439 Arguments may be integers, or markers converted to integers.")
2444 return arith_driver (Alogand
, nargs
, args
);
2447 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2448 "Return bitwise-or of all the arguments.\n\
2449 Arguments may be integers, or markers converted to integers.")
2454 return arith_driver (Alogior
, nargs
, args
);
2457 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2458 "Return bitwise-exclusive-or of all the arguments.\n\
2459 Arguments may be integers, or markers converted to integers.")
2464 return arith_driver (Alogxor
, nargs
, args
);
2467 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2468 "Return VALUE with its bits shifted left by COUNT.\n\
2469 If COUNT is negative, shifting is actually to the right.\n\
2470 In this case, the sign bit is duplicated.")
2472 register Lisp_Object value
, count
;
2474 register Lisp_Object val
;
2476 CHECK_NUMBER (value
, 0);
2477 CHECK_NUMBER (count
, 1);
2479 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2481 else if (XINT (count
) > 0)
2482 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2483 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2484 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2486 XSETINT (val
, XINT (value
) >> -XINT (count
));
2490 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2491 "Return VALUE with its bits shifted left by COUNT.\n\
2492 If COUNT is negative, shifting is actually to the right.\n\
2493 In this case, zeros are shifted in on the left.")
2495 register Lisp_Object value
, count
;
2497 register Lisp_Object val
;
2499 CHECK_NUMBER (value
, 0);
2500 CHECK_NUMBER (count
, 1);
2502 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2504 else if (XINT (count
) > 0)
2505 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2506 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2509 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2513 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2514 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2515 Markers are converted to integers.")
2517 register Lisp_Object number
;
2519 #ifdef LISP_FLOAT_TYPE
2520 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2522 if (FLOATP (number
))
2523 return (make_float (1.0 + XFLOAT_DATA (number
)));
2525 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2526 #endif /* LISP_FLOAT_TYPE */
2528 XSETINT (number
, XINT (number
) + 1);
2532 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2533 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2534 Markers are converted to integers.")
2536 register Lisp_Object number
;
2538 #ifdef LISP_FLOAT_TYPE
2539 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2541 if (FLOATP (number
))
2542 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2544 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2545 #endif /* LISP_FLOAT_TYPE */
2547 XSETINT (number
, XINT (number
) - 1);
2551 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2552 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2554 register Lisp_Object number
;
2556 CHECK_NUMBER (number
, 0);
2557 XSETINT (number
, ~XINT (number
));
2564 Lisp_Object error_tail
, arith_tail
;
2566 Qquote
= intern ("quote");
2567 Qlambda
= intern ("lambda");
2568 Qsubr
= intern ("subr");
2569 Qerror_conditions
= intern ("error-conditions");
2570 Qerror_message
= intern ("error-message");
2571 Qtop_level
= intern ("top-level");
2573 Qerror
= intern ("error");
2574 Qquit
= intern ("quit");
2575 Qwrong_type_argument
= intern ("wrong-type-argument");
2576 Qargs_out_of_range
= intern ("args-out-of-range");
2577 Qvoid_function
= intern ("void-function");
2578 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2579 Qvoid_variable
= intern ("void-variable");
2580 Qsetting_constant
= intern ("setting-constant");
2581 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2583 Qinvalid_function
= intern ("invalid-function");
2584 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2585 Qno_catch
= intern ("no-catch");
2586 Qend_of_file
= intern ("end-of-file");
2587 Qarith_error
= intern ("arith-error");
2588 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2589 Qend_of_buffer
= intern ("end-of-buffer");
2590 Qbuffer_read_only
= intern ("buffer-read-only");
2591 Qmark_inactive
= intern ("mark-inactive");
2593 Qlistp
= intern ("listp");
2594 Qconsp
= intern ("consp");
2595 Qsymbolp
= intern ("symbolp");
2596 Qintegerp
= intern ("integerp");
2597 Qnatnump
= intern ("natnump");
2598 Qwholenump
= intern ("wholenump");
2599 Qstringp
= intern ("stringp");
2600 Qarrayp
= intern ("arrayp");
2601 Qsequencep
= intern ("sequencep");
2602 Qbufferp
= intern ("bufferp");
2603 Qvectorp
= intern ("vectorp");
2604 Qchar_or_string_p
= intern ("char-or-string-p");
2605 Qmarkerp
= intern ("markerp");
2606 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2607 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2608 Qboundp
= intern ("boundp");
2609 Qfboundp
= intern ("fboundp");
2611 #ifdef LISP_FLOAT_TYPE
2612 Qfloatp
= intern ("floatp");
2613 Qnumberp
= intern ("numberp");
2614 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2615 #endif /* LISP_FLOAT_TYPE */
2617 Qchar_table_p
= intern ("char-table-p");
2618 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2620 Qcdr
= intern ("cdr");
2622 /* Handle automatic advice activation */
2623 Qad_advice_info
= intern ("ad-advice-info");
2624 Qad_activate
= intern ("ad-activate");
2626 error_tail
= Fcons (Qerror
, Qnil
);
2628 /* ERROR is used as a signaler for random errors for which nothing else is right */
2630 Fput (Qerror
, Qerror_conditions
,
2632 Fput (Qerror
, Qerror_message
,
2633 build_string ("error"));
2635 Fput (Qquit
, Qerror_conditions
,
2636 Fcons (Qquit
, Qnil
));
2637 Fput (Qquit
, Qerror_message
,
2638 build_string ("Quit"));
2640 Fput (Qwrong_type_argument
, Qerror_conditions
,
2641 Fcons (Qwrong_type_argument
, error_tail
));
2642 Fput (Qwrong_type_argument
, Qerror_message
,
2643 build_string ("Wrong type argument"));
2645 Fput (Qargs_out_of_range
, Qerror_conditions
,
2646 Fcons (Qargs_out_of_range
, error_tail
));
2647 Fput (Qargs_out_of_range
, Qerror_message
,
2648 build_string ("Args out of range"));
2650 Fput (Qvoid_function
, Qerror_conditions
,
2651 Fcons (Qvoid_function
, error_tail
));
2652 Fput (Qvoid_function
, Qerror_message
,
2653 build_string ("Symbol's function definition is void"));
2655 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2656 Fcons (Qcyclic_function_indirection
, error_tail
));
2657 Fput (Qcyclic_function_indirection
, Qerror_message
,
2658 build_string ("Symbol's chain of function indirections contains a loop"));
2660 Fput (Qvoid_variable
, Qerror_conditions
,
2661 Fcons (Qvoid_variable
, error_tail
));
2662 Fput (Qvoid_variable
, Qerror_message
,
2663 build_string ("Symbol's value as variable is void"));
2665 Fput (Qsetting_constant
, Qerror_conditions
,
2666 Fcons (Qsetting_constant
, error_tail
));
2667 Fput (Qsetting_constant
, Qerror_message
,
2668 build_string ("Attempt to set a constant symbol"));
2670 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2671 Fcons (Qinvalid_read_syntax
, error_tail
));
2672 Fput (Qinvalid_read_syntax
, Qerror_message
,
2673 build_string ("Invalid read syntax"));
2675 Fput (Qinvalid_function
, Qerror_conditions
,
2676 Fcons (Qinvalid_function
, error_tail
));
2677 Fput (Qinvalid_function
, Qerror_message
,
2678 build_string ("Invalid function"));
2680 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2681 Fcons (Qwrong_number_of_arguments
, error_tail
));
2682 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2683 build_string ("Wrong number of arguments"));
2685 Fput (Qno_catch
, Qerror_conditions
,
2686 Fcons (Qno_catch
, error_tail
));
2687 Fput (Qno_catch
, Qerror_message
,
2688 build_string ("No catch for tag"));
2690 Fput (Qend_of_file
, Qerror_conditions
,
2691 Fcons (Qend_of_file
, error_tail
));
2692 Fput (Qend_of_file
, Qerror_message
,
2693 build_string ("End of file during parsing"));
2695 arith_tail
= Fcons (Qarith_error
, error_tail
);
2696 Fput (Qarith_error
, Qerror_conditions
,
2698 Fput (Qarith_error
, Qerror_message
,
2699 build_string ("Arithmetic error"));
2701 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2702 Fcons (Qbeginning_of_buffer
, error_tail
));
2703 Fput (Qbeginning_of_buffer
, Qerror_message
,
2704 build_string ("Beginning of buffer"));
2706 Fput (Qend_of_buffer
, Qerror_conditions
,
2707 Fcons (Qend_of_buffer
, error_tail
));
2708 Fput (Qend_of_buffer
, Qerror_message
,
2709 build_string ("End of buffer"));
2711 Fput (Qbuffer_read_only
, Qerror_conditions
,
2712 Fcons (Qbuffer_read_only
, error_tail
));
2713 Fput (Qbuffer_read_only
, Qerror_message
,
2714 build_string ("Buffer is read-only"));
2716 #ifdef LISP_FLOAT_TYPE
2717 Qrange_error
= intern ("range-error");
2718 Qdomain_error
= intern ("domain-error");
2719 Qsingularity_error
= intern ("singularity-error");
2720 Qoverflow_error
= intern ("overflow-error");
2721 Qunderflow_error
= intern ("underflow-error");
2723 Fput (Qdomain_error
, Qerror_conditions
,
2724 Fcons (Qdomain_error
, arith_tail
));
2725 Fput (Qdomain_error
, Qerror_message
,
2726 build_string ("Arithmetic domain error"));
2728 Fput (Qrange_error
, Qerror_conditions
,
2729 Fcons (Qrange_error
, arith_tail
));
2730 Fput (Qrange_error
, Qerror_message
,
2731 build_string ("Arithmetic range error"));
2733 Fput (Qsingularity_error
, Qerror_conditions
,
2734 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2735 Fput (Qsingularity_error
, Qerror_message
,
2736 build_string ("Arithmetic singularity error"));
2738 Fput (Qoverflow_error
, Qerror_conditions
,
2739 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2740 Fput (Qoverflow_error
, Qerror_message
,
2741 build_string ("Arithmetic overflow error"));
2743 Fput (Qunderflow_error
, Qerror_conditions
,
2744 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2745 Fput (Qunderflow_error
, Qerror_message
,
2746 build_string ("Arithmetic underflow error"));
2748 staticpro (&Qrange_error
);
2749 staticpro (&Qdomain_error
);
2750 staticpro (&Qsingularity_error
);
2751 staticpro (&Qoverflow_error
);
2752 staticpro (&Qunderflow_error
);
2753 #endif /* LISP_FLOAT_TYPE */
2757 staticpro (&Qquote
);
2758 staticpro (&Qlambda
);
2760 staticpro (&Qunbound
);
2761 staticpro (&Qerror_conditions
);
2762 staticpro (&Qerror_message
);
2763 staticpro (&Qtop_level
);
2765 staticpro (&Qerror
);
2767 staticpro (&Qwrong_type_argument
);
2768 staticpro (&Qargs_out_of_range
);
2769 staticpro (&Qvoid_function
);
2770 staticpro (&Qcyclic_function_indirection
);
2771 staticpro (&Qvoid_variable
);
2772 staticpro (&Qsetting_constant
);
2773 staticpro (&Qinvalid_read_syntax
);
2774 staticpro (&Qwrong_number_of_arguments
);
2775 staticpro (&Qinvalid_function
);
2776 staticpro (&Qno_catch
);
2777 staticpro (&Qend_of_file
);
2778 staticpro (&Qarith_error
);
2779 staticpro (&Qbeginning_of_buffer
);
2780 staticpro (&Qend_of_buffer
);
2781 staticpro (&Qbuffer_read_only
);
2782 staticpro (&Qmark_inactive
);
2784 staticpro (&Qlistp
);
2785 staticpro (&Qconsp
);
2786 staticpro (&Qsymbolp
);
2787 staticpro (&Qintegerp
);
2788 staticpro (&Qnatnump
);
2789 staticpro (&Qwholenump
);
2790 staticpro (&Qstringp
);
2791 staticpro (&Qarrayp
);
2792 staticpro (&Qsequencep
);
2793 staticpro (&Qbufferp
);
2794 staticpro (&Qvectorp
);
2795 staticpro (&Qchar_or_string_p
);
2796 staticpro (&Qmarkerp
);
2797 staticpro (&Qbuffer_or_string_p
);
2798 staticpro (&Qinteger_or_marker_p
);
2799 #ifdef LISP_FLOAT_TYPE
2800 staticpro (&Qfloatp
);
2801 staticpro (&Qnumberp
);
2802 staticpro (&Qnumber_or_marker_p
);
2803 #endif /* LISP_FLOAT_TYPE */
2804 staticpro (&Qchar_table_p
);
2805 staticpro (&Qvector_or_char_table_p
);
2807 staticpro (&Qboundp
);
2808 staticpro (&Qfboundp
);
2810 staticpro (&Qad_advice_info
);
2811 staticpro (&Qad_activate
);
2813 /* Types that type-of returns. */
2814 Qinteger
= intern ("integer");
2815 Qsymbol
= intern ("symbol");
2816 Qstring
= intern ("string");
2817 Qcons
= intern ("cons");
2818 Qmarker
= intern ("marker");
2819 Qoverlay
= intern ("overlay");
2820 Qfloat
= intern ("float");
2821 Qwindow_configuration
= intern ("window-configuration");
2822 Qprocess
= intern ("process");
2823 Qwindow
= intern ("window");
2824 /* Qsubr = intern ("subr"); */
2825 Qcompiled_function
= intern ("compiled-function");
2826 Qbuffer
= intern ("buffer");
2827 Qframe
= intern ("frame");
2828 Qvector
= intern ("vector");
2829 Qchar_table
= intern ("char-table");
2830 Qbool_vector
= intern ("bool-vector");
2832 staticpro (&Qinteger
);
2833 staticpro (&Qsymbol
);
2834 staticpro (&Qstring
);
2836 staticpro (&Qmarker
);
2837 staticpro (&Qoverlay
);
2838 staticpro (&Qfloat
);
2839 staticpro (&Qwindow_configuration
);
2840 staticpro (&Qprocess
);
2841 staticpro (&Qwindow
);
2842 /* staticpro (&Qsubr); */
2843 staticpro (&Qcompiled_function
);
2844 staticpro (&Qbuffer
);
2845 staticpro (&Qframe
);
2846 staticpro (&Qvector
);
2847 staticpro (&Qchar_table
);
2848 staticpro (&Qbool_vector
);
2850 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2851 "Non-nil means it is an error to set a keyword symbol.\n\
2852 A keyword symbol is a symbol whose name starts with a colon (`:').");
2853 keyword_symbols_constant_flag
= 1;
2857 defsubr (&Stype_of
);
2862 defsubr (&Sintegerp
);
2863 defsubr (&Sinteger_or_marker_p
);
2864 defsubr (&Snumberp
);
2865 defsubr (&Snumber_or_marker_p
);
2866 #ifdef LISP_FLOAT_TYPE
2868 #endif /* LISP_FLOAT_TYPE */
2869 defsubr (&Snatnump
);
2870 defsubr (&Ssymbolp
);
2871 defsubr (&Sstringp
);
2872 defsubr (&Smultibyte_string_p
);
2873 defsubr (&Svectorp
);
2874 defsubr (&Schar_table_p
);
2875 defsubr (&Svector_or_char_table_p
);
2876 defsubr (&Sbool_vector_p
);
2878 defsubr (&Ssequencep
);
2879 defsubr (&Sbufferp
);
2880 defsubr (&Smarkerp
);
2882 defsubr (&Sbyte_code_function_p
);
2883 defsubr (&Schar_or_string_p
);
2886 defsubr (&Scar_safe
);
2887 defsubr (&Scdr_safe
);
2890 defsubr (&Ssymbol_function
);
2891 defsubr (&Sindirect_function
);
2892 defsubr (&Ssymbol_plist
);
2893 defsubr (&Ssymbol_name
);
2894 defsubr (&Smakunbound
);
2895 defsubr (&Sfmakunbound
);
2897 defsubr (&Sfboundp
);
2899 defsubr (&Sdefalias
);
2900 defsubr (&Ssetplist
);
2901 defsubr (&Ssymbol_value
);
2903 defsubr (&Sdefault_boundp
);
2904 defsubr (&Sdefault_value
);
2905 defsubr (&Sset_default
);
2906 defsubr (&Ssetq_default
);
2907 defsubr (&Smake_variable_buffer_local
);
2908 defsubr (&Smake_local_variable
);
2909 defsubr (&Skill_local_variable
);
2910 defsubr (&Smake_variable_frame_local
);
2911 defsubr (&Slocal_variable_p
);
2912 defsubr (&Slocal_variable_if_set_p
);
2915 defsubr (&Snumber_to_string
);
2916 defsubr (&Sstring_to_number
);
2917 defsubr (&Seqlsign
);
2941 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2948 #if defined(USG) && !defined(POSIX_SIGNALS)
2949 /* USG systems forget handlers when they are used;
2950 must reestablish each time */
2951 signal (signo
, arith_error
);
2954 /* VMS systems are like USG. */
2955 signal (signo
, arith_error
);
2959 #else /* not BSD4_1 */
2960 sigsetmask (SIGEMPTYMASK
);
2961 #endif /* not BSD4_1 */
2963 Fsignal (Qarith_error
, Qnil
);
2969 /* Don't do this if just dumping out.
2970 We don't want to call `signal' in this case
2971 so that we don't have trouble with dumping
2972 signal-delivering routines in an inconsistent state. */
2976 #endif /* CANNOT_DUMP */
2977 signal (SIGFPE
, arith_error
);
2980 signal (SIGEMT
, arith_error
);