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 CHECK_SYMBOL (symbol
, 0);
1037 if (NILP (symbol
) || EQ (symbol
, Qt
)
1038 || (XSYMBOL (symbol
)->name
->data
[0] == ':'
1039 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
1040 && !EQ (newval
, symbol
)))
1041 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1042 valcontents
= XSYMBOL (symbol
)->value
;
1044 if (BUFFER_OBJFWDP (valcontents
))
1046 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1047 int idx
= PER_BUFFER_IDX (offset
);
1050 && !let_shadows_buffer_binding_p (symbol
))
1051 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1054 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1055 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1057 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1059 /* What binding is loaded right now? */
1060 current_alist_element
1061 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1063 /* If the current buffer is not the buffer whose binding is
1064 loaded, or if there may be frame-local bindings and the frame
1065 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1066 the default binding is loaded, the loaded binding may be the
1068 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1069 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1070 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1071 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1072 || (BUFFER_LOCAL_VALUEP (valcontents
)
1073 && EQ (XCAR (current_alist_element
),
1074 current_alist_element
)))
1076 /* The currently loaded binding is not necessarily valid.
1077 We need to unload it, and choose a new binding. */
1079 /* Write out `realvalue' to the old loaded binding. */
1080 Fsetcdr (current_alist_element
,
1081 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1083 /* Find the new binding. */
1084 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1085 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1086 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1090 /* This buffer still sees the default value. */
1092 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1093 or if this is `let' rather than `set',
1094 make CURRENT-ALIST-ELEMENT point to itself,
1095 indicating that we're seeing the default value.
1096 Likewise if the variable has been let-bound
1097 in the current buffer. */
1098 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1099 || let_shadows_buffer_binding_p (symbol
))
1101 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1103 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1104 tem1
= Fassq (symbol
,
1105 XFRAME (selected_frame
)->param_alist
);
1108 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1110 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1112 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1113 and we're not within a let that was made for this buffer,
1114 create a new buffer-local binding for the variable.
1115 That means, give this buffer a new assoc for a local value
1116 and load that binding. */
1119 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1120 buf
->local_var_alist
1121 = Fcons (tem1
, buf
->local_var_alist
);
1125 /* Record which binding is now loaded. */
1126 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1129 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1130 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1131 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1133 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1136 /* If storing void (making the symbol void), forward only through
1137 buffer-local indicator, not through Lisp_Objfwd, etc. */
1139 store_symval_forwarding (symbol
, Qnil
, newval
);
1141 store_symval_forwarding (symbol
, valcontents
, newval
);
1146 /* Access or set a buffer-local symbol's default value. */
1148 /* Return the default value of SYMBOL, but don't check for voidness.
1149 Return Qunbound if it is void. */
1152 default_value (symbol
)
1155 register Lisp_Object valcontents
;
1157 CHECK_SYMBOL (symbol
, 0);
1158 valcontents
= XSYMBOL (symbol
)->value
;
1160 /* For a built-in buffer-local variable, get the default value
1161 rather than letting do_symval_forwarding get the current value. */
1162 if (BUFFER_OBJFWDP (valcontents
))
1164 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1165 if (PER_BUFFER_IDX (offset
) != 0)
1166 return PER_BUFFER_DEFAULT (offset
);
1169 /* Handle user-created local variables. */
1170 if (BUFFER_LOCAL_VALUEP (valcontents
)
1171 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1173 /* If var is set up for a buffer that lacks a local value for it,
1174 the current value is nominally the default value.
1175 But the `realvalue' slot may be more up to date, since
1176 ordinary setq stores just that slot. So use that. */
1177 Lisp_Object current_alist_element
, alist_element_car
;
1178 current_alist_element
1179 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1180 alist_element_car
= XCAR (current_alist_element
);
1181 if (EQ (alist_element_car
, current_alist_element
))
1182 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1184 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1186 /* For other variables, get the current value. */
1187 return do_symval_forwarding (valcontents
);
1190 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1191 "Return t if SYMBOL has a non-void default value.\n\
1192 This is the value that is seen in buffers that do not have their own values\n\
1193 for this variable.")
1197 register Lisp_Object value
;
1199 value
= default_value (symbol
);
1200 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1203 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1204 "Return SYMBOL's default value.\n\
1205 This is the value that is seen in buffers that do not have their own values\n\
1206 for this variable. The default value is meaningful for variables with\n\
1207 local bindings in certain buffers.")
1211 register Lisp_Object value
;
1213 value
= default_value (symbol
);
1214 if (EQ (value
, Qunbound
))
1215 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1219 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1220 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1221 The default value is seen in buffers that do not have their own values\n\
1222 for this variable.")
1224 Lisp_Object symbol
, value
;
1226 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1228 CHECK_SYMBOL (symbol
, 0);
1229 valcontents
= XSYMBOL (symbol
)->value
;
1231 /* Handle variables like case-fold-search that have special slots
1232 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1234 if (BUFFER_OBJFWDP (valcontents
))
1236 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1237 int idx
= PER_BUFFER_IDX (offset
);
1239 PER_BUFFER_DEFAULT (offset
) = value
;
1241 /* If this variable is not always local in all buffers,
1242 set it in the buffers that don't nominally have a local value. */
1247 for (b
= all_buffers
; b
; b
= b
->next
)
1248 if (!PER_BUFFER_VALUE_P (b
, idx
))
1249 PER_BUFFER_VALUE (b
, offset
) = value
;
1254 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1255 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1256 return Fset (symbol
, value
);
1258 /* Store new value into the DEFAULT-VALUE slot. */
1259 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1261 /* If the default binding is now loaded, set the REALVALUE slot too. */
1262 current_alist_element
1263 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1264 alist_element_buffer
= Fcar (current_alist_element
);
1265 if (EQ (alist_element_buffer
, current_alist_element
))
1266 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1272 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1273 "Set the default value of variable VAR to VALUE.\n\
1274 VAR, the variable name, is literal (not evaluated);\n\
1275 VALUE is an expression and it is evaluated.\n\
1276 The default value of a variable is seen in buffers\n\
1277 that do not have their own values for the variable.\n\
1279 More generally, you can use multiple variables and values, as in\n\
1280 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1281 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1282 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1287 register Lisp_Object args_left
;
1288 register Lisp_Object val
, symbol
;
1289 struct gcpro gcpro1
;
1299 val
= Feval (Fcar (Fcdr (args_left
)));
1300 symbol
= Fcar (args_left
);
1301 Fset_default (symbol
, val
);
1302 args_left
= Fcdr (Fcdr (args_left
));
1304 while (!NILP (args_left
));
1310 /* Lisp functions for creating and removing buffer-local variables. */
1312 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1313 1, 1, "vMake Variable Buffer Local: ",
1314 "Make VARIABLE become buffer-local whenever it is set.\n\
1315 At any time, the value for the current buffer is in effect,\n\
1316 unless the variable has never been set in this buffer,\n\
1317 in which case the default value is in effect.\n\
1318 Note that binding the variable with `let', or setting it while\n\
1319 a `let'-style binding made in this buffer is in effect,\n\
1320 does not make the variable buffer-local.\n\
1322 The function `default-value' gets the default value and `set-default' sets it.")
1324 register Lisp_Object variable
;
1326 register Lisp_Object tem
, valcontents
, newval
;
1328 CHECK_SYMBOL (variable
, 0);
1330 valcontents
= XSYMBOL (variable
)->value
;
1331 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1332 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1334 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1336 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1338 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1341 if (EQ (valcontents
, Qunbound
))
1342 XSYMBOL (variable
)->value
= Qnil
;
1343 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1345 newval
= allocate_misc ();
1346 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1347 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1348 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1349 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1350 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1351 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1352 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1353 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1354 XSYMBOL (variable
)->value
= newval
;
1358 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1359 1, 1, "vMake Local Variable: ",
1360 "Make VARIABLE have a separate value in the current buffer.\n\
1361 Other buffers will continue to share a common default value.\n\
1362 \(The buffer-local value of VARIABLE starts out as the same value\n\
1363 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1364 See also `make-variable-buffer-local'.\n\
1366 If the variable is already arranged to become local when set,\n\
1367 this function causes a local value to exist for this buffer,\n\
1368 just as setting the variable would do.\n\
1370 This function returns VARIABLE, and therefore\n\
1371 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1374 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1375 Use `make-local-hook' instead.")
1377 register Lisp_Object variable
;
1379 register Lisp_Object tem
, valcontents
;
1381 CHECK_SYMBOL (variable
, 0);
1383 valcontents
= XSYMBOL (variable
)->value
;
1384 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1385 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1387 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1389 tem
= Fboundp (variable
);
1391 /* Make sure the symbol has a local value in this particular buffer,
1392 by setting it to the same value it already has. */
1393 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1396 /* Make sure symbol is set up to hold per-buffer values. */
1397 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1400 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1402 newval
= allocate_misc ();
1403 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1404 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1405 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1406 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1407 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1408 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1409 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1410 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1411 XSYMBOL (variable
)->value
= newval
;
1413 /* Make sure this buffer has its own value of symbol. */
1414 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1417 /* Swap out any local binding for some other buffer, and make
1418 sure the current value is permanently recorded, if it's the
1420 find_symbol_value (variable
);
1422 current_buffer
->local_var_alist
1423 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)),
1424 current_buffer
->local_var_alist
);
1426 /* Make sure symbol does not think it is set up for this buffer;
1427 force it to look once again for this buffer's value. */
1429 Lisp_Object
*pvalbuf
;
1431 valcontents
= XSYMBOL (variable
)->value
;
1433 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1434 if (current_buffer
== XBUFFER (*pvalbuf
))
1436 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1440 /* If the symbol forwards into a C variable, then load the binding
1441 for this buffer now. If C code modifies the variable before we
1442 load the binding in, then that new value will clobber the default
1443 binding the next time we unload it. */
1444 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->realvalue
;
1445 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1446 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1451 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1452 1, 1, "vKill Local Variable: ",
1453 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1454 From now on the default value will apply in this buffer.")
1456 register Lisp_Object variable
;
1458 register Lisp_Object tem
, valcontents
;
1460 CHECK_SYMBOL (variable
, 0);
1462 valcontents
= XSYMBOL (variable
)->value
;
1464 if (BUFFER_OBJFWDP (valcontents
))
1466 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1467 int idx
= PER_BUFFER_IDX (offset
);
1471 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1472 PER_BUFFER_VALUE (current_buffer
, offset
)
1473 = PER_BUFFER_DEFAULT (offset
);
1478 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1479 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1482 /* Get rid of this buffer's alist element, if any. */
1484 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1486 current_buffer
->local_var_alist
1487 = Fdelq (tem
, current_buffer
->local_var_alist
);
1489 /* If the symbol is set up with the current buffer's binding
1490 loaded, recompute its value. We have to do it now, or else
1491 forwarded objects won't work right. */
1493 Lisp_Object
*pvalbuf
;
1494 valcontents
= XSYMBOL (variable
)->value
;
1495 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1496 if (current_buffer
== XBUFFER (*pvalbuf
))
1499 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1500 find_symbol_value (variable
);
1507 /* Lisp functions for creating and removing buffer-local variables. */
1509 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1510 1, 1, "vMake Variable Frame Local: ",
1511 "Enable VARIABLE to have frame-local bindings.\n\
1512 When a frame-local binding exists in the current frame,\n\
1513 it is in effect whenever the current buffer has no buffer-local binding.\n\
1514 A frame-local binding is actual a frame parameter value;\n\
1515 thus, any given frame has a local binding for VARIABLE\n\
1516 if it has a value for the frame parameter named VARIABLE.\n\
1517 See `modify-frame-parameters'.")
1519 register Lisp_Object variable
;
1521 register Lisp_Object tem
, valcontents
, newval
;
1523 CHECK_SYMBOL (variable
, 0);
1525 valcontents
= XSYMBOL (variable
)->value
;
1526 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1527 || BUFFER_OBJFWDP (valcontents
))
1528 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1530 if (BUFFER_LOCAL_VALUEP (valcontents
)
1531 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1533 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1537 if (EQ (valcontents
, Qunbound
))
1538 XSYMBOL (variable
)->value
= Qnil
;
1539 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1541 newval
= allocate_misc ();
1542 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1543 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= XSYMBOL (variable
)->value
;
1544 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1545 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1546 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1547 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1548 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1549 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1550 XSYMBOL (variable
)->value
= newval
;
1554 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1556 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1557 BUFFER defaults to the current buffer.")
1559 register Lisp_Object variable
, buffer
;
1561 Lisp_Object valcontents
;
1562 register struct buffer
*buf
;
1565 buf
= current_buffer
;
1568 CHECK_BUFFER (buffer
, 0);
1569 buf
= XBUFFER (buffer
);
1572 CHECK_SYMBOL (variable
, 0);
1574 valcontents
= XSYMBOL (variable
)->value
;
1575 if (BUFFER_LOCAL_VALUEP (valcontents
)
1576 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1578 Lisp_Object tail
, elt
;
1579 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1582 if (EQ (variable
, XCAR (elt
)))
1586 if (BUFFER_OBJFWDP (valcontents
))
1588 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1589 int idx
= PER_BUFFER_IDX (offset
);
1590 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1596 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1598 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1599 BUFFER defaults to the current buffer.")
1601 register Lisp_Object variable
, buffer
;
1603 Lisp_Object valcontents
;
1604 register struct buffer
*buf
;
1607 buf
= current_buffer
;
1610 CHECK_BUFFER (buffer
, 0);
1611 buf
= XBUFFER (buffer
);
1614 CHECK_SYMBOL (variable
, 0);
1616 valcontents
= XSYMBOL (variable
)->value
;
1618 /* This means that make-variable-buffer-local was done. */
1619 if (BUFFER_LOCAL_VALUEP (valcontents
))
1621 /* All these slots become local if they are set. */
1622 if (BUFFER_OBJFWDP (valcontents
))
1624 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1626 Lisp_Object tail
, elt
;
1627 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1630 if (EQ (variable
, XCAR (elt
)))
1637 /* Find the function at the end of a chain of symbol function indirections. */
1639 /* If OBJECT is a symbol, find the end of its function chain and
1640 return the value found there. If OBJECT is not a symbol, just
1641 return it. If there is a cycle in the function chain, signal a
1642 cyclic-function-indirection error.
1644 This is like Findirect_function, except that it doesn't signal an
1645 error if the chain ends up unbound. */
1647 indirect_function (object
)
1648 register Lisp_Object object
;
1650 Lisp_Object tortoise
, hare
;
1652 hare
= tortoise
= object
;
1656 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1658 hare
= XSYMBOL (hare
)->function
;
1659 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1661 hare
= XSYMBOL (hare
)->function
;
1663 tortoise
= XSYMBOL (tortoise
)->function
;
1665 if (EQ (hare
, tortoise
))
1666 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1672 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1673 "Return the function at the end of OBJECT's function chain.\n\
1674 If OBJECT is a symbol, follow all function indirections and return the final\n\
1675 function binding.\n\
1676 If OBJECT is not a symbol, just return it.\n\
1677 Signal a void-function error if the final symbol is unbound.\n\
1678 Signal a cyclic-function-indirection error if there is a loop in the\n\
1679 function chain of symbols.")
1681 register Lisp_Object object
;
1685 result
= indirect_function (object
);
1687 if (EQ (result
, Qunbound
))
1688 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1692 /* Extract and set vector and string elements */
1694 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1695 "Return the element of ARRAY at index IDX.\n\
1696 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1697 or a byte-code object. IDX starts at 0.")
1699 register Lisp_Object array
;
1702 register int idxval
;
1704 CHECK_NUMBER (idx
, 1);
1705 idxval
= XINT (idx
);
1706 if (STRINGP (array
))
1710 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1711 args_out_of_range (array
, idx
);
1712 if (! STRING_MULTIBYTE (array
))
1713 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1714 idxval_byte
= string_char_to_byte (array
, idxval
);
1716 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1717 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1718 return make_number (c
);
1720 else if (BOOL_VECTOR_P (array
))
1724 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1725 args_out_of_range (array
, idx
);
1727 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1728 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1730 else if (CHAR_TABLE_P (array
))
1735 args_out_of_range (array
, idx
);
1736 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1738 /* For ASCII and 8-bit European characters, the element is
1739 stored in the top table. */
1740 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1742 val
= XCHAR_TABLE (array
)->defalt
;
1743 while (NILP (val
)) /* Follow parents until we find some value. */
1745 array
= XCHAR_TABLE (array
)->parent
;
1748 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1750 val
= XCHAR_TABLE (array
)->defalt
;
1757 Lisp_Object sub_table
;
1759 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1760 if (code
[1] < 32) code
[1] = -1;
1761 else if (code
[2] < 32) code
[2] = -1;
1763 /* Here, the possible range of CODE[0] (== charset ID) is
1764 128..MAX_CHARSET. Since the top level char table contains
1765 data for multibyte characters after 256th element, we must
1766 increment CODE[0] by 128 to get a correct index. */
1768 code
[3] = -1; /* anchor */
1770 try_parent_char_table
:
1772 for (i
= 0; code
[i
] >= 0; i
++)
1774 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1775 if (SUB_CHAR_TABLE_P (val
))
1780 val
= XCHAR_TABLE (sub_table
)->defalt
;
1783 array
= XCHAR_TABLE (array
)->parent
;
1785 goto try_parent_char_table
;
1790 /* Here, VAL is a sub char table. We try the default value
1792 val
= XCHAR_TABLE (val
)->defalt
;
1795 array
= XCHAR_TABLE (array
)->parent
;
1797 goto try_parent_char_table
;
1805 if (VECTORP (array
))
1806 size
= XVECTOR (array
)->size
;
1807 else if (COMPILEDP (array
))
1808 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1810 wrong_type_argument (Qarrayp
, array
);
1812 if (idxval
< 0 || idxval
>= size
)
1813 args_out_of_range (array
, idx
);
1814 return XVECTOR (array
)->contents
[idxval
];
1818 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1819 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1820 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1822 (array
, idx
, newelt
)
1823 register Lisp_Object array
;
1824 Lisp_Object idx
, newelt
;
1826 register int idxval
;
1828 CHECK_NUMBER (idx
, 1);
1829 idxval
= XINT (idx
);
1830 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1831 && ! CHAR_TABLE_P (array
))
1832 array
= wrong_type_argument (Qarrayp
, array
);
1833 CHECK_IMPURE (array
);
1835 if (VECTORP (array
))
1837 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1838 args_out_of_range (array
, idx
);
1839 XVECTOR (array
)->contents
[idxval
] = newelt
;
1841 else if (BOOL_VECTOR_P (array
))
1845 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1846 args_out_of_range (array
, idx
);
1848 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1850 if (! NILP (newelt
))
1851 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1853 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1854 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1856 else if (CHAR_TABLE_P (array
))
1859 args_out_of_range (array
, idx
);
1860 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1861 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1867 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1868 if (code
[1] < 32) code
[1] = -1;
1869 else if (code
[2] < 32) code
[2] = -1;
1871 /* See the comment of the corresponding part in Faref. */
1873 code
[3] = -1; /* anchor */
1874 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1876 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1877 if (SUB_CHAR_TABLE_P (val
))
1883 /* VAL is a leaf. Create a sub char table with the
1884 default value VAL or XCHAR_TABLE (array)->defalt
1885 and look into it. */
1887 temp
= make_sub_char_table (NILP (val
)
1888 ? XCHAR_TABLE (array
)->defalt
1890 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1894 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1897 else if (STRING_MULTIBYTE (array
))
1899 int idxval_byte
, new_len
, actual_len
;
1901 unsigned char *p
, workbuf
[MAX_MULTIBYTE_LENGTH
], *str
= workbuf
;
1903 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1904 args_out_of_range (array
, idx
);
1906 idxval_byte
= string_char_to_byte (array
, idxval
);
1907 p
= &XSTRING (array
)->data
[idxval_byte
];
1909 actual_len
= MULTIBYTE_FORM_LENGTH (p
, STRING_BYTES (XSTRING (array
)));
1910 CHECK_NUMBER (newelt
, 2);
1911 new_len
= CHAR_STRING (XINT (newelt
), str
);
1912 if (actual_len
!= new_len
)
1913 error ("Attempt to change byte length of a string");
1915 /* We can't accept a change causing byte combining. */
1916 if (!ASCII_BYTE_P (*str
)
1917 && ((idxval
> 0 && !CHAR_HEAD_P (*str
)
1918 && (prev_byte
= string_char_to_byte (array
, idxval
- 1),
1919 BYTES_BY_CHAR_HEAD (XSTRING (array
)->data
[prev_byte
])
1920 > idxval_byte
- prev_byte
))
1921 || (idxval
< XSTRING (array
)->size
- 1
1922 && !CHAR_HEAD_P (p
[actual_len
])
1923 && new_len
< BYTES_BY_CHAR_HEAD (*str
))))
1924 error ("Attempt to change char length of a string");
1930 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1931 args_out_of_range (array
, idx
);
1932 CHECK_NUMBER (newelt
, 2);
1933 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1939 /* Arithmetic functions */
1941 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1944 arithcompare (num1
, num2
, comparison
)
1945 Lisp_Object num1
, num2
;
1946 enum comparison comparison
;
1951 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1952 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1954 if (FLOATP (num1
) || FLOATP (num2
))
1957 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
1958 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
1964 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1969 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1974 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1979 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1984 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1989 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1998 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1999 "Return t if two args, both numbers or markers, are equal.")
2001 register Lisp_Object num1
, num2
;
2003 return arithcompare (num1
, num2
, equal
);
2006 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2007 "Return t if first arg is less than second arg. Both must be numbers or markers.")
2009 register Lisp_Object num1
, num2
;
2011 return arithcompare (num1
, num2
, less
);
2014 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2015 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
2017 register Lisp_Object num1
, num2
;
2019 return arithcompare (num1
, num2
, grtr
);
2022 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2023 "Return t if first arg is less than or equal to second arg.\n\
2024 Both must be numbers or markers.")
2026 register Lisp_Object num1
, num2
;
2028 return arithcompare (num1
, num2
, less_or_equal
);
2031 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2032 "Return t if first arg is greater than or equal to second arg.\n\
2033 Both must be numbers or markers.")
2035 register Lisp_Object num1
, num2
;
2037 return arithcompare (num1
, num2
, grtr_or_equal
);
2040 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2041 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
2043 register Lisp_Object num1
, num2
;
2045 return arithcompare (num1
, num2
, notequal
);
2048 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2050 register Lisp_Object number
;
2052 CHECK_NUMBER_OR_FLOAT (number
, 0);
2054 if (FLOATP (number
))
2056 if (XFLOAT_DATA (number
) == 0.0)
2066 /* Convert between long values and pairs of Lisp integers. */
2072 unsigned int top
= i
>> 16;
2073 unsigned int bot
= i
& 0xFFFF;
2075 return make_number (bot
);
2076 if (top
== (unsigned long)-1 >> 16)
2077 return Fcons (make_number (-1), make_number (bot
));
2078 return Fcons (make_number (top
), make_number (bot
));
2085 Lisp_Object top
, bot
;
2092 return ((XINT (top
) << 16) | XINT (bot
));
2095 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2096 "Convert NUMBER to a string by printing it in decimal.\n\
2097 Uses a minus sign if negative.\n\
2098 NUMBER may be an integer or a floating point number.")
2102 char buffer
[VALBITS
];
2104 CHECK_NUMBER_OR_FLOAT (number
, 0);
2106 if (FLOATP (number
))
2108 char pigbuf
[350]; /* see comments in float_to_string */
2110 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2111 return build_string (pigbuf
);
2114 if (sizeof (int) == sizeof (EMACS_INT
))
2115 sprintf (buffer
, "%d", XINT (number
));
2116 else if (sizeof (long) == sizeof (EMACS_INT
))
2117 sprintf (buffer
, "%ld", (long) XINT (number
));
2120 return build_string (buffer
);
2124 digit_to_number (character
, base
)
2125 int character
, base
;
2129 if (character
>= '0' && character
<= '9')
2130 digit
= character
- '0';
2131 else if (character
>= 'a' && character
<= 'z')
2132 digit
= character
- 'a' + 10;
2133 else if (character
>= 'A' && character
<= 'Z')
2134 digit
= character
- 'A' + 10;
2144 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2145 "Convert STRING to a number by parsing it as a decimal number.\n\
2146 This parses both integers and floating point numbers.\n\
2147 It ignores leading spaces and tabs.\n\
2149 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2150 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2151 If the base used is not 10, floating point is not recognized.")
2153 register Lisp_Object string
, base
;
2155 register unsigned char *p
;
2160 CHECK_STRING (string
, 0);
2166 CHECK_NUMBER (base
, 1);
2168 if (b
< 2 || b
> 16)
2169 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2172 /* Skip any whitespace at the front of the number. Some versions of
2173 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2174 p
= XSTRING (string
)->data
;
2175 while (*p
== ' ' || *p
== '\t')
2186 if (isfloat_string (p
) && b
== 10)
2187 val
= make_float (sign
* atof (p
));
2194 int digit
= digit_to_number (*p
++, b
);
2200 if (v
> (EMACS_UINT
) (VALMASK
>> 1))
2201 val
= make_float (sign
* v
);
2203 val
= make_number (sign
* (int) v
);
2211 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2213 extern Lisp_Object
float_arith_driver ();
2214 extern Lisp_Object
fmod_float ();
2217 arith_driver (code
, nargs
, args
)
2220 register Lisp_Object
*args
;
2222 register Lisp_Object val
;
2223 register int argnum
;
2224 register EMACS_INT accum
;
2225 register EMACS_INT next
;
2227 switch (SWITCH_ENUM_CAST (code
))
2240 for (argnum
= 0; argnum
< nargs
; argnum
++)
2242 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2243 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2245 if (FLOATP (val
)) /* time to do serious math */
2246 return (float_arith_driver ((double) accum
, argnum
, code
,
2248 args
[argnum
] = val
; /* runs into a compiler bug. */
2249 next
= XINT (args
[argnum
]);
2250 switch (SWITCH_ENUM_CAST (code
))
2252 case Aadd
: accum
+= next
; break;
2254 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2256 case Amult
: accum
*= next
; break;
2258 if (!argnum
) accum
= next
;
2262 Fsignal (Qarith_error
, Qnil
);
2266 case Alogand
: accum
&= next
; break;
2267 case Alogior
: accum
|= next
; break;
2268 case Alogxor
: accum
^= next
; break;
2269 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2270 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2274 XSETINT (val
, accum
);
2279 #define isnan(x) ((x) != (x))
2282 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2284 register int argnum
;
2287 register Lisp_Object
*args
;
2289 register Lisp_Object val
;
2292 for (; argnum
< nargs
; argnum
++)
2294 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2295 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2299 next
= XFLOAT_DATA (val
);
2303 args
[argnum
] = val
; /* runs into a compiler bug. */
2304 next
= XINT (args
[argnum
]);
2306 switch (SWITCH_ENUM_CAST (code
))
2312 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2322 if (! IEEE_FLOATING_POINT
&& next
== 0)
2323 Fsignal (Qarith_error
, Qnil
);
2330 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2332 if (!argnum
|| isnan (next
) || next
> accum
)
2336 if (!argnum
|| isnan (next
) || next
< accum
)
2342 return make_float (accum
);
2346 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2347 "Return sum of any number of arguments, which are numbers or markers.")
2352 return arith_driver (Aadd
, nargs
, args
);
2355 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2356 "Negate number or subtract numbers or markers.\n\
2357 With one arg, negates it. With more than one arg,\n\
2358 subtracts all but the first from the first.")
2363 return arith_driver (Asub
, nargs
, args
);
2366 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2367 "Returns product of any number of arguments, which are numbers or markers.")
2372 return arith_driver (Amult
, nargs
, args
);
2375 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2376 "Returns first argument divided by all the remaining arguments.\n\
2377 The arguments must be numbers or markers.")
2382 return arith_driver (Adiv
, nargs
, args
);
2385 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2386 "Returns remainder of X divided by Y.\n\
2387 Both must be integers or markers.")
2389 register Lisp_Object x
, y
;
2393 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2394 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2396 if (XFASTINT (y
) == 0)
2397 Fsignal (Qarith_error
, Qnil
);
2399 XSETINT (val
, XINT (x
) % XINT (y
));
2413 /* If the magnitude of the result exceeds that of the divisor, or
2414 the sign of the result does not agree with that of the dividend,
2415 iterate with the reduced value. This does not yield a
2416 particularly accurate result, but at least it will be in the
2417 range promised by fmod. */
2419 r
-= f2
* floor (r
/ f2
);
2420 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2424 #endif /* ! HAVE_FMOD */
2426 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2427 "Returns X modulo Y.\n\
2428 The result falls between zero (inclusive) and Y (exclusive).\n\
2429 Both X and Y must be numbers or markers.")
2431 register Lisp_Object x
, y
;
2436 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2437 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2439 if (FLOATP (x
) || FLOATP (y
))
2440 return fmod_float (x
, y
);
2446 Fsignal (Qarith_error
, Qnil
);
2450 /* If the "remainder" comes out with the wrong sign, fix it. */
2451 if (i2
< 0 ? i1
> 0 : i1
< 0)
2458 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2459 "Return largest of all the arguments (which must be numbers or markers).\n\
2460 The value is always a number; markers are converted to numbers.")
2465 return arith_driver (Amax
, nargs
, args
);
2468 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2469 "Return smallest of all the arguments (which must be numbers or markers).\n\
2470 The value is always a number; markers are converted to numbers.")
2475 return arith_driver (Amin
, nargs
, args
);
2478 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2479 "Return bitwise-and of all the arguments.\n\
2480 Arguments may be integers, or markers converted to integers.")
2485 return arith_driver (Alogand
, nargs
, args
);
2488 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2489 "Return bitwise-or of all the arguments.\n\
2490 Arguments may be integers, or markers converted to integers.")
2495 return arith_driver (Alogior
, nargs
, args
);
2498 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2499 "Return bitwise-exclusive-or of all the arguments.\n\
2500 Arguments may be integers, or markers converted to integers.")
2505 return arith_driver (Alogxor
, nargs
, args
);
2508 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2509 "Return VALUE with its bits shifted left by COUNT.\n\
2510 If COUNT is negative, shifting is actually to the right.\n\
2511 In this case, the sign bit is duplicated.")
2513 register Lisp_Object value
, count
;
2515 register Lisp_Object val
;
2517 CHECK_NUMBER (value
, 0);
2518 CHECK_NUMBER (count
, 1);
2520 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2522 else if (XINT (count
) > 0)
2523 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2524 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2525 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2527 XSETINT (val
, XINT (value
) >> -XINT (count
));
2531 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2532 "Return VALUE with its bits shifted left by COUNT.\n\
2533 If COUNT is negative, shifting is actually to the right.\n\
2534 In this case, zeros are shifted in on the left.")
2536 register Lisp_Object value
, count
;
2538 register Lisp_Object val
;
2540 CHECK_NUMBER (value
, 0);
2541 CHECK_NUMBER (count
, 1);
2543 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2545 else if (XINT (count
) > 0)
2546 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2547 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2550 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2554 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2555 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2556 Markers are converted to integers.")
2558 register Lisp_Object number
;
2560 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2562 if (FLOATP (number
))
2563 return (make_float (1.0 + XFLOAT_DATA (number
)));
2565 XSETINT (number
, XINT (number
) + 1);
2569 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2570 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2571 Markers are converted to integers.")
2573 register Lisp_Object number
;
2575 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2577 if (FLOATP (number
))
2578 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2580 XSETINT (number
, XINT (number
) - 1);
2584 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2585 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2587 register Lisp_Object number
;
2589 CHECK_NUMBER (number
, 0);
2590 XSETINT (number
, ~XINT (number
));
2597 Lisp_Object error_tail
, arith_tail
;
2599 Qquote
= intern ("quote");
2600 Qlambda
= intern ("lambda");
2601 Qsubr
= intern ("subr");
2602 Qerror_conditions
= intern ("error-conditions");
2603 Qerror_message
= intern ("error-message");
2604 Qtop_level
= intern ("top-level");
2606 Qerror
= intern ("error");
2607 Qquit
= intern ("quit");
2608 Qwrong_type_argument
= intern ("wrong-type-argument");
2609 Qargs_out_of_range
= intern ("args-out-of-range");
2610 Qvoid_function
= intern ("void-function");
2611 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2612 Qvoid_variable
= intern ("void-variable");
2613 Qsetting_constant
= intern ("setting-constant");
2614 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2616 Qinvalid_function
= intern ("invalid-function");
2617 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2618 Qno_catch
= intern ("no-catch");
2619 Qend_of_file
= intern ("end-of-file");
2620 Qarith_error
= intern ("arith-error");
2621 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2622 Qend_of_buffer
= intern ("end-of-buffer");
2623 Qbuffer_read_only
= intern ("buffer-read-only");
2624 Qtext_read_only
= intern ("text-read-only");
2625 Qmark_inactive
= intern ("mark-inactive");
2627 Qlistp
= intern ("listp");
2628 Qconsp
= intern ("consp");
2629 Qsymbolp
= intern ("symbolp");
2630 Qkeywordp
= intern ("keywordp");
2631 Qintegerp
= intern ("integerp");
2632 Qnatnump
= intern ("natnump");
2633 Qwholenump
= intern ("wholenump");
2634 Qstringp
= intern ("stringp");
2635 Qarrayp
= intern ("arrayp");
2636 Qsequencep
= intern ("sequencep");
2637 Qbufferp
= intern ("bufferp");
2638 Qvectorp
= intern ("vectorp");
2639 Qchar_or_string_p
= intern ("char-or-string-p");
2640 Qmarkerp
= intern ("markerp");
2641 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2642 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2643 Qboundp
= intern ("boundp");
2644 Qfboundp
= intern ("fboundp");
2646 Qfloatp
= intern ("floatp");
2647 Qnumberp
= intern ("numberp");
2648 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2650 Qchar_table_p
= intern ("char-table-p");
2651 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2653 Qsubrp
= intern ("subrp");
2654 Qunevalled
= intern ("unevalled");
2655 Qmany
= intern ("many");
2657 Qcdr
= intern ("cdr");
2659 /* Handle automatic advice activation */
2660 Qad_advice_info
= intern ("ad-advice-info");
2661 Qad_activate_internal
= intern ("ad-activate-internal");
2663 error_tail
= Fcons (Qerror
, Qnil
);
2665 /* ERROR is used as a signaler for random errors for which nothing else is right */
2667 Fput (Qerror
, Qerror_conditions
,
2669 Fput (Qerror
, Qerror_message
,
2670 build_string ("error"));
2672 Fput (Qquit
, Qerror_conditions
,
2673 Fcons (Qquit
, Qnil
));
2674 Fput (Qquit
, Qerror_message
,
2675 build_string ("Quit"));
2677 Fput (Qwrong_type_argument
, Qerror_conditions
,
2678 Fcons (Qwrong_type_argument
, error_tail
));
2679 Fput (Qwrong_type_argument
, Qerror_message
,
2680 build_string ("Wrong type argument"));
2682 Fput (Qargs_out_of_range
, Qerror_conditions
,
2683 Fcons (Qargs_out_of_range
, error_tail
));
2684 Fput (Qargs_out_of_range
, Qerror_message
,
2685 build_string ("Args out of range"));
2687 Fput (Qvoid_function
, Qerror_conditions
,
2688 Fcons (Qvoid_function
, error_tail
));
2689 Fput (Qvoid_function
, Qerror_message
,
2690 build_string ("Symbol's function definition is void"));
2692 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2693 Fcons (Qcyclic_function_indirection
, error_tail
));
2694 Fput (Qcyclic_function_indirection
, Qerror_message
,
2695 build_string ("Symbol's chain of function indirections contains a loop"));
2697 Fput (Qvoid_variable
, Qerror_conditions
,
2698 Fcons (Qvoid_variable
, error_tail
));
2699 Fput (Qvoid_variable
, Qerror_message
,
2700 build_string ("Symbol's value as variable is void"));
2702 Fput (Qsetting_constant
, Qerror_conditions
,
2703 Fcons (Qsetting_constant
, error_tail
));
2704 Fput (Qsetting_constant
, Qerror_message
,
2705 build_string ("Attempt to set a constant symbol"));
2707 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2708 Fcons (Qinvalid_read_syntax
, error_tail
));
2709 Fput (Qinvalid_read_syntax
, Qerror_message
,
2710 build_string ("Invalid read syntax"));
2712 Fput (Qinvalid_function
, Qerror_conditions
,
2713 Fcons (Qinvalid_function
, error_tail
));
2714 Fput (Qinvalid_function
, Qerror_message
,
2715 build_string ("Invalid function"));
2717 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2718 Fcons (Qwrong_number_of_arguments
, error_tail
));
2719 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2720 build_string ("Wrong number of arguments"));
2722 Fput (Qno_catch
, Qerror_conditions
,
2723 Fcons (Qno_catch
, error_tail
));
2724 Fput (Qno_catch
, Qerror_message
,
2725 build_string ("No catch for tag"));
2727 Fput (Qend_of_file
, Qerror_conditions
,
2728 Fcons (Qend_of_file
, error_tail
));
2729 Fput (Qend_of_file
, Qerror_message
,
2730 build_string ("End of file during parsing"));
2732 arith_tail
= Fcons (Qarith_error
, error_tail
);
2733 Fput (Qarith_error
, Qerror_conditions
,
2735 Fput (Qarith_error
, Qerror_message
,
2736 build_string ("Arithmetic error"));
2738 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2739 Fcons (Qbeginning_of_buffer
, error_tail
));
2740 Fput (Qbeginning_of_buffer
, Qerror_message
,
2741 build_string ("Beginning of buffer"));
2743 Fput (Qend_of_buffer
, Qerror_conditions
,
2744 Fcons (Qend_of_buffer
, error_tail
));
2745 Fput (Qend_of_buffer
, Qerror_message
,
2746 build_string ("End of buffer"));
2748 Fput (Qbuffer_read_only
, Qerror_conditions
,
2749 Fcons (Qbuffer_read_only
, error_tail
));
2750 Fput (Qbuffer_read_only
, Qerror_message
,
2751 build_string ("Buffer is read-only"));
2753 Fput (Qtext_read_only
, Qerror_conditions
,
2754 Fcons (Qtext_read_only
, error_tail
));
2755 Fput (Qtext_read_only
, Qerror_message
,
2756 build_string ("Text is read-only"));
2758 Qrange_error
= intern ("range-error");
2759 Qdomain_error
= intern ("domain-error");
2760 Qsingularity_error
= intern ("singularity-error");
2761 Qoverflow_error
= intern ("overflow-error");
2762 Qunderflow_error
= intern ("underflow-error");
2764 Fput (Qdomain_error
, Qerror_conditions
,
2765 Fcons (Qdomain_error
, arith_tail
));
2766 Fput (Qdomain_error
, Qerror_message
,
2767 build_string ("Arithmetic domain error"));
2769 Fput (Qrange_error
, Qerror_conditions
,
2770 Fcons (Qrange_error
, arith_tail
));
2771 Fput (Qrange_error
, Qerror_message
,
2772 build_string ("Arithmetic range error"));
2774 Fput (Qsingularity_error
, Qerror_conditions
,
2775 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2776 Fput (Qsingularity_error
, Qerror_message
,
2777 build_string ("Arithmetic singularity error"));
2779 Fput (Qoverflow_error
, Qerror_conditions
,
2780 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2781 Fput (Qoverflow_error
, Qerror_message
,
2782 build_string ("Arithmetic overflow error"));
2784 Fput (Qunderflow_error
, Qerror_conditions
,
2785 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2786 Fput (Qunderflow_error
, Qerror_message
,
2787 build_string ("Arithmetic underflow error"));
2789 staticpro (&Qrange_error
);
2790 staticpro (&Qdomain_error
);
2791 staticpro (&Qsingularity_error
);
2792 staticpro (&Qoverflow_error
);
2793 staticpro (&Qunderflow_error
);
2797 staticpro (&Qquote
);
2798 staticpro (&Qlambda
);
2800 staticpro (&Qunbound
);
2801 staticpro (&Qerror_conditions
);
2802 staticpro (&Qerror_message
);
2803 staticpro (&Qtop_level
);
2805 staticpro (&Qerror
);
2807 staticpro (&Qwrong_type_argument
);
2808 staticpro (&Qargs_out_of_range
);
2809 staticpro (&Qvoid_function
);
2810 staticpro (&Qcyclic_function_indirection
);
2811 staticpro (&Qvoid_variable
);
2812 staticpro (&Qsetting_constant
);
2813 staticpro (&Qinvalid_read_syntax
);
2814 staticpro (&Qwrong_number_of_arguments
);
2815 staticpro (&Qinvalid_function
);
2816 staticpro (&Qno_catch
);
2817 staticpro (&Qend_of_file
);
2818 staticpro (&Qarith_error
);
2819 staticpro (&Qbeginning_of_buffer
);
2820 staticpro (&Qend_of_buffer
);
2821 staticpro (&Qbuffer_read_only
);
2822 staticpro (&Qtext_read_only
);
2823 staticpro (&Qmark_inactive
);
2825 staticpro (&Qlistp
);
2826 staticpro (&Qconsp
);
2827 staticpro (&Qsymbolp
);
2828 staticpro (&Qkeywordp
);
2829 staticpro (&Qintegerp
);
2830 staticpro (&Qnatnump
);
2831 staticpro (&Qwholenump
);
2832 staticpro (&Qstringp
);
2833 staticpro (&Qarrayp
);
2834 staticpro (&Qsequencep
);
2835 staticpro (&Qbufferp
);
2836 staticpro (&Qvectorp
);
2837 staticpro (&Qchar_or_string_p
);
2838 staticpro (&Qmarkerp
);
2839 staticpro (&Qbuffer_or_string_p
);
2840 staticpro (&Qinteger_or_marker_p
);
2841 staticpro (&Qfloatp
);
2842 staticpro (&Qnumberp
);
2843 staticpro (&Qnumber_or_marker_p
);
2844 staticpro (&Qchar_table_p
);
2845 staticpro (&Qvector_or_char_table_p
);
2846 staticpro (&Qsubrp
);
2848 staticpro (&Qunevalled
);
2850 staticpro (&Qboundp
);
2851 staticpro (&Qfboundp
);
2853 staticpro (&Qad_advice_info
);
2854 staticpro (&Qad_activate_internal
);
2856 /* Types that type-of returns. */
2857 Qinteger
= intern ("integer");
2858 Qsymbol
= intern ("symbol");
2859 Qstring
= intern ("string");
2860 Qcons
= intern ("cons");
2861 Qmarker
= intern ("marker");
2862 Qoverlay
= intern ("overlay");
2863 Qfloat
= intern ("float");
2864 Qwindow_configuration
= intern ("window-configuration");
2865 Qprocess
= intern ("process");
2866 Qwindow
= intern ("window");
2867 /* Qsubr = intern ("subr"); */
2868 Qcompiled_function
= intern ("compiled-function");
2869 Qbuffer
= intern ("buffer");
2870 Qframe
= intern ("frame");
2871 Qvector
= intern ("vector");
2872 Qchar_table
= intern ("char-table");
2873 Qbool_vector
= intern ("bool-vector");
2874 Qhash_table
= intern ("hash-table");
2876 staticpro (&Qinteger
);
2877 staticpro (&Qsymbol
);
2878 staticpro (&Qstring
);
2880 staticpro (&Qmarker
);
2881 staticpro (&Qoverlay
);
2882 staticpro (&Qfloat
);
2883 staticpro (&Qwindow_configuration
);
2884 staticpro (&Qprocess
);
2885 staticpro (&Qwindow
);
2886 /* staticpro (&Qsubr); */
2887 staticpro (&Qcompiled_function
);
2888 staticpro (&Qbuffer
);
2889 staticpro (&Qframe
);
2890 staticpro (&Qvector
);
2891 staticpro (&Qchar_table
);
2892 staticpro (&Qbool_vector
);
2893 staticpro (&Qhash_table
);
2897 defsubr (&Stype_of
);
2902 defsubr (&Sintegerp
);
2903 defsubr (&Sinteger_or_marker_p
);
2904 defsubr (&Snumberp
);
2905 defsubr (&Snumber_or_marker_p
);
2907 defsubr (&Snatnump
);
2908 defsubr (&Ssymbolp
);
2909 defsubr (&Skeywordp
);
2910 defsubr (&Sstringp
);
2911 defsubr (&Smultibyte_string_p
);
2912 defsubr (&Svectorp
);
2913 defsubr (&Schar_table_p
);
2914 defsubr (&Svector_or_char_table_p
);
2915 defsubr (&Sbool_vector_p
);
2917 defsubr (&Ssequencep
);
2918 defsubr (&Sbufferp
);
2919 defsubr (&Smarkerp
);
2921 defsubr (&Sbyte_code_function_p
);
2922 defsubr (&Schar_or_string_p
);
2925 defsubr (&Scar_safe
);
2926 defsubr (&Scdr_safe
);
2929 defsubr (&Ssymbol_function
);
2930 defsubr (&Sindirect_function
);
2931 defsubr (&Ssymbol_plist
);
2932 defsubr (&Ssymbol_name
);
2933 defsubr (&Smakunbound
);
2934 defsubr (&Sfmakunbound
);
2936 defsubr (&Sfboundp
);
2938 defsubr (&Sdefalias
);
2939 defsubr (&Ssetplist
);
2940 defsubr (&Ssymbol_value
);
2942 defsubr (&Sdefault_boundp
);
2943 defsubr (&Sdefault_value
);
2944 defsubr (&Sset_default
);
2945 defsubr (&Ssetq_default
);
2946 defsubr (&Smake_variable_buffer_local
);
2947 defsubr (&Smake_local_variable
);
2948 defsubr (&Skill_local_variable
);
2949 defsubr (&Smake_variable_frame_local
);
2950 defsubr (&Slocal_variable_p
);
2951 defsubr (&Slocal_variable_if_set_p
);
2954 defsubr (&Snumber_to_string
);
2955 defsubr (&Sstring_to_number
);
2956 defsubr (&Seqlsign
);
2979 defsubr (&Ssubr_arity
);
2981 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2988 #if defined(USG) && !defined(POSIX_SIGNALS)
2989 /* USG systems forget handlers when they are used;
2990 must reestablish each time */
2991 signal (signo
, arith_error
);
2994 /* VMS systems are like USG. */
2995 signal (signo
, arith_error
);
2999 #else /* not BSD4_1 */
3000 sigsetmask (SIGEMPTYMASK
);
3001 #endif /* not BSD4_1 */
3003 Fsignal (Qarith_error
, Qnil
);
3009 /* Don't do this if just dumping out.
3010 We don't want to call `signal' in this case
3011 so that we don't have trouble with dumping
3012 signal-delivering routines in an inconsistent state. */
3016 #endif /* CANNOT_DUMP */
3017 signal (SIGFPE
, arith_error
);
3020 signal (SIGEMT
, arith_error
);