1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99,2000 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
31 #include "syssignal.h"
37 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
38 #ifndef IEEE_FLOATING_POINT
39 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
40 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
41 #define IEEE_FLOATING_POINT 1
43 #define IEEE_FLOATING_POINT 0
47 /* Work around a problem that happens because math.h on hpux 7
48 defines two static variables--which, in Emacs, are not really static,
49 because `static' is defined as nothing. The problem is that they are
50 here, in floatfns.c, and in lread.c.
51 These macros prevent the name conflict. */
52 #if defined (HPUX) && !defined (HPUX8)
53 #define _MAXLDBL data_c_maxldbl
54 #define _NMAXLDBL data_c_nmaxldbl
60 extern double atof ();
63 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
64 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
65 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
66 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
67 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
68 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
69 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
70 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
71 Lisp_Object Qtext_read_only
;
72 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
73 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
74 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
75 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
76 Lisp_Object Qboundp
, Qfboundp
;
77 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
80 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
82 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
83 Lisp_Object Qoverflow_error
, Qunderflow_error
;
86 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
88 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
89 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
91 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
92 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
93 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
95 static Lisp_Object
swap_in_symval_forwarding ();
97 Lisp_Object
set_internal ();
100 wrong_type_argument (predicate
, value
)
101 register Lisp_Object predicate
, value
;
103 register Lisp_Object tem
;
106 if (!EQ (Vmocklisp_arguments
, Qt
))
108 if (STRINGP (value
) &&
109 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
110 return Fstring_to_number (value
, Qnil
);
111 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
112 return Fnumber_to_string (value
);
115 /* If VALUE is not even a valid Lisp object, abort here
116 where we can get a backtrace showing where it came from. */
117 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
120 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
121 tem
= call1 (predicate
, value
);
130 error ("Attempt to modify read-only object");
134 args_out_of_range (a1
, a2
)
138 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
142 args_out_of_range_3 (a1
, a2
, a3
)
143 Lisp_Object a1
, a2
, a3
;
146 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
149 /* On some machines, XINT needs a temporary location.
150 Here it is, in case it is needed. */
152 int sign_extend_temp
;
154 /* On a few machines, XINT can only be done by calling this. */
157 sign_extend_lisp_int (num
)
160 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
161 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
163 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
166 /* Data type predicates */
168 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
169 "Return t if the two args are the same Lisp object.")
171 Lisp_Object obj1
, obj2
;
178 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
187 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
188 "Return a symbol representing the type of OBJECT.\n\
189 The symbol returned names the object's basic type;\n\
190 for example, (type-of 1) returns `integer'.")
194 switch (XGCTYPE (object
))
209 switch (XMISCTYPE (object
))
211 case Lisp_Misc_Marker
:
213 case Lisp_Misc_Overlay
:
215 case Lisp_Misc_Float
:
220 case Lisp_Vectorlike
:
221 if (GC_WINDOW_CONFIGURATIONP (object
))
222 return Qwindow_configuration
;
223 if (GC_PROCESSP (object
))
225 if (GC_WINDOWP (object
))
227 if (GC_SUBRP (object
))
229 if (GC_COMPILEDP (object
))
230 return Qcompiled_function
;
231 if (GC_BUFFERP (object
))
233 if (GC_CHAR_TABLE_P (object
))
235 if (GC_BOOL_VECTOR_P (object
))
237 if (GC_FRAMEP (object
))
239 if (GC_HASH_TABLE_P (object
))
251 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
260 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
261 "Return t if OBJECT is not a cons cell. This includes nil.")
270 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
271 "Return t if OBJECT is a list. This includes nil.")
275 if (CONSP (object
) || NILP (object
))
280 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
281 "Return t if OBJECT is not a list. Lists include nil.")
285 if (CONSP (object
) || NILP (object
))
290 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
291 "Return t if OBJECT is a symbol.")
295 if (SYMBOLP (object
))
300 /* Define this in C to avoid unnecessarily consing up the symbol
302 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
303 "Return t if OBJECT is a keyword.\n\
304 This means that it is a symbol with a print name beginning with `:'\n\
305 interned in the initial obarray.")
310 && XSYMBOL (object
)->name
->data
[0] == ':'
311 && EQ (XSYMBOL (object
)->obarray
, initial_obarray
))
316 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
317 "Return t if OBJECT is a vector.")
321 if (VECTORP (object
))
326 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
327 "Return t if OBJECT is a string.")
331 if (STRINGP (object
))
336 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
337 1, 1, 0, "Return t if OBJECT is a multibyte string.")
341 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
346 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
347 "Return t if OBJECT is a char-table.")
351 if (CHAR_TABLE_P (object
))
356 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
357 Svector_or_char_table_p
, 1, 1, 0,
358 "Return t if OBJECT is a char-table or vector.")
362 if (VECTORP (object
) || CHAR_TABLE_P (object
))
367 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
371 if (BOOL_VECTOR_P (object
))
376 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
380 if (VECTORP (object
) || STRINGP (object
)
381 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
386 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
387 "Return t if OBJECT is a sequence (list or array).")
389 register Lisp_Object object
;
391 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
392 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
397 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
401 if (BUFFERP (object
))
406 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
410 if (MARKERP (object
))
415 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
424 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
425 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
429 if (COMPILEDP (object
))
434 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
435 "Return t if OBJECT is a character (an integer) or a string.")
437 register Lisp_Object object
;
439 if (INTEGERP (object
) || STRINGP (object
))
444 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
448 if (INTEGERP (object
))
453 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
454 "Return t if OBJECT is an integer or a marker (editor pointer).")
456 register Lisp_Object object
;
458 if (MARKERP (object
) || INTEGERP (object
))
463 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
464 "Return t if OBJECT is a nonnegative integer.")
468 if (NATNUMP (object
))
473 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
474 "Return t if OBJECT is a number (floating point or integer).")
478 if (NUMBERP (object
))
484 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
485 Snumber_or_marker_p
, 1, 1, 0,
486 "Return t if OBJECT is a number or a marker.")
490 if (NUMBERP (object
) || MARKERP (object
))
495 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
496 "Return t if OBJECT is a floating point number.")
506 /* Extract and set components of lists */
508 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
509 "Return the car of LIST. If arg is nil, return nil.\n\
510 Error if arg is not nil and not a cons cell. See also `car-safe'.")
512 register Lisp_Object list
;
518 else if (EQ (list
, Qnil
))
521 list
= wrong_type_argument (Qlistp
, list
);
525 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
526 "Return the car of OBJECT if it is a cons cell, or else nil.")
531 return XCAR (object
);
536 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
537 "Return the cdr of LIST. If arg is nil, return nil.\n\
538 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
541 register Lisp_Object list
;
547 else if (EQ (list
, Qnil
))
550 list
= wrong_type_argument (Qlistp
, list
);
554 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
555 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
560 return XCDR (object
);
565 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
566 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
568 register Lisp_Object cell
, newcar
;
571 cell
= wrong_type_argument (Qconsp
, cell
);
574 XCAR (cell
) = newcar
;
578 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
579 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
581 register Lisp_Object cell
, newcdr
;
584 cell
= wrong_type_argument (Qconsp
, cell
);
587 XCDR (cell
) = newcdr
;
591 /* Extract and set components of symbols */
593 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
595 register Lisp_Object symbol
;
597 Lisp_Object valcontents
;
598 CHECK_SYMBOL (symbol
, 0);
600 valcontents
= XSYMBOL (symbol
)->value
;
602 if (BUFFER_LOCAL_VALUEP (valcontents
)
603 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
604 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
606 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
609 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
611 register Lisp_Object symbol
;
613 CHECK_SYMBOL (symbol
, 0);
614 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
617 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
619 register Lisp_Object symbol
;
621 CHECK_SYMBOL (symbol
, 0);
622 if (NILP (symbol
) || EQ (symbol
, Qt
)
623 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
624 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)))
625 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
626 Fset (symbol
, Qunbound
);
630 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
632 register Lisp_Object symbol
;
634 CHECK_SYMBOL (symbol
, 0);
635 if (NILP (symbol
) || EQ (symbol
, Qt
))
636 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
637 XSYMBOL (symbol
)->function
= Qunbound
;
641 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
642 "Return SYMBOL's function definition. Error if that is void.")
644 register Lisp_Object symbol
;
646 CHECK_SYMBOL (symbol
, 0);
647 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
648 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
649 return XSYMBOL (symbol
)->function
;
652 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
654 register Lisp_Object symbol
;
656 CHECK_SYMBOL (symbol
, 0);
657 return XSYMBOL (symbol
)->plist
;
660 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
662 register Lisp_Object symbol
;
664 register Lisp_Object name
;
666 CHECK_SYMBOL (symbol
, 0);
667 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
671 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
672 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
674 register Lisp_Object symbol
, definition
;
676 CHECK_SYMBOL (symbol
, 0);
677 if (NILP (symbol
) || EQ (symbol
, Qt
))
678 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
679 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
680 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
682 XSYMBOL (symbol
)->function
= definition
;
683 /* Handle automatic advice activation */
684 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
686 call2 (Qad_activate_internal
, symbol
, Qnil
);
687 definition
= XSYMBOL (symbol
)->function
;
692 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
693 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
694 Associates the function with the current load file, if any.")
696 register Lisp_Object symbol
, definition
;
698 definition
= Ffset (symbol
, definition
);
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
;
713 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
714 "Return minimum and maximum number of args allowed for SUBR.\n\
715 SUBR must be a built-in function.\n\
716 The returned value is a pair (MIN . MAX). MIN is the minimum number\n\
717 of args. MAX is the maximum number or the symbol `many', for a\n\
718 function with `&rest' args, or `unevalled' for a special form.")
722 short minargs
, maxargs
;
724 wrong_type_argument (Qsubrp
, subr
);
725 minargs
= XSUBR (subr
)->min_args
;
726 maxargs
= XSUBR (subr
)->max_args
;
728 return Fcons (make_number (minargs
), Qmany
);
729 else if (maxargs
== UNEVALLED
)
730 return Fcons (make_number (minargs
), Qunevalled
);
732 return Fcons (make_number (minargs
), make_number (maxargs
));
736 /* Getting and setting values of symbols */
738 /* Given the raw contents of a symbol value cell,
739 return the Lisp value of the symbol.
740 This does not handle buffer-local variables; use
741 swap_in_symval_forwarding for that. */
744 do_symval_forwarding (valcontents
)
745 register Lisp_Object valcontents
;
747 register Lisp_Object val
;
749 if (MISCP (valcontents
))
750 switch (XMISCTYPE (valcontents
))
752 case Lisp_Misc_Intfwd
:
753 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
756 case Lisp_Misc_Boolfwd
:
757 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
759 case Lisp_Misc_Objfwd
:
760 return *XOBJFWD (valcontents
)->objvar
;
762 case Lisp_Misc_Buffer_Objfwd
:
763 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
764 return PER_BUFFER_VALUE (current_buffer
, offset
);
766 case Lisp_Misc_Kboard_Objfwd
:
767 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
768 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
773 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
774 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
775 buffer-independent contents of the value cell: forwarded just one
776 step past the buffer-localness. */
779 store_symval_forwarding (symbol
, valcontents
, newval
)
781 register Lisp_Object valcontents
, newval
;
783 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
786 switch (XMISCTYPE (valcontents
))
788 case Lisp_Misc_Intfwd
:
789 CHECK_NUMBER (newval
, 1);
790 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
791 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
792 error ("Value out of range for variable `%s'",
793 XSYMBOL (symbol
)->name
->data
);
796 case Lisp_Misc_Boolfwd
:
797 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
800 case Lisp_Misc_Objfwd
:
801 *XOBJFWD (valcontents
)->objvar
= newval
;
804 case Lisp_Misc_Buffer_Objfwd
:
806 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
809 type
= PER_BUFFER_TYPE (offset
);
810 if (XINT (type
) == -1)
811 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
813 if (! NILP (type
) && ! NILP (newval
)
814 && XTYPE (newval
) != XINT (type
))
815 buffer_slot_type_mismatch (offset
);
817 PER_BUFFER_VALUE (current_buffer
, offset
) = newval
;
821 case Lisp_Misc_Kboard_Objfwd
:
822 (*(Lisp_Object
*)((char *)current_kboard
823 + XKBOARD_OBJFWD (valcontents
)->offset
))
834 valcontents
= XSYMBOL (symbol
)->value
;
835 if (BUFFER_LOCAL_VALUEP (valcontents
)
836 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
837 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
839 XSYMBOL (symbol
)->value
= newval
;
843 /* Set up SYMBOL to refer to its global binding.
844 This makes it safe to alter the status of other bindings. */
847 swap_in_global_binding (symbol
)
850 Lisp_Object valcontents
, cdr
;
852 valcontents
= XSYMBOL (symbol
)->value
;
853 if (!BUFFER_LOCAL_VALUEP (valcontents
)
854 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
856 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
858 /* Unload the previously loaded binding. */
860 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
862 /* Select the global binding in the symbol. */
864 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
));
866 /* Indicate that the global binding is set up now. */
867 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
868 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
869 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
870 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
873 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
874 VALCONTENTS is the contents of its value cell,
875 which points to a struct Lisp_Buffer_Local_Value.
877 Return the value forwarded one step past the buffer-local stage.
878 This could be another forwarding pointer. */
881 swap_in_symval_forwarding (symbol
, valcontents
)
882 Lisp_Object symbol
, valcontents
;
884 register Lisp_Object tem1
;
885 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
888 || current_buffer
!= XBUFFER (tem1
)
889 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
890 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
892 /* Unload the previously loaded binding. */
893 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
895 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
896 /* Choose the new binding. */
897 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
898 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
899 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
902 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
903 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
905 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
907 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
910 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
912 /* Load the new binding. */
913 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = tem1
;
914 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
915 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
916 store_symval_forwarding (symbol
,
917 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
920 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
923 /* Find the value of a symbol, returning Qunbound if it's not bound.
924 This is helpful for code which just wants to get a variable's value
925 if it has one, without signaling an error.
926 Note that it must not be possible to quit
927 within this function. Great care is required for this. */
930 find_symbol_value (symbol
)
933 register Lisp_Object valcontents
;
934 register Lisp_Object val
;
935 CHECK_SYMBOL (symbol
, 0);
936 valcontents
= XSYMBOL (symbol
)->value
;
938 if (BUFFER_LOCAL_VALUEP (valcontents
)
939 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
940 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
,
943 if (MISCP (valcontents
))
945 switch (XMISCTYPE (valcontents
))
947 case Lisp_Misc_Intfwd
:
948 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
951 case Lisp_Misc_Boolfwd
:
952 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
954 case Lisp_Misc_Objfwd
:
955 return *XOBJFWD (valcontents
)->objvar
;
957 case Lisp_Misc_Buffer_Objfwd
:
958 return PER_BUFFER_VALUE (current_buffer
,
959 XBUFFER_OBJFWD (valcontents
)->offset
);
961 case Lisp_Misc_Kboard_Objfwd
:
962 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
963 + (char *)current_kboard
);
970 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
971 "Return SYMBOL's value. Error if that is void.")
977 val
= find_symbol_value (symbol
);
978 if (EQ (val
, Qunbound
))
979 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
984 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
985 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
987 register Lisp_Object symbol
, newval
;
989 return set_internal (symbol
, newval
, current_buffer
, 0);
992 /* Return 1 if SYMBOL currently has a let-binding
993 which was made in the buffer that is now current. */
996 let_shadows_buffer_binding_p (symbol
)
999 struct specbinding
*p
;
1001 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1003 && CONSP (p
->symbol
)
1004 && EQ (symbol
, XCAR (p
->symbol
))
1005 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1011 /* Store the value NEWVAL into SYMBOL.
1012 If buffer-locality is an issue, BUF specifies which buffer to use.
1013 (0 stands for the current buffer.)
1015 If BINDFLAG is zero, then if this symbol is supposed to become
1016 local in every buffer where it is set, then we make it local.
1017 If BINDFLAG is nonzero, we don't do that. */
1020 set_internal (symbol
, newval
, buf
, bindflag
)
1021 register Lisp_Object symbol
, newval
;
1025 int voide
= EQ (newval
, Qunbound
);
1027 register Lisp_Object valcontents
, tem1
, current_alist_element
;
1030 buf
= current_buffer
;
1032 /* If restoring in a dead buffer, do nothing. */
1033 if (NILP (buf
->name
))
1036 if (strcmp (XSYMBOL (symbol
)->name
->data
, "foo") == 0)
1037 fprintf (stderr
, "foo\n");
1039 CHECK_SYMBOL (symbol
, 0);
1040 if (NILP (symbol
) || EQ (symbol
, Qt
)
1041 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
1042 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
1043 && !EQ (newval
, symbol
)))
1044 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1045 valcontents
= XSYMBOL (symbol
)->value
;
1047 if (BUFFER_OBJFWDP (valcontents
))
1049 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1050 int idx
= PER_BUFFER_IDX (offset
);
1053 && !let_shadows_buffer_binding_p (symbol
))
1054 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1057 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1058 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1060 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1062 /* What binding is loaded right now? */
1063 current_alist_element
1064 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1066 /* If the current buffer is not the buffer whose binding is
1067 loaded, or if there may be frame-local bindings and the frame
1068 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1069 the default binding is loaded, the loaded binding may be the
1071 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1072 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1073 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1074 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1075 || (BUFFER_LOCAL_VALUEP (valcontents
)
1076 && EQ (XCAR (current_alist_element
),
1077 current_alist_element
)))
1079 /* The currently loaded binding is not necessarily valid.
1080 We need to unload it, and choose a new binding. */
1082 /* Write out `realvalue' to the old loaded binding. */
1083 Fsetcdr (current_alist_element
,
1084 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1086 /* Find the new binding. */
1087 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1088 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1089 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1093 /* This buffer still sees the default value. */
1095 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1096 or if this is `let' rather than `set',
1097 make CURRENT-ALIST-ELEMENT point to itself,
1098 indicating that we're seeing the default value.
1099 Likewise if the variable has been let-bound
1100 in the current buffer. */
1101 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1102 || let_shadows_buffer_binding_p (symbol
))
1104 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1106 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1107 tem1
= Fassq (symbol
,
1108 XFRAME (selected_frame
)->param_alist
);
1111 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1113 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1115 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1116 and we're not within a let that was made for this buffer,
1117 create a new buffer-local binding for the variable.
1118 That means, give this buffer a new assoc for a local value
1119 and load that binding. */
1122 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1123 buf
->local_var_alist
1124 = Fcons (tem1
, buf
->local_var_alist
);
1128 /* Record which binding is now loaded. */
1129 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1132 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1133 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1134 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1136 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1139 /* If storing void (making the symbol void), forward only through
1140 buffer-local indicator, not through Lisp_Objfwd, etc. */
1142 store_symval_forwarding (symbol
, Qnil
, newval
);
1144 store_symval_forwarding (symbol
, valcontents
, newval
);
1149 /* Access or set a buffer-local symbol's default value. */
1151 /* Return the default value of SYMBOL, but don't check for voidness.
1152 Return Qunbound if it is void. */
1155 default_value (symbol
)
1158 register Lisp_Object valcontents
;
1160 CHECK_SYMBOL (symbol
, 0);
1161 valcontents
= XSYMBOL (symbol
)->value
;
1163 /* For a built-in buffer-local variable, get the default value
1164 rather than letting do_symval_forwarding get the current value. */
1165 if (BUFFER_OBJFWDP (valcontents
))
1167 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1168 if (PER_BUFFER_IDX (offset
) != 0)
1169 return PER_BUFFER_DEFAULT (offset
);
1172 /* Handle user-created local variables. */
1173 if (BUFFER_LOCAL_VALUEP (valcontents
)
1174 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1176 /* If var is set up for a buffer that lacks a local value for it,
1177 the current value is nominally the default value.
1178 But the `realvalue' slot may be more up to date, since
1179 ordinary setq stores just that slot. So use that. */
1180 Lisp_Object current_alist_element
, alist_element_car
;
1181 current_alist_element
1182 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1183 alist_element_car
= XCAR (current_alist_element
);
1184 if (EQ (alist_element_car
, current_alist_element
))
1185 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1187 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1189 /* For other variables, get the current value. */
1190 return do_symval_forwarding (valcontents
);
1193 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1194 "Return t if SYMBOL has a non-void default value.\n\
1195 This is the value that is seen in buffers that do not have their own values\n\
1196 for this variable.")
1200 register Lisp_Object value
;
1202 value
= default_value (symbol
);
1203 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1206 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1207 "Return SYMBOL's default value.\n\
1208 This is the value that is seen in buffers that do not have their own values\n\
1209 for this variable. The default value is meaningful for variables with\n\
1210 local bindings in certain buffers.")
1214 register Lisp_Object value
;
1216 value
= default_value (symbol
);
1217 if (EQ (value
, Qunbound
))
1218 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1222 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1223 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1224 The default value is seen in buffers that do not have their own values\n\
1225 for this variable.")
1227 Lisp_Object symbol
, value
;
1229 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1231 CHECK_SYMBOL (symbol
, 0);
1232 valcontents
= XSYMBOL (symbol
)->value
;
1234 /* Handle variables like case-fold-search that have special slots
1235 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1237 if (BUFFER_OBJFWDP (valcontents
))
1239 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1240 int idx
= PER_BUFFER_IDX (offset
);
1242 PER_BUFFER_DEFAULT (offset
) = value
;
1244 /* If this variable is not always local in all buffers,
1245 set it in the buffers that don't nominally have a local value. */
1250 for (b
= all_buffers
; b
; b
= b
->next
)
1251 if (!PER_BUFFER_VALUE_P (b
, idx
))
1252 PER_BUFFER_VALUE (b
, offset
) = value
;
1257 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1258 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1259 return Fset (symbol
, value
);
1261 /* Store new value into the DEFAULT-VALUE slot. */
1262 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1264 /* If the default binding is now loaded, set the REALVALUE slot too. */
1265 current_alist_element
1266 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1267 alist_element_buffer
= Fcar (current_alist_element
);
1268 if (EQ (alist_element_buffer
, current_alist_element
))
1269 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1275 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1276 "Set the default value of variable VAR to VALUE.\n\
1277 VAR, the variable name, is literal (not evaluated);\n\
1278 VALUE is an expression and it is evaluated.\n\
1279 The default value of a variable is seen in buffers\n\
1280 that do not have their own values for the variable.\n\
1282 More generally, you can use multiple variables and values, as in\n\
1283 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1284 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1285 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1290 register Lisp_Object args_left
;
1291 register Lisp_Object val
, symbol
;
1292 struct gcpro gcpro1
;
1302 val
= Feval (Fcar (Fcdr (args_left
)));
1303 symbol
= Fcar (args_left
);
1304 Fset_default (symbol
, val
);
1305 args_left
= Fcdr (Fcdr (args_left
));
1307 while (!NILP (args_left
));
1313 /* Lisp functions for creating and removing buffer-local variables. */
1315 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1316 1, 1, "vMake Variable Buffer Local: ",
1317 "Make VARIABLE become buffer-local whenever it is set.\n\
1318 At any time, the value for the current buffer is in effect,\n\
1319 unless the variable has never been set in this buffer,\n\
1320 in which case the default value is in effect.\n\
1321 Note that binding the variable with `let', or setting it while\n\
1322 a `let'-style binding made in this buffer is in effect,\n\
1323 does not make the variable buffer-local.\n\
1325 The function `default-value' gets the default value and `set-default' sets it.")
1327 register Lisp_Object variable
;
1329 register Lisp_Object tem
, valcontents
, newval
;
1331 CHECK_SYMBOL (variable
, 0);
1333 valcontents
= XSYMBOL (variable
)->value
;
1334 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1335 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1337 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1339 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1341 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1344 if (EQ (valcontents
, Qunbound
))
1345 XSYMBOL (variable
)->value
= Qnil
;
1346 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1348 newval
= allocate_misc ();
1349 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1350 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1351 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1352 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1353 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1354 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1355 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1356 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1357 XSYMBOL (variable
)->value
= newval
;
1361 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1362 1, 1, "vMake Local Variable: ",
1363 "Make VARIABLE have a separate value in the current buffer.\n\
1364 Other buffers will continue to share a common default value.\n\
1365 \(The buffer-local value of VARIABLE starts out as the same value\n\
1366 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1367 See also `make-variable-buffer-local'.\n\
1369 If the variable is already arranged to become local when set,\n\
1370 this function causes a local value to exist for this buffer,\n\
1371 just as setting the variable would do.\n\
1373 This function returns VARIABLE, and therefore\n\
1374 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1377 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1378 Use `make-local-hook' instead.")
1380 register Lisp_Object variable
;
1382 register Lisp_Object tem
, valcontents
;
1384 CHECK_SYMBOL (variable
, 0);
1386 valcontents
= XSYMBOL (variable
)->value
;
1387 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1388 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1390 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1392 tem
= Fboundp (variable
);
1394 /* Make sure the symbol has a local value in this particular buffer,
1395 by setting it to the same value it already has. */
1396 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1399 /* Make sure symbol is set up to hold per-buffer values. */
1400 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1403 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1405 newval
= allocate_misc ();
1406 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1407 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1408 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1409 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1410 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1411 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1412 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1413 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1414 XSYMBOL (variable
)->value
= newval
;
1416 /* Make sure this buffer has its own value of symbol. */
1417 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1420 /* Swap out any local binding for some other buffer, and make
1421 sure the current value is permanently recorded, if it's the
1423 find_symbol_value (variable
);
1425 current_buffer
->local_var_alist
1426 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1427 current_buffer
->local_var_alist
);
1429 /* Make sure symbol does not think it is set up for this buffer;
1430 force it to look once again for this buffer's value. */
1432 Lisp_Object
*pvalbuf
;
1434 valcontents
= XSYMBOL (variable
)->value
;
1436 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1437 if (current_buffer
== XBUFFER (*pvalbuf
))
1439 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1443 /* If the symbol forwards into a C variable, then load the binding
1444 for this buffer now. If C code modifies the variable before we
1445 load the binding in, then that new value will clobber the default
1446 binding the next time we unload it. */
1447 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1448 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1449 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1454 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1455 1, 1, "vKill Local Variable: ",
1456 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1457 From now on the default value will apply in this buffer.")
1459 register Lisp_Object variable
;
1461 register Lisp_Object tem
, valcontents
;
1463 CHECK_SYMBOL (variable
, 0);
1465 valcontents
= XSYMBOL (variable
)->value
;
1467 if (BUFFER_OBJFWDP (valcontents
))
1469 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1470 int idx
= PER_BUFFER_IDX (offset
);
1474 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1475 PER_BUFFER_VALUE (current_buffer
, offset
)
1476 = PER_BUFFER_DEFAULT (offset
);
1481 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1482 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1485 /* Get rid of this buffer's alist element, if any. */
1487 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1489 current_buffer
->local_var_alist
1490 = Fdelq (tem
, current_buffer
->local_var_alist
);
1492 /* If the symbol is set up with the current buffer's binding
1493 loaded, recompute its value. We have to do it now, or else
1494 forwarded objects won't work right. */
1496 Lisp_Object
*pvalbuf
;
1497 valcontents
= XSYMBOL (variable
)->value
;
1498 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1499 if (current_buffer
== XBUFFER (*pvalbuf
))
1502 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1503 find_symbol_value (variable
);
1510 /* Lisp functions for creating and removing buffer-local variables. */
1512 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1513 1, 1, "vMake Variable Frame Local: ",
1514 "Enable VARIABLE to have frame-local bindings.\n\
1515 When a frame-local binding exists in the current frame,\n\
1516 it is in effect whenever the current buffer has no buffer-local binding.\n\
1517 A frame-local binding is actual a frame parameter value;\n\
1518 thus, any given frame has a local binding for VARIABLE\n\
1519 if it has a value for the frame parameter named VARIABLE.\n\
1520 See `modify-frame-parameters'.")
1522 register Lisp_Object variable
;
1524 register Lisp_Object tem
, valcontents
, newval
;
1526 CHECK_SYMBOL (variable
, 0);
1528 valcontents
= XSYMBOL (variable
)->value
;
1529 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1530 || BUFFER_OBJFWDP (valcontents
))
1531 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1533 if (BUFFER_LOCAL_VALUEP (valcontents
)
1534 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1536 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1540 if (EQ (valcontents
, Qunbound
))
1541 XSYMBOL (variable
)->value
= Qnil
;
1542 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1544 newval
= allocate_misc ();
1545 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1546 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1547 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1548 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1549 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1550 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1551 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1552 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1553 XSYMBOL (variable
)->value
= newval
;
1557 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1559 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1560 BUFFER defaults to the current buffer.")
1562 register Lisp_Object variable
, buffer
;
1564 Lisp_Object valcontents
;
1565 register struct buffer
*buf
;
1568 buf
= current_buffer
;
1571 CHECK_BUFFER (buffer
, 0);
1572 buf
= XBUFFER (buffer
);
1575 CHECK_SYMBOL (variable
, 0);
1577 valcontents
= XSYMBOL (variable
)->value
;
1578 if (BUFFER_LOCAL_VALUEP (valcontents
)
1579 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1581 Lisp_Object tail
, elt
;
1582 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1585 if (EQ (variable
, XCAR (elt
)))
1589 if (BUFFER_OBJFWDP (valcontents
))
1591 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1592 int idx
= PER_BUFFER_IDX (offset
);
1593 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1599 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1601 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1602 BUFFER defaults to the current buffer.")
1604 register Lisp_Object variable
, buffer
;
1606 Lisp_Object valcontents
;
1607 register struct buffer
*buf
;
1610 buf
= current_buffer
;
1613 CHECK_BUFFER (buffer
, 0);
1614 buf
= XBUFFER (buffer
);
1617 CHECK_SYMBOL (variable
, 0);
1619 valcontents
= XSYMBOL (variable
)->value
;
1621 /* This means that make-variable-buffer-local was done. */
1622 if (BUFFER_LOCAL_VALUEP (valcontents
))
1624 /* All these slots become local if they are set. */
1625 if (BUFFER_OBJFWDP (valcontents
))
1627 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1629 Lisp_Object tail
, elt
;
1630 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1633 if (EQ (variable
, XCAR (elt
)))
1640 /* Find the function at the end of a chain of symbol function indirections. */
1642 /* If OBJECT is a symbol, find the end of its function chain and
1643 return the value found there. If OBJECT is not a symbol, just
1644 return it. If there is a cycle in the function chain, signal a
1645 cyclic-function-indirection error.
1647 This is like Findirect_function, except that it doesn't signal an
1648 error if the chain ends up unbound. */
1650 indirect_function (object
)
1651 register Lisp_Object object
;
1653 Lisp_Object tortoise
, hare
;
1655 hare
= tortoise
= object
;
1659 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1661 hare
= XSYMBOL (hare
)->function
;
1662 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1664 hare
= XSYMBOL (hare
)->function
;
1666 tortoise
= XSYMBOL (tortoise
)->function
;
1668 if (EQ (hare
, tortoise
))
1669 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1675 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1676 "Return the function at the end of OBJECT's function chain.\n\
1677 If OBJECT is a symbol, follow all function indirections and return the final\n\
1678 function binding.\n\
1679 If OBJECT is not a symbol, just return it.\n\
1680 Signal a void-function error if the final symbol is unbound.\n\
1681 Signal a cyclic-function-indirection error if there is a loop in the\n\
1682 function chain of symbols.")
1684 register Lisp_Object object
;
1688 result
= indirect_function (object
);
1690 if (EQ (result
, Qunbound
))
1691 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1695 /* Extract and set vector and string elements */
1697 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1698 "Return the element of ARRAY at index IDX.\n\
1699 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1700 or a byte-code object. IDX starts at 0.")
1702 register Lisp_Object array
;
1705 register int idxval
;
1707 CHECK_NUMBER (idx
, 1);
1708 idxval
= XINT (idx
);
1709 if (STRINGP (array
))
1713 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1714 args_out_of_range (array
, idx
);
1715 if (! STRING_MULTIBYTE (array
))
1716 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1717 idxval_byte
= string_char_to_byte (array
, idxval
);
1719 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1720 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1721 return make_number (c
);
1723 else if (BOOL_VECTOR_P (array
))
1727 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1728 args_out_of_range (array
, idx
);
1730 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1731 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1733 else if (CHAR_TABLE_P (array
))
1738 args_out_of_range (array
, idx
);
1739 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1741 /* For ASCII and 8-bit European characters, the element is
1742 stored in the top table. */
1743 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1745 val
= XCHAR_TABLE (array
)->defalt
;
1746 while (NILP (val
)) /* Follow parents until we find some value. */
1748 array
= XCHAR_TABLE (array
)->parent
;
1751 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1753 val
= XCHAR_TABLE (array
)->defalt
;
1760 Lisp_Object sub_table
;
1762 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1763 if (code
[1] < 32) code
[1] = -1;
1764 else if (code
[2] < 32) code
[2] = -1;
1766 /* Here, the possible range of CODE[0] (== charset ID) is
1767 128..MAX_CHARSET. Since the top level char table contains
1768 data for multibyte characters after 256th element, we must
1769 increment CODE[0] by 128 to get a correct index. */
1771 code
[3] = -1; /* anchor */
1773 try_parent_char_table
:
1775 for (i
= 0; code
[i
] >= 0; i
++)
1777 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1778 if (SUB_CHAR_TABLE_P (val
))
1783 val
= XCHAR_TABLE (sub_table
)->defalt
;
1786 array
= XCHAR_TABLE (array
)->parent
;
1788 goto try_parent_char_table
;
1793 /* Here, VAL is a sub char table. We try the default value
1795 val
= XCHAR_TABLE (val
)->defalt
;
1798 array
= XCHAR_TABLE (array
)->parent
;
1800 goto try_parent_char_table
;
1808 if (VECTORP (array
))
1809 size
= XVECTOR (array
)->size
;
1810 else if (COMPILEDP (array
))
1811 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1813 wrong_type_argument (Qarrayp
, array
);
1815 if (idxval
< 0 || idxval
>= size
)
1816 args_out_of_range (array
, idx
);
1817 return XVECTOR (array
)->contents
[idxval
];
1821 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1822 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1823 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1825 (array
, idx
, newelt
)
1826 register Lisp_Object array
;
1827 Lisp_Object idx
, newelt
;
1829 register int idxval
;
1831 CHECK_NUMBER (idx
, 1);
1832 idxval
= XINT (idx
);
1833 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1834 && ! CHAR_TABLE_P (array
))
1835 array
= wrong_type_argument (Qarrayp
, array
);
1836 CHECK_IMPURE (array
);
1838 if (VECTORP (array
))
1840 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1841 args_out_of_range (array
, idx
);
1842 XVECTOR (array
)->contents
[idxval
] = newelt
;
1844 else if (BOOL_VECTOR_P (array
))
1848 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1849 args_out_of_range (array
, idx
);
1851 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1853 if (! NILP (newelt
))
1854 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1856 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1857 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1859 else if (CHAR_TABLE_P (array
))
1862 args_out_of_range (array
, idx
);
1863 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1864 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1870 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1871 if (code
[1] < 32) code
[1] = -1;
1872 else if (code
[2] < 32) code
[2] = -1;
1874 /* See the comment of the corresponding part in Faref. */
1876 code
[3] = -1; /* anchor */
1877 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1879 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1880 if (SUB_CHAR_TABLE_P (val
))
1886 /* VAL is a leaf. Create a sub char table with the
1887 default value VAL or XCHAR_TABLE (array)->defalt
1888 and look into it. */
1890 temp
= make_sub_char_table (NILP (val
)
1891 ? XCHAR_TABLE (array
)->defalt
1893 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1897 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1900 else if (STRING_MULTIBYTE (array
))
1902 int idxval_byte
, new_len
, actual_len
;
1904 unsigned char *p
, workbuf
[MAX_MULTIBYTE_LENGTH
], *str
= workbuf
;
1906 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1907 args_out_of_range (array
, idx
);
1909 idxval_byte
= string_char_to_byte (array
, idxval
);
1910 p
= &XSTRING (array
)->data
[idxval_byte
];
1912 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1913 CHECK_NUMBER (newelt
, 2);
1914 new_len
= CHAR_STRING (XINT (newelt
), str
);
1915 if (actual_len
!= new_len
)
1916 error ("Attempt to change byte length of a string");
1918 /* We can't accept a change causing byte combining. */
1919 if (!ASCII_BYTE_P (*str
)
1920 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1921 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1922 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1923 > idxval_byte
- prev_byte
))
1924 || (idxval
< XSTRING (array
)->size
- 1
1925 && !CHAR_HEAD_P (p
[actual_len
])
1926 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1927 error ("Attempt to change char length of a string");
1933 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1934 args_out_of_range (array
, idx
);
1935 CHECK_NUMBER (newelt
, 2);
1936 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1942 /* Arithmetic functions */
1944 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1947 arithcompare (num1
, num2
, comparison
)
1948 Lisp_Object num1
, num2
;
1949 enum comparison comparison
;
1954 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1955 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1957 if (FLOATP (num1
) || FLOATP (num2
))
1960 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1961 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1967 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1972 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1977 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1982 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1987 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1992 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2001 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2002 "Return t if two args, both numbers or markers, are equal.")
2004 register Lisp_Object num1
, num2
;
2006 return arithcompare (num1
, num2
, equal
);
2009 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2010 "Return t if first arg is less than second arg. Both must be numbers or markers.")
2012 register Lisp_Object num1
, num2
;
2014 return arithcompare (num1
, num2
, less
);
2017 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2018 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
2020 register Lisp_Object num1
, num2
;
2022 return arithcompare (num1
, num2
, grtr
);
2025 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2026 "Return t if first arg is less than or equal to second arg.\n\
2027 Both must be numbers or markers.")
2029 register Lisp_Object num1
, num2
;
2031 return arithcompare (num1
, num2
, less_or_equal
);
2034 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2035 "Return t if first arg is greater than or equal to second arg.\n\
2036 Both must be numbers or markers.")
2038 register Lisp_Object num1
, num2
;
2040 return arithcompare (num1
, num2
, grtr_or_equal
);
2043 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2044 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
2046 register Lisp_Object num1
, num2
;
2048 return arithcompare (num1
, num2
, notequal
);
2051 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2053 register Lisp_Object number
;
2055 CHECK_NUMBER_OR_FLOAT (number
, 0);
2057 if (FLOATP (number
))
2059 if (XFLOAT_DATA (number
) == 0.0)
2069 /* Convert between long values and pairs of Lisp integers. */
2075 unsigned int top
= i
>> 16;
2076 unsigned int bot
= i
& 0xFFFF;
2078 return make_number (bot
);
2079 if (top
== (unsigned long)-1 >> 16)
2080 return Fcons (make_number (-1), make_number (bot
));
2081 return Fcons (make_number (top
), make_number (bot
));
2088 Lisp_Object top
, bot
;
2095 return ((XINT (top
) << 16) | XINT (bot
));
2098 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2099 "Convert NUMBER to a string by printing it in decimal.\n\
2100 Uses a minus sign if negative.\n\
2101 NUMBER may be an integer or a floating point number.")
2105 char buffer
[VALBITS
];
2107 CHECK_NUMBER_OR_FLOAT (number
, 0);
2109 if (FLOATP (number
))
2111 char pigbuf
[350]; /* see comments in float_to_string */
2113 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2114 return build_string (pigbuf
);
2117 if (sizeof (int) == sizeof (EMACS_INT
))
2118 sprintf (buffer
, "%d", XINT (number
));
2119 else if (sizeof (long) == sizeof (EMACS_INT
))
2120 sprintf (buffer
, "%ld", (long) XINT (number
));
2123 return build_string (buffer
);
2127 digit_to_number (character
, base
)
2128 int character
, base
;
2132 if (character
>= '0' && character
<= '9')
2133 digit
= character
- '0';
2134 else if (character
>= 'a' && character
<= 'z')
2135 digit
= character
- 'a' + 10;
2136 else if (character
>= 'A' && character
<= 'Z')
2137 digit
= character
- 'A' + 10;
2147 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2148 "Convert STRING to a number by parsing it as a decimal number.\n\
2149 This parses both integers and floating point numbers.\n\
2150 It ignores leading spaces and tabs.\n\
2152 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2153 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2154 If the base used is not 10, floating point is not recognized.")
2156 register Lisp_Object string
, base
;
2158 register unsigned char *p
;
2163 CHECK_STRING (string
, 0);
2169 CHECK_NUMBER (base
, 1);
2171 if (b
< 2 || b
> 16)
2172 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2175 /* Skip any whitespace at the front of the number. Some versions of
2176 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2177 p
= XSTRING (string
)->data
;
2178 while (*p
== ' ' || *p
== '\t')
2189 if (isfloat_string (p
) && b
== 10)
2190 val
= make_float (sign
* atof (p
));
2197 int digit
= digit_to_number (*p
++, b
);
2203 if (v
> (EMACS_UINT
) (VALMASK
>> 1))
2204 val
= make_float (sign
* v
);
2206 val
= make_number (sign
* (int) v
);
2214 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2216 extern Lisp_Object
float_arith_driver ();
2217 extern Lisp_Object
fmod_float ();
2220 arith_driver (code
, nargs
, args
)
2223 register Lisp_Object
*args
;
2225 register Lisp_Object val
;
2226 register int argnum
;
2227 register EMACS_INT accum
;
2228 register EMACS_INT next
;
2230 switch (SWITCH_ENUM_CAST (code
))
2243 for (argnum
= 0; argnum
< nargs
; argnum
++)
2245 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2246 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2248 if (FLOATP (val
)) /* time to do serious math */
2249 return (float_arith_driver ((double) accum
, argnum
, code
,
2251 args
[argnum
] = val
; /* runs into a compiler bug. */
2252 next
= XINT (args
[argnum
]);
2253 switch (SWITCH_ENUM_CAST (code
))
2255 case Aadd
: accum
+= next
; break;
2257 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2259 case Amult
: accum
*= next
; break;
2261 if (!argnum
) accum
= next
;
2265 Fsignal (Qarith_error
, Qnil
);
2269 case Alogand
: accum
&= next
; break;
2270 case Alogior
: accum
|= next
; break;
2271 case Alogxor
: accum
^= next
; break;
2272 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2273 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2277 XSETINT (val
, accum
);
2282 #define isnan(x) ((x) != (x))
2285 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2287 register int argnum
;
2290 register Lisp_Object
*args
;
2292 register Lisp_Object val
;
2295 for (; argnum
< nargs
; argnum
++)
2297 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2298 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2302 next
= XFLOAT_DATA (val
);
2306 args
[argnum
] = val
; /* runs into a compiler bug. */
2307 next
= XINT (args
[argnum
]);
2309 switch (SWITCH_ENUM_CAST (code
))
2315 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2325 if (! IEEE_FLOATING_POINT
&& next
== 0)
2326 Fsignal (Qarith_error
, Qnil
);
2333 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2335 if (!argnum
|| isnan (next
) || next
> accum
)
2339 if (!argnum
|| isnan (next
) || next
< accum
)
2345 return make_float (accum
);
2349 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2350 "Return sum of any number of arguments, which are numbers or markers.")
2355 return arith_driver (Aadd
, nargs
, args
);
2358 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2359 "Negate number or subtract numbers or markers.\n\
2360 With one arg, negates it. With more than one arg,\n\
2361 subtracts all but the first from the first.")
2366 return arith_driver (Asub
, nargs
, args
);
2369 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2370 "Returns product of any number of arguments, which are numbers or markers.")
2375 return arith_driver (Amult
, nargs
, args
);
2378 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2379 "Returns first argument divided by all the remaining arguments.\n\
2380 The arguments must be numbers or markers.")
2385 return arith_driver (Adiv
, nargs
, args
);
2388 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2389 "Returns remainder of X divided by Y.\n\
2390 Both must be integers or markers.")
2392 register Lisp_Object x
, y
;
2396 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2397 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2399 if (XFASTINT (y
) == 0)
2400 Fsignal (Qarith_error
, Qnil
);
2402 XSETINT (val
, XINT (x
) % XINT (y
));
2416 /* If the magnitude of the result exceeds that of the divisor, or
2417 the sign of the result does not agree with that of the dividend,
2418 iterate with the reduced value. This does not yield a
2419 particularly accurate result, but at least it will be in the
2420 range promised by fmod. */
2422 r
-= f2
* floor (r
/ f2
);
2423 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2427 #endif /* ! HAVE_FMOD */
2429 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2430 "Returns X modulo Y.\n\
2431 The result falls between zero (inclusive) and Y (exclusive).\n\
2432 Both X and Y must be numbers or markers.")
2434 register Lisp_Object x
, y
;
2439 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2440 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2442 if (FLOATP (x
) || FLOATP (y
))
2443 return fmod_float (x
, y
);
2449 Fsignal (Qarith_error
, Qnil
);
2453 /* If the "remainder" comes out with the wrong sign, fix it. */
2454 if (i2
< 0 ? i1
> 0 : i1
< 0)
2461 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2462 "Return largest of all the arguments (which must be numbers or markers).\n\
2463 The value is always a number; markers are converted to numbers.")
2468 return arith_driver (Amax
, nargs
, args
);
2471 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2472 "Return smallest of all the arguments (which must be numbers or markers).\n\
2473 The value is always a number; markers are converted to numbers.")
2478 return arith_driver (Amin
, nargs
, args
);
2481 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2482 "Return bitwise-and of all the arguments.\n\
2483 Arguments may be integers, or markers converted to integers.")
2488 return arith_driver (Alogand
, nargs
, args
);
2491 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2492 "Return bitwise-or of all the arguments.\n\
2493 Arguments may be integers, or markers converted to integers.")
2498 return arith_driver (Alogior
, nargs
, args
);
2501 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2502 "Return bitwise-exclusive-or of all the arguments.\n\
2503 Arguments may be integers, or markers converted to integers.")
2508 return arith_driver (Alogxor
, nargs
, args
);
2511 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2512 "Return VALUE with its bits shifted left by COUNT.\n\
2513 If COUNT is negative, shifting is actually to the right.\n\
2514 In this case, the sign bit is duplicated.")
2516 register Lisp_Object value
, count
;
2518 register Lisp_Object val
;
2520 CHECK_NUMBER (value
, 0);
2521 CHECK_NUMBER (count
, 1);
2523 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2525 else if (XINT (count
) > 0)
2526 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2527 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2528 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2530 XSETINT (val
, XINT (value
) >> -XINT (count
));
2534 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2535 "Return VALUE with its bits shifted left by COUNT.\n\
2536 If COUNT is negative, shifting is actually to the right.\n\
2537 In this case, zeros are shifted in on the left.")
2539 register Lisp_Object value
, count
;
2541 register Lisp_Object val
;
2543 CHECK_NUMBER (value
, 0);
2544 CHECK_NUMBER (count
, 1);
2546 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2548 else if (XINT (count
) > 0)
2549 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2550 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2553 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2557 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2558 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2559 Markers are converted to integers.")
2561 register Lisp_Object number
;
2563 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2565 if (FLOATP (number
))
2566 return (make_float (1.0 + XFLOAT_DATA (number
)));
2568 XSETINT (number
, XINT (number
) + 1);
2572 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2573 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2574 Markers are converted to integers.")
2576 register Lisp_Object number
;
2578 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2580 if (FLOATP (number
))
2581 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2583 XSETINT (number
, XINT (number
) - 1);
2587 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2588 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2590 register Lisp_Object number
;
2592 CHECK_NUMBER (number
, 0);
2593 XSETINT (number
, ~XINT (number
));
2600 Lisp_Object error_tail
, arith_tail
;
2602 Qquote
= intern ("quote");
2603 Qlambda
= intern ("lambda");
2604 Qsubr
= intern ("subr");
2605 Qerror_conditions
= intern ("error-conditions");
2606 Qerror_message
= intern ("error-message");
2607 Qtop_level
= intern ("top-level");
2609 Qerror
= intern ("error");
2610 Qquit
= intern ("quit");
2611 Qwrong_type_argument
= intern ("wrong-type-argument");
2612 Qargs_out_of_range
= intern ("args-out-of-range");
2613 Qvoid_function
= intern ("void-function");
2614 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2615 Qvoid_variable
= intern ("void-variable");
2616 Qsetting_constant
= intern ("setting-constant");
2617 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2619 Qinvalid_function
= intern ("invalid-function");
2620 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2621 Qno_catch
= intern ("no-catch");
2622 Qend_of_file
= intern ("end-of-file");
2623 Qarith_error
= intern ("arith-error");
2624 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2625 Qend_of_buffer
= intern ("end-of-buffer");
2626 Qbuffer_read_only
= intern ("buffer-read-only");
2627 Qtext_read_only
= intern ("text-read-only");
2628 Qmark_inactive
= intern ("mark-inactive");
2630 Qlistp
= intern ("listp");
2631 Qconsp
= intern ("consp");
2632 Qsymbolp
= intern ("symbolp");
2633 Qkeywordp
= intern ("keywordp");
2634 Qintegerp
= intern ("integerp");
2635 Qnatnump
= intern ("natnump");
2636 Qwholenump
= intern ("wholenump");
2637 Qstringp
= intern ("stringp");
2638 Qarrayp
= intern ("arrayp");
2639 Qsequencep
= intern ("sequencep");
2640 Qbufferp
= intern ("bufferp");
2641 Qvectorp
= intern ("vectorp");
2642 Qchar_or_string_p
= intern ("char-or-string-p");
2643 Qmarkerp
= intern ("markerp");
2644 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2645 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2646 Qboundp
= intern ("boundp");
2647 Qfboundp
= intern ("fboundp");
2649 Qfloatp
= intern ("floatp");
2650 Qnumberp
= intern ("numberp");
2651 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2653 Qchar_table_p
= intern ("char-table-p");
2654 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2656 Qsubrp
= intern ("subrp");
2657 Qunevalled
= intern ("unevalled");
2658 Qmany
= intern ("many");
2660 Qcdr
= intern ("cdr");
2662 /* Handle automatic advice activation */
2663 Qad_advice_info
= intern ("ad-advice-info");
2664 Qad_activate_internal
= intern ("ad-activate-internal");
2666 error_tail
= Fcons (Qerror
, Qnil
);
2668 /* ERROR is used as a signaler for random errors for which nothing else is right */
2670 Fput (Qerror
, Qerror_conditions
,
2672 Fput (Qerror
, Qerror_message
,
2673 build_string ("error"));
2675 Fput (Qquit
, Qerror_conditions
,
2676 Fcons (Qquit
, Qnil
));
2677 Fput (Qquit
, Qerror_message
,
2678 build_string ("Quit"));
2680 Fput (Qwrong_type_argument
, Qerror_conditions
,
2681 Fcons (Qwrong_type_argument
, error_tail
));
2682 Fput (Qwrong_type_argument
, Qerror_message
,
2683 build_string ("Wrong type argument"));
2685 Fput (Qargs_out_of_range
, Qerror_conditions
,
2686 Fcons (Qargs_out_of_range
, error_tail
));
2687 Fput (Qargs_out_of_range
, Qerror_message
,
2688 build_string ("Args out of range"));
2690 Fput (Qvoid_function
, Qerror_conditions
,
2691 Fcons (Qvoid_function
, error_tail
));
2692 Fput (Qvoid_function
, Qerror_message
,
2693 build_string ("Symbol's function definition is void"));
2695 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2696 Fcons (Qcyclic_function_indirection
, error_tail
));
2697 Fput (Qcyclic_function_indirection
, Qerror_message
,
2698 build_string ("Symbol's chain of function indirections contains a loop"));
2700 Fput (Qvoid_variable
, Qerror_conditions
,
2701 Fcons (Qvoid_variable
, error_tail
));
2702 Fput (Qvoid_variable
, Qerror_message
,
2703 build_string ("Symbol's value as variable is void"));
2705 Fput (Qsetting_constant
, Qerror_conditions
,
2706 Fcons (Qsetting_constant
, error_tail
));
2707 Fput (Qsetting_constant
, Qerror_message
,
2708 build_string ("Attempt to set a constant symbol"));
2710 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2711 Fcons (Qinvalid_read_syntax
, error_tail
));
2712 Fput (Qinvalid_read_syntax
, Qerror_message
,
2713 build_string ("Invalid read syntax"));
2715 Fput (Qinvalid_function
, Qerror_conditions
,
2716 Fcons (Qinvalid_function
, error_tail
));
2717 Fput (Qinvalid_function
, Qerror_message
,
2718 build_string ("Invalid function"));
2720 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2721 Fcons (Qwrong_number_of_arguments
, error_tail
));
2722 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2723 build_string ("Wrong number of arguments"));
2725 Fput (Qno_catch
, Qerror_conditions
,
2726 Fcons (Qno_catch
, error_tail
));
2727 Fput (Qno_catch
, Qerror_message
,
2728 build_string ("No catch for tag"));
2730 Fput (Qend_of_file
, Qerror_conditions
,
2731 Fcons (Qend_of_file
, error_tail
));
2732 Fput (Qend_of_file
, Qerror_message
,
2733 build_string ("End of file during parsing"));
2735 arith_tail
= Fcons (Qarith_error
, error_tail
);
2736 Fput (Qarith_error
, Qerror_conditions
,
2738 Fput (Qarith_error
, Qerror_message
,
2739 build_string ("Arithmetic error"));
2741 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2742 Fcons (Qbeginning_of_buffer
, error_tail
));
2743 Fput (Qbeginning_of_buffer
, Qerror_message
,
2744 build_string ("Beginning of buffer"));
2746 Fput (Qend_of_buffer
, Qerror_conditions
,
2747 Fcons (Qend_of_buffer
, error_tail
));
2748 Fput (Qend_of_buffer
, Qerror_message
,
2749 build_string ("End of buffer"));
2751 Fput (Qbuffer_read_only
, Qerror_conditions
,
2752 Fcons (Qbuffer_read_only
, error_tail
));
2753 Fput (Qbuffer_read_only
, Qerror_message
,
2754 build_string ("Buffer is read-only"));
2756 Fput (Qtext_read_only
, Qerror_conditions
,
2757 Fcons (Qtext_read_only
, error_tail
));
2758 Fput (Qtext_read_only
, Qerror_message
,
2759 build_string ("Text is read-only"));
2761 Qrange_error
= intern ("range-error");
2762 Qdomain_error
= intern ("domain-error");
2763 Qsingularity_error
= intern ("singularity-error");
2764 Qoverflow_error
= intern ("overflow-error");
2765 Qunderflow_error
= intern ("underflow-error");
2767 Fput (Qdomain_error
, Qerror_conditions
,
2768 Fcons (Qdomain_error
, arith_tail
));
2769 Fput (Qdomain_error
, Qerror_message
,
2770 build_string ("Arithmetic domain error"));
2772 Fput (Qrange_error
, Qerror_conditions
,
2773 Fcons (Qrange_error
, arith_tail
));
2774 Fput (Qrange_error
, Qerror_message
,
2775 build_string ("Arithmetic range error"));
2777 Fput (Qsingularity_error
, Qerror_conditions
,
2778 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2779 Fput (Qsingularity_error
, Qerror_message
,
2780 build_string ("Arithmetic singularity error"));
2782 Fput (Qoverflow_error
, Qerror_conditions
,
2783 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2784 Fput (Qoverflow_error
, Qerror_message
,
2785 build_string ("Arithmetic overflow error"));
2787 Fput (Qunderflow_error
, Qerror_conditions
,
2788 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2789 Fput (Qunderflow_error
, Qerror_message
,
2790 build_string ("Arithmetic underflow error"));
2792 staticpro (&Qrange_error
);
2793 staticpro (&Qdomain_error
);
2794 staticpro (&Qsingularity_error
);
2795 staticpro (&Qoverflow_error
);
2796 staticpro (&Qunderflow_error
);
2800 staticpro (&Qquote
);
2801 staticpro (&Qlambda
);
2803 staticpro (&Qunbound
);
2804 staticpro (&Qerror_conditions
);
2805 staticpro (&Qerror_message
);
2806 staticpro (&Qtop_level
);
2808 staticpro (&Qerror
);
2810 staticpro (&Qwrong_type_argument
);
2811 staticpro (&Qargs_out_of_range
);
2812 staticpro (&Qvoid_function
);
2813 staticpro (&Qcyclic_function_indirection
);
2814 staticpro (&Qvoid_variable
);
2815 staticpro (&Qsetting_constant
);
2816 staticpro (&Qinvalid_read_syntax
);
2817 staticpro (&Qwrong_number_of_arguments
);
2818 staticpro (&Qinvalid_function
);
2819 staticpro (&Qno_catch
);
2820 staticpro (&Qend_of_file
);
2821 staticpro (&Qarith_error
);
2822 staticpro (&Qbeginning_of_buffer
);
2823 staticpro (&Qend_of_buffer
);
2824 staticpro (&Qbuffer_read_only
);
2825 staticpro (&Qtext_read_only
);
2826 staticpro (&Qmark_inactive
);
2828 staticpro (&Qlistp
);
2829 staticpro (&Qconsp
);
2830 staticpro (&Qsymbolp
);
2831 staticpro (&Qkeywordp
);
2832 staticpro (&Qintegerp
);
2833 staticpro (&Qnatnump
);
2834 staticpro (&Qwholenump
);
2835 staticpro (&Qstringp
);
2836 staticpro (&Qarrayp
);
2837 staticpro (&Qsequencep
);
2838 staticpro (&Qbufferp
);
2839 staticpro (&Qvectorp
);
2840 staticpro (&Qchar_or_string_p
);
2841 staticpro (&Qmarkerp
);
2842 staticpro (&Qbuffer_or_string_p
);
2843 staticpro (&Qinteger_or_marker_p
);
2844 staticpro (&Qfloatp
);
2845 staticpro (&Qnumberp
);
2846 staticpro (&Qnumber_or_marker_p
);
2847 staticpro (&Qchar_table_p
);
2848 staticpro (&Qvector_or_char_table_p
);
2849 staticpro (&Qsubrp
);
2851 staticpro (&Qunevalled
);
2853 staticpro (&Qboundp
);
2854 staticpro (&Qfboundp
);
2856 staticpro (&Qad_advice_info
);
2857 staticpro (&Qad_activate_internal
);
2859 /* Types that type-of returns. */
2860 Qinteger
= intern ("integer");
2861 Qsymbol
= intern ("symbol");
2862 Qstring
= intern ("string");
2863 Qcons
= intern ("cons");
2864 Qmarker
= intern ("marker");
2865 Qoverlay
= intern ("overlay");
2866 Qfloat
= intern ("float");
2867 Qwindow_configuration
= intern ("window-configuration");
2868 Qprocess
= intern ("process");
2869 Qwindow
= intern ("window");
2870 /* Qsubr = intern ("subr"); */
2871 Qcompiled_function
= intern ("compiled-function");
2872 Qbuffer
= intern ("buffer");
2873 Qframe
= intern ("frame");
2874 Qvector
= intern ("vector");
2875 Qchar_table
= intern ("char-table");
2876 Qbool_vector
= intern ("bool-vector");
2877 Qhash_table
= intern ("hash-table");
2879 staticpro (&Qinteger
);
2880 staticpro (&Qsymbol
);
2881 staticpro (&Qstring
);
2883 staticpro (&Qmarker
);
2884 staticpro (&Qoverlay
);
2885 staticpro (&Qfloat
);
2886 staticpro (&Qwindow_configuration
);
2887 staticpro (&Qprocess
);
2888 staticpro (&Qwindow
);
2889 /* staticpro (&Qsubr); */
2890 staticpro (&Qcompiled_function
);
2891 staticpro (&Qbuffer
);
2892 staticpro (&Qframe
);
2893 staticpro (&Qvector
);
2894 staticpro (&Qchar_table
);
2895 staticpro (&Qbool_vector
);
2896 staticpro (&Qhash_table
);
2900 defsubr (&Stype_of
);
2905 defsubr (&Sintegerp
);
2906 defsubr (&Sinteger_or_marker_p
);
2907 defsubr (&Snumberp
);
2908 defsubr (&Snumber_or_marker_p
);
2910 defsubr (&Snatnump
);
2911 defsubr (&Ssymbolp
);
2912 defsubr (&Skeywordp
);
2913 defsubr (&Sstringp
);
2914 defsubr (&Smultibyte_string_p
);
2915 defsubr (&Svectorp
);
2916 defsubr (&Schar_table_p
);
2917 defsubr (&Svector_or_char_table_p
);
2918 defsubr (&Sbool_vector_p
);
2920 defsubr (&Ssequencep
);
2921 defsubr (&Sbufferp
);
2922 defsubr (&Smarkerp
);
2924 defsubr (&Sbyte_code_function_p
);
2925 defsubr (&Schar_or_string_p
);
2928 defsubr (&Scar_safe
);
2929 defsubr (&Scdr_safe
);
2932 defsubr (&Ssymbol_function
);
2933 defsubr (&Sindirect_function
);
2934 defsubr (&Ssymbol_plist
);
2935 defsubr (&Ssymbol_name
);
2936 defsubr (&Smakunbound
);
2937 defsubr (&Sfmakunbound
);
2939 defsubr (&Sfboundp
);
2941 defsubr (&Sdefalias
);
2942 defsubr (&Ssetplist
);
2943 defsubr (&Ssymbol_value
);
2945 defsubr (&Sdefault_boundp
);
2946 defsubr (&Sdefault_value
);
2947 defsubr (&Sset_default
);
2948 defsubr (&Ssetq_default
);
2949 defsubr (&Smake_variable_buffer_local
);
2950 defsubr (&Smake_local_variable
);
2951 defsubr (&Skill_local_variable
);
2952 defsubr (&Smake_variable_frame_local
);
2953 defsubr (&Slocal_variable_p
);
2954 defsubr (&Slocal_variable_if_set_p
);
2957 defsubr (&Snumber_to_string
);
2958 defsubr (&Sstring_to_number
);
2959 defsubr (&Seqlsign
);
2982 defsubr (&Ssubr_arity
);
2984 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2991 #if defined(USG) && !defined(POSIX_SIGNALS)
2992 /* USG systems forget handlers when they are used;
2993 must reestablish each time */
2994 signal (signo
, arith_error
);
2997 /* VMS systems are like USG. */
2998 signal (signo
, arith_error
);
3002 #else /* not BSD4_1 */
3003 sigsetmask (SIGEMPTYMASK
);
3004 #endif /* not BSD4_1 */
3006 Fsignal (Qarith_error
, Qnil
);
3012 /* Don't do this if just dumping out.
3013 We don't want to call `signal' in this case
3014 so that we don't have trouble with dumping
3015 signal-delivering routines in an inconsistent state. */
3019 #endif /* CANNOT_DUMP */
3020 signal (SIGFPE
, arith_error
);
3023 signal (SIGEMT
, arith_error
);