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 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
72 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
73 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
74 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
75 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
76 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
77 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
78 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
79 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
80 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
81 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
82 Lisp_Object Qbuffer_or_string_p
;
83 Lisp_Object Qboundp
, Qfboundp
;
84 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
87 Lisp_Object Qad_advice_info
, Qad_activate
;
89 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
90 Lisp_Object Qoverflow_error
, Qunderflow_error
;
92 #ifdef LISP_FLOAT_TYPE
94 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
97 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
98 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
100 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
101 static Lisp_Object Qchar_table
, Qbool_vector
;
103 static Lisp_Object
swap_in_symval_forwarding ();
105 Lisp_Object
set_internal ();
108 wrong_type_argument (predicate
, value
)
109 register Lisp_Object predicate
, value
;
111 register Lisp_Object tem
;
114 if (!EQ (Vmocklisp_arguments
, Qt
))
116 if (STRINGP (value
) &&
117 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
118 return Fstring_to_number (value
, Qnil
);
119 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
120 return Fnumber_to_string (value
);
123 /* If VALUE is not even a valid Lisp object, abort here
124 where we can get a backtrace showing where it came from. */
125 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
128 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
129 tem
= call1 (predicate
, value
);
137 error ("Attempt to modify read-only object");
141 args_out_of_range (a1
, a2
)
145 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
149 args_out_of_range_3 (a1
, a2
, a3
)
150 Lisp_Object a1
, a2
, a3
;
153 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
156 /* On some machines, XINT needs a temporary location.
157 Here it is, in case it is needed. */
159 int sign_extend_temp
;
161 /* On a few machines, XINT can only be done by calling this. */
164 sign_extend_lisp_int (num
)
167 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
168 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
170 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
173 /* Data type predicates */
175 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
176 "Return t if the two args are the same Lisp object.")
178 Lisp_Object obj1
, obj2
;
185 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
194 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
195 "Return a symbol representing the type of OBJECT.\n\
196 The symbol returned names the object's basic type;\n\
197 for example, (type-of 1) returns `integer'.")
201 switch (XGCTYPE (object
))
216 switch (XMISCTYPE (object
))
218 case Lisp_Misc_Marker
:
220 case Lisp_Misc_Overlay
:
222 case Lisp_Misc_Float
:
227 case Lisp_Vectorlike
:
228 if (GC_WINDOW_CONFIGURATIONP (object
))
229 return Qwindow_configuration
;
230 if (GC_PROCESSP (object
))
232 if (GC_WINDOWP (object
))
234 if (GC_SUBRP (object
))
236 if (GC_COMPILEDP (object
))
237 return Qcompiled_function
;
238 if (GC_BUFFERP (object
))
240 if (GC_CHAR_TABLE_P (object
))
242 if (GC_BOOL_VECTOR_P (object
))
244 if (GC_FRAMEP (object
))
248 #ifdef LISP_FLOAT_TYPE
258 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
267 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
268 "Return t if OBJECT is not a cons cell. This includes nil.")
277 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
278 "Return t if OBJECT is a list. This includes nil.")
282 if (CONSP (object
) || NILP (object
))
287 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
288 "Return t if OBJECT is not a list. Lists include nil.")
292 if (CONSP (object
) || NILP (object
))
297 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
298 "Return t if OBJECT is a symbol.")
302 if (SYMBOLP (object
))
307 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
308 "Return t if OBJECT is a vector.")
312 if (VECTORP (object
))
317 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
318 "Return t if OBJECT is a string.")
322 if (STRINGP (object
))
327 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
328 1, 1, 0, "Return t if OBJECT is a multibyte string.")
332 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
337 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
338 "Return t if OBJECT is a char-table.")
342 if (CHAR_TABLE_P (object
))
347 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
348 Svector_or_char_table_p
, 1, 1, 0,
349 "Return t if OBJECT is a char-table or vector.")
353 if (VECTORP (object
) || CHAR_TABLE_P (object
))
358 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
362 if (BOOL_VECTOR_P (object
))
367 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
371 if (VECTORP (object
) || STRINGP (object
)
372 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
377 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
378 "Return t if OBJECT is a sequence (list or array).")
380 register Lisp_Object object
;
382 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
383 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
388 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
392 if (BUFFERP (object
))
397 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
401 if (MARKERP (object
))
406 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
415 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
416 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
420 if (COMPILEDP (object
))
425 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
426 "Return t if OBJECT is a character (an integer) or a string.")
428 register Lisp_Object object
;
430 if (INTEGERP (object
) || STRINGP (object
))
435 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
439 if (INTEGERP (object
))
444 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
445 "Return t if OBJECT is an integer or a marker (editor pointer).")
447 register Lisp_Object object
;
449 if (MARKERP (object
) || INTEGERP (object
))
454 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
455 "Return t if OBJECT is a nonnegative integer.")
459 if (NATNUMP (object
))
464 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
465 "Return t if OBJECT is a number (floating point or integer).")
469 if (NUMBERP (object
))
475 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
476 Snumber_or_marker_p
, 1, 1, 0,
477 "Return t if OBJECT is a number or a marker.")
481 if (NUMBERP (object
) || MARKERP (object
))
486 #ifdef LISP_FLOAT_TYPE
487 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
488 "Return t if OBJECT is a floating point number.")
496 #endif /* LISP_FLOAT_TYPE */
498 /* Extract and set components of lists */
500 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
501 "Return the car of LIST. If arg is nil, return nil.\n\
502 Error if arg is not nil and not a cons cell. See also `car-safe'.")
504 register Lisp_Object list
;
509 return XCONS (list
)->car
;
510 else if (EQ (list
, Qnil
))
513 list
= wrong_type_argument (Qlistp
, list
);
517 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
518 "Return the car of OBJECT if it is a cons cell, or else nil.")
523 return XCONS (object
)->car
;
528 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
529 "Return the cdr of LIST. If arg is nil, return nil.\n\
530 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
533 register Lisp_Object list
;
538 return XCONS (list
)->cdr
;
539 else if (EQ (list
, Qnil
))
542 list
= wrong_type_argument (Qlistp
, list
);
546 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
547 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
552 return XCONS (object
)->cdr
;
557 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
558 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
560 register Lisp_Object cell
, newcar
;
563 cell
= wrong_type_argument (Qconsp
, cell
);
566 XCONS (cell
)->car
= newcar
;
570 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
571 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
573 register Lisp_Object cell
, newcdr
;
576 cell
= wrong_type_argument (Qconsp
, cell
);
579 XCONS (cell
)->cdr
= newcdr
;
583 /* Extract and set components of symbols */
585 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
587 register Lisp_Object symbol
;
589 Lisp_Object valcontents
;
590 CHECK_SYMBOL (symbol
, 0);
592 valcontents
= XSYMBOL (symbol
)->value
;
594 if (BUFFER_LOCAL_VALUEP (valcontents
)
595 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
596 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
598 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
601 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
603 register Lisp_Object symbol
;
605 CHECK_SYMBOL (symbol
, 0);
606 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
609 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
611 register Lisp_Object symbol
;
613 CHECK_SYMBOL (symbol
, 0);
614 if (NILP (symbol
) || EQ (symbol
, Qt
))
615 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
616 Fset (symbol
, Qunbound
);
620 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
622 register Lisp_Object symbol
;
624 CHECK_SYMBOL (symbol
, 0);
625 if (NILP (symbol
) || EQ (symbol
, Qt
))
626 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
627 XSYMBOL (symbol
)->function
= Qunbound
;
631 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
632 "Return SYMBOL's function definition. Error if that is void.")
634 register Lisp_Object symbol
;
636 CHECK_SYMBOL (symbol
, 0);
637 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
638 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
639 return XSYMBOL (symbol
)->function
;
642 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
644 register Lisp_Object symbol
;
646 CHECK_SYMBOL (symbol
, 0);
647 return XSYMBOL (symbol
)->plist
;
650 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
652 register Lisp_Object symbol
;
654 register Lisp_Object name
;
656 CHECK_SYMBOL (symbol
, 0);
657 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
661 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
662 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
664 register Lisp_Object symbol
, definition
;
666 CHECK_SYMBOL (symbol
, 0);
667 if (NILP (symbol
) || EQ (symbol
, Qt
))
668 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
669 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
670 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
672 XSYMBOL (symbol
)->function
= definition
;
673 /* Handle automatic advice activation */
674 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
676 call2 (Qad_activate
, symbol
, Qnil
);
677 definition
= XSYMBOL (symbol
)->function
;
682 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
683 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
684 Associates the function with the current load file, if any.")
686 register Lisp_Object symbol
, definition
;
688 CHECK_SYMBOL (symbol
, 0);
689 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
690 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
692 XSYMBOL (symbol
)->function
= definition
;
693 /* Handle automatic advice activation */
694 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
696 call2 (Qad_activate
, symbol
, Qnil
);
697 definition
= XSYMBOL (symbol
)->function
;
699 LOADHIST_ATTACH (symbol
);
703 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
704 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
706 register Lisp_Object symbol
, newplist
;
708 CHECK_SYMBOL (symbol
, 0);
709 XSYMBOL (symbol
)->plist
= newplist
;
714 /* Getting and setting values of symbols */
716 /* Given the raw contents of a symbol value cell,
717 return the Lisp value of the symbol.
718 This does not handle buffer-local variables; use
719 swap_in_symval_forwarding for that. */
722 do_symval_forwarding (valcontents
)
723 register Lisp_Object valcontents
;
725 register Lisp_Object val
;
727 if (MISCP (valcontents
))
728 switch (XMISCTYPE (valcontents
))
730 case Lisp_Misc_Intfwd
:
731 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
734 case Lisp_Misc_Boolfwd
:
735 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
737 case Lisp_Misc_Objfwd
:
738 return *XOBJFWD (valcontents
)->objvar
;
740 case Lisp_Misc_Buffer_Objfwd
:
741 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
742 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
744 case Lisp_Misc_Kboard_Objfwd
:
745 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
746 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
751 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
752 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
753 buffer-independent contents of the value cell: forwarded just one
754 step past the buffer-localness. */
757 store_symval_forwarding (symbol
, valcontents
, newval
)
759 register Lisp_Object valcontents
, newval
;
761 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
764 switch (XMISCTYPE (valcontents
))
766 case Lisp_Misc_Intfwd
:
767 CHECK_NUMBER (newval
, 1);
768 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
769 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
770 error ("Value out of range for variable `%s'",
771 XSYMBOL (symbol
)->name
->data
);
774 case Lisp_Misc_Boolfwd
:
775 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
778 case Lisp_Misc_Objfwd
:
779 *XOBJFWD (valcontents
)->objvar
= newval
;
782 case Lisp_Misc_Buffer_Objfwd
:
784 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
787 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
788 if (XINT (type
) == -1)
789 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
791 if (! NILP (type
) && ! NILP (newval
)
792 && XTYPE (newval
) != XINT (type
))
793 buffer_slot_type_mismatch (offset
);
795 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
799 case Lisp_Misc_Kboard_Objfwd
:
800 (*(Lisp_Object
*)((char *)current_kboard
801 + XKBOARD_OBJFWD (valcontents
)->offset
))
812 valcontents
= XSYMBOL (symbol
)->value
;
813 if (BUFFER_LOCAL_VALUEP (valcontents
)
814 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
815 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
817 XSYMBOL (symbol
)->value
= newval
;
821 /* Set up the buffer-local symbol SYMBOL for validity in the current
822 buffer. VALCONTENTS is the contents of its value cell.
823 Return the value forwarded one step past the buffer-local indicator. */
826 swap_in_symval_forwarding (symbol
, valcontents
)
827 Lisp_Object symbol
, valcontents
;
829 /* valcontents is a pointer to a struct resembling the cons
830 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
832 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
833 local_var_alist, that being the element whose car is this
834 variable. Or it can be a pointer to the
835 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
836 an element in its alist for this variable.
838 If the current buffer is not BUFFER, we store the current
839 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
840 appropriate alist element for the buffer now current and set up
841 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
842 element, and store into BUFFER.
844 Note that REALVALUE can be a forwarding pointer. */
846 register Lisp_Object tem1
;
847 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
849 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
)
850 || selected_frame
!= XFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
852 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
854 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
855 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
856 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
857 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
860 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
861 tem1
= assq_no_quit (symbol
, selected_frame
->param_alist
);
863 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
865 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
868 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
870 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
= tem1
;
871 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
872 XSETFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
, selected_frame
);
873 store_symval_forwarding (symbol
,
874 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
877 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
880 /* Find the value of a symbol, returning Qunbound if it's not bound.
881 This is helpful for code which just wants to get a variable's value
882 if it has one, without signaling an error.
883 Note that it must not be possible to quit
884 within this function. Great care is required for this. */
887 find_symbol_value (symbol
)
890 register Lisp_Object valcontents
, tem1
;
891 register Lisp_Object val
;
892 CHECK_SYMBOL (symbol
, 0);
893 valcontents
= XSYMBOL (symbol
)->value
;
895 if (BUFFER_LOCAL_VALUEP (valcontents
)
896 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
897 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
899 if (MISCP (valcontents
))
901 switch (XMISCTYPE (valcontents
))
903 case Lisp_Misc_Intfwd
:
904 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
907 case Lisp_Misc_Boolfwd
:
908 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
910 case Lisp_Misc_Objfwd
:
911 return *XOBJFWD (valcontents
)->objvar
;
913 case Lisp_Misc_Buffer_Objfwd
:
914 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
915 + (char *)current_buffer
);
917 case Lisp_Misc_Kboard_Objfwd
:
918 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
919 + (char *)current_kboard
);
926 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
927 "Return SYMBOL's value. Error if that is void.")
933 val
= find_symbol_value (symbol
);
934 if (EQ (val
, Qunbound
))
935 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
940 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
941 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
943 register Lisp_Object symbol
, newval
;
945 return set_internal (symbol
, newval
, 0);
948 /* Store the value NEWVAL into SYMBOL.
949 If BINDFLAG is zero, then if this symbol is supposed to become
950 local in every buffer where it is set, then we make it local.
951 If BINDFLAG is nonzero, we don't do that. */
954 set_internal (symbol
, newval
, bindflag
)
955 register Lisp_Object symbol
, newval
;
958 int voide
= EQ (newval
, Qunbound
);
960 register Lisp_Object valcontents
, tem1
, current_alist_element
;
962 CHECK_SYMBOL (symbol
, 0);
963 if (NILP (symbol
) || EQ (symbol
, Qt
))
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
)));
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 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
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
)
1017 selected_frame
!= XFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
)
1018 || (BUFFER_LOCAL_VALUEP (valcontents
)
1019 && EQ (XCONS (current_alist_element
)->car
,
1020 current_alist_element
)))
1022 /* Write out the cached value for the old buffer; copy it
1023 back to its alist element. This works if the current
1024 buffer only sees the default value, too. */
1025 Fsetcdr (current_alist_element
,
1026 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1028 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1029 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1030 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1031 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1035 /* This buffer still sees the default value. */
1037 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1038 or if this is `let' rather than `set',
1039 make CURRENT-ALIST-ELEMENT point to itself,
1040 indicating that we're seeing the default value. */
1041 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1043 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1045 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1046 tem1
= Fassq (symbol
, 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 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
1068 /* Set BUFFER and FRAME for binding now loaded. */
1069 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
,
1071 XSETFRAME (XBUFFER_LOCAL_VALUE (valcontents
)->frame
,
1074 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1077 /* If storing void (making the symbol void), forward only through
1078 buffer-local indicator, not through Lisp_Objfwd, etc. */
1080 store_symval_forwarding (symbol
, Qnil
, newval
);
1082 store_symval_forwarding (symbol
, valcontents
, newval
);
1087 /* Access or set a buffer-local symbol's default value. */
1089 /* Return the default value of SYMBOL, but don't check for voidness.
1090 Return Qunbound if it is void. */
1093 default_value (symbol
)
1096 register Lisp_Object valcontents
;
1098 CHECK_SYMBOL (symbol
, 0);
1099 valcontents
= XSYMBOL (symbol
)->value
;
1101 /* For a built-in buffer-local variable, get the default value
1102 rather than letting do_symval_forwarding get the current value. */
1103 if (BUFFER_OBJFWDP (valcontents
))
1105 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1107 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1108 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1111 /* Handle user-created local variables. */
1112 if (BUFFER_LOCAL_VALUEP (valcontents
)
1113 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1115 /* If var is set up for a buffer that lacks a local value for it,
1116 the current value is nominally the default value.
1117 But the current value slot may be more up to date, since
1118 ordinary setq stores just that slot. So use that. */
1119 Lisp_Object current_alist_element
, alist_element_car
;
1120 current_alist_element
1121 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1122 alist_element_car
= XCONS (current_alist_element
)->car
;
1123 if (EQ (alist_element_car
, current_alist_element
))
1124 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1126 return XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1128 /* For other variables, get the current value. */
1129 return do_symval_forwarding (valcontents
);
1132 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1133 "Return t if SYMBOL has a non-void default value.\n\
1134 This is the value that is seen in buffers that do not have their own values\n\
1135 for this variable.")
1139 register Lisp_Object value
;
1141 value
= default_value (symbol
);
1142 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1145 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1146 "Return SYMBOL's default value.\n\
1147 This is the value that is seen in buffers that do not have their own values\n\
1148 for this variable. The default value is meaningful for variables with\n\
1149 local bindings in certain buffers.")
1153 register Lisp_Object value
;
1155 value
= default_value (symbol
);
1156 if (EQ (value
, Qunbound
))
1157 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1161 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1162 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1163 The default value is seen in buffers that do not have their own values\n\
1164 for this variable.")
1166 Lisp_Object symbol
, value
;
1168 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1170 CHECK_SYMBOL (symbol
, 0);
1171 valcontents
= XSYMBOL (symbol
)->value
;
1173 /* Handle variables like case-fold-search that have special slots
1174 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1176 if (BUFFER_OBJFWDP (valcontents
))
1178 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1179 register struct buffer
*b
;
1180 register int mask
= XINT (*((Lisp_Object
*)
1181 (idx
+ (char *)&buffer_local_flags
)));
1183 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1185 /* If this variable is not always local in all buffers,
1186 set it in the buffers that don't nominally have a local value. */
1189 for (b
= all_buffers
; b
; b
= b
->next
)
1190 if (!(b
->local_var_flags
& mask
))
1191 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1196 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1197 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1198 return Fset (symbol
, value
);
1200 /* Store new value into the DEFAULT-VALUE slot */
1201 XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
= value
;
1203 /* If that slot is current, we must set the REALVALUE slot too */
1204 current_alist_element
1205 = XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1206 alist_element_buffer
= Fcar (current_alist_element
);
1207 if (EQ (alist_element_buffer
, current_alist_element
))
1208 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1214 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1215 "Set the default value of variable VAR to VALUE.\n\
1216 VAR, the variable name, is literal (not evaluated);\n\
1217 VALUE is an expression and it is evaluated.\n\
1218 The default value of a variable is seen in buffers\n\
1219 that do not have their own values for the variable.\n\
1221 More generally, you can use multiple variables and values, as in\n\
1222 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1223 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1224 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1229 register Lisp_Object args_left
;
1230 register Lisp_Object val
, symbol
;
1231 struct gcpro gcpro1
;
1241 val
= Feval (Fcar (Fcdr (args_left
)));
1242 symbol
= Fcar (args_left
);
1243 Fset_default (symbol
, val
);
1244 args_left
= Fcdr (Fcdr (args_left
));
1246 while (!NILP (args_left
));
1252 /* Lisp functions for creating and removing buffer-local variables. */
1254 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1255 1, 1, "vMake Variable Buffer Local: ",
1256 "Make VARIABLE have a separate value for each buffer.\n\
1257 At any time, the value for the current buffer is in effect.\n\
1258 There is also a default value which is seen in any buffer which has not yet\n\
1259 set its own value.\n\
1260 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1261 for the current buffer if it was previously using the default value.\n\
1262 The function `default-value' gets the default value and `set-default' sets it.")
1264 register Lisp_Object variable
;
1266 register Lisp_Object tem
, valcontents
, newval
;
1268 CHECK_SYMBOL (variable
, 0);
1270 valcontents
= XSYMBOL (variable
)->value
;
1271 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1272 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1274 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1276 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1278 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1281 if (EQ (valcontents
, Qunbound
))
1282 XSYMBOL (variable
)->value
= Qnil
;
1283 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1284 XCONS (tem
)->car
= tem
;
1285 newval
= allocate_misc ();
1286 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1287 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1288 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1289 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1290 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 1;
1291 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1292 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1293 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1294 XSYMBOL (variable
)->value
= newval
;
1298 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1299 1, 1, "vMake Local Variable: ",
1300 "Make VARIABLE have a separate value in the current buffer.\n\
1301 Other buffers will continue to share a common default value.\n\
1302 \(The buffer-local value of VARIABLE starts out as the same value\n\
1303 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1304 See also `make-variable-buffer-local'.\n\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 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1310 Use `make-local-hook' instead.")
1312 register Lisp_Object variable
;
1314 register Lisp_Object tem
, valcontents
;
1316 CHECK_SYMBOL (variable
, 0);
1318 valcontents
= XSYMBOL (variable
)->value
;
1319 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1320 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1322 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1324 tem
= Fboundp (variable
);
1326 /* Make sure the symbol has a local value in this particular buffer,
1327 by setting it to the same value it already has. */
1328 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1331 /* Make sure symbol is set up to hold per-buffer values */
1332 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1335 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1336 XCONS (tem
)->car
= tem
;
1337 newval
= allocate_misc ();
1338 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1339 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1340 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1341 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1342 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1343 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1344 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1345 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1346 XSYMBOL (variable
)->value
= newval
;
1348 /* Make sure this buffer has its own value of symbol */
1349 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1352 /* Swap out any local binding for some other buffer, and make
1353 sure the current value is permanently recorded, if it's the
1355 find_symbol_value (variable
);
1357 current_buffer
->local_var_alist
1358 = Fcons (Fcons (variable
, XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
),
1359 current_buffer
->local_var_alist
);
1361 /* Make sure symbol does not think it is set up for this buffer;
1362 force it to look once again for this buffer's value */
1364 Lisp_Object
*pvalbuf
;
1366 valcontents
= XSYMBOL (variable
)->value
;
1368 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1369 if (current_buffer
== XBUFFER (*pvalbuf
))
1371 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1375 /* If the symbol forwards into a C variable, then swap in the
1376 variable for this buffer immediately. If C code modifies the
1377 variable before we swap in, then that new value will clobber the
1378 default value the next time we swap. */
1379 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1380 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1381 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1386 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1387 1, 1, "vKill Local Variable: ",
1388 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1389 From now on the default value will apply in this buffer.")
1391 register Lisp_Object variable
;
1393 register Lisp_Object tem
, valcontents
;
1395 CHECK_SYMBOL (variable
, 0);
1397 valcontents
= XSYMBOL (variable
)->value
;
1399 if (BUFFER_OBJFWDP (valcontents
))
1401 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1402 register int mask
= XINT (*((Lisp_Object
*)
1403 (idx
+ (char *)&buffer_local_flags
)));
1407 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1408 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1409 current_buffer
->local_var_flags
&= ~mask
;
1414 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1415 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1418 /* Get rid of this buffer's alist element, if any */
1420 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1422 current_buffer
->local_var_alist
1423 = Fdelq (tem
, current_buffer
->local_var_alist
);
1425 /* If the symbol is set up for the current buffer, recompute its
1426 value. We have to do it now, or else forwarded objects won't
1429 Lisp_Object
*pvalbuf
;
1430 valcontents
= XSYMBOL (variable
)->value
;
1431 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1432 if (current_buffer
== XBUFFER (*pvalbuf
))
1435 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1436 find_symbol_value (variable
);
1443 /* Lisp functions for creating and removing buffer-local variables. */
1445 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1446 1, 1, "vMake Variable Frame Local: ",
1447 "Enable VARIABLE to have frame-local bindings.\n\
1448 When a frame-local binding exists in the current frame,\n\
1449 it is in effect whenever the current buffer has no buffer-local binding.\n\
1450 A frame-local binding is actual a frame parameter value;\n\
1451 thus, any given frame has a local binding for VARIABLE\n\
1452 if it has a value for the frame parameter named VARIABLE.\n\
1453 See `modify-frame-parameters'.")
1455 register Lisp_Object variable
;
1457 register Lisp_Object tem
, valcontents
, newval
;
1459 CHECK_SYMBOL (variable
, 0);
1461 valcontents
= XSYMBOL (variable
)->value
;
1462 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1463 || BUFFER_OBJFWDP (valcontents
))
1464 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1466 if (BUFFER_LOCAL_VALUEP (valcontents
)
1467 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1470 if (EQ (valcontents
, Qunbound
))
1471 XSYMBOL (variable
)->value
= Qnil
;
1472 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1473 XCONS (tem
)->car
= tem
;
1474 newval
= allocate_misc ();
1475 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1476 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1477 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1478 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1479 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1480 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1481 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1482 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1483 XSYMBOL (variable
)->value
= newval
;
1487 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1489 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1490 BUFFER defaults to the current buffer.")
1492 register Lisp_Object variable
, buffer
;
1494 Lisp_Object valcontents
;
1495 register struct buffer
*buf
;
1498 buf
= current_buffer
;
1501 CHECK_BUFFER (buffer
, 0);
1502 buf
= XBUFFER (buffer
);
1505 CHECK_SYMBOL (variable
, 0);
1507 valcontents
= XSYMBOL (variable
)->value
;
1508 if (BUFFER_LOCAL_VALUEP (valcontents
)
1509 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1511 Lisp_Object tail
, elt
;
1512 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1514 elt
= XCONS (tail
)->car
;
1515 if (EQ (variable
, XCONS (elt
)->car
))
1519 if (BUFFER_OBJFWDP (valcontents
))
1521 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1522 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1523 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1529 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1531 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1532 BUFFER defaults to the current buffer.")
1534 register Lisp_Object variable
, buffer
;
1536 Lisp_Object valcontents
;
1537 register struct buffer
*buf
;
1540 buf
= current_buffer
;
1543 CHECK_BUFFER (buffer
, 0);
1544 buf
= XBUFFER (buffer
);
1547 CHECK_SYMBOL (variable
, 0);
1549 valcontents
= XSYMBOL (variable
)->value
;
1551 /* This means that make-variable-buffer-local was done. */
1552 if (BUFFER_LOCAL_VALUEP (valcontents
))
1554 /* All these slots become local if they are set. */
1555 if (BUFFER_OBJFWDP (valcontents
))
1557 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1559 Lisp_Object tail
, elt
;
1560 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1562 elt
= XCONS (tail
)->car
;
1563 if (EQ (variable
, XCONS (elt
)->car
))
1570 /* Find the function at the end of a chain of symbol function indirections. */
1572 /* If OBJECT is a symbol, find the end of its function chain and
1573 return the value found there. If OBJECT is not a symbol, just
1574 return it. If there is a cycle in the function chain, signal a
1575 cyclic-function-indirection error.
1577 This is like Findirect_function, except that it doesn't signal an
1578 error if the chain ends up unbound. */
1580 indirect_function (object
)
1581 register Lisp_Object object
;
1583 Lisp_Object tortoise
, hare
;
1585 hare
= tortoise
= object
;
1589 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1591 hare
= XSYMBOL (hare
)->function
;
1592 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1594 hare
= XSYMBOL (hare
)->function
;
1596 tortoise
= XSYMBOL (tortoise
)->function
;
1598 if (EQ (hare
, tortoise
))
1599 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1605 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1606 "Return the function at the end of OBJECT's function chain.\n\
1607 If OBJECT is a symbol, follow all function indirections and return the final\n\
1608 function binding.\n\
1609 If OBJECT is not a symbol, just return it.\n\
1610 Signal a void-function error if the final symbol is unbound.\n\
1611 Signal a cyclic-function-indirection error if there is a loop in the\n\
1612 function chain of symbols.")
1614 register Lisp_Object object
;
1618 result
= indirect_function (object
);
1620 if (EQ (result
, Qunbound
))
1621 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1625 /* Extract and set vector and string elements */
1627 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1628 "Return the element of ARRAY at index IDX.\n\
1629 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1630 or a byte-code object. IDX starts at 0.")
1632 register Lisp_Object array
;
1635 register int idxval
;
1637 CHECK_NUMBER (idx
, 1);
1638 idxval
= XINT (idx
);
1639 if (STRINGP (array
))
1644 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1645 args_out_of_range (array
, idx
);
1646 if (! STRING_MULTIBYTE (array
))
1647 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1648 idxval_byte
= string_char_to_byte (array
, idxval
);
1650 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1651 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1652 return make_number (c
);
1654 else if (BOOL_VECTOR_P (array
))
1658 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1659 args_out_of_range (array
, idx
);
1661 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1662 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1664 else if (CHAR_TABLE_P (array
))
1669 args_out_of_range (array
, idx
);
1670 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1672 /* For ASCII and 8-bit European characters, the element is
1673 stored in the top table. */
1674 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1676 val
= XCHAR_TABLE (array
)->defalt
;
1677 while (NILP (val
)) /* Follow parents until we find some value. */
1679 array
= XCHAR_TABLE (array
)->parent
;
1682 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1684 val
= XCHAR_TABLE (array
)->defalt
;
1691 Lisp_Object sub_table
;
1693 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1694 if (code
[0] != CHARSET_COMPOSITION
)
1696 if (code
[1] < 32) code
[1] = -1;
1697 else if (code
[2] < 32) code
[2] = -1;
1699 /* Here, the possible range of CODE[0] (== charset ID) is
1700 128..MAX_CHARSET. Since the top level char table contains
1701 data for multibyte characters after 256th element, we must
1702 increment CODE[0] by 128 to get a correct index. */
1704 code
[3] = -1; /* anchor */
1706 try_parent_char_table
:
1708 for (i
= 0; code
[i
] >= 0; i
++)
1710 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1711 if (SUB_CHAR_TABLE_P (val
))
1716 val
= XCHAR_TABLE (sub_table
)->defalt
;
1719 array
= XCHAR_TABLE (array
)->parent
;
1721 goto try_parent_char_table
;
1726 /* Here, VAL is a sub char table. We try the default value
1728 val
= XCHAR_TABLE (val
)->defalt
;
1731 array
= XCHAR_TABLE (array
)->parent
;
1733 goto try_parent_char_table
;
1741 if (VECTORP (array
))
1742 size
= XVECTOR (array
)->size
;
1743 else if (COMPILEDP (array
))
1744 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1746 wrong_type_argument (Qarrayp
, array
);
1748 if (idxval
< 0 || idxval
>= size
)
1749 args_out_of_range (array
, idx
);
1750 return XVECTOR (array
)->contents
[idxval
];
1754 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1755 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1756 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1758 (array
, idx
, newelt
)
1759 register Lisp_Object array
;
1760 Lisp_Object idx
, newelt
;
1762 register int idxval
;
1764 CHECK_NUMBER (idx
, 1);
1765 idxval
= XINT (idx
);
1766 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1767 && ! CHAR_TABLE_P (array
))
1768 array
= wrong_type_argument (Qarrayp
, array
);
1769 CHECK_IMPURE (array
);
1771 if (VECTORP (array
))
1773 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1774 args_out_of_range (array
, idx
);
1775 XVECTOR (array
)->contents
[idxval
] = newelt
;
1777 else if (BOOL_VECTOR_P (array
))
1781 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1782 args_out_of_range (array
, idx
);
1784 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1786 if (! NILP (newelt
))
1787 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1789 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1790 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1792 else if (CHAR_TABLE_P (array
))
1797 args_out_of_range (array
, idx
);
1798 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1799 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1805 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1806 if (code
[0] != CHARSET_COMPOSITION
)
1808 if (code
[1] < 32) code
[1] = -1;
1809 else if (code
[2] < 32) code
[2] = -1;
1811 /* See the comment of the corresponding part in Faref. */
1813 code
[3] = -1; /* anchor */
1814 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1816 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1817 if (SUB_CHAR_TABLE_P (val
))
1823 /* VAL is a leaf. Create a sub char table with the
1824 default value VAL or XCHAR_TABLE (array)->defalt
1825 and look into it. */
1827 temp
= make_sub_char_table (NILP (val
)
1828 ? XCHAR_TABLE (array
)->defalt
1830 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1834 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1837 else if (STRING_MULTIBYTE (array
))
1839 Lisp_Object new_len
;
1840 int c
, idxval_byte
, actual_len
;
1841 unsigned char *p
, *str
;
1843 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1844 args_out_of_range (array
, idx
);
1846 idxval_byte
= string_char_to_byte (array
, idxval
);
1847 p
= &XSTRING (array
)->data
[idxval_byte
];
1850 = MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1851 new_len
= Fchar_bytes (newelt
);
1852 if (actual_len
!= XINT (new_len
))
1853 error ("Attempt to change byte length of a string");
1855 CHAR_STRING (XINT (newelt
), p
, str
);
1857 bcopy (str
, p
, actual_len
);
1861 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1862 args_out_of_range (array
, idx
);
1863 CHECK_NUMBER (newelt
, 2);
1864 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1870 /* Arithmetic functions */
1872 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1875 arithcompare (num1
, num2
, comparison
)
1876 Lisp_Object num1
, num2
;
1877 enum comparison comparison
;
1882 #ifdef LISP_FLOAT_TYPE
1883 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1884 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1886 if (FLOATP (num1
) || FLOATP (num2
))
1889 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1890 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1893 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1894 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1895 #endif /* LISP_FLOAT_TYPE */
1900 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1905 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1910 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1915 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1920 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1925 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1934 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1935 "Return t if two args, both numbers or markers, are equal.")
1937 register Lisp_Object num1
, num2
;
1939 return arithcompare (num1
, num2
, equal
);
1942 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1943 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1945 register Lisp_Object num1
, num2
;
1947 return arithcompare (num1
, num2
, less
);
1950 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1951 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1953 register Lisp_Object num1
, num2
;
1955 return arithcompare (num1
, num2
, grtr
);
1958 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1959 "Return t if first arg is less than or equal to second arg.\n\
1960 Both must be numbers or markers.")
1962 register Lisp_Object num1
, num2
;
1964 return arithcompare (num1
, num2
, less_or_equal
);
1967 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1968 "Return t if first arg is greater 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
, grtr_or_equal
);
1976 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1977 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1979 register Lisp_Object num1
, num2
;
1981 return arithcompare (num1
, num2
, notequal
);
1984 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1986 register Lisp_Object number
;
1988 #ifdef LISP_FLOAT_TYPE
1989 CHECK_NUMBER_OR_FLOAT (number
, 0);
1991 if (FLOATP (number
))
1993 if (XFLOAT(number
)->data
== 0.0)
1998 CHECK_NUMBER (number
, 0);
1999 #endif /* LISP_FLOAT_TYPE */
2006 /* Convert between long values and pairs of Lisp integers. */
2012 unsigned int top
= i
>> 16;
2013 unsigned int bot
= i
& 0xFFFF;
2015 return make_number (bot
);
2016 if (top
== (unsigned long)-1 >> 16)
2017 return Fcons (make_number (-1), make_number (bot
));
2018 return Fcons (make_number (top
), make_number (bot
));
2025 Lisp_Object top
, bot
;
2028 top
= XCONS (c
)->car
;
2029 bot
= XCONS (c
)->cdr
;
2031 bot
= XCONS (bot
)->car
;
2032 return ((XINT (top
) << 16) | XINT (bot
));
2035 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2036 "Convert NUMBER to a string by printing it in decimal.\n\
2037 Uses a minus sign if negative.\n\
2038 NUMBER may be an integer or a floating point number.")
2042 char buffer
[VALBITS
];
2044 #ifndef LISP_FLOAT_TYPE
2045 CHECK_NUMBER (number
, 0);
2047 CHECK_NUMBER_OR_FLOAT (number
, 0);
2049 if (FLOATP (number
))
2051 char pigbuf
[350]; /* see comments in float_to_string */
2053 float_to_string (pigbuf
, XFLOAT(number
)->data
);
2054 return build_string (pigbuf
);
2056 #endif /* LISP_FLOAT_TYPE */
2058 if (sizeof (int) == sizeof (EMACS_INT
))
2059 sprintf (buffer
, "%d", XINT (number
));
2060 else if (sizeof (long) == sizeof (EMACS_INT
))
2061 sprintf (buffer
, "%ld", XINT (number
));
2064 return build_string (buffer
);
2068 digit_to_number (character
, base
)
2069 int character
, base
;
2073 if (character
>= '0' && character
<= '9')
2074 digit
= character
- '0';
2075 else if (character
>= 'a' && character
<= 'z')
2076 digit
= character
- 'a' + 10;
2077 else if (character
>= 'A' && character
<= 'Z')
2078 digit
= character
- 'A' + 10;
2088 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2089 "Convert STRING to a number by parsing it as a decimal number.\n\
2090 This parses both integers and floating point numbers.\n\
2091 It ignores leading spaces and tabs.\n\
2093 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2094 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2095 Floating point numbers always use base 10.")
2097 register Lisp_Object string
, base
;
2099 register unsigned char *p
;
2100 register int b
, digit
, v
= 0;
2103 CHECK_STRING (string
, 0);
2109 CHECK_NUMBER (base
, 1);
2111 if (b
< 2 || b
> 16)
2112 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2115 p
= XSTRING (string
)->data
;
2117 /* Skip any whitespace at the front of the number. Some versions of
2118 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2119 while (*p
== ' ' || *p
== '\t')
2130 #ifdef LISP_FLOAT_TYPE
2131 if (isfloat_string (p
))
2132 return make_float (negative
* atof (p
));
2133 #endif /* LISP_FLOAT_TYPE */
2137 int digit
= digit_to_number (*p
++, b
);
2143 return make_number (negative
* v
);
2148 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2150 extern Lisp_Object
float_arith_driver ();
2151 extern Lisp_Object
fmod_float ();
2154 arith_driver (code
, nargs
, args
)
2157 register Lisp_Object
*args
;
2159 register Lisp_Object val
;
2160 register int argnum
;
2161 register EMACS_INT accum
;
2162 register EMACS_INT next
;
2164 switch (SWITCH_ENUM_CAST (code
))
2177 for (argnum
= 0; argnum
< nargs
; argnum
++)
2179 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2180 #ifdef LISP_FLOAT_TYPE
2181 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2183 if (FLOATP (val
)) /* time to do serious math */
2184 return (float_arith_driver ((double) accum
, argnum
, code
,
2187 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2188 #endif /* LISP_FLOAT_TYPE */
2189 args
[argnum
] = val
; /* runs into a compiler bug. */
2190 next
= XINT (args
[argnum
]);
2191 switch (SWITCH_ENUM_CAST (code
))
2193 case Aadd
: accum
+= next
; break;
2195 if (!argnum
&& nargs
!= 1)
2199 case Amult
: accum
*= next
; break;
2201 if (!argnum
) accum
= next
;
2205 Fsignal (Qarith_error
, Qnil
);
2209 case Alogand
: accum
&= next
; break;
2210 case Alogior
: accum
|= next
; break;
2211 case Alogxor
: accum
^= next
; break;
2212 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2213 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2217 XSETINT (val
, accum
);
2222 #define isnan(x) ((x) != (x))
2224 #ifdef LISP_FLOAT_TYPE
2227 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2229 register int argnum
;
2232 register Lisp_Object
*args
;
2234 register Lisp_Object val
;
2237 for (; argnum
< nargs
; argnum
++)
2239 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2240 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2244 next
= XFLOAT (val
)->data
;
2248 args
[argnum
] = val
; /* runs into a compiler bug. */
2249 next
= XINT (args
[argnum
]);
2251 switch (SWITCH_ENUM_CAST (code
))
2257 if (!argnum
&& nargs
!= 1)
2269 if (! IEEE_FLOATING_POINT
&& next
== 0)
2270 Fsignal (Qarith_error
, Qnil
);
2277 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2279 if (!argnum
|| isnan (next
) || next
> accum
)
2283 if (!argnum
|| isnan (next
) || next
< accum
)
2289 return make_float (accum
);
2291 #endif /* LISP_FLOAT_TYPE */
2293 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2294 "Return sum of any number of arguments, which are numbers or markers.")
2299 return arith_driver (Aadd
, nargs
, args
);
2302 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2303 "Negate number or subtract numbers or markers.\n\
2304 With one arg, negates it. With more than one arg,\n\
2305 subtracts all but the first from the first.")
2310 return arith_driver (Asub
, nargs
, args
);
2313 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2314 "Returns product of any number of arguments, which are numbers or markers.")
2319 return arith_driver (Amult
, nargs
, args
);
2322 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2323 "Returns first argument divided by all the remaining arguments.\n\
2324 The arguments must be numbers or markers.")
2329 return arith_driver (Adiv
, nargs
, args
);
2332 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2333 "Returns remainder of X divided by Y.\n\
2334 Both must be integers or markers.")
2336 register Lisp_Object x
, y
;
2340 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2341 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2343 if (XFASTINT (y
) == 0)
2344 Fsignal (Qarith_error
, Qnil
);
2346 XSETINT (val
, XINT (x
) % XINT (y
));
2360 /* If the magnitude of the result exceeds that of the divisor, or
2361 the sign of the result does not agree with that of the dividend,
2362 iterate with the reduced value. This does not yield a
2363 particularly accurate result, but at least it will be in the
2364 range promised by fmod. */
2366 r
-= f2
* floor (r
/ f2
);
2367 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2371 #endif /* ! HAVE_FMOD */
2373 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2374 "Returns X modulo Y.\n\
2375 The result falls between zero (inclusive) and Y (exclusive).\n\
2376 Both X and Y must be numbers or markers.")
2378 register Lisp_Object x
, y
;
2383 #ifdef LISP_FLOAT_TYPE
2384 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2385 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2387 if (FLOATP (x
) || FLOATP (y
))
2388 return fmod_float (x
, y
);
2390 #else /* not LISP_FLOAT_TYPE */
2391 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2392 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2393 #endif /* not LISP_FLOAT_TYPE */
2399 Fsignal (Qarith_error
, Qnil
);
2403 /* If the "remainder" comes out with the wrong sign, fix it. */
2404 if (i2
< 0 ? i1
> 0 : i1
< 0)
2411 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2412 "Return largest of all the arguments (which must be numbers or markers).\n\
2413 The value is always a number; markers are converted to numbers.")
2418 return arith_driver (Amax
, nargs
, args
);
2421 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2422 "Return smallest of all the arguments (which must be numbers or markers).\n\
2423 The value is always a number; markers are converted to numbers.")
2428 return arith_driver (Amin
, nargs
, args
);
2431 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2432 "Return bitwise-and of all the arguments.\n\
2433 Arguments may be integers, or markers converted to integers.")
2438 return arith_driver (Alogand
, nargs
, args
);
2441 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2442 "Return bitwise-or of all the arguments.\n\
2443 Arguments may be integers, or markers converted to integers.")
2448 return arith_driver (Alogior
, nargs
, args
);
2451 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2452 "Return bitwise-exclusive-or of all the arguments.\n\
2453 Arguments may be integers, or markers converted to integers.")
2458 return arith_driver (Alogxor
, nargs
, args
);
2461 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2462 "Return VALUE with its bits shifted left by COUNT.\n\
2463 If COUNT is negative, shifting is actually to the right.\n\
2464 In this case, the sign bit is duplicated.")
2466 register Lisp_Object value
, count
;
2468 register Lisp_Object val
;
2470 CHECK_NUMBER (value
, 0);
2471 CHECK_NUMBER (count
, 1);
2473 if (XINT (count
) > 0)
2474 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2476 XSETINT (val
, XINT (value
) >> -XINT (count
));
2480 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2481 "Return VALUE with its bits shifted left by COUNT.\n\
2482 If COUNT is negative, shifting is actually to the right.\n\
2483 In this case, zeros are shifted in on the left.")
2485 register Lisp_Object value
, count
;
2487 register Lisp_Object val
;
2489 CHECK_NUMBER (value
, 0);
2490 CHECK_NUMBER (count
, 1);
2492 if (XINT (count
) > 0)
2493 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2495 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2499 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2500 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2501 Markers are converted to integers.")
2503 register Lisp_Object number
;
2505 #ifdef LISP_FLOAT_TYPE
2506 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2508 if (FLOATP (number
))
2509 return (make_float (1.0 + XFLOAT (number
)->data
));
2511 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2512 #endif /* LISP_FLOAT_TYPE */
2514 XSETINT (number
, XINT (number
) + 1);
2518 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2519 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2520 Markers are converted to integers.")
2522 register Lisp_Object number
;
2524 #ifdef LISP_FLOAT_TYPE
2525 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2527 if (FLOATP (number
))
2528 return (make_float (-1.0 + XFLOAT (number
)->data
));
2530 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2531 #endif /* LISP_FLOAT_TYPE */
2533 XSETINT (number
, XINT (number
) - 1);
2537 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2538 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2540 register Lisp_Object number
;
2542 CHECK_NUMBER (number
, 0);
2543 XSETINT (number
, ~XINT (number
));
2550 Lisp_Object error_tail
, arith_tail
;
2552 Qquote
= intern ("quote");
2553 Qlambda
= intern ("lambda");
2554 Qsubr
= intern ("subr");
2555 Qerror_conditions
= intern ("error-conditions");
2556 Qerror_message
= intern ("error-message");
2557 Qtop_level
= intern ("top-level");
2559 Qerror
= intern ("error");
2560 Qquit
= intern ("quit");
2561 Qwrong_type_argument
= intern ("wrong-type-argument");
2562 Qargs_out_of_range
= intern ("args-out-of-range");
2563 Qvoid_function
= intern ("void-function");
2564 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2565 Qvoid_variable
= intern ("void-variable");
2566 Qsetting_constant
= intern ("setting-constant");
2567 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2569 Qinvalid_function
= intern ("invalid-function");
2570 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2571 Qno_catch
= intern ("no-catch");
2572 Qend_of_file
= intern ("end-of-file");
2573 Qarith_error
= intern ("arith-error");
2574 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2575 Qend_of_buffer
= intern ("end-of-buffer");
2576 Qbuffer_read_only
= intern ("buffer-read-only");
2577 Qmark_inactive
= intern ("mark-inactive");
2579 Qlistp
= intern ("listp");
2580 Qconsp
= intern ("consp");
2581 Qsymbolp
= intern ("symbolp");
2582 Qintegerp
= intern ("integerp");
2583 Qnatnump
= intern ("natnump");
2584 Qwholenump
= intern ("wholenump");
2585 Qstringp
= intern ("stringp");
2586 Qarrayp
= intern ("arrayp");
2587 Qsequencep
= intern ("sequencep");
2588 Qbufferp
= intern ("bufferp");
2589 Qvectorp
= intern ("vectorp");
2590 Qchar_or_string_p
= intern ("char-or-string-p");
2591 Qmarkerp
= intern ("markerp");
2592 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2593 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2594 Qboundp
= intern ("boundp");
2595 Qfboundp
= intern ("fboundp");
2597 #ifdef LISP_FLOAT_TYPE
2598 Qfloatp
= intern ("floatp");
2599 Qnumberp
= intern ("numberp");
2600 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2601 #endif /* LISP_FLOAT_TYPE */
2603 Qchar_table_p
= intern ("char-table-p");
2604 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2606 Qcdr
= intern ("cdr");
2608 /* Handle automatic advice activation */
2609 Qad_advice_info
= intern ("ad-advice-info");
2610 Qad_activate
= intern ("ad-activate");
2612 error_tail
= Fcons (Qerror
, Qnil
);
2614 /* ERROR is used as a signaler for random errors for which nothing else is right */
2616 Fput (Qerror
, Qerror_conditions
,
2618 Fput (Qerror
, Qerror_message
,
2619 build_string ("error"));
2621 Fput (Qquit
, Qerror_conditions
,
2622 Fcons (Qquit
, Qnil
));
2623 Fput (Qquit
, Qerror_message
,
2624 build_string ("Quit"));
2626 Fput (Qwrong_type_argument
, Qerror_conditions
,
2627 Fcons (Qwrong_type_argument
, error_tail
));
2628 Fput (Qwrong_type_argument
, Qerror_message
,
2629 build_string ("Wrong type argument"));
2631 Fput (Qargs_out_of_range
, Qerror_conditions
,
2632 Fcons (Qargs_out_of_range
, error_tail
));
2633 Fput (Qargs_out_of_range
, Qerror_message
,
2634 build_string ("Args out of range"));
2636 Fput (Qvoid_function
, Qerror_conditions
,
2637 Fcons (Qvoid_function
, error_tail
));
2638 Fput (Qvoid_function
, Qerror_message
,
2639 build_string ("Symbol's function definition is void"));
2641 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2642 Fcons (Qcyclic_function_indirection
, error_tail
));
2643 Fput (Qcyclic_function_indirection
, Qerror_message
,
2644 build_string ("Symbol's chain of function indirections contains a loop"));
2646 Fput (Qvoid_variable
, Qerror_conditions
,
2647 Fcons (Qvoid_variable
, error_tail
));
2648 Fput (Qvoid_variable
, Qerror_message
,
2649 build_string ("Symbol's value as variable is void"));
2651 Fput (Qsetting_constant
, Qerror_conditions
,
2652 Fcons (Qsetting_constant
, error_tail
));
2653 Fput (Qsetting_constant
, Qerror_message
,
2654 build_string ("Attempt to set a constant symbol"));
2656 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2657 Fcons (Qinvalid_read_syntax
, error_tail
));
2658 Fput (Qinvalid_read_syntax
, Qerror_message
,
2659 build_string ("Invalid read syntax"));
2661 Fput (Qinvalid_function
, Qerror_conditions
,
2662 Fcons (Qinvalid_function
, error_tail
));
2663 Fput (Qinvalid_function
, Qerror_message
,
2664 build_string ("Invalid function"));
2666 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2667 Fcons (Qwrong_number_of_arguments
, error_tail
));
2668 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2669 build_string ("Wrong number of arguments"));
2671 Fput (Qno_catch
, Qerror_conditions
,
2672 Fcons (Qno_catch
, error_tail
));
2673 Fput (Qno_catch
, Qerror_message
,
2674 build_string ("No catch for tag"));
2676 Fput (Qend_of_file
, Qerror_conditions
,
2677 Fcons (Qend_of_file
, error_tail
));
2678 Fput (Qend_of_file
, Qerror_message
,
2679 build_string ("End of file during parsing"));
2681 arith_tail
= Fcons (Qarith_error
, error_tail
);
2682 Fput (Qarith_error
, Qerror_conditions
,
2684 Fput (Qarith_error
, Qerror_message
,
2685 build_string ("Arithmetic error"));
2687 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2688 Fcons (Qbeginning_of_buffer
, error_tail
));
2689 Fput (Qbeginning_of_buffer
, Qerror_message
,
2690 build_string ("Beginning of buffer"));
2692 Fput (Qend_of_buffer
, Qerror_conditions
,
2693 Fcons (Qend_of_buffer
, error_tail
));
2694 Fput (Qend_of_buffer
, Qerror_message
,
2695 build_string ("End of buffer"));
2697 Fput (Qbuffer_read_only
, Qerror_conditions
,
2698 Fcons (Qbuffer_read_only
, error_tail
));
2699 Fput (Qbuffer_read_only
, Qerror_message
,
2700 build_string ("Buffer is read-only"));
2702 #ifdef LISP_FLOAT_TYPE
2703 Qrange_error
= intern ("range-error");
2704 Qdomain_error
= intern ("domain-error");
2705 Qsingularity_error
= intern ("singularity-error");
2706 Qoverflow_error
= intern ("overflow-error");
2707 Qunderflow_error
= intern ("underflow-error");
2709 Fput (Qdomain_error
, Qerror_conditions
,
2710 Fcons (Qdomain_error
, arith_tail
));
2711 Fput (Qdomain_error
, Qerror_message
,
2712 build_string ("Arithmetic domain error"));
2714 Fput (Qrange_error
, Qerror_conditions
,
2715 Fcons (Qrange_error
, arith_tail
));
2716 Fput (Qrange_error
, Qerror_message
,
2717 build_string ("Arithmetic range error"));
2719 Fput (Qsingularity_error
, Qerror_conditions
,
2720 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2721 Fput (Qsingularity_error
, Qerror_message
,
2722 build_string ("Arithmetic singularity error"));
2724 Fput (Qoverflow_error
, Qerror_conditions
,
2725 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2726 Fput (Qoverflow_error
, Qerror_message
,
2727 build_string ("Arithmetic overflow error"));
2729 Fput (Qunderflow_error
, Qerror_conditions
,
2730 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2731 Fput (Qunderflow_error
, Qerror_message
,
2732 build_string ("Arithmetic underflow error"));
2734 staticpro (&Qrange_error
);
2735 staticpro (&Qdomain_error
);
2736 staticpro (&Qsingularity_error
);
2737 staticpro (&Qoverflow_error
);
2738 staticpro (&Qunderflow_error
);
2739 #endif /* LISP_FLOAT_TYPE */
2743 staticpro (&Qquote
);
2744 staticpro (&Qlambda
);
2746 staticpro (&Qunbound
);
2747 staticpro (&Qerror_conditions
);
2748 staticpro (&Qerror_message
);
2749 staticpro (&Qtop_level
);
2751 staticpro (&Qerror
);
2753 staticpro (&Qwrong_type_argument
);
2754 staticpro (&Qargs_out_of_range
);
2755 staticpro (&Qvoid_function
);
2756 staticpro (&Qcyclic_function_indirection
);
2757 staticpro (&Qvoid_variable
);
2758 staticpro (&Qsetting_constant
);
2759 staticpro (&Qinvalid_read_syntax
);
2760 staticpro (&Qwrong_number_of_arguments
);
2761 staticpro (&Qinvalid_function
);
2762 staticpro (&Qno_catch
);
2763 staticpro (&Qend_of_file
);
2764 staticpro (&Qarith_error
);
2765 staticpro (&Qbeginning_of_buffer
);
2766 staticpro (&Qend_of_buffer
);
2767 staticpro (&Qbuffer_read_only
);
2768 staticpro (&Qmark_inactive
);
2770 staticpro (&Qlistp
);
2771 staticpro (&Qconsp
);
2772 staticpro (&Qsymbolp
);
2773 staticpro (&Qintegerp
);
2774 staticpro (&Qnatnump
);
2775 staticpro (&Qwholenump
);
2776 staticpro (&Qstringp
);
2777 staticpro (&Qarrayp
);
2778 staticpro (&Qsequencep
);
2779 staticpro (&Qbufferp
);
2780 staticpro (&Qvectorp
);
2781 staticpro (&Qchar_or_string_p
);
2782 staticpro (&Qmarkerp
);
2783 staticpro (&Qbuffer_or_string_p
);
2784 staticpro (&Qinteger_or_marker_p
);
2785 #ifdef LISP_FLOAT_TYPE
2786 staticpro (&Qfloatp
);
2787 staticpro (&Qnumberp
);
2788 staticpro (&Qnumber_or_marker_p
);
2789 #endif /* LISP_FLOAT_TYPE */
2790 staticpro (&Qchar_table_p
);
2791 staticpro (&Qvector_or_char_table_p
);
2793 staticpro (&Qboundp
);
2794 staticpro (&Qfboundp
);
2796 staticpro (&Qad_advice_info
);
2797 staticpro (&Qad_activate
);
2799 /* Types that type-of returns. */
2800 Qinteger
= intern ("integer");
2801 Qsymbol
= intern ("symbol");
2802 Qstring
= intern ("string");
2803 Qcons
= intern ("cons");
2804 Qmarker
= intern ("marker");
2805 Qoverlay
= intern ("overlay");
2806 Qfloat
= intern ("float");
2807 Qwindow_configuration
= intern ("window-configuration");
2808 Qprocess
= intern ("process");
2809 Qwindow
= intern ("window");
2810 /* Qsubr = intern ("subr"); */
2811 Qcompiled_function
= intern ("compiled-function");
2812 Qbuffer
= intern ("buffer");
2813 Qframe
= intern ("frame");
2814 Qvector
= intern ("vector");
2815 Qchar_table
= intern ("char-table");
2816 Qbool_vector
= intern ("bool-vector");
2818 staticpro (&Qinteger
);
2819 staticpro (&Qsymbol
);
2820 staticpro (&Qstring
);
2822 staticpro (&Qmarker
);
2823 staticpro (&Qoverlay
);
2824 staticpro (&Qfloat
);
2825 staticpro (&Qwindow_configuration
);
2826 staticpro (&Qprocess
);
2827 staticpro (&Qwindow
);
2828 /* staticpro (&Qsubr); */
2829 staticpro (&Qcompiled_function
);
2830 staticpro (&Qbuffer
);
2831 staticpro (&Qframe
);
2832 staticpro (&Qvector
);
2833 staticpro (&Qchar_table
);
2834 staticpro (&Qbool_vector
);
2838 defsubr (&Stype_of
);
2843 defsubr (&Sintegerp
);
2844 defsubr (&Sinteger_or_marker_p
);
2845 defsubr (&Snumberp
);
2846 defsubr (&Snumber_or_marker_p
);
2847 #ifdef LISP_FLOAT_TYPE
2849 #endif /* LISP_FLOAT_TYPE */
2850 defsubr (&Snatnump
);
2851 defsubr (&Ssymbolp
);
2852 defsubr (&Sstringp
);
2853 defsubr (&Smultibyte_string_p
);
2854 defsubr (&Svectorp
);
2855 defsubr (&Schar_table_p
);
2856 defsubr (&Svector_or_char_table_p
);
2857 defsubr (&Sbool_vector_p
);
2859 defsubr (&Ssequencep
);
2860 defsubr (&Sbufferp
);
2861 defsubr (&Smarkerp
);
2863 defsubr (&Sbyte_code_function_p
);
2864 defsubr (&Schar_or_string_p
);
2867 defsubr (&Scar_safe
);
2868 defsubr (&Scdr_safe
);
2871 defsubr (&Ssymbol_function
);
2872 defsubr (&Sindirect_function
);
2873 defsubr (&Ssymbol_plist
);
2874 defsubr (&Ssymbol_name
);
2875 defsubr (&Smakunbound
);
2876 defsubr (&Sfmakunbound
);
2878 defsubr (&Sfboundp
);
2880 defsubr (&Sdefalias
);
2881 defsubr (&Ssetplist
);
2882 defsubr (&Ssymbol_value
);
2884 defsubr (&Sdefault_boundp
);
2885 defsubr (&Sdefault_value
);
2886 defsubr (&Sset_default
);
2887 defsubr (&Ssetq_default
);
2888 defsubr (&Smake_variable_buffer_local
);
2889 defsubr (&Smake_local_variable
);
2890 defsubr (&Skill_local_variable
);
2891 defsubr (&Smake_variable_frame_local
);
2892 defsubr (&Slocal_variable_p
);
2893 defsubr (&Slocal_variable_if_set_p
);
2896 defsubr (&Snumber_to_string
);
2897 defsubr (&Sstring_to_number
);
2898 defsubr (&Seqlsign
);
2922 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2929 #if defined(USG) && !defined(POSIX_SIGNALS)
2930 /* USG systems forget handlers when they are used;
2931 must reestablish each time */
2932 signal (signo
, arith_error
);
2935 /* VMS systems are like USG. */
2936 signal (signo
, arith_error
);
2940 #else /* not BSD4_1 */
2941 sigsetmask (SIGEMPTYMASK
);
2942 #endif /* not BSD4_1 */
2944 Fsignal (Qarith_error
, Qnil
);
2949 /* Don't do this if just dumping out.
2950 We don't want to call `signal' in this case
2951 so that we don't have trouble with dumping
2952 signal-delivering routines in an inconsistent state. */
2956 #endif /* CANNOT_DUMP */
2957 signal (SIGFPE
, arith_error
);
2960 signal (SIGEMT
, arith_error
);