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, 2001, 2003
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
32 #include "syssignal.h"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
69 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
70 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
71 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
72 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
73 Lisp_Object Qtext_read_only
;
74 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
75 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
76 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
77 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
78 Lisp_Object Qboundp
, Qfboundp
;
79 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
82 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
84 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
85 Lisp_Object Qoverflow_error
, Qunderflow_error
;
88 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
90 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
91 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
93 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
94 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
95 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
97 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
99 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
103 circular_list_error (list
)
106 Fsignal (Qcircular_list
, list
);
111 wrong_type_argument (predicate
, value
)
112 register Lisp_Object predicate
, value
;
114 register Lisp_Object tem
;
117 /* If VALUE is not even a valid Lisp object, abort here
118 where we can get a backtrace showing where it came from. */
119 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
122 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
123 tem
= call1 (predicate
, value
);
132 error ("Attempt to modify read-only object");
136 args_out_of_range (a1
, a2
)
140 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
144 args_out_of_range_3 (a1
, a2
, a3
)
145 Lisp_Object a1
, a2
, a3
;
148 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
151 /* On some machines, XINT needs a temporary location.
152 Here it is, in case it is needed. */
154 int sign_extend_temp
;
156 /* On a few machines, XINT can only be done by calling this. */
159 sign_extend_lisp_int (num
)
162 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
163 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
165 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
168 /* Data type predicates */
170 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
171 doc
: /* Return t if the two args are the same Lisp object. */)
173 Lisp_Object obj1
, obj2
;
180 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
181 doc
: /* Return t if OBJECT is nil. */)
190 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
191 doc
: /* Return a symbol representing the type of OBJECT.
192 The symbol returned names the object's basic type;
193 for example, (type-of 1) returns `integer'. */)
197 switch (XGCTYPE (object
))
212 switch (XMISCTYPE (object
))
214 case Lisp_Misc_Marker
:
216 case Lisp_Misc_Overlay
:
218 case Lisp_Misc_Float
:
223 case Lisp_Vectorlike
:
224 if (GC_WINDOW_CONFIGURATIONP (object
))
225 return Qwindow_configuration
;
226 if (GC_PROCESSP (object
))
228 if (GC_WINDOWP (object
))
230 if (GC_SUBRP (object
))
232 if (GC_COMPILEDP (object
))
233 return Qcompiled_function
;
234 if (GC_BUFFERP (object
))
236 if (GC_CHAR_TABLE_P (object
))
238 if (GC_BOOL_VECTOR_P (object
))
240 if (GC_FRAMEP (object
))
242 if (GC_HASH_TABLE_P (object
))
254 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
255 doc
: /* Return t if OBJECT is a cons cell. */)
264 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
265 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
274 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
275 doc
: /* Return t if OBJECT is a list. This includes nil. */)
279 if (CONSP (object
) || NILP (object
))
284 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
285 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
289 if (CONSP (object
) || NILP (object
))
294 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
295 doc
: /* Return t if OBJECT is a symbol. */)
299 if (SYMBOLP (object
))
304 /* Define this in C to avoid unnecessarily consing up the symbol
306 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is a keyword.
308 This means that it is a symbol with a print name beginning with `:'
309 interned in the initial obarray. */)
314 && SREF (SYMBOL_NAME (object
), 0) == ':'
315 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
320 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a vector. */)
325 if (VECTORP (object
))
330 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
331 doc
: /* Return t if OBJECT is a string. */)
335 if (STRINGP (object
))
340 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
342 doc
: /* Return t if OBJECT is a multibyte string. */)
346 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
351 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a char-table. */)
356 if (CHAR_TABLE_P (object
))
361 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
362 Svector_or_char_table_p
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a char-table or vector. */)
367 if (VECTORP (object
) || CHAR_TABLE_P (object
))
372 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
373 doc
: /* Return t if OBJECT is a bool-vector. */)
377 if (BOOL_VECTOR_P (object
))
382 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 if (VECTORP (object
) || STRINGP (object
)
388 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
393 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
394 doc
: /* Return t if OBJECT is a sequence (list or array). */)
396 register Lisp_Object object
;
398 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
399 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
404 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is an editor buffer. */)
409 if (BUFFERP (object
))
414 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
419 if (MARKERP (object
))
424 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a built-in function. */)
434 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
436 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
440 if (COMPILEDP (object
))
445 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
446 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
448 register Lisp_Object object
;
450 if (INTEGERP (object
) || STRINGP (object
))
455 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
456 doc
: /* Return t if OBJECT is an integer. */)
460 if (INTEGERP (object
))
465 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
466 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
468 register Lisp_Object object
;
470 if (MARKERP (object
) || INTEGERP (object
))
475 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
476 doc
: /* Return t if OBJECT is a nonnegative integer. */)
480 if (NATNUMP (object
))
485 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
486 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
490 if (NUMBERP (object
))
496 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
497 Snumber_or_marker_p
, 1, 1, 0,
498 doc
: /* Return t if OBJECT is a number or a marker. */)
502 if (NUMBERP (object
) || MARKERP (object
))
507 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
508 doc
: /* Return t if OBJECT is a floating point number. */)
518 /* Extract and set components of lists */
520 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
521 doc
: /* Return the car of LIST. If arg is nil, return nil.
522 Error if arg is not nil and not a cons cell. See also `car-safe'. */)
524 register Lisp_Object list
;
530 else if (EQ (list
, Qnil
))
533 list
= wrong_type_argument (Qlistp
, list
);
537 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
538 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
543 return XCAR (object
);
548 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
549 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
550 Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
552 register Lisp_Object list
;
558 else if (EQ (list
, Qnil
))
561 list
= wrong_type_argument (Qlistp
, list
);
565 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
566 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
571 return XCDR (object
);
576 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
577 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
579 register Lisp_Object cell
, newcar
;
582 cell
= wrong_type_argument (Qconsp
, cell
);
585 XSETCAR (cell
, newcar
);
589 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
590 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
592 register Lisp_Object cell
, newcdr
;
595 cell
= wrong_type_argument (Qconsp
, cell
);
598 XSETCDR (cell
, newcdr
);
602 /* Extract and set components of symbols */
604 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
605 doc
: /* Return t if SYMBOL's value is not void. */)
607 register Lisp_Object symbol
;
609 Lisp_Object valcontents
;
610 CHECK_SYMBOL (symbol
);
612 valcontents
= SYMBOL_VALUE (symbol
);
614 if (BUFFER_LOCAL_VALUEP (valcontents
)
615 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
616 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
618 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
621 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
622 doc
: /* Return t if SYMBOL's function definition is not void. */)
624 register Lisp_Object symbol
;
626 CHECK_SYMBOL (symbol
);
627 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
630 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
631 doc
: /* Make SYMBOL's value be void.
634 register Lisp_Object symbol
;
636 CHECK_SYMBOL (symbol
);
637 if (XSYMBOL (symbol
)->constant
)
638 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
639 Fset (symbol
, Qunbound
);
643 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
644 doc
: /* Make SYMBOL's function definition be void.
647 register Lisp_Object symbol
;
649 CHECK_SYMBOL (symbol
);
650 if (NILP (symbol
) || EQ (symbol
, Qt
))
651 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
652 XSYMBOL (symbol
)->function
= Qunbound
;
656 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
657 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
659 register Lisp_Object symbol
;
661 CHECK_SYMBOL (symbol
);
662 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
663 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
664 return XSYMBOL (symbol
)->function
;
667 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
668 doc
: /* Return SYMBOL's property list. */)
670 register Lisp_Object symbol
;
672 CHECK_SYMBOL (symbol
);
673 return XSYMBOL (symbol
)->plist
;
676 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
677 doc
: /* Return SYMBOL's name, a string. */)
679 register Lisp_Object symbol
;
681 register Lisp_Object name
;
683 CHECK_SYMBOL (symbol
);
684 name
= SYMBOL_NAME (symbol
);
688 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
689 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
691 register Lisp_Object symbol
, definition
;
693 CHECK_SYMBOL (symbol
);
694 if (NILP (symbol
) || EQ (symbol
, Qt
))
695 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
696 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
697 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
699 XSYMBOL (symbol
)->function
= definition
;
700 /* Handle automatic advice activation */
701 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
703 call2 (Qad_activate_internal
, symbol
, Qnil
);
704 definition
= XSYMBOL (symbol
)->function
;
709 extern Lisp_Object Qfunction_documentation
;
711 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
712 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
713 Associates the function with the current load file, if any.
714 The optional third argument DOCSTRING specifies the documentation string
715 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
716 determined by DEFINITION. */)
717 (symbol
, definition
, docstring
)
718 register Lisp_Object symbol
, definition
, docstring
;
720 if (CONSP (XSYMBOL (symbol
)->function
)
721 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
722 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
723 definition
= Ffset (symbol
, definition
);
724 LOADHIST_ATTACH (symbol
);
725 if (!NILP (docstring
))
726 Fput (symbol
, Qfunction_documentation
, docstring
);
730 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
731 doc
: /* Set SYMBOL's property list to NEWVAL, and return NEWVAL. */)
733 register Lisp_Object symbol
, newplist
;
735 CHECK_SYMBOL (symbol
);
736 XSYMBOL (symbol
)->plist
= newplist
;
740 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
741 doc
: /* Return minimum and maximum number of args allowed for SUBR.
742 SUBR must be a built-in function.
743 The returned value is a pair (MIN . MAX). MIN is the minimum number
744 of args. MAX is the maximum number or the symbol `many', for a
745 function with `&rest' args, or `unevalled' for a special form. */)
749 short minargs
, maxargs
;
751 wrong_type_argument (Qsubrp
, subr
);
752 minargs
= XSUBR (subr
)->min_args
;
753 maxargs
= XSUBR (subr
)->max_args
;
755 return Fcons (make_number (minargs
), Qmany
);
756 else if (maxargs
== UNEVALLED
)
757 return Fcons (make_number (minargs
), Qunevalled
);
759 return Fcons (make_number (minargs
), make_number (maxargs
));
762 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
763 doc
: /* Return the interactive form of SUBR or nil if none.
764 SUBR must be a built-in function. Value, if non-nil, is a list
765 \(interactive SPEC). */)
770 wrong_type_argument (Qsubrp
, subr
);
771 if (XSUBR (subr
)->prompt
)
772 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
777 /***********************************************************************
778 Getting and Setting Values of Symbols
779 ***********************************************************************/
781 /* Return the symbol holding SYMBOL's value. Signal
782 `cyclic-variable-indirection' if SYMBOL's chain of variable
783 indirections contains a loop. */
786 indirect_variable (symbol
)
789 Lisp_Object tortoise
, hare
;
791 hare
= tortoise
= symbol
;
793 while (XSYMBOL (hare
)->indirect_variable
)
795 hare
= XSYMBOL (hare
)->value
;
796 if (!XSYMBOL (hare
)->indirect_variable
)
799 hare
= XSYMBOL (hare
)->value
;
800 tortoise
= XSYMBOL (tortoise
)->value
;
802 if (EQ (hare
, tortoise
))
803 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
810 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
811 doc
: /* Return the variable at the end of OBJECT's variable chain.
812 If OBJECT is a symbol, follow all variable indirections and return the final
813 variable. If OBJECT is not a symbol, just return it.
814 Signal a cyclic-variable-indirection error if there is a loop in the
815 variable chain of symbols. */)
819 if (SYMBOLP (object
))
820 object
= indirect_variable (object
);
825 /* Given the raw contents of a symbol value cell,
826 return the Lisp value of the symbol.
827 This does not handle buffer-local variables; use
828 swap_in_symval_forwarding for that. */
831 do_symval_forwarding (valcontents
)
832 register Lisp_Object valcontents
;
834 register Lisp_Object val
;
836 if (MISCP (valcontents
))
837 switch (XMISCTYPE (valcontents
))
839 case Lisp_Misc_Intfwd
:
840 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
843 case Lisp_Misc_Boolfwd
:
844 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
846 case Lisp_Misc_Objfwd
:
847 return *XOBJFWD (valcontents
)->objvar
;
849 case Lisp_Misc_Buffer_Objfwd
:
850 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
851 return PER_BUFFER_VALUE (current_buffer
, offset
);
853 case Lisp_Misc_Kboard_Objfwd
:
854 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
855 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
860 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
861 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
862 buffer-independent contents of the value cell: forwarded just one
863 step past the buffer-localness.
865 BUF non-zero means set the value in buffer BUF instead of the
866 current buffer. This only plays a role for per-buffer variables. */
869 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
871 register Lisp_Object valcontents
, newval
;
874 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
877 switch (XMISCTYPE (valcontents
))
879 case Lisp_Misc_Intfwd
:
880 CHECK_NUMBER (newval
);
881 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
882 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
883 error ("Value out of range for variable `%s'",
884 SDATA (SYMBOL_NAME (symbol
)));
887 case Lisp_Misc_Boolfwd
:
888 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
891 case Lisp_Misc_Objfwd
:
892 *XOBJFWD (valcontents
)->objvar
= newval
;
895 case Lisp_Misc_Buffer_Objfwd
:
897 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
900 type
= PER_BUFFER_TYPE (offset
);
901 if (! NILP (type
) && ! NILP (newval
)
902 && XTYPE (newval
) != XINT (type
))
903 buffer_slot_type_mismatch (offset
);
906 buf
= current_buffer
;
907 PER_BUFFER_VALUE (buf
, offset
) = newval
;
911 case Lisp_Misc_Kboard_Objfwd
:
913 char *base
= (char *) current_kboard
;
914 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
915 *(Lisp_Object
*) p
= newval
;
926 valcontents
= SYMBOL_VALUE (symbol
);
927 if (BUFFER_LOCAL_VALUEP (valcontents
)
928 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
929 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
931 SET_SYMBOL_VALUE (symbol
, newval
);
935 /* Set up SYMBOL to refer to its global binding.
936 This makes it safe to alter the status of other bindings. */
939 swap_in_global_binding (symbol
)
942 Lisp_Object valcontents
, cdr
;
944 valcontents
= SYMBOL_VALUE (symbol
);
945 if (!BUFFER_LOCAL_VALUEP (valcontents
)
946 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
948 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
950 /* Unload the previously loaded binding. */
952 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
954 /* Select the global binding in the symbol. */
956 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
958 /* Indicate that the global binding is set up now. */
959 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
960 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
961 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
962 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
965 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
966 VALCONTENTS is the contents of its value cell,
967 which points to a struct Lisp_Buffer_Local_Value.
969 Return the value forwarded one step past the buffer-local stage.
970 This could be another forwarding pointer. */
973 swap_in_symval_forwarding (symbol
, valcontents
)
974 Lisp_Object symbol
, valcontents
;
976 register Lisp_Object tem1
;
978 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
981 || current_buffer
!= XBUFFER (tem1
)
982 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
983 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
985 if (XSYMBOL (symbol
)->indirect_variable
)
986 symbol
= indirect_variable (symbol
);
988 /* Unload the previously loaded binding. */
989 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
991 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
992 /* Choose the new binding. */
993 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
994 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
995 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
998 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
999 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1001 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1003 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1006 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1008 /* Load the new binding. */
1009 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1010 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1011 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1012 store_symval_forwarding (symbol
,
1013 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1016 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1019 /* Find the value of a symbol, returning Qunbound if it's not bound.
1020 This is helpful for code which just wants to get a variable's value
1021 if it has one, without signaling an error.
1022 Note that it must not be possible to quit
1023 within this function. Great care is required for this. */
1026 find_symbol_value (symbol
)
1029 register Lisp_Object valcontents
;
1030 register Lisp_Object val
;
1032 CHECK_SYMBOL (symbol
);
1033 valcontents
= SYMBOL_VALUE (symbol
);
1035 if (BUFFER_LOCAL_VALUEP (valcontents
)
1036 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1037 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1039 if (MISCP (valcontents
))
1041 switch (XMISCTYPE (valcontents
))
1043 case Lisp_Misc_Intfwd
:
1044 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1047 case Lisp_Misc_Boolfwd
:
1048 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1050 case Lisp_Misc_Objfwd
:
1051 return *XOBJFWD (valcontents
)->objvar
;
1053 case Lisp_Misc_Buffer_Objfwd
:
1054 return PER_BUFFER_VALUE (current_buffer
,
1055 XBUFFER_OBJFWD (valcontents
)->offset
);
1057 case Lisp_Misc_Kboard_Objfwd
:
1058 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1059 + (char *)current_kboard
);
1066 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1067 doc
: /* Return SYMBOL's value. Error if that is void. */)
1073 val
= find_symbol_value (symbol
);
1074 if (EQ (val
, Qunbound
))
1075 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1080 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1081 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1083 register Lisp_Object symbol
, newval
;
1085 return set_internal (symbol
, newval
, current_buffer
, 0);
1088 /* Return 1 if SYMBOL currently has a let-binding
1089 which was made in the buffer that is now current. */
1092 let_shadows_buffer_binding_p (symbol
)
1095 volatile struct specbinding
*p
;
1097 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1099 && CONSP (p
->symbol
))
1101 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1102 if ((EQ (symbol
, let_bound_symbol
)
1103 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1104 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1105 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1109 return p
>= specpdl
;
1112 /* Store the value NEWVAL into SYMBOL.
1113 If buffer-locality is an issue, BUF specifies which buffer to use.
1114 (0 stands for the current buffer.)
1116 If BINDFLAG is zero, then if this symbol is supposed to become
1117 local in every buffer where it is set, then we make it local.
1118 If BINDFLAG is nonzero, we don't do that. */
1121 set_internal (symbol
, newval
, buf
, bindflag
)
1122 register Lisp_Object symbol
, newval
;
1126 int voide
= EQ (newval
, Qunbound
);
1128 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1131 buf
= current_buffer
;
1133 /* If restoring in a dead buffer, do nothing. */
1134 if (NILP (buf
->name
))
1137 CHECK_SYMBOL (symbol
);
1138 if (SYMBOL_CONSTANT_P (symbol
)
1139 && (NILP (Fkeywordp (symbol
))
1140 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1141 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1143 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1145 if (BUFFER_OBJFWDP (valcontents
))
1147 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1148 int idx
= PER_BUFFER_IDX (offset
);
1151 && !let_shadows_buffer_binding_p (symbol
))
1152 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1154 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1155 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1157 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1158 if (XSYMBOL (symbol
)->indirect_variable
)
1159 symbol
= indirect_variable (symbol
);
1161 /* What binding is loaded right now? */
1162 current_alist_element
1163 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1165 /* If the current buffer is not the buffer whose binding is
1166 loaded, or if there may be frame-local bindings and the frame
1167 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1168 the default binding is loaded, the loaded binding may be the
1170 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1171 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1172 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1173 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1174 || (BUFFER_LOCAL_VALUEP (valcontents
)
1175 && EQ (XCAR (current_alist_element
),
1176 current_alist_element
)))
1178 /* The currently loaded binding is not necessarily valid.
1179 We need to unload it, and choose a new binding. */
1181 /* Write out `realvalue' to the old loaded binding. */
1182 Fsetcdr (current_alist_element
,
1183 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1185 /* Find the new binding. */
1186 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1187 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1188 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1192 /* This buffer still sees the default value. */
1194 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1195 or if this is `let' rather than `set',
1196 make CURRENT-ALIST-ELEMENT point to itself,
1197 indicating that we're seeing the default value.
1198 Likewise if the variable has been let-bound
1199 in the current buffer. */
1200 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1201 || let_shadows_buffer_binding_p (symbol
))
1203 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1205 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1206 tem1
= Fassq (symbol
,
1207 XFRAME (selected_frame
)->param_alist
);
1210 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1212 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1214 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1215 and we're not within a let that was made for this buffer,
1216 create a new buffer-local binding for the variable.
1217 That means, give this buffer a new assoc for a local value
1218 and load that binding. */
1221 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1222 buf
->local_var_alist
1223 = Fcons (tem1
, buf
->local_var_alist
);
1227 /* Record which binding is now loaded. */
1228 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1231 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1232 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1233 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1235 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1238 /* If storing void (making the symbol void), forward only through
1239 buffer-local indicator, not through Lisp_Objfwd, etc. */
1241 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1243 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1245 /* If we just set a variable whose current binding is frame-local,
1246 store the new value in the frame parameter too. */
1248 if (BUFFER_LOCAL_VALUEP (valcontents
)
1249 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1251 /* What binding is loaded right now? */
1252 current_alist_element
1253 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1255 /* If the current buffer is not the buffer whose binding is
1256 loaded, or if there may be frame-local bindings and the frame
1257 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1258 the default binding is loaded, the loaded binding may be the
1260 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1261 XSETCDR (current_alist_element
, newval
);
1267 /* Access or set a buffer-local symbol's default value. */
1269 /* Return the default value of SYMBOL, but don't check for voidness.
1270 Return Qunbound if it is void. */
1273 default_value (symbol
)
1276 register Lisp_Object valcontents
;
1278 CHECK_SYMBOL (symbol
);
1279 valcontents
= SYMBOL_VALUE (symbol
);
1281 /* For a built-in buffer-local variable, get the default value
1282 rather than letting do_symval_forwarding get the current value. */
1283 if (BUFFER_OBJFWDP (valcontents
))
1285 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1286 if (PER_BUFFER_IDX (offset
) != 0)
1287 return PER_BUFFER_DEFAULT (offset
);
1290 /* Handle user-created local variables. */
1291 if (BUFFER_LOCAL_VALUEP (valcontents
)
1292 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1294 /* If var is set up for a buffer that lacks a local value for it,
1295 the current value is nominally the default value.
1296 But the `realvalue' slot may be more up to date, since
1297 ordinary setq stores just that slot. So use that. */
1298 Lisp_Object current_alist_element
, alist_element_car
;
1299 current_alist_element
1300 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1301 alist_element_car
= XCAR (current_alist_element
);
1302 if (EQ (alist_element_car
, current_alist_element
))
1303 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1305 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1307 /* For other variables, get the current value. */
1308 return do_symval_forwarding (valcontents
);
1311 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1312 doc
: /* Return t if SYMBOL has a non-void default value.
1313 This is the value that is seen in buffers that do not have their own values
1314 for this variable. */)
1318 register Lisp_Object value
;
1320 value
= default_value (symbol
);
1321 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1324 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1325 doc
: /* Return SYMBOL's default value.
1326 This is the value that is seen in buffers that do not have their own values
1327 for this variable. The default value is meaningful for variables with
1328 local bindings in certain buffers. */)
1332 register Lisp_Object value
;
1334 value
= default_value (symbol
);
1335 if (EQ (value
, Qunbound
))
1336 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1340 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1341 doc
: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1342 The default value is seen in buffers that do not have their own values
1343 for this variable. */)
1345 Lisp_Object symbol
, value
;
1347 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1349 CHECK_SYMBOL (symbol
);
1350 valcontents
= SYMBOL_VALUE (symbol
);
1352 /* Handle variables like case-fold-search that have special slots
1353 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1355 if (BUFFER_OBJFWDP (valcontents
))
1357 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1358 int idx
= PER_BUFFER_IDX (offset
);
1360 PER_BUFFER_DEFAULT (offset
) = value
;
1362 /* If this variable is not always local in all buffers,
1363 set it in the buffers that don't nominally have a local value. */
1368 for (b
= all_buffers
; b
; b
= b
->next
)
1369 if (!PER_BUFFER_VALUE_P (b
, idx
))
1370 PER_BUFFER_VALUE (b
, offset
) = value
;
1375 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1376 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1377 return Fset (symbol
, value
);
1379 /* Store new value into the DEFAULT-VALUE slot. */
1380 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1382 /* If the default binding is now loaded, set the REALVALUE slot too. */
1383 current_alist_element
1384 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1385 alist_element_buffer
= Fcar (current_alist_element
);
1386 if (EQ (alist_element_buffer
, current_alist_element
))
1387 store_symval_forwarding (symbol
,
1388 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1394 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1395 doc
: /* Set the default value of variable VAR to VALUE.
1396 VAR, the variable name, is literal (not evaluated);
1397 VALUE is an expression: it is evaluated and its value returned.
1398 The default value of a variable is seen in buffers
1399 that do not have their own values for the variable.
1401 More generally, you can use multiple variables and values, as in
1402 (setq-default SYMBOL VALUE SYMBOL VALUE...)
1403 This sets each SYMBOL's default value to the corresponding VALUE.
1404 The VALUE for the Nth SYMBOL can refer to the new default values
1406 usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */)
1410 register Lisp_Object args_left
;
1411 register Lisp_Object val
, symbol
;
1412 struct gcpro gcpro1
;
1422 val
= Feval (Fcar (Fcdr (args_left
)));
1423 symbol
= XCAR (args_left
);
1424 Fset_default (symbol
, val
);
1425 args_left
= Fcdr (XCDR (args_left
));
1427 while (!NILP (args_left
));
1433 /* Lisp functions for creating and removing buffer-local variables. */
1435 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1436 1, 1, "vMake Variable Buffer Local: ",
1437 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1438 At any time, the value for the current buffer is in effect,
1439 unless the variable has never been set in this buffer,
1440 in which case the default value is in effect.
1441 Note that binding the variable with `let', or setting it while
1442 a `let'-style binding made in this buffer is in effect,
1443 does not make the variable buffer-local. Return VARIABLE.
1445 The function `default-value' gets the default value and `set-default' sets it. */)
1447 register Lisp_Object variable
;
1449 register Lisp_Object tem
, valcontents
, newval
;
1451 CHECK_SYMBOL (variable
);
1452 variable
= indirect_variable (variable
);
1454 valcontents
= SYMBOL_VALUE (variable
);
1455 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1456 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1458 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1460 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1462 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1465 if (EQ (valcontents
, Qunbound
))
1466 SET_SYMBOL_VALUE (variable
, Qnil
);
1467 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1469 newval
= allocate_misc ();
1470 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1471 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1472 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1473 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1474 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1475 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1476 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1477 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1478 SET_SYMBOL_VALUE (variable
, newval
);
1482 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1483 1, 1, "vMake Local Variable: ",
1484 doc
: /* Make VARIABLE have a separate value in the current buffer.
1485 Other buffers will continue to share a common default value.
1486 \(The buffer-local value of VARIABLE starts out as the same value
1487 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1488 See also `make-variable-buffer-local'. Return VARIABLE.
1490 If the variable is already arranged to become local when set,
1491 this function causes a local value to exist for this buffer,
1492 just as setting the variable would do.
1494 This function returns VARIABLE, and therefore
1495 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1498 Do not use `make-local-variable' to make a hook variable buffer-local.
1499 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1501 register Lisp_Object variable
;
1503 register Lisp_Object tem
, valcontents
;
1505 CHECK_SYMBOL (variable
);
1506 variable
= indirect_variable (variable
);
1508 valcontents
= SYMBOL_VALUE (variable
);
1509 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1510 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1512 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1514 tem
= Fboundp (variable
);
1516 /* Make sure the symbol has a local value in this particular buffer,
1517 by setting it to the same value it already has. */
1518 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1521 /* Make sure symbol is set up to hold per-buffer values. */
1522 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1525 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1527 newval
= allocate_misc ();
1528 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1529 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1530 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1531 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1532 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1533 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1534 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1535 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1536 SET_SYMBOL_VALUE (variable
, newval
);;
1538 /* Make sure this buffer has its own value of symbol. */
1539 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1542 /* Swap out any local binding for some other buffer, and make
1543 sure the current value is permanently recorded, if it's the
1545 find_symbol_value (variable
);
1547 current_buffer
->local_var_alist
1548 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1549 current_buffer
->local_var_alist
);
1551 /* Make sure symbol does not think it is set up for this buffer;
1552 force it to look once again for this buffer's value. */
1554 Lisp_Object
*pvalbuf
;
1556 valcontents
= SYMBOL_VALUE (variable
);
1558 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1559 if (current_buffer
== XBUFFER (*pvalbuf
))
1561 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1565 /* If the symbol forwards into a C variable, then load the binding
1566 for this buffer now. If C code modifies the variable before we
1567 load the binding in, then that new value will clobber the default
1568 binding the next time we unload it. */
1569 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1570 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1571 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1576 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1577 1, 1, "vKill Local Variable: ",
1578 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1579 From now on the default value will apply in this buffer. Return VARIABLE. */)
1581 register Lisp_Object variable
;
1583 register Lisp_Object tem
, valcontents
;
1585 CHECK_SYMBOL (variable
);
1586 variable
= indirect_variable (variable
);
1588 valcontents
= SYMBOL_VALUE (variable
);
1590 if (BUFFER_OBJFWDP (valcontents
))
1592 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1593 int idx
= PER_BUFFER_IDX (offset
);
1597 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1598 PER_BUFFER_VALUE (current_buffer
, offset
)
1599 = PER_BUFFER_DEFAULT (offset
);
1604 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1605 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1608 /* Get rid of this buffer's alist element, if any. */
1610 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1612 current_buffer
->local_var_alist
1613 = Fdelq (tem
, current_buffer
->local_var_alist
);
1615 /* If the symbol is set up with the current buffer's binding
1616 loaded, recompute its value. We have to do it now, or else
1617 forwarded objects won't work right. */
1619 Lisp_Object
*pvalbuf
, buf
;
1620 valcontents
= SYMBOL_VALUE (variable
);
1621 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1622 XSETBUFFER (buf
, current_buffer
);
1623 if (EQ (buf
, *pvalbuf
))
1626 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1627 find_symbol_value (variable
);
1634 /* Lisp functions for creating and removing buffer-local variables. */
1636 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1637 1, 1, "vMake Variable Frame Local: ",
1638 doc
: /* Enable VARIABLE to have frame-local bindings.
1639 When a frame-local binding exists in the current frame,
1640 it is in effect whenever the current buffer has no buffer-local binding.
1641 A frame-local binding is actually a frame parameter value;
1642 thus, any given frame has a local binding for VARIABLE if it has
1643 a value for the frame parameter named VARIABLE. Return VARIABLE.
1644 See `modify-frame-parameters' for how to set frame parameters. */)
1646 register Lisp_Object variable
;
1648 register Lisp_Object tem
, valcontents
, newval
;
1650 CHECK_SYMBOL (variable
);
1651 variable
= indirect_variable (variable
);
1653 valcontents
= SYMBOL_VALUE (variable
);
1654 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1655 || BUFFER_OBJFWDP (valcontents
))
1656 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1658 if (BUFFER_LOCAL_VALUEP (valcontents
)
1659 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1661 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1665 if (EQ (valcontents
, Qunbound
))
1666 SET_SYMBOL_VALUE (variable
, Qnil
);
1667 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1669 newval
= allocate_misc ();
1670 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1671 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1672 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1673 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1674 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1675 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1676 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1677 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1678 SET_SYMBOL_VALUE (variable
, newval
);
1682 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1684 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1685 BUFFER defaults to the current buffer. */)
1687 register Lisp_Object variable
, buffer
;
1689 Lisp_Object valcontents
;
1690 register struct buffer
*buf
;
1693 buf
= current_buffer
;
1696 CHECK_BUFFER (buffer
);
1697 buf
= XBUFFER (buffer
);
1700 CHECK_SYMBOL (variable
);
1701 variable
= indirect_variable (variable
);
1703 valcontents
= SYMBOL_VALUE (variable
);
1704 if (BUFFER_LOCAL_VALUEP (valcontents
)
1705 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1707 Lisp_Object tail
, elt
;
1709 variable
= indirect_variable (variable
);
1710 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1713 if (EQ (variable
, XCAR (elt
)))
1717 if (BUFFER_OBJFWDP (valcontents
))
1719 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1720 int idx
= PER_BUFFER_IDX (offset
);
1721 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1727 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1729 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
1730 BUFFER defaults to the current buffer. */)
1732 register Lisp_Object variable
, buffer
;
1734 Lisp_Object valcontents
;
1735 register struct buffer
*buf
;
1738 buf
= current_buffer
;
1741 CHECK_BUFFER (buffer
);
1742 buf
= XBUFFER (buffer
);
1745 CHECK_SYMBOL (variable
);
1746 variable
= indirect_variable (variable
);
1748 valcontents
= SYMBOL_VALUE (variable
);
1750 /* This means that make-variable-buffer-local was done. */
1751 if (BUFFER_LOCAL_VALUEP (valcontents
))
1753 /* All these slots become local if they are set. */
1754 if (BUFFER_OBJFWDP (valcontents
))
1756 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1758 Lisp_Object tail
, elt
;
1759 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1762 if (EQ (variable
, XCAR (elt
)))
1769 /* Find the function at the end of a chain of symbol function indirections. */
1771 /* If OBJECT is a symbol, find the end of its function chain and
1772 return the value found there. If OBJECT is not a symbol, just
1773 return it. If there is a cycle in the function chain, signal a
1774 cyclic-function-indirection error.
1776 This is like Findirect_function, except that it doesn't signal an
1777 error if the chain ends up unbound. */
1779 indirect_function (object
)
1780 register Lisp_Object object
;
1782 Lisp_Object tortoise
, hare
;
1784 hare
= tortoise
= object
;
1788 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1790 hare
= XSYMBOL (hare
)->function
;
1791 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1793 hare
= XSYMBOL (hare
)->function
;
1795 tortoise
= XSYMBOL (tortoise
)->function
;
1797 if (EQ (hare
, tortoise
))
1798 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1804 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1805 doc
: /* Return the function at the end of OBJECT's function chain.
1806 If OBJECT is a symbol, follow all function indirections and return the final
1808 If OBJECT is not a symbol, just return it.
1809 Signal a void-function error if the final symbol is unbound.
1810 Signal a cyclic-function-indirection error if there is a loop in the
1811 function chain of symbols. */)
1813 register Lisp_Object object
;
1817 result
= indirect_function (object
);
1819 if (EQ (result
, Qunbound
))
1820 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1824 /* Extract and set vector and string elements */
1826 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1827 doc
: /* Return the element of ARRAY at index IDX.
1828 ARRAY may be a vector, a string, a char-table, a bool-vector,
1829 or a byte-code object. IDX starts at 0. */)
1831 register Lisp_Object array
;
1834 register int idxval
;
1837 idxval
= XINT (idx
);
1838 if (STRINGP (array
))
1842 if (idxval
< 0 || idxval
>= SCHARS (array
))
1843 args_out_of_range (array
, idx
);
1844 if (! STRING_MULTIBYTE (array
))
1845 return make_number ((unsigned char) SREF (array
, idxval
));
1846 idxval_byte
= string_char_to_byte (array
, idxval
);
1848 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1849 SBYTES (array
) - idxval_byte
);
1850 return make_number (c
);
1852 else if (BOOL_VECTOR_P (array
))
1856 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1857 args_out_of_range (array
, idx
);
1859 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1860 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1862 else if (CHAR_TABLE_P (array
))
1869 args_out_of_range (array
, idx
);
1870 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1872 /* For ASCII and 8-bit European characters, the element is
1873 stored in the top table. */
1874 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1876 val
= XCHAR_TABLE (array
)->defalt
;
1877 while (NILP (val
)) /* Follow parents until we find some value. */
1879 array
= XCHAR_TABLE (array
)->parent
;
1882 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1884 val
= XCHAR_TABLE (array
)->defalt
;
1891 Lisp_Object sub_table
;
1893 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1894 if (code
[1] < 32) code
[1] = -1;
1895 else if (code
[2] < 32) code
[2] = -1;
1897 /* Here, the possible range of CODE[0] (== charset ID) is
1898 128..MAX_CHARSET. Since the top level char table contains
1899 data for multibyte characters after 256th element, we must
1900 increment CODE[0] by 128 to get a correct index. */
1902 code
[3] = -1; /* anchor */
1904 try_parent_char_table
:
1906 for (i
= 0; code
[i
] >= 0; i
++)
1908 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1909 if (SUB_CHAR_TABLE_P (val
))
1914 val
= XCHAR_TABLE (sub_table
)->defalt
;
1917 array
= XCHAR_TABLE (array
)->parent
;
1919 goto try_parent_char_table
;
1924 /* Here, VAL is a sub char table. We try the default value
1926 val
= XCHAR_TABLE (val
)->defalt
;
1929 array
= XCHAR_TABLE (array
)->parent
;
1931 goto try_parent_char_table
;
1939 if (VECTORP (array
))
1940 size
= XVECTOR (array
)->size
;
1941 else if (COMPILEDP (array
))
1942 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1944 wrong_type_argument (Qarrayp
, array
);
1946 if (idxval
< 0 || idxval
>= size
)
1947 args_out_of_range (array
, idx
);
1948 return XVECTOR (array
)->contents
[idxval
];
1952 /* Don't use alloca for relocating string data larger than this, lest
1953 we overflow their stack. The value is the same as what used in
1954 fns.c for base64 handling. */
1955 #define MAX_ALLOCA 16*1024
1957 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1958 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1959 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
1960 bool-vector. IDX starts at 0. */)
1961 (array
, idx
, newelt
)
1962 register Lisp_Object array
;
1963 Lisp_Object idx
, newelt
;
1965 register int idxval
;
1968 idxval
= XINT (idx
);
1969 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1970 && ! CHAR_TABLE_P (array
))
1971 array
= wrong_type_argument (Qarrayp
, array
);
1972 CHECK_IMPURE (array
);
1974 if (VECTORP (array
))
1976 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1977 args_out_of_range (array
, idx
);
1978 XVECTOR (array
)->contents
[idxval
] = newelt
;
1980 else if (BOOL_VECTOR_P (array
))
1984 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1985 args_out_of_range (array
, idx
);
1987 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1989 if (! NILP (newelt
))
1990 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1992 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1993 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1995 else if (CHAR_TABLE_P (array
))
1998 args_out_of_range (array
, idx
);
1999 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2000 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2006 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2007 if (code
[1] < 32) code
[1] = -1;
2008 else if (code
[2] < 32) code
[2] = -1;
2010 /* See the comment of the corresponding part in Faref. */
2012 code
[3] = -1; /* anchor */
2013 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2015 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2016 if (SUB_CHAR_TABLE_P (val
))
2022 /* VAL is a leaf. Create a sub char table with the
2023 default value VAL or XCHAR_TABLE (array)->defalt
2024 and look into it. */
2026 temp
= make_sub_char_table (NILP (val
)
2027 ? XCHAR_TABLE (array
)->defalt
2029 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2033 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2036 else if (STRING_MULTIBYTE (array
))
2038 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2039 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2041 if (idxval
< 0 || idxval
>= SCHARS (array
))
2042 args_out_of_range (array
, idx
);
2043 CHECK_NUMBER (newelt
);
2045 nbytes
= SBYTES (array
);
2047 idxval_byte
= string_char_to_byte (array
, idxval
);
2048 p1
= SDATA (array
) + idxval_byte
;
2049 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2050 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2051 if (prev_bytes
!= new_bytes
)
2053 /* We must relocate the string data. */
2054 int nchars
= SCHARS (array
);
2057 str
= (nbytes
<= MAX_ALLOCA
2058 ? (unsigned char *) alloca (nbytes
)
2059 : (unsigned char *) xmalloc (nbytes
));
2060 bcopy (SDATA (array
), str
, nbytes
);
2061 allocate_string_data (XSTRING (array
), nchars
,
2062 nbytes
+ new_bytes
- prev_bytes
);
2063 bcopy (str
, SDATA (array
), idxval_byte
);
2064 p1
= SDATA (array
) + idxval_byte
;
2065 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2066 nbytes
- (idxval_byte
+ prev_bytes
));
2067 if (nbytes
> MAX_ALLOCA
)
2069 clear_string_char_byte_cache ();
2076 if (idxval
< 0 || idxval
>= SCHARS (array
))
2077 args_out_of_range (array
, idx
);
2078 CHECK_NUMBER (newelt
);
2080 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2081 SSET (array
, idxval
, XINT (newelt
));
2084 /* We must relocate the string data while converting it to
2086 int idxval_byte
, prev_bytes
, new_bytes
;
2087 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2088 unsigned char *origstr
= SDATA (array
), *str
;
2091 nchars
= SCHARS (array
);
2092 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2093 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2095 str
= (nbytes
<= MAX_ALLOCA
2096 ? (unsigned char *) alloca (nbytes
)
2097 : (unsigned char *) xmalloc (nbytes
));
2098 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2099 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2101 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2102 allocate_string_data (XSTRING (array
), nchars
,
2103 nbytes
+ new_bytes
- prev_bytes
);
2104 bcopy (str
, SDATA (array
), idxval_byte
);
2105 p1
= SDATA (array
) + idxval_byte
;
2108 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2109 nbytes
- (idxval_byte
+ prev_bytes
));
2110 if (nbytes
> MAX_ALLOCA
)
2112 clear_string_char_byte_cache ();
2119 /* Arithmetic functions */
2121 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2124 arithcompare (num1
, num2
, comparison
)
2125 Lisp_Object num1
, num2
;
2126 enum comparison comparison
;
2128 double f1
= 0, f2
= 0;
2131 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2132 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2134 if (FLOATP (num1
) || FLOATP (num2
))
2137 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2138 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2144 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2149 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2154 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2159 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2164 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2169 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2178 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2179 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2181 register Lisp_Object num1
, num2
;
2183 return arithcompare (num1
, num2
, equal
);
2186 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2187 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2189 register Lisp_Object num1
, num2
;
2191 return arithcompare (num1
, num2
, less
);
2194 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2195 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2197 register Lisp_Object num1
, num2
;
2199 return arithcompare (num1
, num2
, grtr
);
2202 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2203 doc
: /* Return t if first arg is less than or equal to second arg.
2204 Both must be numbers or markers. */)
2206 register Lisp_Object num1
, num2
;
2208 return arithcompare (num1
, num2
, less_or_equal
);
2211 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2212 doc
: /* Return t if first arg is greater than or equal to second arg.
2213 Both must be numbers or markers. */)
2215 register Lisp_Object num1
, num2
;
2217 return arithcompare (num1
, num2
, grtr_or_equal
);
2220 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2221 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2223 register Lisp_Object num1
, num2
;
2225 return arithcompare (num1
, num2
, notequal
);
2228 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2229 doc
: /* Return t if NUMBER is zero. */)
2231 register Lisp_Object number
;
2233 CHECK_NUMBER_OR_FLOAT (number
);
2235 if (FLOATP (number
))
2237 if (XFLOAT_DATA (number
) == 0.0)
2247 /* Convert between long values and pairs of Lisp integers. */
2253 unsigned long top
= i
>> 16;
2254 unsigned int bot
= i
& 0xFFFF;
2256 return make_number (bot
);
2257 if (top
== (unsigned long)-1 >> 16)
2258 return Fcons (make_number (-1), make_number (bot
));
2259 return Fcons (make_number (top
), make_number (bot
));
2266 Lisp_Object top
, bot
;
2273 return ((XINT (top
) << 16) | XINT (bot
));
2276 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2277 doc
: /* Return the decimal representation of NUMBER as a string.
2278 Uses a minus sign if negative.
2279 NUMBER may be an integer or a floating point number. */)
2283 char buffer
[VALBITS
];
2285 CHECK_NUMBER_OR_FLOAT (number
);
2287 if (FLOATP (number
))
2289 char pigbuf
[350]; /* see comments in float_to_string */
2291 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2292 return build_string (pigbuf
);
2295 if (sizeof (int) == sizeof (EMACS_INT
))
2296 sprintf (buffer
, "%d", XINT (number
));
2297 else if (sizeof (long) == sizeof (EMACS_INT
))
2298 sprintf (buffer
, "%ld", (long) XINT (number
));
2301 return build_string (buffer
);
2305 digit_to_number (character
, base
)
2306 int character
, base
;
2310 if (character
>= '0' && character
<= '9')
2311 digit
= character
- '0';
2312 else if (character
>= 'a' && character
<= 'z')
2313 digit
= character
- 'a' + 10;
2314 else if (character
>= 'A' && character
<= 'Z')
2315 digit
= character
- 'A' + 10;
2325 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2326 doc
: /* Parse STRING as a decimal number and return the number.
2327 This parses both integers and floating point numbers.
2328 It ignores leading spaces and tabs.
2330 If BASE, interpret STRING as a number in that base. If BASE isn't
2331 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2332 If the base used is not 10, floating point is not recognized. */)
2334 register Lisp_Object string
, base
;
2336 register unsigned char *p
;
2341 CHECK_STRING (string
);
2347 CHECK_NUMBER (base
);
2349 if (b
< 2 || b
> 16)
2350 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2353 /* Skip any whitespace at the front of the number. Some versions of
2354 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2356 while (*p
== ' ' || *p
== '\t')
2367 if (isfloat_string (p
) && b
== 10)
2368 val
= make_float (sign
* atof (p
));
2375 int digit
= digit_to_number (*p
++, b
);
2381 val
= make_fixnum_or_float (sign
* v
);
2401 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2402 int, Lisp_Object
*));
2403 extern Lisp_Object
fmod_float ();
2406 arith_driver (code
, nargs
, args
)
2409 register Lisp_Object
*args
;
2411 register Lisp_Object val
;
2412 register int argnum
;
2413 register EMACS_INT accum
= 0;
2414 register EMACS_INT next
;
2416 switch (SWITCH_ENUM_CAST (code
))
2434 for (argnum
= 0; argnum
< nargs
; argnum
++)
2436 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2438 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2441 return float_arith_driver ((double) accum
, argnum
, code
,
2444 next
= XINT (args
[argnum
]);
2445 switch (SWITCH_ENUM_CAST (code
))
2451 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2462 Fsignal (Qarith_error
, Qnil
);
2476 if (!argnum
|| next
> accum
)
2480 if (!argnum
|| next
< accum
)
2486 XSETINT (val
, accum
);
2491 #define isnan(x) ((x) != (x))
2494 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2496 register int argnum
;
2499 register Lisp_Object
*args
;
2501 register Lisp_Object val
;
2504 for (; argnum
< nargs
; argnum
++)
2506 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2507 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2511 next
= XFLOAT_DATA (val
);
2515 args
[argnum
] = val
; /* runs into a compiler bug. */
2516 next
= XINT (args
[argnum
]);
2518 switch (SWITCH_ENUM_CAST (code
))
2524 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2534 if (! IEEE_FLOATING_POINT
&& next
== 0)
2535 Fsignal (Qarith_error
, Qnil
);
2542 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2544 if (!argnum
|| isnan (next
) || next
> accum
)
2548 if (!argnum
|| isnan (next
) || next
< accum
)
2554 return make_float (accum
);
2558 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2559 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2560 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2565 return arith_driver (Aadd
, nargs
, args
);
2568 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2569 doc
: /* Negate number or subtract numbers or markers and return the result.
2570 With one arg, negates it. With more than one arg,
2571 subtracts all but the first from the first.
2572 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2577 return arith_driver (Asub
, nargs
, args
);
2580 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2581 doc
: /* Return product of any number of arguments, which are numbers or markers.
2582 usage: (* &rest NUMBERS-OR-MARKERS) */)
2587 return arith_driver (Amult
, nargs
, args
);
2590 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2591 doc
: /* Return first argument divided by all the remaining arguments.
2592 The arguments must be numbers or markers.
2593 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2598 return arith_driver (Adiv
, nargs
, args
);
2601 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2602 doc
: /* Return remainder of X divided by Y.
2603 Both must be integers or markers. */)
2605 register Lisp_Object x
, y
;
2609 CHECK_NUMBER_COERCE_MARKER (x
);
2610 CHECK_NUMBER_COERCE_MARKER (y
);
2612 if (XFASTINT (y
) == 0)
2613 Fsignal (Qarith_error
, Qnil
);
2615 XSETINT (val
, XINT (x
) % XINT (y
));
2629 /* If the magnitude of the result exceeds that of the divisor, or
2630 the sign of the result does not agree with that of the dividend,
2631 iterate with the reduced value. This does not yield a
2632 particularly accurate result, but at least it will be in the
2633 range promised by fmod. */
2635 r
-= f2
* floor (r
/ f2
);
2636 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2640 #endif /* ! HAVE_FMOD */
2642 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2643 doc
: /* Return X modulo Y.
2644 The result falls between zero (inclusive) and Y (exclusive).
2645 Both X and Y must be numbers or markers. */)
2647 register Lisp_Object x
, y
;
2652 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2653 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2655 if (FLOATP (x
) || FLOATP (y
))
2656 return fmod_float (x
, y
);
2662 Fsignal (Qarith_error
, Qnil
);
2666 /* If the "remainder" comes out with the wrong sign, fix it. */
2667 if (i2
< 0 ? i1
> 0 : i1
< 0)
2674 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2675 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2676 The value is always a number; markers are converted to numbers.
2677 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2682 return arith_driver (Amax
, nargs
, args
);
2685 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2686 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2687 The value is always a number; markers are converted to numbers.
2688 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2693 return arith_driver (Amin
, nargs
, args
);
2696 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2697 doc
: /* Return bitwise-and of all the arguments.
2698 Arguments may be integers, or markers converted to integers.
2699 usage: (logand &rest INTS-OR-MARKERS) */)
2704 return arith_driver (Alogand
, nargs
, args
);
2707 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2708 doc
: /* Return bitwise-or of all the arguments.
2709 Arguments may be integers, or markers converted to integers.
2710 usage: (logior &rest INTS-OR-MARKERS) */)
2715 return arith_driver (Alogior
, nargs
, args
);
2718 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2719 doc
: /* Return bitwise-exclusive-or of all the arguments.
2720 Arguments may be integers, or markers converted to integers.
2721 usage: (logxor &rest INTS-OR-MARKERS) */)
2726 return arith_driver (Alogxor
, nargs
, args
);
2729 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2730 doc
: /* Return VALUE with its bits shifted left by COUNT.
2731 If COUNT is negative, shifting is actually to the right.
2732 In this case, the sign bit is duplicated. */)
2734 register Lisp_Object value
, count
;
2736 register Lisp_Object val
;
2738 CHECK_NUMBER (value
);
2739 CHECK_NUMBER (count
);
2741 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2743 else if (XINT (count
) > 0)
2744 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2745 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2746 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2748 XSETINT (val
, XINT (value
) >> -XINT (count
));
2752 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2753 doc
: /* Return VALUE with its bits shifted left by COUNT.
2754 If COUNT is negative, shifting is actually to the right.
2755 In this case, zeros are shifted in on the left. */)
2757 register Lisp_Object value
, count
;
2759 register Lisp_Object val
;
2761 CHECK_NUMBER (value
);
2762 CHECK_NUMBER (count
);
2764 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2766 else if (XINT (count
) > 0)
2767 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2768 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2771 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2775 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2776 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2777 Markers are converted to integers. */)
2779 register Lisp_Object number
;
2781 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2783 if (FLOATP (number
))
2784 return (make_float (1.0 + XFLOAT_DATA (number
)));
2786 XSETINT (number
, XINT (number
) + 1);
2790 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2791 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2792 Markers are converted to integers. */)
2794 register Lisp_Object number
;
2796 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2798 if (FLOATP (number
))
2799 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2801 XSETINT (number
, XINT (number
) - 1);
2805 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2806 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2808 register Lisp_Object number
;
2810 CHECK_NUMBER (number
);
2811 XSETINT (number
, ~XINT (number
));
2818 Lisp_Object error_tail
, arith_tail
;
2820 Qquote
= intern ("quote");
2821 Qlambda
= intern ("lambda");
2822 Qsubr
= intern ("subr");
2823 Qerror_conditions
= intern ("error-conditions");
2824 Qerror_message
= intern ("error-message");
2825 Qtop_level
= intern ("top-level");
2827 Qerror
= intern ("error");
2828 Qquit
= intern ("quit");
2829 Qwrong_type_argument
= intern ("wrong-type-argument");
2830 Qargs_out_of_range
= intern ("args-out-of-range");
2831 Qvoid_function
= intern ("void-function");
2832 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2833 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2834 Qvoid_variable
= intern ("void-variable");
2835 Qsetting_constant
= intern ("setting-constant");
2836 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2838 Qinvalid_function
= intern ("invalid-function");
2839 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2840 Qno_catch
= intern ("no-catch");
2841 Qend_of_file
= intern ("end-of-file");
2842 Qarith_error
= intern ("arith-error");
2843 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2844 Qend_of_buffer
= intern ("end-of-buffer");
2845 Qbuffer_read_only
= intern ("buffer-read-only");
2846 Qtext_read_only
= intern ("text-read-only");
2847 Qmark_inactive
= intern ("mark-inactive");
2849 Qlistp
= intern ("listp");
2850 Qconsp
= intern ("consp");
2851 Qsymbolp
= intern ("symbolp");
2852 Qkeywordp
= intern ("keywordp");
2853 Qintegerp
= intern ("integerp");
2854 Qnatnump
= intern ("natnump");
2855 Qwholenump
= intern ("wholenump");
2856 Qstringp
= intern ("stringp");
2857 Qarrayp
= intern ("arrayp");
2858 Qsequencep
= intern ("sequencep");
2859 Qbufferp
= intern ("bufferp");
2860 Qvectorp
= intern ("vectorp");
2861 Qchar_or_string_p
= intern ("char-or-string-p");
2862 Qmarkerp
= intern ("markerp");
2863 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2864 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2865 Qboundp
= intern ("boundp");
2866 Qfboundp
= intern ("fboundp");
2868 Qfloatp
= intern ("floatp");
2869 Qnumberp
= intern ("numberp");
2870 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2872 Qchar_table_p
= intern ("char-table-p");
2873 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2875 Qsubrp
= intern ("subrp");
2876 Qunevalled
= intern ("unevalled");
2877 Qmany
= intern ("many");
2879 Qcdr
= intern ("cdr");
2881 /* Handle automatic advice activation */
2882 Qad_advice_info
= intern ("ad-advice-info");
2883 Qad_activate_internal
= intern ("ad-activate-internal");
2885 error_tail
= Fcons (Qerror
, Qnil
);
2887 /* ERROR is used as a signaler for random errors for which nothing else is right */
2889 Fput (Qerror
, Qerror_conditions
,
2891 Fput (Qerror
, Qerror_message
,
2892 build_string ("error"));
2894 Fput (Qquit
, Qerror_conditions
,
2895 Fcons (Qquit
, Qnil
));
2896 Fput (Qquit
, Qerror_message
,
2897 build_string ("Quit"));
2899 Fput (Qwrong_type_argument
, Qerror_conditions
,
2900 Fcons (Qwrong_type_argument
, error_tail
));
2901 Fput (Qwrong_type_argument
, Qerror_message
,
2902 build_string ("Wrong type argument"));
2904 Fput (Qargs_out_of_range
, Qerror_conditions
,
2905 Fcons (Qargs_out_of_range
, error_tail
));
2906 Fput (Qargs_out_of_range
, Qerror_message
,
2907 build_string ("Args out of range"));
2909 Fput (Qvoid_function
, Qerror_conditions
,
2910 Fcons (Qvoid_function
, error_tail
));
2911 Fput (Qvoid_function
, Qerror_message
,
2912 build_string ("Symbol's function definition is void"));
2914 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2915 Fcons (Qcyclic_function_indirection
, error_tail
));
2916 Fput (Qcyclic_function_indirection
, Qerror_message
,
2917 build_string ("Symbol's chain of function indirections contains a loop"));
2919 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2920 Fcons (Qcyclic_variable_indirection
, error_tail
));
2921 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2922 build_string ("Symbol's chain of variable indirections contains a loop"));
2924 Qcircular_list
= intern ("circular-list");
2925 staticpro (&Qcircular_list
);
2926 Fput (Qcircular_list
, Qerror_conditions
,
2927 Fcons (Qcircular_list
, error_tail
));
2928 Fput (Qcircular_list
, Qerror_message
,
2929 build_string ("List contains a loop"));
2931 Fput (Qvoid_variable
, Qerror_conditions
,
2932 Fcons (Qvoid_variable
, error_tail
));
2933 Fput (Qvoid_variable
, Qerror_message
,
2934 build_string ("Symbol's value as variable is void"));
2936 Fput (Qsetting_constant
, Qerror_conditions
,
2937 Fcons (Qsetting_constant
, error_tail
));
2938 Fput (Qsetting_constant
, Qerror_message
,
2939 build_string ("Attempt to set a constant symbol"));
2941 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2942 Fcons (Qinvalid_read_syntax
, error_tail
));
2943 Fput (Qinvalid_read_syntax
, Qerror_message
,
2944 build_string ("Invalid read syntax"));
2946 Fput (Qinvalid_function
, Qerror_conditions
,
2947 Fcons (Qinvalid_function
, error_tail
));
2948 Fput (Qinvalid_function
, Qerror_message
,
2949 build_string ("Invalid function"));
2951 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2952 Fcons (Qwrong_number_of_arguments
, error_tail
));
2953 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2954 build_string ("Wrong number of arguments"));
2956 Fput (Qno_catch
, Qerror_conditions
,
2957 Fcons (Qno_catch
, error_tail
));
2958 Fput (Qno_catch
, Qerror_message
,
2959 build_string ("No catch for tag"));
2961 Fput (Qend_of_file
, Qerror_conditions
,
2962 Fcons (Qend_of_file
, error_tail
));
2963 Fput (Qend_of_file
, Qerror_message
,
2964 build_string ("End of file during parsing"));
2966 arith_tail
= Fcons (Qarith_error
, error_tail
);
2967 Fput (Qarith_error
, Qerror_conditions
,
2969 Fput (Qarith_error
, Qerror_message
,
2970 build_string ("Arithmetic error"));
2972 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2973 Fcons (Qbeginning_of_buffer
, error_tail
));
2974 Fput (Qbeginning_of_buffer
, Qerror_message
,
2975 build_string ("Beginning of buffer"));
2977 Fput (Qend_of_buffer
, Qerror_conditions
,
2978 Fcons (Qend_of_buffer
, error_tail
));
2979 Fput (Qend_of_buffer
, Qerror_message
,
2980 build_string ("End of buffer"));
2982 Fput (Qbuffer_read_only
, Qerror_conditions
,
2983 Fcons (Qbuffer_read_only
, error_tail
));
2984 Fput (Qbuffer_read_only
, Qerror_message
,
2985 build_string ("Buffer is read-only"));
2987 Fput (Qtext_read_only
, Qerror_conditions
,
2988 Fcons (Qtext_read_only
, error_tail
));
2989 Fput (Qtext_read_only
, Qerror_message
,
2990 build_string ("Text is read-only"));
2992 Qrange_error
= intern ("range-error");
2993 Qdomain_error
= intern ("domain-error");
2994 Qsingularity_error
= intern ("singularity-error");
2995 Qoverflow_error
= intern ("overflow-error");
2996 Qunderflow_error
= intern ("underflow-error");
2998 Fput (Qdomain_error
, Qerror_conditions
,
2999 Fcons (Qdomain_error
, arith_tail
));
3000 Fput (Qdomain_error
, Qerror_message
,
3001 build_string ("Arithmetic domain error"));
3003 Fput (Qrange_error
, Qerror_conditions
,
3004 Fcons (Qrange_error
, arith_tail
));
3005 Fput (Qrange_error
, Qerror_message
,
3006 build_string ("Arithmetic range error"));
3008 Fput (Qsingularity_error
, Qerror_conditions
,
3009 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3010 Fput (Qsingularity_error
, Qerror_message
,
3011 build_string ("Arithmetic singularity error"));
3013 Fput (Qoverflow_error
, Qerror_conditions
,
3014 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3015 Fput (Qoverflow_error
, Qerror_message
,
3016 build_string ("Arithmetic overflow error"));
3018 Fput (Qunderflow_error
, Qerror_conditions
,
3019 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3020 Fput (Qunderflow_error
, Qerror_message
,
3021 build_string ("Arithmetic underflow error"));
3023 staticpro (&Qrange_error
);
3024 staticpro (&Qdomain_error
);
3025 staticpro (&Qsingularity_error
);
3026 staticpro (&Qoverflow_error
);
3027 staticpro (&Qunderflow_error
);
3031 staticpro (&Qquote
);
3032 staticpro (&Qlambda
);
3034 staticpro (&Qunbound
);
3035 staticpro (&Qerror_conditions
);
3036 staticpro (&Qerror_message
);
3037 staticpro (&Qtop_level
);
3039 staticpro (&Qerror
);
3041 staticpro (&Qwrong_type_argument
);
3042 staticpro (&Qargs_out_of_range
);
3043 staticpro (&Qvoid_function
);
3044 staticpro (&Qcyclic_function_indirection
);
3045 staticpro (&Qvoid_variable
);
3046 staticpro (&Qsetting_constant
);
3047 staticpro (&Qinvalid_read_syntax
);
3048 staticpro (&Qwrong_number_of_arguments
);
3049 staticpro (&Qinvalid_function
);
3050 staticpro (&Qno_catch
);
3051 staticpro (&Qend_of_file
);
3052 staticpro (&Qarith_error
);
3053 staticpro (&Qbeginning_of_buffer
);
3054 staticpro (&Qend_of_buffer
);
3055 staticpro (&Qbuffer_read_only
);
3056 staticpro (&Qtext_read_only
);
3057 staticpro (&Qmark_inactive
);
3059 staticpro (&Qlistp
);
3060 staticpro (&Qconsp
);
3061 staticpro (&Qsymbolp
);
3062 staticpro (&Qkeywordp
);
3063 staticpro (&Qintegerp
);
3064 staticpro (&Qnatnump
);
3065 staticpro (&Qwholenump
);
3066 staticpro (&Qstringp
);
3067 staticpro (&Qarrayp
);
3068 staticpro (&Qsequencep
);
3069 staticpro (&Qbufferp
);
3070 staticpro (&Qvectorp
);
3071 staticpro (&Qchar_or_string_p
);
3072 staticpro (&Qmarkerp
);
3073 staticpro (&Qbuffer_or_string_p
);
3074 staticpro (&Qinteger_or_marker_p
);
3075 staticpro (&Qfloatp
);
3076 staticpro (&Qnumberp
);
3077 staticpro (&Qnumber_or_marker_p
);
3078 staticpro (&Qchar_table_p
);
3079 staticpro (&Qvector_or_char_table_p
);
3080 staticpro (&Qsubrp
);
3082 staticpro (&Qunevalled
);
3084 staticpro (&Qboundp
);
3085 staticpro (&Qfboundp
);
3087 staticpro (&Qad_advice_info
);
3088 staticpro (&Qad_activate_internal
);
3090 /* Types that type-of returns. */
3091 Qinteger
= intern ("integer");
3092 Qsymbol
= intern ("symbol");
3093 Qstring
= intern ("string");
3094 Qcons
= intern ("cons");
3095 Qmarker
= intern ("marker");
3096 Qoverlay
= intern ("overlay");
3097 Qfloat
= intern ("float");
3098 Qwindow_configuration
= intern ("window-configuration");
3099 Qprocess
= intern ("process");
3100 Qwindow
= intern ("window");
3101 /* Qsubr = intern ("subr"); */
3102 Qcompiled_function
= intern ("compiled-function");
3103 Qbuffer
= intern ("buffer");
3104 Qframe
= intern ("frame");
3105 Qvector
= intern ("vector");
3106 Qchar_table
= intern ("char-table");
3107 Qbool_vector
= intern ("bool-vector");
3108 Qhash_table
= intern ("hash-table");
3110 staticpro (&Qinteger
);
3111 staticpro (&Qsymbol
);
3112 staticpro (&Qstring
);
3114 staticpro (&Qmarker
);
3115 staticpro (&Qoverlay
);
3116 staticpro (&Qfloat
);
3117 staticpro (&Qwindow_configuration
);
3118 staticpro (&Qprocess
);
3119 staticpro (&Qwindow
);
3120 /* staticpro (&Qsubr); */
3121 staticpro (&Qcompiled_function
);
3122 staticpro (&Qbuffer
);
3123 staticpro (&Qframe
);
3124 staticpro (&Qvector
);
3125 staticpro (&Qchar_table
);
3126 staticpro (&Qbool_vector
);
3127 staticpro (&Qhash_table
);
3129 defsubr (&Sindirect_variable
);
3130 defsubr (&Ssubr_interactive_form
);
3133 defsubr (&Stype_of
);
3138 defsubr (&Sintegerp
);
3139 defsubr (&Sinteger_or_marker_p
);
3140 defsubr (&Snumberp
);
3141 defsubr (&Snumber_or_marker_p
);
3143 defsubr (&Snatnump
);
3144 defsubr (&Ssymbolp
);
3145 defsubr (&Skeywordp
);
3146 defsubr (&Sstringp
);
3147 defsubr (&Smultibyte_string_p
);
3148 defsubr (&Svectorp
);
3149 defsubr (&Schar_table_p
);
3150 defsubr (&Svector_or_char_table_p
);
3151 defsubr (&Sbool_vector_p
);
3153 defsubr (&Ssequencep
);
3154 defsubr (&Sbufferp
);
3155 defsubr (&Smarkerp
);
3157 defsubr (&Sbyte_code_function_p
);
3158 defsubr (&Schar_or_string_p
);
3161 defsubr (&Scar_safe
);
3162 defsubr (&Scdr_safe
);
3165 defsubr (&Ssymbol_function
);
3166 defsubr (&Sindirect_function
);
3167 defsubr (&Ssymbol_plist
);
3168 defsubr (&Ssymbol_name
);
3169 defsubr (&Smakunbound
);
3170 defsubr (&Sfmakunbound
);
3172 defsubr (&Sfboundp
);
3174 defsubr (&Sdefalias
);
3175 defsubr (&Ssetplist
);
3176 defsubr (&Ssymbol_value
);
3178 defsubr (&Sdefault_boundp
);
3179 defsubr (&Sdefault_value
);
3180 defsubr (&Sset_default
);
3181 defsubr (&Ssetq_default
);
3182 defsubr (&Smake_variable_buffer_local
);
3183 defsubr (&Smake_local_variable
);
3184 defsubr (&Skill_local_variable
);
3185 defsubr (&Smake_variable_frame_local
);
3186 defsubr (&Slocal_variable_p
);
3187 defsubr (&Slocal_variable_if_set_p
);
3190 defsubr (&Snumber_to_string
);
3191 defsubr (&Sstring_to_number
);
3192 defsubr (&Seqlsign
);
3215 defsubr (&Ssubr_arity
);
3217 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3219 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3220 doc
: /* The largest value that is representable in a Lisp integer. */);
3221 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3223 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3224 doc
: /* The smallest value that is representable in a Lisp integer. */);
3225 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3232 #if defined(USG) && !defined(POSIX_SIGNALS)
3233 /* USG systems forget handlers when they are used;
3234 must reestablish each time */
3235 signal (signo
, arith_error
);
3238 /* VMS systems are like USG. */
3239 signal (signo
, arith_error
);
3243 #else /* not BSD4_1 */
3244 sigsetmask (SIGEMPTYMASK
);
3245 #endif /* not BSD4_1 */
3247 Fsignal (Qarith_error
, Qnil
);
3253 /* Don't do this if just dumping out.
3254 We don't want to call `signal' in this case
3255 so that we don't have trouble with dumping
3256 signal-delivering routines in an inconsistent state. */
3260 #endif /* CANNOT_DUMP */
3261 signal (SIGFPE
, arith_error
);
3264 signal (SIGEMT
, arith_error
);
3268 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3269 (do not change this comment) */