1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97, 1998 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
44 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
45 #ifndef IEEE_FLOATING_POINT
46 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
47 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
48 #define IEEE_FLOATING_POINT 1
50 #define IEEE_FLOATING_POINT 0
54 /* Work around a problem that happens because math.h on hpux 7
55 defines two static variables--which, in Emacs, are not really static,
56 because `static' is defined as nothing. The problem is that they are
57 here, in floatfns.c, and in lread.c.
58 These macros prevent the name conflict. */
59 #if defined (HPUX) && !defined (HPUX8)
60 #define _MAXLDBL data_c_maxldbl
61 #define _NMAXLDBL data_c_nmaxldbl
65 #endif /* LISP_FLOAT_TYPE */
68 extern double atof ();
71 /* Nonzero means it is an error to set a symbol whose name starts with
73 int keyword_symbols_constant_flag
;
75 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
76 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
77 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
78 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
79 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
80 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
81 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
82 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
83 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
84 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
85 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
86 Lisp_Object Qbuffer_or_string_p
;
87 Lisp_Object Qboundp
, Qfboundp
;
88 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
91 Lisp_Object Qad_advice_info
, Qad_activate
;
93 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
94 Lisp_Object Qoverflow_error
, Qunderflow_error
;
96 #ifdef LISP_FLOAT_TYPE
98 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
101 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
102 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
103 Lisp_Object Qprocess
;
104 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
105 static Lisp_Object Qchar_table
, Qbool_vector
;
107 static Lisp_Object
swap_in_symval_forwarding ();
109 Lisp_Object
set_internal ();
112 wrong_type_argument (predicate
, value
)
113 register Lisp_Object predicate
, value
;
115 register Lisp_Object tem
;
118 if (!EQ (Vmocklisp_arguments
, Qt
))
120 if (STRINGP (value
) &&
121 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
122 return Fstring_to_number (value
, Qnil
);
123 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
124 return Fnumber_to_string (value
);
127 /* If VALUE is not even a valid Lisp object, abort here
128 where we can get a backtrace showing where it came from. */
129 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
132 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
133 tem
= call1 (predicate
, value
);
142 error ("Attempt to modify read-only object");
146 args_out_of_range (a1
, a2
)
150 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
154 args_out_of_range_3 (a1
, a2
, a3
)
155 Lisp_Object a1
, a2
, a3
;
158 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
161 /* On some machines, XINT needs a temporary location.
162 Here it is, in case it is needed. */
164 int sign_extend_temp
;
166 /* On a few machines, XINT can only be done by calling this. */
169 sign_extend_lisp_int (num
)
172 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
173 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
175 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
178 /* Data type predicates */
180 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
181 "Return t if the two args are the same Lisp object.")
183 Lisp_Object obj1
, obj2
;
190 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
199 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
200 "Return a symbol representing the type of OBJECT.\n\
201 The symbol returned names the object's basic type;\n\
202 for example, (type-of 1) returns `integer'.")
206 switch (XGCTYPE (object
))
221 switch (XMISCTYPE (object
))
223 case Lisp_Misc_Marker
:
225 case Lisp_Misc_Overlay
:
227 case Lisp_Misc_Float
:
232 case Lisp_Vectorlike
:
233 if (GC_WINDOW_CONFIGURATIONP (object
))
234 return Qwindow_configuration
;
235 if (GC_PROCESSP (object
))
237 if (GC_WINDOWP (object
))
239 if (GC_SUBRP (object
))
241 if (GC_COMPILEDP (object
))
242 return Qcompiled_function
;
243 if (GC_BUFFERP (object
))
245 if (GC_CHAR_TABLE_P (object
))
247 if (GC_BOOL_VECTOR_P (object
))
249 if (GC_FRAMEP (object
))
253 #ifdef LISP_FLOAT_TYPE
263 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
272 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
273 "Return t if OBJECT is not a cons cell. This includes nil.")
282 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
283 "Return t if OBJECT is a list. This includes nil.")
287 if (CONSP (object
) || NILP (object
))
292 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
293 "Return t if OBJECT is not a list. Lists include nil.")
297 if (CONSP (object
) || NILP (object
))
302 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
303 "Return t if OBJECT is a symbol.")
307 if (SYMBOLP (object
))
312 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
313 "Return t if OBJECT is a vector.")
317 if (VECTORP (object
))
322 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
323 "Return t if OBJECT is a string.")
327 if (STRINGP (object
))
332 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
333 1, 1, 0, "Return t if OBJECT is a multibyte string.")
337 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
342 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
343 "Return t if OBJECT is a char-table.")
347 if (CHAR_TABLE_P (object
))
352 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
353 Svector_or_char_table_p
, 1, 1, 0,
354 "Return t if OBJECT is a char-table or vector.")
358 if (VECTORP (object
) || CHAR_TABLE_P (object
))
363 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
367 if (BOOL_VECTOR_P (object
))
372 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
376 if (VECTORP (object
) || STRINGP (object
)
377 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
382 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
383 "Return t if OBJECT is a sequence (list or array).")
385 register Lisp_Object object
;
387 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
388 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
393 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
397 if (BUFFERP (object
))
402 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
406 if (MARKERP (object
))
411 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
420 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
421 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
425 if (COMPILEDP (object
))
430 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
431 "Return t if OBJECT is a character (an integer) or a string.")
433 register Lisp_Object object
;
435 if (INTEGERP (object
) || STRINGP (object
))
440 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
444 if (INTEGERP (object
))
449 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
450 "Return t if OBJECT is an integer or a marker (editor pointer).")
452 register Lisp_Object object
;
454 if (MARKERP (object
) || INTEGERP (object
))
459 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
460 "Return t if OBJECT is a nonnegative integer.")
464 if (NATNUMP (object
))
469 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
470 "Return t if OBJECT is a number (floating point or integer).")
474 if (NUMBERP (object
))
480 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
481 Snumber_or_marker_p
, 1, 1, 0,
482 "Return t if OBJECT is a number or a marker.")
486 if (NUMBERP (object
) || MARKERP (object
))
491 #ifdef LISP_FLOAT_TYPE
492 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
493 "Return t if OBJECT is a floating point number.")
501 #endif /* LISP_FLOAT_TYPE */
503 /* Extract and set components of lists */
505 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
506 "Return the car of LIST. If arg is nil, return nil.\n\
507 Error if arg is not nil and not a cons cell. See also `car-safe'.")
509 register Lisp_Object list
;
514 return XCONS (list
)->car
;
515 else if (EQ (list
, Qnil
))
518 list
= wrong_type_argument (Qlistp
, list
);
522 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
523 "Return the car of OBJECT if it is a cons cell, or else nil.")
528 return XCONS (object
)->car
;
533 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
534 "Return the cdr of LIST. If arg is nil, return nil.\n\
535 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
538 register Lisp_Object list
;
543 return XCONS (list
)->cdr
;
544 else if (EQ (list
, Qnil
))
547 list
= wrong_type_argument (Qlistp
, list
);
551 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
552 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
557 return XCONS (object
)->cdr
;
562 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
563 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
565 register Lisp_Object cell
, newcar
;
568 cell
= wrong_type_argument (Qconsp
, cell
);
571 XCONS (cell
)->car
= newcar
;
575 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
576 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
578 register Lisp_Object cell
, newcdr
;
581 cell
= wrong_type_argument (Qconsp
, cell
);
584 XCONS (cell
)->cdr
= newcdr
;
588 /* Extract and set components of symbols */
590 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
592 register Lisp_Object symbol
;
594 Lisp_Object valcontents
;
595 CHECK_SYMBOL (symbol
, 0);
597 valcontents
= XSYMBOL (symbol
)->value
;
599 if (BUFFER_LOCAL_VALUEP (valcontents
)
600 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
601 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
603 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
606 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
608 register Lisp_Object symbol
;
610 CHECK_SYMBOL (symbol
, 0);
611 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
614 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
616 register Lisp_Object symbol
;
618 CHECK_SYMBOL (symbol
, 0);
619 if (NILP (symbol
) || EQ (symbol
, Qt
)
620 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
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 CHECK_SYMBOL (symbol
, 0);
696 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
697 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
699 XSYMBOL (symbol
)->function
= definition
;
700 /* Handle automatic advice activation */
701 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
703 call2 (Qad_activate
, symbol
, Qnil
);
704 definition
= XSYMBOL (symbol
)->function
;
706 LOADHIST_ATTACH (symbol
);
710 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
711 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
713 register Lisp_Object symbol
, newplist
;
715 CHECK_SYMBOL (symbol
, 0);
716 XSYMBOL (symbol
)->plist
= newplist
;
721 /* Getting and setting values of symbols */
723 /* Given the raw contents of a symbol value cell,
724 return the Lisp value of the symbol.
725 This does not handle buffer-local variables; use
726 swap_in_symval_forwarding for that. */
729 do_symval_forwarding (valcontents
)
730 register Lisp_Object valcontents
;
732 register Lisp_Object val
;
734 if (MISCP (valcontents
))
735 switch (XMISCTYPE (valcontents
))
737 case Lisp_Misc_Intfwd
:
738 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
741 case Lisp_Misc_Boolfwd
:
742 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
744 case Lisp_Misc_Objfwd
:
745 return *XOBJFWD (valcontents
)->objvar
;
747 case Lisp_Misc_Buffer_Objfwd
:
748 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
749 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
751 case Lisp_Misc_Kboard_Objfwd
:
752 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
753 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
758 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
759 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
760 buffer-independent contents of the value cell: forwarded just one
761 step past the buffer-localness. */
764 store_symval_forwarding (symbol
, valcontents
, newval
)
766 register Lisp_Object valcontents
, newval
;
768 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
771 switch (XMISCTYPE (valcontents
))
773 case Lisp_Misc_Intfwd
:
774 CHECK_NUMBER (newval
, 1);
775 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
776 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
777 error ("Value out of range for variable `%s'",
778 XSYMBOL (symbol
)->name
->data
);
781 case Lisp_Misc_Boolfwd
:
782 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
785 case Lisp_Misc_Objfwd
:
786 *XOBJFWD (valcontents
)->objvar
= newval
;
789 case Lisp_Misc_Buffer_Objfwd
:
791 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
794 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
795 if (XINT (type
) == -1)
796 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
798 if (! NILP (type
) && ! NILP (newval
)
799 && XTYPE (newval
) != XINT (type
))
800 buffer_slot_type_mismatch (offset
);
802 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
806 case Lisp_Misc_Kboard_Objfwd
:
807 (*(Lisp_Object
*)((char *)current_kboard
808 + XKBOARD_OBJFWD (valcontents
)->offset
))
819 valcontents
= XSYMBOL (symbol
)->value
;
820 if (BUFFER_LOCAL_VALUEP (valcontents
)
821 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
822 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
824 XSYMBOL (symbol
)->value
= newval
;
828 /* Set up the buffer-local symbol SYMBOL for validity in the current
829 buffer. VALCONTENTS is the contents of its value cell.
830 Return the value forwarded one step past the buffer-local indicator. */
833 swap_in_symval_forwarding (symbol
, valcontents
)
834 Lisp_Object symbol
, valcontents
;
836 /* valcontents is a pointer to a struct resembling the cons
837 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
839 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
840 local_var_alist, that being the element whose car is this
841 variable. Or it can be a pointer to the
842 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
843 an element in its alist for this variable.
845 If the current buffer is not BUFFER, we store the current
846 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
847 appropriate alist element for the buffer now current and set up
848 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
849 element, and store into BUFFER.
851 Note that REALVALUE can be a forwarding pointer. */
853 register Lisp_Object tem1
;
854 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
856 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
)
857 || selected_frame
!= XFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
859 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
861 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
862 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
863 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
864 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
867 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
868 tem1
= assq_no_quit (symbol
, selected_frame
->param_alist
);
870 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
872 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
875 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
877 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
= tem1
;
878 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
879 XSETFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
, selected_frame
);
880 store_symval_forwarding (symbol
,
881 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
884 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
887 /* Find the value of a symbol, returning Qunbound if it's not bound.
888 This is helpful for code which just wants to get a variable's value
889 if it has one, without signaling an error.
890 Note that it must not be possible to quit
891 within this function. Great care is required for this. */
894 find_symbol_value (symbol
)
897 register Lisp_Object valcontents
, tem1
;
898 register Lisp_Object val
;
899 CHECK_SYMBOL (symbol
, 0);
900 valcontents
= XSYMBOL (symbol
)->value
;
902 if (BUFFER_LOCAL_VALUEP (valcontents
)
903 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
904 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
906 if (MISCP (valcontents
))
908 switch (XMISCTYPE (valcontents
))
910 case Lisp_Misc_Intfwd
:
911 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
914 case Lisp_Misc_Boolfwd
:
915 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
917 case Lisp_Misc_Objfwd
:
918 return *XOBJFWD (valcontents
)->objvar
;
920 case Lisp_Misc_Buffer_Objfwd
:
921 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
922 + (char *)current_buffer
);
924 case Lisp_Misc_Kboard_Objfwd
:
925 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
926 + (char *)current_kboard
);
933 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
934 "Return SYMBOL's value. Error if that is void.")
940 val
= find_symbol_value (symbol
);
941 if (EQ (val
, Qunbound
))
942 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
947 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
948 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
950 register Lisp_Object symbol
, newval
;
952 return set_internal (symbol
, newval
, 0);
955 /* Store the value NEWVAL into SYMBOL.
956 If BINDFLAG is zero, then if this symbol is supposed to become
957 local in every buffer where it is set, then we make it local.
958 If BINDFLAG is nonzero, we don't do that. */
961 set_internal (symbol
, newval
, bindflag
)
962 register Lisp_Object symbol
, newval
;
965 int voide
= EQ (newval
, Qunbound
);
967 register Lisp_Object valcontents
, tem1
, current_alist_element
;
969 CHECK_SYMBOL (symbol
, 0);
970 if (NILP (symbol
) || EQ (symbol
, Qt
)
971 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
972 && keyword_symbols_constant_flag
&& ! EQ (newval
, symbol
)))
973 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
974 valcontents
= XSYMBOL (symbol
)->value
;
976 if (BUFFER_OBJFWDP (valcontents
))
978 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
979 register int mask
= XINT (*((Lisp_Object
*)
980 (idx
+ (char *)&buffer_local_flags
)));
982 current_buffer
->local_var_flags
|= mask
;
985 else if (BUFFER_LOCAL_VALUEP (valcontents
)
986 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
988 /* valcontents is actually a pointer to a struct resembling a cons,
989 with contents something like:
990 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
992 BUFFER is the last buffer for which this symbol's value was
995 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
996 local_var_alist, that being the element whose car is this
997 variable. Or it can be a pointer to the
998 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
999 have an element in its alist for this variable (that is, if
1000 BUFFER sees the default value of this variable).
1002 If we want to examine or set the value and BUFFER is current,
1003 we just examine or set REALVALUE. If BUFFER is not current, we
1004 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
1005 then find the appropriate alist element for the buffer now
1006 current and set up CURRENT-ALIST-ELEMENT. Then we set
1007 REALVALUE out of that element, and store into BUFFER.
1009 If we are setting the variable and the current buffer does
1010 not have an alist entry for this variable, an alist entry is
1013 Note that REALVALUE can be a forwarding pointer. Each time
1014 it is examined or set, forwarding must be done. */
1016 /* What value are we caching right now? */
1017 current_alist_element
1018 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1020 /* If the current buffer is not the buffer whose binding is
1021 currently cached, or if it's a Lisp_Buffer_Local_Value and
1022 we're looking at the default value, the cache is invalid; we
1023 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
1024 if (current_buffer
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1026 selected_frame
!= XFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
)
1027 || (BUFFER_LOCAL_VALUEP (valcontents
)
1028 && EQ (XCONS (current_alist_element
)->car
,
1029 current_alist_element
)))
1031 /* Write out the cached value for the old buffer; copy it
1032 back to its alist element. This works if the current
1033 buffer only sees the default value, too. */
1034 Fsetcdr (current_alist_element
,
1035 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1037 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1038 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1039 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1040 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1044 /* This buffer still sees the default value. */
1046 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1047 or if this is `let' rather than `set',
1048 make CURRENT-ALIST-ELEMENT point to itself,
1049 indicating that we're seeing the default value. */
1050 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1052 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1054 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1055 tem1
= Fassq (symbol
, selected_frame
->param_alist
);
1058 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1060 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1062 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1063 give this buffer a new assoc for a local value and set
1064 CURRENT-ALIST-ELEMENT to point to that. */
1067 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1068 current_buffer
->local_var_alist
1069 = Fcons (tem1
, current_buffer
->local_var_alist
);
1073 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1074 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
1077 /* Set BUFFER and FRAME for binding now loaded. */
1078 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
,
1080 XSETFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
,
1083 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1086 /* If storing void (making the symbol void), forward only through
1087 buffer-local indicator, not through Lisp_Objfwd, etc. */
1089 store_symval_forwarding (symbol
, Qnil
, newval
);
1091 store_symval_forwarding (symbol
, valcontents
, newval
);
1096 /* Access or set a buffer-local symbol's default value. */
1098 /* Return the default value of SYMBOL, but don't check for voidness.
1099 Return Qunbound if it is void. */
1102 default_value (symbol
)
1105 register Lisp_Object valcontents
;
1107 CHECK_SYMBOL (symbol
, 0);
1108 valcontents
= XSYMBOL (symbol
)->value
;
1110 /* For a built-in buffer-local variable, get the default value
1111 rather than letting do_symval_forwarding get the current value. */
1112 if (BUFFER_OBJFWDP (valcontents
))
1114 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1116 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1117 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1120 /* Handle user-created local variables. */
1121 if (BUFFER_LOCAL_VALUEP (valcontents
)
1122 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1124 /* If var is set up for a buffer that lacks a local value for it,
1125 the current value is nominally the default value.
1126 But the current value slot may be more up to date, since
1127 ordinary setq stores just that slot. So use that. */
1128 Lisp_Object current_alist_element
, alist_element_car
;
1129 current_alist_element
1130 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1131 alist_element_car
= XCONS (current_alist_element
)->car
;
1132 if (EQ (alist_element_car
, current_alist_element
))
1133 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1135 return XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1137 /* For other variables, get the current value. */
1138 return do_symval_forwarding (valcontents
);
1141 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1142 "Return t if SYMBOL has a non-void default value.\n\
1143 This is the value that is seen in buffers that do not have their own values\n\
1144 for this variable.")
1148 register Lisp_Object value
;
1150 value
= default_value (symbol
);
1151 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1154 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1155 "Return SYMBOL's default value.\n\
1156 This is the value that is seen in buffers that do not have their own values\n\
1157 for this variable. The default value is meaningful for variables with\n\
1158 local bindings in certain buffers.")
1162 register Lisp_Object value
;
1164 value
= default_value (symbol
);
1165 if (EQ (value
, Qunbound
))
1166 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1170 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1171 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1172 The default value is seen in buffers that do not have their own values\n\
1173 for this variable.")
1175 Lisp_Object symbol
, value
;
1177 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1179 CHECK_SYMBOL (symbol
, 0);
1180 valcontents
= XSYMBOL (symbol
)->value
;
1182 /* Handle variables like case-fold-search that have special slots
1183 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1185 if (BUFFER_OBJFWDP (valcontents
))
1187 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1188 register struct buffer
*b
;
1189 register int mask
= XINT (*((Lisp_Object
*)
1190 (idx
+ (char *)&buffer_local_flags
)));
1192 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1194 /* If this variable is not always local in all buffers,
1195 set it in the buffers that don't nominally have a local value. */
1198 for (b
= all_buffers
; b
; b
= b
->next
)
1199 if (!(b
->local_var_flags
& mask
))
1200 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1205 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1206 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1207 return Fset (symbol
, value
);
1209 /* Store new value into the DEFAULT-VALUE slot */
1210 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
= value
;
1212 /* If that slot is current, we must set the REALVALUE slot too */
1213 current_alist_element
1214 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1215 alist_element_buffer
= Fcar (current_alist_element
);
1216 if (EQ (alist_element_buffer
, current_alist_element
))
1217 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1223 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1224 "Set the default value of variable VAR to VALUE.\n\
1225 VAR, the variable name, is literal (not evaluated);\n\
1226 VALUE is an expression and it is evaluated.\n\
1227 The default value of a variable is seen in buffers\n\
1228 that do not have their own values for the variable.\n\
1230 More generally, you can use multiple variables and values, as in\n\
1231 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1232 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1233 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1238 register Lisp_Object args_left
;
1239 register Lisp_Object val
, symbol
;
1240 struct gcpro gcpro1
;
1250 val
= Feval (Fcar (Fcdr (args_left
)));
1251 symbol
= Fcar (args_left
);
1252 Fset_default (symbol
, val
);
1253 args_left
= Fcdr (Fcdr (args_left
));
1255 while (!NILP (args_left
));
1261 /* Lisp functions for creating and removing buffer-local variables. */
1263 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1264 1, 1, "vMake Variable Buffer Local: ",
1265 "Make VARIABLE have a separate value for each buffer.\n\
1266 At any time, the value for the current buffer is in effect.\n\
1267 There is also a default value which is seen in any buffer which has not yet\n\
1268 set its own value.\n\
1269 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1270 for the current buffer if it was previously using the default value.\n\
1271 The function `default-value' gets the default value and `set-default' sets it.")
1273 register Lisp_Object variable
;
1275 register Lisp_Object tem
, valcontents
, newval
;
1277 CHECK_SYMBOL (variable
, 0);
1279 valcontents
= XSYMBOL (variable
)->value
;
1280 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1281 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1283 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1285 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1287 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1290 if (EQ (valcontents
, Qunbound
))
1291 XSYMBOL (variable
)->value
= Qnil
;
1292 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1293 XCONS (tem
)->car
= tem
;
1294 newval
= allocate_misc ();
1295 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1296 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1297 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1298 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1299 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 1;
1300 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1301 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1302 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1303 XSYMBOL (variable
)->value
= newval
;
1307 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1308 1, 1, "vMake Local Variable: ",
1309 "Make VARIABLE have a separate value in the current buffer.\n\
1310 Other buffers will continue to share a common default value.\n\
1311 \(The buffer-local value of VARIABLE starts out as the same value\n\
1312 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1313 See also `make-variable-buffer-local'.\n\n\
1314 If the variable is already arranged to become local when set,\n\
1315 this function causes a local value to exist for this buffer,\n\
1316 just as setting the variable would do.\n\
1318 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1319 Use `make-local-hook' instead.")
1321 register Lisp_Object variable
;
1323 register Lisp_Object tem
, valcontents
;
1325 CHECK_SYMBOL (variable
, 0);
1327 valcontents
= XSYMBOL (variable
)->value
;
1328 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1329 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1331 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1333 tem
= Fboundp (variable
);
1335 /* Make sure the symbol has a local value in this particular buffer,
1336 by setting it to the same value it already has. */
1337 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1340 /* Make sure symbol is set up to hold per-buffer values */
1341 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1344 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1345 XCONS (tem
)->car
= tem
;
1346 newval
= allocate_misc ();
1347 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1348 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1349 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1350 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1351 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1352 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1353 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1354 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1355 XSYMBOL (variable
)->value
= newval
;
1357 /* Make sure this buffer has its own value of symbol */
1358 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1361 /* Swap out any local binding for some other buffer, and make
1362 sure the current value is permanently recorded, if it's the
1364 find_symbol_value (variable
);
1366 current_buffer
->local_var_alist
1367 = Fcons (Fcons (variable
, XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
),
1368 current_buffer
->local_var_alist
);
1370 /* Make sure symbol does not think it is set up for this buffer;
1371 force it to look once again for this buffer's value */
1373 Lisp_Object
*pvalbuf
;
1375 valcontents
= XSYMBOL (variable
)->value
;
1377 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1378 if (current_buffer
== XBUFFER (*pvalbuf
))
1380 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1384 /* If the symbol forwards into a C variable, then swap in the
1385 variable for this buffer immediately. If C code modifies the
1386 variable before we swap in, then that new value will clobber the
1387 default value the next time we swap. */
1388 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1389 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1390 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1395 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1396 1, 1, "vKill Local Variable: ",
1397 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1398 From now on the default value will apply in this buffer.")
1400 register Lisp_Object variable
;
1402 register Lisp_Object tem
, valcontents
;
1404 CHECK_SYMBOL (variable
, 0);
1406 valcontents
= XSYMBOL (variable
)->value
;
1408 if (BUFFER_OBJFWDP (valcontents
))
1410 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1411 register int mask
= XINT (*((Lisp_Object
*)
1412 (idx
+ (char *)&buffer_local_flags
)));
1416 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1417 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1418 current_buffer
->local_var_flags
&= ~mask
;
1423 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1424 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1427 /* Get rid of this buffer's alist element, if any */
1429 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1431 current_buffer
->local_var_alist
1432 = Fdelq (tem
, current_buffer
->local_var_alist
);
1434 /* If the symbol is set up for the current buffer, recompute its
1435 value. We have to do it now, or else forwarded objects won't
1438 Lisp_Object
*pvalbuf
;
1439 valcontents
= XSYMBOL (variable
)->value
;
1440 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1441 if (current_buffer
== XBUFFER (*pvalbuf
))
1444 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1445 find_symbol_value (variable
);
1452 /* Lisp functions for creating and removing buffer-local variables. */
1454 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1455 1, 1, "vMake Variable Frame Local: ",
1456 "Enable VARIABLE to have frame-local bindings.\n\
1457 When a frame-local binding exists in the current frame,\n\
1458 it is in effect whenever the current buffer has no buffer-local binding.\n\
1459 A frame-local binding is actual a frame parameter value;\n\
1460 thus, any given frame has a local binding for VARIABLE\n\
1461 if it has a value for the frame parameter named VARIABLE.\n\
1462 See `modify-frame-parameters'.")
1464 register Lisp_Object variable
;
1466 register Lisp_Object tem
, valcontents
, newval
;
1468 CHECK_SYMBOL (variable
, 0);
1470 valcontents
= XSYMBOL (variable
)->value
;
1471 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1472 || BUFFER_OBJFWDP (valcontents
))
1473 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1475 if (BUFFER_LOCAL_VALUEP (valcontents
)
1476 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1479 if (EQ (valcontents
, Qunbound
))
1480 XSYMBOL (variable
)->value
= Qnil
;
1481 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1482 XCONS (tem
)->car
= tem
;
1483 newval
= allocate_misc ();
1484 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1485 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1486 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1487 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1488 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1489 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1490 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1491 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1492 XSYMBOL (variable
)->value
= newval
;
1496 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1498 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1499 BUFFER defaults to the current buffer.")
1501 register Lisp_Object variable
, buffer
;
1503 Lisp_Object valcontents
;
1504 register struct buffer
*buf
;
1507 buf
= current_buffer
;
1510 CHECK_BUFFER (buffer
, 0);
1511 buf
= XBUFFER (buffer
);
1514 CHECK_SYMBOL (variable
, 0);
1516 valcontents
= XSYMBOL (variable
)->value
;
1517 if (BUFFER_LOCAL_VALUEP (valcontents
)
1518 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1520 Lisp_Object tail
, elt
;
1521 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1523 elt
= XCONS (tail
)->car
;
1524 if (EQ (variable
, XCONS (elt
)->car
))
1528 if (BUFFER_OBJFWDP (valcontents
))
1530 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1531 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1532 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1538 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1540 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1541 BUFFER defaults to the current buffer.")
1543 register Lisp_Object variable
, buffer
;
1545 Lisp_Object valcontents
;
1546 register struct buffer
*buf
;
1549 buf
= current_buffer
;
1552 CHECK_BUFFER (buffer
, 0);
1553 buf
= XBUFFER (buffer
);
1556 CHECK_SYMBOL (variable
, 0);
1558 valcontents
= XSYMBOL (variable
)->value
;
1560 /* This means that make-variable-buffer-local was done. */
1561 if (BUFFER_LOCAL_VALUEP (valcontents
))
1563 /* All these slots become local if they are set. */
1564 if (BUFFER_OBJFWDP (valcontents
))
1566 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1568 Lisp_Object tail
, elt
;
1569 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1571 elt
= XCONS (tail
)->car
;
1572 if (EQ (variable
, XCONS (elt
)->car
))
1579 /* Find the function at the end of a chain of symbol function indirections. */
1581 /* If OBJECT is a symbol, find the end of its function chain and
1582 return the value found there. If OBJECT is not a symbol, just
1583 return it. If there is a cycle in the function chain, signal a
1584 cyclic-function-indirection error.
1586 This is like Findirect_function, except that it doesn't signal an
1587 error if the chain ends up unbound. */
1589 indirect_function (object
)
1590 register Lisp_Object object
;
1592 Lisp_Object tortoise
, hare
;
1594 hare
= tortoise
= object
;
1598 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1600 hare
= XSYMBOL (hare
)->function
;
1601 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1603 hare
= XSYMBOL (hare
)->function
;
1605 tortoise
= XSYMBOL (tortoise
)->function
;
1607 if (EQ (hare
, tortoise
))
1608 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1614 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1615 "Return the function at the end of OBJECT's function chain.\n\
1616 If OBJECT is a symbol, follow all function indirections and return the final\n\
1617 function binding.\n\
1618 If OBJECT is not a symbol, just return it.\n\
1619 Signal a void-function error if the final symbol is unbound.\n\
1620 Signal a cyclic-function-indirection error if there is a loop in the\n\
1621 function chain of symbols.")
1623 register Lisp_Object object
;
1627 result
= indirect_function (object
);
1629 if (EQ (result
, Qunbound
))
1630 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1634 /* Extract and set vector and string elements */
1636 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1637 "Return the element of ARRAY at index IDX.\n\
1638 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1639 or a byte-code object. IDX starts at 0.")
1641 register Lisp_Object array
;
1644 register int idxval
;
1646 CHECK_NUMBER (idx
, 1);
1647 idxval
= XINT (idx
);
1648 if (STRINGP (array
))
1653 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1654 args_out_of_range (array
, idx
);
1655 if (! STRING_MULTIBYTE (array
))
1656 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1657 idxval_byte
= string_char_to_byte (array
, idxval
);
1659 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1660 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1661 return make_number (c
);
1663 else if (BOOL_VECTOR_P (array
))
1667 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1668 args_out_of_range (array
, idx
);
1670 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1671 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1673 else if (CHAR_TABLE_P (array
))
1678 args_out_of_range (array
, idx
);
1679 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1681 /* For ASCII and 8-bit European characters, the element is
1682 stored in the top table. */
1683 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1685 val
= XCHAR_TABLE (array
)->defalt
;
1686 while (NILP (val
)) /* Follow parents until we find some value. */
1688 array
= XCHAR_TABLE (array
)->parent
;
1691 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1693 val
= XCHAR_TABLE (array
)->defalt
;
1700 Lisp_Object sub_table
;
1702 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1703 if (code
[0] != CHARSET_COMPOSITION
)
1705 if (code
[1] < 32) code
[1] = -1;
1706 else if (code
[2] < 32) code
[2] = -1;
1708 /* Here, the possible range of CODE[0] (== charset ID) is
1709 128..MAX_CHARSET. Since the top level char table contains
1710 data for multibyte characters after 256th element, we must
1711 increment CODE[0] by 128 to get a correct index. */
1713 code
[3] = -1; /* anchor */
1715 try_parent_char_table
:
1717 for (i
= 0; code
[i
] >= 0; i
++)
1719 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1720 if (SUB_CHAR_TABLE_P (val
))
1725 val
= XCHAR_TABLE (sub_table
)->defalt
;
1728 array
= XCHAR_TABLE (array
)->parent
;
1730 goto try_parent_char_table
;
1735 /* Here, VAL is a sub char table. We try the default value
1737 val
= XCHAR_TABLE (val
)->defalt
;
1740 array
= XCHAR_TABLE (array
)->parent
;
1742 goto try_parent_char_table
;
1750 if (VECTORP (array
))
1751 size
= XVECTOR (array
)->size
;
1752 else if (COMPILEDP (array
))
1753 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1755 wrong_type_argument (Qarrayp
, array
);
1757 if (idxval
< 0 || idxval
>= size
)
1758 args_out_of_range (array
, idx
);
1759 return XVECTOR (array
)->contents
[idxval
];
1763 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1764 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1765 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1767 (array
, idx
, newelt
)
1768 register Lisp_Object array
;
1769 Lisp_Object idx
, newelt
;
1771 register int idxval
;
1773 CHECK_NUMBER (idx
, 1);
1774 idxval
= XINT (idx
);
1775 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1776 && ! CHAR_TABLE_P (array
))
1777 array
= wrong_type_argument (Qarrayp
, array
);
1778 CHECK_IMPURE (array
);
1780 if (VECTORP (array
))
1782 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1783 args_out_of_range (array
, idx
);
1784 XVECTOR (array
)->contents
[idxval
] = newelt
;
1786 else if (BOOL_VECTOR_P (array
))
1790 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1791 args_out_of_range (array
, idx
);
1793 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1795 if (! NILP (newelt
))
1796 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1798 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1799 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1801 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_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1815 if (code
[0] != CHARSET_COMPOSITION
)
1817 if (code
[1] < 32) code
[1] = -1;
1818 else if (code
[2] < 32) code
[2] = -1;
1820 /* See the comment of the corresponding part in Faref. */
1822 code
[3] = -1; /* anchor */
1823 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1825 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1826 if (SUB_CHAR_TABLE_P (val
))
1832 /* VAL is a leaf. Create a sub char table with the
1833 default value VAL or XCHAR_TABLE (array)->defalt
1834 and look into it. */
1836 temp
= make_sub_char_table (NILP (val
)
1837 ? XCHAR_TABLE (array
)->defalt
1839 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1843 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1846 else if (STRING_MULTIBYTE (array
))
1848 Lisp_Object new_len
;
1849 int c
, idxval_byte
, actual_len
;
1850 unsigned char *p
, *str
;
1852 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1853 args_out_of_range (array
, idx
);
1855 idxval_byte
= string_char_to_byte (array
, idxval
);
1856 p
= &XSTRING (array
)->data
[idxval_byte
];
1859 = MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1860 new_len
= Fchar_bytes (newelt
);
1861 if (actual_len
!= XINT (new_len
))
1862 error ("Attempt to change byte length of a string");
1864 CHAR_STRING (XINT (newelt
), p
, str
);
1866 bcopy (str
, p
, actual_len
);
1870 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1871 args_out_of_range (array
, idx
);
1872 CHECK_NUMBER (newelt
, 2);
1873 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1879 /* Arithmetic functions */
1881 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1884 arithcompare (num1
, num2
, comparison
)
1885 Lisp_Object num1
, num2
;
1886 enum comparison comparison
;
1891 #ifdef LISP_FLOAT_TYPE
1892 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1893 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1895 if (FLOATP (num1
) || FLOATP (num2
))
1898 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1899 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1902 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1903 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1904 #endif /* LISP_FLOAT_TYPE */
1909 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1914 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1919 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1924 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1929 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1934 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1943 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1944 "Return t if two args, both numbers or markers, are equal.")
1946 register Lisp_Object num1
, num2
;
1948 return arithcompare (num1
, num2
, equal
);
1951 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1952 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1954 register Lisp_Object num1
, num2
;
1956 return arithcompare (num1
, num2
, less
);
1959 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1960 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1962 register Lisp_Object num1
, num2
;
1964 return arithcompare (num1
, num2
, grtr
);
1967 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1968 "Return t if first arg is less than or equal to second arg.\n\
1969 Both must be numbers or markers.")
1971 register Lisp_Object num1
, num2
;
1973 return arithcompare (num1
, num2
, less_or_equal
);
1976 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1977 "Return t if first arg is greater than or equal to second arg.\n\
1978 Both must be numbers or markers.")
1980 register Lisp_Object num1
, num2
;
1982 return arithcompare (num1
, num2
, grtr_or_equal
);
1985 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1986 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1988 register Lisp_Object num1
, num2
;
1990 return arithcompare (num1
, num2
, notequal
);
1993 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1995 register Lisp_Object number
;
1997 #ifdef LISP_FLOAT_TYPE
1998 CHECK_NUMBER_OR_FLOAT (number
, 0);
2000 if (FLOATP (number
))
2002 if (XFLOAT(number
)->data
== 0.0)
2007 CHECK_NUMBER (number
, 0);
2008 #endif /* LISP_FLOAT_TYPE */
2015 /* Convert between long values and pairs of Lisp integers. */
2021 unsigned int top
= i
>> 16;
2022 unsigned int bot
= i
& 0xFFFF;
2024 return make_number (bot
);
2025 if (top
== (unsigned long)-1 >> 16)
2026 return Fcons (make_number (-1), make_number (bot
));
2027 return Fcons (make_number (top
), make_number (bot
));
2034 Lisp_Object top
, bot
;
2037 top
= XCONS (c
)->car
;
2038 bot
= XCONS (c
)->cdr
;
2040 bot
= XCONS (bot
)->car
;
2041 return ((XINT (top
) << 16) | XINT (bot
));
2044 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2045 "Convert NUMBER to a string by printing it in decimal.\n\
2046 Uses a minus sign if negative.\n\
2047 NUMBER may be an integer or a floating point number.")
2051 char buffer
[VALBITS
];
2053 #ifndef LISP_FLOAT_TYPE
2054 CHECK_NUMBER (number
, 0);
2056 CHECK_NUMBER_OR_FLOAT (number
, 0);
2058 if (FLOATP (number
))
2060 char pigbuf
[350]; /* see comments in float_to_string */
2062 float_to_string (pigbuf
, XFLOAT(number
)->data
);
2063 return build_string (pigbuf
);
2065 #endif /* LISP_FLOAT_TYPE */
2067 if (sizeof (int) == sizeof (EMACS_INT
))
2068 sprintf (buffer
, "%d", XINT (number
));
2069 else if (sizeof (long) == sizeof (EMACS_INT
))
2070 sprintf (buffer
, "%ld", XINT (number
));
2073 return build_string (buffer
);
2077 digit_to_number (character
, base
)
2078 int character
, base
;
2082 if (character
>= '0' && character
<= '9')
2083 digit
= character
- '0';
2084 else if (character
>= 'a' && character
<= 'z')
2085 digit
= character
- 'a' + 10;
2086 else if (character
>= 'A' && character
<= 'Z')
2087 digit
= character
- 'A' + 10;
2097 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2098 "Convert STRING to a number by parsing it as a decimal number.\n\
2099 This parses both integers and floating point numbers.\n\
2100 It ignores leading spaces and tabs.\n\
2102 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2103 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2104 Floating point numbers always use base 10.")
2106 register Lisp_Object string
, base
;
2108 register unsigned char *p
;
2109 register int b
, digit
, v
= 0;
2112 CHECK_STRING (string
, 0);
2118 CHECK_NUMBER (base
, 1);
2120 if (b
< 2 || b
> 16)
2121 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2124 p
= XSTRING (string
)->data
;
2126 /* Skip any whitespace at the front of the number. Some versions of
2127 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2128 while (*p
== ' ' || *p
== '\t')
2139 #ifdef LISP_FLOAT_TYPE
2140 if (isfloat_string (p
))
2141 return make_float (negative
* atof (p
));
2142 #endif /* LISP_FLOAT_TYPE */
2146 int digit
= digit_to_number (*p
++, b
);
2152 return make_number (negative
* v
);
2157 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2159 extern Lisp_Object
float_arith_driver ();
2160 extern Lisp_Object
fmod_float ();
2163 arith_driver (code
, nargs
, args
)
2166 register Lisp_Object
*args
;
2168 register Lisp_Object val
;
2169 register int argnum
;
2170 register EMACS_INT accum
;
2171 register EMACS_INT next
;
2173 switch (SWITCH_ENUM_CAST (code
))
2186 for (argnum
= 0; argnum
< nargs
; argnum
++)
2188 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2189 #ifdef LISP_FLOAT_TYPE
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
,
2196 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2197 #endif /* LISP_FLOAT_TYPE */
2198 args
[argnum
] = val
; /* runs into a compiler bug. */
2199 next
= XINT (args
[argnum
]);
2200 switch (SWITCH_ENUM_CAST (code
))
2202 case Aadd
: accum
+= next
; break;
2204 if (!argnum
&& nargs
!= 1)
2208 case Amult
: accum
*= next
; break;
2210 if (!argnum
) accum
= next
;
2214 Fsignal (Qarith_error
, Qnil
);
2218 case Alogand
: accum
&= next
; break;
2219 case Alogior
: accum
|= next
; break;
2220 case Alogxor
: accum
^= next
; break;
2221 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2222 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2226 XSETINT (val
, accum
);
2231 #define isnan(x) ((x) != (x))
2233 #ifdef LISP_FLOAT_TYPE
2236 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2238 register int argnum
;
2241 register Lisp_Object
*args
;
2243 register Lisp_Object val
;
2246 for (; argnum
< nargs
; argnum
++)
2248 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2249 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2253 next
= XFLOAT (val
)->data
;
2257 args
[argnum
] = val
; /* runs into a compiler bug. */
2258 next
= XINT (args
[argnum
]);
2260 switch (SWITCH_ENUM_CAST (code
))
2266 if (!argnum
&& nargs
!= 1)
2278 if (! IEEE_FLOATING_POINT
&& next
== 0)
2279 Fsignal (Qarith_error
, Qnil
);
2286 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2288 if (!argnum
|| isnan (next
) || next
> accum
)
2292 if (!argnum
|| isnan (next
) || next
< accum
)
2298 return make_float (accum
);
2300 #endif /* LISP_FLOAT_TYPE */
2302 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2303 "Return sum of any number of arguments, which are numbers or markers.")
2308 return arith_driver (Aadd
, nargs
, args
);
2311 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2312 "Negate number or subtract numbers or markers.\n\
2313 With one arg, negates it. With more than one arg,\n\
2314 subtracts all but the first from the first.")
2319 return arith_driver (Asub
, nargs
, args
);
2322 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2323 "Returns product of any number of arguments, which are numbers or markers.")
2328 return arith_driver (Amult
, nargs
, args
);
2331 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2332 "Returns first argument divided by all the remaining arguments.\n\
2333 The arguments must be numbers or markers.")
2338 return arith_driver (Adiv
, nargs
, args
);
2341 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2342 "Returns remainder of X divided by Y.\n\
2343 Both must be integers or markers.")
2345 register Lisp_Object x
, y
;
2349 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2350 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2352 if (XFASTINT (y
) == 0)
2353 Fsignal (Qarith_error
, Qnil
);
2355 XSETINT (val
, XINT (x
) % XINT (y
));
2369 /* If the magnitude of the result exceeds that of the divisor, or
2370 the sign of the result does not agree with that of the dividend,
2371 iterate with the reduced value. This does not yield a
2372 particularly accurate result, but at least it will be in the
2373 range promised by fmod. */
2375 r
-= f2
* floor (r
/ f2
);
2376 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2380 #endif /* ! HAVE_FMOD */
2382 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2383 "Returns X modulo Y.\n\
2384 The result falls between zero (inclusive) and Y (exclusive).\n\
2385 Both X and Y must be numbers or markers.")
2387 register Lisp_Object x
, y
;
2392 #ifdef LISP_FLOAT_TYPE
2393 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2394 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2396 if (FLOATP (x
) || FLOATP (y
))
2397 return fmod_float (x
, y
);
2399 #else /* not LISP_FLOAT_TYPE */
2400 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2401 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2402 #endif /* not LISP_FLOAT_TYPE */
2408 Fsignal (Qarith_error
, Qnil
);
2412 /* If the "remainder" comes out with the wrong sign, fix it. */
2413 if (i2
< 0 ? i1
> 0 : i1
< 0)
2420 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2421 "Return largest of all the arguments (which must be numbers or markers).\n\
2422 The value is always a number; markers are converted to numbers.")
2427 return arith_driver (Amax
, nargs
, args
);
2430 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2431 "Return smallest of all the arguments (which must be numbers or markers).\n\
2432 The value is always a number; markers are converted to numbers.")
2437 return arith_driver (Amin
, nargs
, args
);
2440 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2441 "Return bitwise-and of all the arguments.\n\
2442 Arguments may be integers, or markers converted to integers.")
2447 return arith_driver (Alogand
, nargs
, args
);
2450 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2451 "Return bitwise-or of all the arguments.\n\
2452 Arguments may be integers, or markers converted to integers.")
2457 return arith_driver (Alogior
, nargs
, args
);
2460 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2461 "Return bitwise-exclusive-or of all the arguments.\n\
2462 Arguments may be integers, or markers converted to integers.")
2467 return arith_driver (Alogxor
, nargs
, args
);
2470 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2471 "Return VALUE with its bits shifted left by COUNT.\n\
2472 If COUNT is negative, shifting is actually to the right.\n\
2473 In this case, the sign bit is duplicated.")
2475 register Lisp_Object value
, count
;
2477 register Lisp_Object val
;
2479 CHECK_NUMBER (value
, 0);
2480 CHECK_NUMBER (count
, 1);
2482 if (XINT (count
) > 0)
2483 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2485 XSETINT (val
, XINT (value
) >> -XINT (count
));
2489 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2490 "Return VALUE with its bits shifted left by COUNT.\n\
2491 If COUNT is negative, shifting is actually to the right.\n\
2492 In this case, zeros are shifted in on the left.")
2494 register Lisp_Object value
, count
;
2496 register Lisp_Object val
;
2498 CHECK_NUMBER (value
, 0);
2499 CHECK_NUMBER (count
, 1);
2501 if (XINT (count
) > 0)
2502 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2504 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2508 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2509 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2510 Markers are converted to integers.")
2512 register Lisp_Object number
;
2514 #ifdef LISP_FLOAT_TYPE
2515 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2517 if (FLOATP (number
))
2518 return (make_float (1.0 + XFLOAT (number
)->data
));
2520 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2521 #endif /* LISP_FLOAT_TYPE */
2523 XSETINT (number
, XINT (number
) + 1);
2527 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2528 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2529 Markers are converted to integers.")
2531 register Lisp_Object number
;
2533 #ifdef LISP_FLOAT_TYPE
2534 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2536 if (FLOATP (number
))
2537 return (make_float (-1.0 + XFLOAT (number
)->data
));
2539 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2540 #endif /* LISP_FLOAT_TYPE */
2542 XSETINT (number
, XINT (number
) - 1);
2546 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2547 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2549 register Lisp_Object number
;
2551 CHECK_NUMBER (number
, 0);
2552 XSETINT (number
, ~XINT (number
));
2559 Lisp_Object error_tail
, arith_tail
;
2561 Qquote
= intern ("quote");
2562 Qlambda
= intern ("lambda");
2563 Qsubr
= intern ("subr");
2564 Qerror_conditions
= intern ("error-conditions");
2565 Qerror_message
= intern ("error-message");
2566 Qtop_level
= intern ("top-level");
2568 Qerror
= intern ("error");
2569 Qquit
= intern ("quit");
2570 Qwrong_type_argument
= intern ("wrong-type-argument");
2571 Qargs_out_of_range
= intern ("args-out-of-range");
2572 Qvoid_function
= intern ("void-function");
2573 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2574 Qvoid_variable
= intern ("void-variable");
2575 Qsetting_constant
= intern ("setting-constant");
2576 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2578 Qinvalid_function
= intern ("invalid-function");
2579 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2580 Qno_catch
= intern ("no-catch");
2581 Qend_of_file
= intern ("end-of-file");
2582 Qarith_error
= intern ("arith-error");
2583 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2584 Qend_of_buffer
= intern ("end-of-buffer");
2585 Qbuffer_read_only
= intern ("buffer-read-only");
2586 Qmark_inactive
= intern ("mark-inactive");
2588 Qlistp
= intern ("listp");
2589 Qconsp
= intern ("consp");
2590 Qsymbolp
= intern ("symbolp");
2591 Qintegerp
= intern ("integerp");
2592 Qnatnump
= intern ("natnump");
2593 Qwholenump
= intern ("wholenump");
2594 Qstringp
= intern ("stringp");
2595 Qarrayp
= intern ("arrayp");
2596 Qsequencep
= intern ("sequencep");
2597 Qbufferp
= intern ("bufferp");
2598 Qvectorp
= intern ("vectorp");
2599 Qchar_or_string_p
= intern ("char-or-string-p");
2600 Qmarkerp
= intern ("markerp");
2601 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2602 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2603 Qboundp
= intern ("boundp");
2604 Qfboundp
= intern ("fboundp");
2606 #ifdef LISP_FLOAT_TYPE
2607 Qfloatp
= intern ("floatp");
2608 Qnumberp
= intern ("numberp");
2609 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2610 #endif /* LISP_FLOAT_TYPE */
2612 Qchar_table_p
= intern ("char-table-p");
2613 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2615 Qcdr
= intern ("cdr");
2617 /* Handle automatic advice activation */
2618 Qad_advice_info
= intern ("ad-advice-info");
2619 Qad_activate
= intern ("ad-activate");
2621 error_tail
= Fcons (Qerror
, Qnil
);
2623 /* ERROR is used as a signaler for random errors for which nothing else is right */
2625 Fput (Qerror
, Qerror_conditions
,
2627 Fput (Qerror
, Qerror_message
,
2628 build_string ("error"));
2630 Fput (Qquit
, Qerror_conditions
,
2631 Fcons (Qquit
, Qnil
));
2632 Fput (Qquit
, Qerror_message
,
2633 build_string ("Quit"));
2635 Fput (Qwrong_type_argument
, Qerror_conditions
,
2636 Fcons (Qwrong_type_argument
, error_tail
));
2637 Fput (Qwrong_type_argument
, Qerror_message
,
2638 build_string ("Wrong type argument"));
2640 Fput (Qargs_out_of_range
, Qerror_conditions
,
2641 Fcons (Qargs_out_of_range
, error_tail
));
2642 Fput (Qargs_out_of_range
, Qerror_message
,
2643 build_string ("Args out of range"));
2645 Fput (Qvoid_function
, Qerror_conditions
,
2646 Fcons (Qvoid_function
, error_tail
));
2647 Fput (Qvoid_function
, Qerror_message
,
2648 build_string ("Symbol's function definition is void"));
2650 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2651 Fcons (Qcyclic_function_indirection
, error_tail
));
2652 Fput (Qcyclic_function_indirection
, Qerror_message
,
2653 build_string ("Symbol's chain of function indirections contains a loop"));
2655 Fput (Qvoid_variable
, Qerror_conditions
,
2656 Fcons (Qvoid_variable
, error_tail
));
2657 Fput (Qvoid_variable
, Qerror_message
,
2658 build_string ("Symbol's value as variable is void"));
2660 Fput (Qsetting_constant
, Qerror_conditions
,
2661 Fcons (Qsetting_constant
, error_tail
));
2662 Fput (Qsetting_constant
, Qerror_message
,
2663 build_string ("Attempt to set a constant symbol"));
2665 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2666 Fcons (Qinvalid_read_syntax
, error_tail
));
2667 Fput (Qinvalid_read_syntax
, Qerror_message
,
2668 build_string ("Invalid read syntax"));
2670 Fput (Qinvalid_function
, Qerror_conditions
,
2671 Fcons (Qinvalid_function
, error_tail
));
2672 Fput (Qinvalid_function
, Qerror_message
,
2673 build_string ("Invalid function"));
2675 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2676 Fcons (Qwrong_number_of_arguments
, error_tail
));
2677 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2678 build_string ("Wrong number of arguments"));
2680 Fput (Qno_catch
, Qerror_conditions
,
2681 Fcons (Qno_catch
, error_tail
));
2682 Fput (Qno_catch
, Qerror_message
,
2683 build_string ("No catch for tag"));
2685 Fput (Qend_of_file
, Qerror_conditions
,
2686 Fcons (Qend_of_file
, error_tail
));
2687 Fput (Qend_of_file
, Qerror_message
,
2688 build_string ("End of file during parsing"));
2690 arith_tail
= Fcons (Qarith_error
, error_tail
);
2691 Fput (Qarith_error
, Qerror_conditions
,
2693 Fput (Qarith_error
, Qerror_message
,
2694 build_string ("Arithmetic error"));
2696 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2697 Fcons (Qbeginning_of_buffer
, error_tail
));
2698 Fput (Qbeginning_of_buffer
, Qerror_message
,
2699 build_string ("Beginning of buffer"));
2701 Fput (Qend_of_buffer
, Qerror_conditions
,
2702 Fcons (Qend_of_buffer
, error_tail
));
2703 Fput (Qend_of_buffer
, Qerror_message
,
2704 build_string ("End of buffer"));
2706 Fput (Qbuffer_read_only
, Qerror_conditions
,
2707 Fcons (Qbuffer_read_only
, error_tail
));
2708 Fput (Qbuffer_read_only
, Qerror_message
,
2709 build_string ("Buffer is read-only"));
2711 #ifdef LISP_FLOAT_TYPE
2712 Qrange_error
= intern ("range-error");
2713 Qdomain_error
= intern ("domain-error");
2714 Qsingularity_error
= intern ("singularity-error");
2715 Qoverflow_error
= intern ("overflow-error");
2716 Qunderflow_error
= intern ("underflow-error");
2718 Fput (Qdomain_error
, Qerror_conditions
,
2719 Fcons (Qdomain_error
, arith_tail
));
2720 Fput (Qdomain_error
, Qerror_message
,
2721 build_string ("Arithmetic domain error"));
2723 Fput (Qrange_error
, Qerror_conditions
,
2724 Fcons (Qrange_error
, arith_tail
));
2725 Fput (Qrange_error
, Qerror_message
,
2726 build_string ("Arithmetic range error"));
2728 Fput (Qsingularity_error
, Qerror_conditions
,
2729 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2730 Fput (Qsingularity_error
, Qerror_message
,
2731 build_string ("Arithmetic singularity error"));
2733 Fput (Qoverflow_error
, Qerror_conditions
,
2734 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2735 Fput (Qoverflow_error
, Qerror_message
,
2736 build_string ("Arithmetic overflow error"));
2738 Fput (Qunderflow_error
, Qerror_conditions
,
2739 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2740 Fput (Qunderflow_error
, Qerror_message
,
2741 build_string ("Arithmetic underflow error"));
2743 staticpro (&Qrange_error
);
2744 staticpro (&Qdomain_error
);
2745 staticpro (&Qsingularity_error
);
2746 staticpro (&Qoverflow_error
);
2747 staticpro (&Qunderflow_error
);
2748 #endif /* LISP_FLOAT_TYPE */
2752 staticpro (&Qquote
);
2753 staticpro (&Qlambda
);
2755 staticpro (&Qunbound
);
2756 staticpro (&Qerror_conditions
);
2757 staticpro (&Qerror_message
);
2758 staticpro (&Qtop_level
);
2760 staticpro (&Qerror
);
2762 staticpro (&Qwrong_type_argument
);
2763 staticpro (&Qargs_out_of_range
);
2764 staticpro (&Qvoid_function
);
2765 staticpro (&Qcyclic_function_indirection
);
2766 staticpro (&Qvoid_variable
);
2767 staticpro (&Qsetting_constant
);
2768 staticpro (&Qinvalid_read_syntax
);
2769 staticpro (&Qwrong_number_of_arguments
);
2770 staticpro (&Qinvalid_function
);
2771 staticpro (&Qno_catch
);
2772 staticpro (&Qend_of_file
);
2773 staticpro (&Qarith_error
);
2774 staticpro (&Qbeginning_of_buffer
);
2775 staticpro (&Qend_of_buffer
);
2776 staticpro (&Qbuffer_read_only
);
2777 staticpro (&Qmark_inactive
);
2779 staticpro (&Qlistp
);
2780 staticpro (&Qconsp
);
2781 staticpro (&Qsymbolp
);
2782 staticpro (&Qintegerp
);
2783 staticpro (&Qnatnump
);
2784 staticpro (&Qwholenump
);
2785 staticpro (&Qstringp
);
2786 staticpro (&Qarrayp
);
2787 staticpro (&Qsequencep
);
2788 staticpro (&Qbufferp
);
2789 staticpro (&Qvectorp
);
2790 staticpro (&Qchar_or_string_p
);
2791 staticpro (&Qmarkerp
);
2792 staticpro (&Qbuffer_or_string_p
);
2793 staticpro (&Qinteger_or_marker_p
);
2794 #ifdef LISP_FLOAT_TYPE
2795 staticpro (&Qfloatp
);
2796 staticpro (&Qnumberp
);
2797 staticpro (&Qnumber_or_marker_p
);
2798 #endif /* LISP_FLOAT_TYPE */
2799 staticpro (&Qchar_table_p
);
2800 staticpro (&Qvector_or_char_table_p
);
2802 staticpro (&Qboundp
);
2803 staticpro (&Qfboundp
);
2805 staticpro (&Qad_advice_info
);
2806 staticpro (&Qad_activate
);
2808 /* Types that type-of returns. */
2809 Qinteger
= intern ("integer");
2810 Qsymbol
= intern ("symbol");
2811 Qstring
= intern ("string");
2812 Qcons
= intern ("cons");
2813 Qmarker
= intern ("marker");
2814 Qoverlay
= intern ("overlay");
2815 Qfloat
= intern ("float");
2816 Qwindow_configuration
= intern ("window-configuration");
2817 Qprocess
= intern ("process");
2818 Qwindow
= intern ("window");
2819 /* Qsubr = intern ("subr"); */
2820 Qcompiled_function
= intern ("compiled-function");
2821 Qbuffer
= intern ("buffer");
2822 Qframe
= intern ("frame");
2823 Qvector
= intern ("vector");
2824 Qchar_table
= intern ("char-table");
2825 Qbool_vector
= intern ("bool-vector");
2827 staticpro (&Qinteger
);
2828 staticpro (&Qsymbol
);
2829 staticpro (&Qstring
);
2831 staticpro (&Qmarker
);
2832 staticpro (&Qoverlay
);
2833 staticpro (&Qfloat
);
2834 staticpro (&Qwindow_configuration
);
2835 staticpro (&Qprocess
);
2836 staticpro (&Qwindow
);
2837 /* staticpro (&Qsubr); */
2838 staticpro (&Qcompiled_function
);
2839 staticpro (&Qbuffer
);
2840 staticpro (&Qframe
);
2841 staticpro (&Qvector
);
2842 staticpro (&Qchar_table
);
2843 staticpro (&Qbool_vector
);
2845 DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag
,
2846 "Non-nil means it is an error to set a keyword symbol.\n\
2847 A keyword symbol is a symbol whose name starts with a colon (`:').");
2848 keyword_symbols_constant_flag
= 1;
2852 defsubr (&Stype_of
);
2857 defsubr (&Sintegerp
);
2858 defsubr (&Sinteger_or_marker_p
);
2859 defsubr (&Snumberp
);
2860 defsubr (&Snumber_or_marker_p
);
2861 #ifdef LISP_FLOAT_TYPE
2863 #endif /* LISP_FLOAT_TYPE */
2864 defsubr (&Snatnump
);
2865 defsubr (&Ssymbolp
);
2866 defsubr (&Sstringp
);
2867 defsubr (&Smultibyte_string_p
);
2868 defsubr (&Svectorp
);
2869 defsubr (&Schar_table_p
);
2870 defsubr (&Svector_or_char_table_p
);
2871 defsubr (&Sbool_vector_p
);
2873 defsubr (&Ssequencep
);
2874 defsubr (&Sbufferp
);
2875 defsubr (&Smarkerp
);
2877 defsubr (&Sbyte_code_function_p
);
2878 defsubr (&Schar_or_string_p
);
2881 defsubr (&Scar_safe
);
2882 defsubr (&Scdr_safe
);
2885 defsubr (&Ssymbol_function
);
2886 defsubr (&Sindirect_function
);
2887 defsubr (&Ssymbol_plist
);
2888 defsubr (&Ssymbol_name
);
2889 defsubr (&Smakunbound
);
2890 defsubr (&Sfmakunbound
);
2892 defsubr (&Sfboundp
);
2894 defsubr (&Sdefalias
);
2895 defsubr (&Ssetplist
);
2896 defsubr (&Ssymbol_value
);
2898 defsubr (&Sdefault_boundp
);
2899 defsubr (&Sdefault_value
);
2900 defsubr (&Sset_default
);
2901 defsubr (&Ssetq_default
);
2902 defsubr (&Smake_variable_buffer_local
);
2903 defsubr (&Smake_local_variable
);
2904 defsubr (&Skill_local_variable
);
2905 defsubr (&Smake_variable_frame_local
);
2906 defsubr (&Slocal_variable_p
);
2907 defsubr (&Slocal_variable_if_set_p
);
2910 defsubr (&Snumber_to_string
);
2911 defsubr (&Sstring_to_number
);
2912 defsubr (&Seqlsign
);
2936 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2943 #if defined(USG) && !defined(POSIX_SIGNALS)
2944 /* USG systems forget handlers when they are used;
2945 must reestablish each time */
2946 signal (signo
, arith_error
);
2949 /* VMS systems are like USG. */
2950 signal (signo
, arith_error
);
2954 #else /* not BSD4_1 */
2955 sigsetmask (SIGEMPTYMASK
);
2956 #endif /* not BSD4_1 */
2958 Fsignal (Qarith_error
, Qnil
);
2964 /* Don't do this if just dumping out.
2965 We don't want to call `signal' in this case
2966 so that we don't have trouble with dumping
2967 signal-delivering routines in an inconsistent state. */
2971 #endif /* CANNOT_DUMP */
2972 signal (SIGFPE
, arith_error
);
2975 signal (SIGEMT
, arith_error
);