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, 2002
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. */
28 #include "character.h"
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 && XSYMBOL (object
)->name
->data
[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 or a string. */)
448 register Lisp_Object object
;
450 if (CHARACTERP (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. */)
633 register Lisp_Object symbol
;
635 CHECK_SYMBOL (symbol
);
636 if (XSYMBOL (symbol
)->constant
)
637 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
638 Fset (symbol
, Qunbound
);
642 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
643 doc
: /* Make SYMBOL's function definition be void. */)
645 register Lisp_Object symbol
;
647 CHECK_SYMBOL (symbol
);
648 if (NILP (symbol
) || EQ (symbol
, Qt
))
649 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
650 XSYMBOL (symbol
)->function
= Qunbound
;
654 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
655 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
657 register Lisp_Object symbol
;
659 CHECK_SYMBOL (symbol
);
660 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
661 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
662 return XSYMBOL (symbol
)->function
;
665 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
666 doc
: /* Return SYMBOL's property list. */)
668 register Lisp_Object symbol
;
670 CHECK_SYMBOL (symbol
);
671 return XSYMBOL (symbol
)->plist
;
674 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
675 doc
: /* Return SYMBOL's name, a string. */)
677 register Lisp_Object symbol
;
679 register Lisp_Object name
;
681 CHECK_SYMBOL (symbol
);
682 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
686 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
687 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
689 register Lisp_Object symbol
, definition
;
691 CHECK_SYMBOL (symbol
);
692 if (NILP (symbol
) || EQ (symbol
, Qt
))
693 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
694 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
695 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
697 XSYMBOL (symbol
)->function
= definition
;
698 /* Handle automatic advice activation */
699 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
701 call2 (Qad_activate_internal
, symbol
, Qnil
);
702 definition
= XSYMBOL (symbol
)->function
;
707 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
708 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
709 Associates the function with the current load file, if any. */)
711 register Lisp_Object symbol
, definition
;
713 definition
= Ffset (symbol
, definition
);
714 LOADHIST_ATTACH (symbol
);
718 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
719 doc
: /* Set SYMBOL's property list to NEWVAL, and return NEWVAL. */)
721 register Lisp_Object symbol
, newplist
;
723 CHECK_SYMBOL (symbol
);
724 XSYMBOL (symbol
)->plist
= newplist
;
728 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
729 doc
: /* Return minimum and maximum number of args allowed for SUBR.
730 SUBR must be a built-in function.
731 The returned value is a pair (MIN . MAX). MIN is the minimum number
732 of args. MAX is the maximum number or the symbol `many', for a
733 function with `&rest' args, or `unevalled' for a special form. */)
737 short minargs
, maxargs
;
739 wrong_type_argument (Qsubrp
, subr
);
740 minargs
= XSUBR (subr
)->min_args
;
741 maxargs
= XSUBR (subr
)->max_args
;
743 return Fcons (make_number (minargs
), Qmany
);
744 else if (maxargs
== UNEVALLED
)
745 return Fcons (make_number (minargs
), Qunevalled
);
747 return Fcons (make_number (minargs
), make_number (maxargs
));
750 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
751 doc
: /* Return the interactive form of SUBR or nil if none.
752 SUBR must be a built-in function. Value, if non-nil, is a list
753 \(interactive SPEC). */)
758 wrong_type_argument (Qsubrp
, subr
);
759 if (XSUBR (subr
)->prompt
)
760 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
765 /***********************************************************************
766 Getting and Setting Values of Symbols
767 ***********************************************************************/
769 /* Return the symbol holding SYMBOL's value. Signal
770 `cyclic-variable-indirection' if SYMBOL's chain of variable
771 indirections contains a loop. */
774 indirect_variable (symbol
)
777 Lisp_Object tortoise
, hare
;
779 hare
= tortoise
= symbol
;
781 while (XSYMBOL (hare
)->indirect_variable
)
783 hare
= XSYMBOL (hare
)->value
;
784 if (!XSYMBOL (hare
)->indirect_variable
)
787 hare
= XSYMBOL (hare
)->value
;
788 tortoise
= XSYMBOL (tortoise
)->value
;
790 if (EQ (hare
, tortoise
))
791 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
798 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
799 doc
: /* Return the variable at the end of OBJECT's variable chain.
800 If OBJECT is a symbol, follow all variable indirections and return the final
801 variable. If OBJECT is not a symbol, just return it.
802 Signal a cyclic-variable-indirection error if there is a loop in the
803 variable chain of symbols. */)
807 if (SYMBOLP (object
))
808 object
= indirect_variable (object
);
813 /* Given the raw contents of a symbol value cell,
814 return the Lisp value of the symbol.
815 This does not handle buffer-local variables; use
816 swap_in_symval_forwarding for that. */
819 do_symval_forwarding (valcontents
)
820 register Lisp_Object valcontents
;
822 register Lisp_Object val
;
824 if (MISCP (valcontents
))
825 switch (XMISCTYPE (valcontents
))
827 case Lisp_Misc_Intfwd
:
828 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
831 case Lisp_Misc_Boolfwd
:
832 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
834 case Lisp_Misc_Objfwd
:
835 return *XOBJFWD (valcontents
)->objvar
;
837 case Lisp_Misc_Buffer_Objfwd
:
838 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
839 return PER_BUFFER_VALUE (current_buffer
, offset
);
841 case Lisp_Misc_Kboard_Objfwd
:
842 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
843 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
848 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
849 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
850 buffer-independent contents of the value cell: forwarded just one
851 step past the buffer-localness.
853 BUF non-zero means set the value in buffer BUF instead of the
854 current buffer. This only plays a role for per-buffer variables. */
857 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
859 register Lisp_Object valcontents
, newval
;
862 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
865 switch (XMISCTYPE (valcontents
))
867 case Lisp_Misc_Intfwd
:
868 CHECK_NUMBER (newval
);
869 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
870 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
871 error ("Value out of range for variable `%s'",
872 XSYMBOL (symbol
)->name
->data
);
875 case Lisp_Misc_Boolfwd
:
876 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
879 case Lisp_Misc_Objfwd
:
880 *XOBJFWD (valcontents
)->objvar
= newval
;
883 case Lisp_Misc_Buffer_Objfwd
:
885 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
888 type
= PER_BUFFER_TYPE (offset
);
889 if (XINT (type
) == -1)
890 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
892 if (! NILP (type
) && ! NILP (newval
)
893 && XTYPE (newval
) != XINT (type
))
894 buffer_slot_type_mismatch (offset
);
897 buf
= current_buffer
;
898 PER_BUFFER_VALUE (buf
, offset
) = newval
;
902 case Lisp_Misc_Kboard_Objfwd
:
904 char *base
= (char *) current_kboard
;
905 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
906 *(Lisp_Object
*) p
= newval
;
917 valcontents
= SYMBOL_VALUE (symbol
);
918 if (BUFFER_LOCAL_VALUEP (valcontents
)
919 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
920 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
922 SET_SYMBOL_VALUE (symbol
, newval
);
926 /* Set up SYMBOL to refer to its global binding.
927 This makes it safe to alter the status of other bindings. */
930 swap_in_global_binding (symbol
)
933 Lisp_Object valcontents
, cdr
;
935 valcontents
= SYMBOL_VALUE (symbol
);
936 if (!BUFFER_LOCAL_VALUEP (valcontents
)
937 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
939 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
941 /* Unload the previously loaded binding. */
943 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
945 /* Select the global binding in the symbol. */
947 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
949 /* Indicate that the global binding is set up now. */
950 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
951 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
952 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
953 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
956 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
957 VALCONTENTS is the contents of its value cell,
958 which points to a struct Lisp_Buffer_Local_Value.
960 Return the value forwarded one step past the buffer-local stage.
961 This could be another forwarding pointer. */
964 swap_in_symval_forwarding (symbol
, valcontents
)
965 Lisp_Object symbol
, valcontents
;
967 register Lisp_Object tem1
;
969 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
972 || current_buffer
!= XBUFFER (tem1
)
973 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
974 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
976 if (XSYMBOL (symbol
)->indirect_variable
)
977 symbol
= indirect_variable (symbol
);
979 /* Unload the previously loaded binding. */
980 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
982 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
983 /* Choose the new binding. */
984 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
985 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
986 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
989 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
990 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
992 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
994 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
997 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
999 /* Load the new binding. */
1000 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1001 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1002 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1003 store_symval_forwarding (symbol
,
1004 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1007 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1010 /* Find the value of a symbol, returning Qunbound if it's not bound.
1011 This is helpful for code which just wants to get a variable's value
1012 if it has one, without signaling an error.
1013 Note that it must not be possible to quit
1014 within this function. Great care is required for this. */
1017 find_symbol_value (symbol
)
1020 register Lisp_Object valcontents
;
1021 register Lisp_Object val
;
1023 CHECK_SYMBOL (symbol
);
1024 valcontents
= SYMBOL_VALUE (symbol
);
1026 if (BUFFER_LOCAL_VALUEP (valcontents
)
1027 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1028 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1030 if (MISCP (valcontents
))
1032 switch (XMISCTYPE (valcontents
))
1034 case Lisp_Misc_Intfwd
:
1035 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1038 case Lisp_Misc_Boolfwd
:
1039 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1041 case Lisp_Misc_Objfwd
:
1042 return *XOBJFWD (valcontents
)->objvar
;
1044 case Lisp_Misc_Buffer_Objfwd
:
1045 return PER_BUFFER_VALUE (current_buffer
,
1046 XBUFFER_OBJFWD (valcontents
)->offset
);
1048 case Lisp_Misc_Kboard_Objfwd
:
1049 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1050 + (char *)current_kboard
);
1057 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1058 doc
: /* Return SYMBOL's value. Error if that is void. */)
1064 val
= find_symbol_value (symbol
);
1065 if (EQ (val
, Qunbound
))
1066 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1071 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1072 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1074 register Lisp_Object symbol
, newval
;
1076 return set_internal (symbol
, newval
, current_buffer
, 0);
1079 /* Return 1 if SYMBOL currently has a let-binding
1080 which was made in the buffer that is now current. */
1083 let_shadows_buffer_binding_p (symbol
)
1086 struct specbinding
*p
;
1088 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1090 && CONSP (p
->symbol
))
1092 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1093 if ((EQ (symbol
, let_bound_symbol
)
1094 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1095 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1096 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1100 return p
>= specpdl
;
1103 /* Store the value NEWVAL into SYMBOL.
1104 If buffer-locality is an issue, BUF specifies which buffer to use.
1105 (0 stands for the current buffer.)
1107 If BINDFLAG is zero, then if this symbol is supposed to become
1108 local in every buffer where it is set, then we make it local.
1109 If BINDFLAG is nonzero, we don't do that. */
1112 set_internal (symbol
, newval
, buf
, bindflag
)
1113 register Lisp_Object symbol
, newval
;
1117 int voide
= EQ (newval
, Qunbound
);
1119 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1122 buf
= current_buffer
;
1124 /* If restoring in a dead buffer, do nothing. */
1125 if (NILP (buf
->name
))
1128 CHECK_SYMBOL (symbol
);
1129 if (SYMBOL_CONSTANT_P (symbol
)
1130 && (NILP (Fkeywordp (symbol
))
1131 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1132 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1134 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1136 if (BUFFER_OBJFWDP (valcontents
))
1138 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1139 int idx
= PER_BUFFER_IDX (offset
);
1142 && !let_shadows_buffer_binding_p (symbol
))
1143 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1145 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1146 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1148 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1149 if (XSYMBOL (symbol
)->indirect_variable
)
1150 symbol
= indirect_variable (symbol
);
1152 /* What binding is loaded right now? */
1153 current_alist_element
1154 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1156 /* If the current buffer is not the buffer whose binding is
1157 loaded, or if there may be frame-local bindings and the frame
1158 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1159 the default binding is loaded, the loaded binding may be the
1161 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1162 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1163 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1164 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1165 || (BUFFER_LOCAL_VALUEP (valcontents
)
1166 && EQ (XCAR (current_alist_element
),
1167 current_alist_element
)))
1169 /* The currently loaded binding is not necessarily valid.
1170 We need to unload it, and choose a new binding. */
1172 /* Write out `realvalue' to the old loaded binding. */
1173 Fsetcdr (current_alist_element
,
1174 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1176 /* Find the new binding. */
1177 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1178 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1179 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1183 /* This buffer still sees the default value. */
1185 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1186 or if this is `let' rather than `set',
1187 make CURRENT-ALIST-ELEMENT point to itself,
1188 indicating that we're seeing the default value.
1189 Likewise if the variable has been let-bound
1190 in the current buffer. */
1191 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1192 || let_shadows_buffer_binding_p (symbol
))
1194 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1196 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1197 tem1
= Fassq (symbol
,
1198 XFRAME (selected_frame
)->param_alist
);
1201 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1203 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1205 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1206 and we're not within a let that was made for this buffer,
1207 create a new buffer-local binding for the variable.
1208 That means, give this buffer a new assoc for a local value
1209 and load that binding. */
1212 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1213 buf
->local_var_alist
1214 = Fcons (tem1
, buf
->local_var_alist
);
1218 /* Record which binding is now loaded. */
1219 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1222 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1223 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1224 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1226 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1229 /* If storing void (making the symbol void), forward only through
1230 buffer-local indicator, not through Lisp_Objfwd, etc. */
1232 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1234 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1236 /* If we just set a variable whose current binding is frame-local,
1237 store the new value in the frame parameter too. */
1239 if (BUFFER_LOCAL_VALUEP (valcontents
)
1240 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1242 /* What binding is loaded right now? */
1243 current_alist_element
1244 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1246 /* If the current buffer is not the buffer whose binding is
1247 loaded, or if there may be frame-local bindings and the frame
1248 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1249 the default binding is loaded, the loaded binding may be the
1251 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1252 XSETCDR (current_alist_element
, newval
);
1258 /* Access or set a buffer-local symbol's default value. */
1260 /* Return the default value of SYMBOL, but don't check for voidness.
1261 Return Qunbound if it is void. */
1264 default_value (symbol
)
1267 register Lisp_Object valcontents
;
1269 CHECK_SYMBOL (symbol
);
1270 valcontents
= SYMBOL_VALUE (symbol
);
1272 /* For a built-in buffer-local variable, get the default value
1273 rather than letting do_symval_forwarding get the current value. */
1274 if (BUFFER_OBJFWDP (valcontents
))
1276 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1277 if (PER_BUFFER_IDX (offset
) != 0)
1278 return PER_BUFFER_DEFAULT (offset
);
1281 /* Handle user-created local variables. */
1282 if (BUFFER_LOCAL_VALUEP (valcontents
)
1283 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1285 /* If var is set up for a buffer that lacks a local value for it,
1286 the current value is nominally the default value.
1287 But the `realvalue' slot may be more up to date, since
1288 ordinary setq stores just that slot. So use that. */
1289 Lisp_Object current_alist_element
, alist_element_car
;
1290 current_alist_element
1291 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1292 alist_element_car
= XCAR (current_alist_element
);
1293 if (EQ (alist_element_car
, current_alist_element
))
1294 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1296 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1298 /* For other variables, get the current value. */
1299 return do_symval_forwarding (valcontents
);
1302 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1303 doc
: /* Return t if SYMBOL has a non-void default value.
1304 This is the value that is seen in buffers that do not have their own values
1305 for this variable. */)
1309 register Lisp_Object value
;
1311 value
= default_value (symbol
);
1312 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1315 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1316 doc
: /* Return SYMBOL's default value.
1317 This is the value that is seen in buffers that do not have their own values
1318 for this variable. The default value is meaningful for variables with
1319 local bindings in certain buffers. */)
1323 register Lisp_Object value
;
1325 value
= default_value (symbol
);
1326 if (EQ (value
, Qunbound
))
1327 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1331 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1332 doc
: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1333 The default value is seen in buffers that do not have their own values
1334 for this variable. */)
1336 Lisp_Object symbol
, value
;
1338 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1340 CHECK_SYMBOL (symbol
);
1341 valcontents
= SYMBOL_VALUE (symbol
);
1343 /* Handle variables like case-fold-search that have special slots
1344 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1346 if (BUFFER_OBJFWDP (valcontents
))
1348 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1349 int idx
= PER_BUFFER_IDX (offset
);
1351 PER_BUFFER_DEFAULT (offset
) = value
;
1353 /* If this variable is not always local in all buffers,
1354 set it in the buffers that don't nominally have a local value. */
1359 for (b
= all_buffers
; b
; b
= b
->next
)
1360 if (!PER_BUFFER_VALUE_P (b
, idx
))
1361 PER_BUFFER_VALUE (b
, offset
) = value
;
1366 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1367 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1368 return Fset (symbol
, value
);
1370 /* Store new value into the DEFAULT-VALUE slot. */
1371 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1373 /* If the default binding is now loaded, set the REALVALUE slot too. */
1374 current_alist_element
1375 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1376 alist_element_buffer
= Fcar (current_alist_element
);
1377 if (EQ (alist_element_buffer
, current_alist_element
))
1378 store_symval_forwarding (symbol
,
1379 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1385 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1386 doc
: /* Set the default value of variable VAR to VALUE.
1387 VAR, the variable name, is literal (not evaluated);
1388 VALUE is an expression and it is evaluated.
1389 The default value of a variable is seen in buffers
1390 that do not have their own values for the variable.
1392 More generally, you can use multiple variables and values, as in
1393 (setq-default SYMBOL VALUE SYMBOL VALUE...)
1394 This sets each SYMBOL's default value to the corresponding VALUE.
1395 The VALUE for the Nth SYMBOL can refer to the new default values
1397 usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */)
1401 register Lisp_Object args_left
;
1402 register Lisp_Object val
, symbol
;
1403 struct gcpro gcpro1
;
1413 val
= Feval (Fcar (Fcdr (args_left
)));
1414 symbol
= Fcar (args_left
);
1415 Fset_default (symbol
, val
);
1416 args_left
= Fcdr (Fcdr (args_left
));
1418 while (!NILP (args_left
));
1424 /* Lisp functions for creating and removing buffer-local variables. */
1426 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1427 1, 1, "vMake Variable Buffer Local: ",
1428 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1429 At any time, the value for the current buffer is in effect,
1430 unless the variable has never been set in this buffer,
1431 in which case the default value is in effect.
1432 Note that binding the variable with `let', or setting it while
1433 a `let'-style binding made in this buffer is in effect,
1434 does not make the variable buffer-local.
1436 The function `default-value' gets the default value and `set-default' sets it. */)
1438 register Lisp_Object variable
;
1440 register Lisp_Object tem
, valcontents
, newval
;
1442 CHECK_SYMBOL (variable
);
1444 valcontents
= SYMBOL_VALUE (variable
);
1445 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1446 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1448 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1450 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1452 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1455 if (EQ (valcontents
, Qunbound
))
1456 SET_SYMBOL_VALUE (variable
, Qnil
);
1457 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1459 newval
= allocate_misc ();
1460 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1461 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1462 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1463 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1464 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1465 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1466 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1467 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1468 SET_SYMBOL_VALUE (variable
, newval
);
1472 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1473 1, 1, "vMake Local Variable: ",
1474 doc
: /* Make VARIABLE have a separate value in the current buffer.
1475 Other buffers will continue to share a common default value.
1476 \(The buffer-local value of VARIABLE starts out as the same value
1477 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1478 See also `make-variable-buffer-local'.
1480 If the variable is already arranged to become local when set,
1481 this function causes a local value to exist for this buffer,
1482 just as setting the variable would do.
1484 This function returns VARIABLE, and therefore
1485 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1488 Do not use `make-local-variable' to make a hook variable buffer-local.
1489 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1491 register Lisp_Object variable
;
1493 register Lisp_Object tem
, valcontents
;
1495 CHECK_SYMBOL (variable
);
1497 valcontents
= SYMBOL_VALUE (variable
);
1498 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1499 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1501 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1503 tem
= Fboundp (variable
);
1505 /* Make sure the symbol has a local value in this particular buffer,
1506 by setting it to the same value it already has. */
1507 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1510 /* Make sure symbol is set up to hold per-buffer values. */
1511 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1514 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1516 newval
= allocate_misc ();
1517 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1518 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1519 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1520 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1521 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1522 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1523 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1524 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1525 SET_SYMBOL_VALUE (variable
, newval
);;
1527 /* Make sure this buffer has its own value of symbol. */
1528 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1531 /* Swap out any local binding for some other buffer, and make
1532 sure the current value is permanently recorded, if it's the
1534 find_symbol_value (variable
);
1536 current_buffer
->local_var_alist
1537 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1538 current_buffer
->local_var_alist
);
1540 /* Make sure symbol does not think it is set up for this buffer;
1541 force it to look once again for this buffer's value. */
1543 Lisp_Object
*pvalbuf
;
1545 valcontents
= SYMBOL_VALUE (variable
);
1547 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1548 if (current_buffer
== XBUFFER (*pvalbuf
))
1550 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1554 /* If the symbol forwards into a C variable, then load the binding
1555 for this buffer now. If C code modifies the variable before we
1556 load the binding in, then that new value will clobber the default
1557 binding the next time we unload it. */
1558 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1559 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1560 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1565 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1566 1, 1, "vKill Local Variable: ",
1567 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1568 From now on the default value will apply in this buffer. */)
1570 register Lisp_Object variable
;
1572 register Lisp_Object tem
, valcontents
;
1574 CHECK_SYMBOL (variable
);
1576 valcontents
= SYMBOL_VALUE (variable
);
1578 if (BUFFER_OBJFWDP (valcontents
))
1580 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1581 int idx
= PER_BUFFER_IDX (offset
);
1585 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1586 PER_BUFFER_VALUE (current_buffer
, offset
)
1587 = PER_BUFFER_DEFAULT (offset
);
1592 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1593 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1596 /* Get rid of this buffer's alist element, if any. */
1598 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1600 current_buffer
->local_var_alist
1601 = Fdelq (tem
, current_buffer
->local_var_alist
);
1603 /* If the symbol is set up with the current buffer's binding
1604 loaded, recompute its value. We have to do it now, or else
1605 forwarded objects won't work right. */
1607 Lisp_Object
*pvalbuf
;
1608 valcontents
= SYMBOL_VALUE (variable
);
1609 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1610 if (current_buffer
== XBUFFER (*pvalbuf
))
1613 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1614 find_symbol_value (variable
);
1621 /* Lisp functions for creating and removing buffer-local variables. */
1623 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1624 1, 1, "vMake Variable Frame Local: ",
1625 doc
: /* Enable VARIABLE to have frame-local bindings.
1626 When a frame-local binding exists in the current frame,
1627 it is in effect whenever the current buffer has no buffer-local binding.
1628 A frame-local binding is actual a frame parameter value;
1629 thus, any given frame has a local binding for VARIABLE
1630 if it has a value for the frame parameter named VARIABLE.
1631 See `modify-frame-parameters'. */)
1633 register Lisp_Object variable
;
1635 register Lisp_Object tem
, valcontents
, newval
;
1637 CHECK_SYMBOL (variable
);
1639 valcontents
= SYMBOL_VALUE (variable
);
1640 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1641 || BUFFER_OBJFWDP (valcontents
))
1642 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1644 if (BUFFER_LOCAL_VALUEP (valcontents
)
1645 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1647 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1651 if (EQ (valcontents
, Qunbound
))
1652 SET_SYMBOL_VALUE (variable
, Qnil
);
1653 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1655 newval
= allocate_misc ();
1656 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1657 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1658 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1659 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1660 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1661 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1662 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1663 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1664 SET_SYMBOL_VALUE (variable
, newval
);
1668 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1670 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1671 BUFFER defaults to the current buffer. */)
1673 register Lisp_Object variable
, buffer
;
1675 Lisp_Object valcontents
;
1676 register struct buffer
*buf
;
1679 buf
= current_buffer
;
1682 CHECK_BUFFER (buffer
);
1683 buf
= XBUFFER (buffer
);
1686 CHECK_SYMBOL (variable
);
1688 valcontents
= SYMBOL_VALUE (variable
);
1689 if (BUFFER_LOCAL_VALUEP (valcontents
)
1690 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1692 Lisp_Object tail
, elt
;
1694 variable
= indirect_variable (variable
);
1695 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1698 if (EQ (variable
, XCAR (elt
)))
1702 if (BUFFER_OBJFWDP (valcontents
))
1704 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1705 int idx
= PER_BUFFER_IDX (offset
);
1706 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1712 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1714 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
1715 BUFFER defaults to the current buffer. */)
1717 register Lisp_Object variable
, buffer
;
1719 Lisp_Object valcontents
;
1720 register struct buffer
*buf
;
1723 buf
= current_buffer
;
1726 CHECK_BUFFER (buffer
);
1727 buf
= XBUFFER (buffer
);
1730 CHECK_SYMBOL (variable
);
1732 valcontents
= SYMBOL_VALUE (variable
);
1734 /* This means that make-variable-buffer-local was done. */
1735 if (BUFFER_LOCAL_VALUEP (valcontents
))
1737 /* All these slots become local if they are set. */
1738 if (BUFFER_OBJFWDP (valcontents
))
1740 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1742 Lisp_Object tail
, elt
;
1743 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1746 if (EQ (variable
, XCAR (elt
)))
1753 /* Find the function at the end of a chain of symbol function indirections. */
1755 /* If OBJECT is a symbol, find the end of its function chain and
1756 return the value found there. If OBJECT is not a symbol, just
1757 return it. If there is a cycle in the function chain, signal a
1758 cyclic-function-indirection error.
1760 This is like Findirect_function, except that it doesn't signal an
1761 error if the chain ends up unbound. */
1763 indirect_function (object
)
1764 register Lisp_Object object
;
1766 Lisp_Object tortoise
, hare
;
1768 hare
= tortoise
= object
;
1772 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1774 hare
= XSYMBOL (hare
)->function
;
1775 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1777 hare
= XSYMBOL (hare
)->function
;
1779 tortoise
= XSYMBOL (tortoise
)->function
;
1781 if (EQ (hare
, tortoise
))
1782 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1788 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1789 doc
: /* Return the function at the end of OBJECT's function chain.
1790 If OBJECT is a symbol, follow all function indirections and return the final
1792 If OBJECT is not a symbol, just return it.
1793 Signal a void-function error if the final symbol is unbound.
1794 Signal a cyclic-function-indirection error if there is a loop in the
1795 function chain of symbols. */)
1797 register Lisp_Object object
;
1801 result
= indirect_function (object
);
1803 if (EQ (result
, Qunbound
))
1804 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1808 /* Extract and set vector and string elements */
1810 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1811 doc
: /* Return the element of ARRAY at index IDX.
1812 ARRAY may be a vector, a string, a char-table, a bool-vector,
1813 or a byte-code object. IDX starts at 0. */)
1815 register Lisp_Object array
;
1818 register int idxval
;
1821 idxval
= XINT (idx
);
1822 if (STRINGP (array
))
1826 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1827 args_out_of_range (array
, idx
);
1828 if (! STRING_MULTIBYTE (array
))
1829 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1830 idxval_byte
= string_char_to_byte (array
, idxval
);
1832 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1833 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1834 return make_number (c
);
1836 else if (BOOL_VECTOR_P (array
))
1840 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1841 args_out_of_range (array
, idx
);
1843 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1844 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1846 else if (CHAR_TABLE_P (array
))
1848 CHECK_CHARACTER (idx
);
1849 return CHAR_TABLE_REF (array
, idxval
);
1854 if (VECTORP (array
))
1855 size
= XVECTOR (array
)->size
;
1856 else if (COMPILEDP (array
))
1857 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1859 wrong_type_argument (Qarrayp
, array
);
1861 if (idxval
< 0 || idxval
>= size
)
1862 args_out_of_range (array
, idx
);
1863 return XVECTOR (array
)->contents
[idxval
];
1867 /* Don't use alloca for relocating string data larger than this, lest
1868 we overflow their stack. The value is the same as what used in
1869 fns.c for base64 handling. */
1870 #define MAX_ALLOCA 16*1024
1872 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1873 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1874 ARRAY may be a vector, a string, a char-table or a bool-vector.
1875 IDX starts at 0. */)
1876 (array
, idx
, newelt
)
1877 register Lisp_Object array
;
1878 Lisp_Object idx
, newelt
;
1880 register int idxval
;
1883 idxval
= XINT (idx
);
1884 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1885 && ! CHAR_TABLE_P (array
))
1886 array
= wrong_type_argument (Qarrayp
, array
);
1887 CHECK_IMPURE (array
);
1889 if (VECTORP (array
))
1891 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1892 args_out_of_range (array
, idx
);
1893 XVECTOR (array
)->contents
[idxval
] = newelt
;
1895 else if (BOOL_VECTOR_P (array
))
1899 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1900 args_out_of_range (array
, idx
);
1902 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1904 if (! NILP (newelt
))
1905 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1907 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1908 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1910 else if (CHAR_TABLE_P (array
))
1912 CHECK_CHARACTER (idx
);
1913 CHAR_TABLE_SET (array
, idxval
, newelt
);
1915 else if (STRING_MULTIBYTE (array
))
1917 int idxval_byte
, prev_bytes
, new_bytes
;
1918 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
1920 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1921 args_out_of_range (array
, idx
);
1922 CHECK_NUMBER (newelt
);
1924 idxval_byte
= string_char_to_byte (array
, idxval
);
1925 p1
= &XSTRING (array
)->data
[idxval_byte
];
1926 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
1927 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
1928 if (prev_bytes
!= new_bytes
)
1930 /* We must relocate the string data. */
1931 int nchars
= XSTRING (array
)->size
;
1932 int nbytes
= STRING_BYTES (XSTRING (array
));
1935 str
= (nbytes
<= MAX_ALLOCA
1936 ? (unsigned char *) alloca (nbytes
)
1937 : (unsigned char *) xmalloc (nbytes
));
1938 bcopy (XSTRING (array
)->data
, str
, nbytes
);
1939 allocate_string_data (XSTRING (array
), nchars
,
1940 nbytes
+ new_bytes
- prev_bytes
);
1941 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
1942 p1
= XSTRING (array
)->data
+ idxval_byte
;
1943 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
1944 nbytes
- (idxval_byte
+ prev_bytes
));
1945 if (nbytes
> MAX_ALLOCA
)
1947 clear_string_char_byte_cache ();
1954 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1955 args_out_of_range (array
, idx
);
1956 CHECK_NUMBER (newelt
);
1958 if (XINT (newelt
) < 0 || ASCII_CHAR_P (XINT (newelt
)))
1959 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1962 /* We must relocate the string data while converting it to
1964 int idxval_byte
, prev_bytes
, new_bytes
;
1965 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
1966 unsigned char *origstr
= XSTRING (array
)->data
, *str
;
1969 nchars
= XSTRING (array
)->size
;
1970 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
1971 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
1973 str
= (nbytes
<= MAX_ALLOCA
1974 ? (unsigned char *) alloca (nbytes
)
1975 : (unsigned char *) xmalloc (nbytes
));
1976 copy_text (XSTRING (array
)->data
, str
, nchars
, 0, 1);
1977 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
1979 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
1980 allocate_string_data (XSTRING (array
), nchars
,
1981 nbytes
+ new_bytes
- prev_bytes
);
1982 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
1983 p1
= XSTRING (array
)->data
+ idxval_byte
;
1986 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
1987 nbytes
- (idxval_byte
+ prev_bytes
));
1988 if (nbytes
> MAX_ALLOCA
)
1990 clear_string_char_byte_cache ();
1997 /* Arithmetic functions */
1999 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2002 arithcompare (num1
, num2
, comparison
)
2003 Lisp_Object num1
, num2
;
2004 enum comparison comparison
;
2006 double f1
= 0, f2
= 0;
2009 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2010 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2012 if (FLOATP (num1
) || FLOATP (num2
))
2015 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2016 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2022 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2027 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2032 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2037 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2042 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2047 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2056 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2057 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2059 register Lisp_Object num1
, num2
;
2061 return arithcompare (num1
, num2
, equal
);
2064 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2065 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2067 register Lisp_Object num1
, num2
;
2069 return arithcompare (num1
, num2
, less
);
2072 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2073 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2075 register Lisp_Object num1
, num2
;
2077 return arithcompare (num1
, num2
, grtr
);
2080 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2081 doc
: /* Return t if first arg is less than or equal to second arg.
2082 Both must be numbers or markers. */)
2084 register Lisp_Object num1
, num2
;
2086 return arithcompare (num1
, num2
, less_or_equal
);
2089 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2090 doc
: /* Return t if first arg is greater than or equal to second arg.
2091 Both must be numbers or markers. */)
2093 register Lisp_Object num1
, num2
;
2095 return arithcompare (num1
, num2
, grtr_or_equal
);
2098 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2099 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2101 register Lisp_Object num1
, num2
;
2103 return arithcompare (num1
, num2
, notequal
);
2106 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2107 doc
: /* Return t if NUMBER is zero. */)
2109 register Lisp_Object number
;
2111 CHECK_NUMBER_OR_FLOAT (number
);
2113 if (FLOATP (number
))
2115 if (XFLOAT_DATA (number
) == 0.0)
2125 /* Convert between long values and pairs of Lisp integers. */
2131 unsigned int top
= i
>> 16;
2132 unsigned int bot
= i
& 0xFFFF;
2134 return make_number (bot
);
2135 if (top
== (unsigned long)-1 >> 16)
2136 return Fcons (make_number (-1), make_number (bot
));
2137 return Fcons (make_number (top
), make_number (bot
));
2144 Lisp_Object top
, bot
;
2151 return ((XINT (top
) << 16) | XINT (bot
));
2154 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2155 doc
: /* Convert NUMBER to a string by printing it in decimal.
2156 Uses a minus sign if negative.
2157 NUMBER may be an integer or a floating point number. */)
2161 char buffer
[VALBITS
];
2163 CHECK_NUMBER_OR_FLOAT (number
);
2165 if (FLOATP (number
))
2167 char pigbuf
[350]; /* see comments in float_to_string */
2169 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2170 return build_string (pigbuf
);
2173 if (sizeof (int) == sizeof (EMACS_INT
))
2174 sprintf (buffer
, "%d", XINT (number
));
2175 else if (sizeof (long) == sizeof (EMACS_INT
))
2176 sprintf (buffer
, "%ld", (long) XINT (number
));
2179 return build_string (buffer
);
2183 digit_to_number (character
, base
)
2184 int character
, base
;
2188 if (character
>= '0' && character
<= '9')
2189 digit
= character
- '0';
2190 else if (character
>= 'a' && character
<= 'z')
2191 digit
= character
- 'a' + 10;
2192 else if (character
>= 'A' && character
<= 'Z')
2193 digit
= character
- 'A' + 10;
2203 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2204 doc
: /* Convert STRING to a number by parsing it as a decimal number.
2205 This parses both integers and floating point numbers.
2206 It ignores leading spaces and tabs.
2208 If BASE, interpret STRING as a number in that base. If BASE isn't
2209 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2210 If the base used is not 10, floating point is not recognized. */)
2212 register Lisp_Object string
, base
;
2214 register unsigned char *p
;
2219 CHECK_STRING (string
);
2225 CHECK_NUMBER (base
);
2227 if (b
< 2 || b
> 16)
2228 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2231 /* Skip any whitespace at the front of the number. Some versions of
2232 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2233 p
= XSTRING (string
)->data
;
2234 while (*p
== ' ' || *p
== '\t')
2245 if (isfloat_string (p
) && b
== 10)
2246 val
= make_float (sign
* atof (p
));
2253 int digit
= digit_to_number (*p
++, b
);
2259 val
= make_fixnum_or_float (sign
* v
);
2279 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2280 int, Lisp_Object
*));
2281 extern Lisp_Object
fmod_float ();
2284 arith_driver (code
, nargs
, args
)
2287 register Lisp_Object
*args
;
2289 register Lisp_Object val
;
2290 register int argnum
;
2291 register EMACS_INT accum
= 0;
2292 register EMACS_INT next
;
2294 switch (SWITCH_ENUM_CAST (code
))
2312 for (argnum
= 0; argnum
< nargs
; argnum
++)
2314 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2316 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2319 return float_arith_driver ((double) accum
, argnum
, code
,
2322 next
= XINT (args
[argnum
]);
2323 switch (SWITCH_ENUM_CAST (code
))
2329 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2340 Fsignal (Qarith_error
, Qnil
);
2354 if (!argnum
|| next
> accum
)
2358 if (!argnum
|| next
< accum
)
2364 XSETINT (val
, accum
);
2369 #define isnan(x) ((x) != (x))
2372 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2374 register int argnum
;
2377 register Lisp_Object
*args
;
2379 register Lisp_Object val
;
2382 for (; argnum
< nargs
; argnum
++)
2384 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2385 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2389 next
= XFLOAT_DATA (val
);
2393 args
[argnum
] = val
; /* runs into a compiler bug. */
2394 next
= XINT (args
[argnum
]);
2396 switch (SWITCH_ENUM_CAST (code
))
2402 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2412 if (! IEEE_FLOATING_POINT
&& next
== 0)
2413 Fsignal (Qarith_error
, Qnil
);
2420 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2422 if (!argnum
|| isnan (next
) || next
> accum
)
2426 if (!argnum
|| isnan (next
) || next
< accum
)
2432 return make_float (accum
);
2436 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2437 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2438 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2443 return arith_driver (Aadd
, nargs
, args
);
2446 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2447 doc
: /* Negate number or subtract numbers or markers.
2448 With one arg, negates it. With more than one arg,
2449 subtracts all but the first from the first.
2450 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2455 return arith_driver (Asub
, nargs
, args
);
2458 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2459 doc
: /* Return product of any number of arguments, which are numbers or markers.
2460 usage: (* &rest NUMBERS-OR-MARKERS) */)
2465 return arith_driver (Amult
, nargs
, args
);
2468 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2469 doc
: /* Return first argument divided by all the remaining arguments.
2470 The arguments must be numbers or markers.
2471 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2476 return arith_driver (Adiv
, nargs
, args
);
2479 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2480 doc
: /* Return remainder of X divided by Y.
2481 Both must be integers or markers. */)
2483 register Lisp_Object x
, y
;
2487 CHECK_NUMBER_COERCE_MARKER (x
);
2488 CHECK_NUMBER_COERCE_MARKER (y
);
2490 if (XFASTINT (y
) == 0)
2491 Fsignal (Qarith_error
, Qnil
);
2493 XSETINT (val
, XINT (x
) % XINT (y
));
2507 /* If the magnitude of the result exceeds that of the divisor, or
2508 the sign of the result does not agree with that of the dividend,
2509 iterate with the reduced value. This does not yield a
2510 particularly accurate result, but at least it will be in the
2511 range promised by fmod. */
2513 r
-= f2
* floor (r
/ f2
);
2514 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2518 #endif /* ! HAVE_FMOD */
2520 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2521 doc
: /* Return X modulo Y.
2522 The result falls between zero (inclusive) and Y (exclusive).
2523 Both X and Y must be numbers or markers. */)
2525 register Lisp_Object x
, y
;
2530 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2531 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2533 if (FLOATP (x
) || FLOATP (y
))
2534 return fmod_float (x
, y
);
2540 Fsignal (Qarith_error
, Qnil
);
2544 /* If the "remainder" comes out with the wrong sign, fix it. */
2545 if (i2
< 0 ? i1
> 0 : i1
< 0)
2552 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2553 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2554 The value is always a number; markers are converted to numbers.
2555 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2560 return arith_driver (Amax
, nargs
, args
);
2563 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2564 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2565 The value is always a number; markers are converted to numbers.
2566 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2571 return arith_driver (Amin
, nargs
, args
);
2574 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2575 doc
: /* Return bitwise-and of all the arguments.
2576 Arguments may be integers, or markers converted to integers.
2577 usage: (logand &rest INTS-OR-MARKERS) */)
2582 return arith_driver (Alogand
, nargs
, args
);
2585 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2586 doc
: /* Return bitwise-or of all the arguments.
2587 Arguments may be integers, or markers converted to integers.
2588 usage: (logior &rest INTS-OR-MARKERS) */)
2593 return arith_driver (Alogior
, nargs
, args
);
2596 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2597 doc
: /* Return bitwise-exclusive-or of all the arguments.
2598 Arguments may be integers, or markers converted to integers.
2599 usage: (logxor &rest INTS-OR-MARKERS) */)
2604 return arith_driver (Alogxor
, nargs
, args
);
2607 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2608 doc
: /* Return VALUE with its bits shifted left by COUNT.
2609 If COUNT is negative, shifting is actually to the right.
2610 In this case, the sign bit is duplicated. */)
2612 register Lisp_Object value
, count
;
2614 register Lisp_Object val
;
2616 CHECK_NUMBER (value
);
2617 CHECK_NUMBER (count
);
2619 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2621 else if (XINT (count
) > 0)
2622 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2623 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2624 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2626 XSETINT (val
, XINT (value
) >> -XINT (count
));
2630 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2631 doc
: /* Return VALUE with its bits shifted left by COUNT.
2632 If COUNT is negative, shifting is actually to the right.
2633 In this case, zeros are shifted in on the left. */)
2635 register Lisp_Object value
, count
;
2637 register Lisp_Object val
;
2639 CHECK_NUMBER (value
);
2640 CHECK_NUMBER (count
);
2642 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2644 else if (XINT (count
) > 0)
2645 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2646 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2649 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2653 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2654 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2655 Markers are converted to integers. */)
2657 register Lisp_Object number
;
2659 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2661 if (FLOATP (number
))
2662 return (make_float (1.0 + XFLOAT_DATA (number
)));
2664 XSETINT (number
, XINT (number
) + 1);
2668 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2669 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2670 Markers are converted to integers. */)
2672 register Lisp_Object number
;
2674 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2676 if (FLOATP (number
))
2677 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2679 XSETINT (number
, XINT (number
) - 1);
2683 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2684 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2686 register Lisp_Object number
;
2688 CHECK_NUMBER (number
);
2689 XSETINT (number
, ~XINT (number
));
2696 Lisp_Object error_tail
, arith_tail
;
2698 Qquote
= intern ("quote");
2699 Qlambda
= intern ("lambda");
2700 Qsubr
= intern ("subr");
2701 Qerror_conditions
= intern ("error-conditions");
2702 Qerror_message
= intern ("error-message");
2703 Qtop_level
= intern ("top-level");
2705 Qerror
= intern ("error");
2706 Qquit
= intern ("quit");
2707 Qwrong_type_argument
= intern ("wrong-type-argument");
2708 Qargs_out_of_range
= intern ("args-out-of-range");
2709 Qvoid_function
= intern ("void-function");
2710 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2711 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2712 Qvoid_variable
= intern ("void-variable");
2713 Qsetting_constant
= intern ("setting-constant");
2714 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2716 Qinvalid_function
= intern ("invalid-function");
2717 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2718 Qno_catch
= intern ("no-catch");
2719 Qend_of_file
= intern ("end-of-file");
2720 Qarith_error
= intern ("arith-error");
2721 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2722 Qend_of_buffer
= intern ("end-of-buffer");
2723 Qbuffer_read_only
= intern ("buffer-read-only");
2724 Qtext_read_only
= intern ("text-read-only");
2725 Qmark_inactive
= intern ("mark-inactive");
2727 Qlistp
= intern ("listp");
2728 Qconsp
= intern ("consp");
2729 Qsymbolp
= intern ("symbolp");
2730 Qkeywordp
= intern ("keywordp");
2731 Qintegerp
= intern ("integerp");
2732 Qnatnump
= intern ("natnump");
2733 Qwholenump
= intern ("wholenump");
2734 Qstringp
= intern ("stringp");
2735 Qarrayp
= intern ("arrayp");
2736 Qsequencep
= intern ("sequencep");
2737 Qbufferp
= intern ("bufferp");
2738 Qvectorp
= intern ("vectorp");
2739 Qchar_or_string_p
= intern ("char-or-string-p");
2740 Qmarkerp
= intern ("markerp");
2741 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2742 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2743 Qboundp
= intern ("boundp");
2744 Qfboundp
= intern ("fboundp");
2746 Qfloatp
= intern ("floatp");
2747 Qnumberp
= intern ("numberp");
2748 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2750 Qchar_table_p
= intern ("char-table-p");
2751 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2753 Qsubrp
= intern ("subrp");
2754 Qunevalled
= intern ("unevalled");
2755 Qmany
= intern ("many");
2757 Qcdr
= intern ("cdr");
2759 /* Handle automatic advice activation */
2760 Qad_advice_info
= intern ("ad-advice-info");
2761 Qad_activate_internal
= intern ("ad-activate-internal");
2763 error_tail
= Fcons (Qerror
, Qnil
);
2765 /* ERROR is used as a signaler for random errors for which nothing else is right */
2767 Fput (Qerror
, Qerror_conditions
,
2769 Fput (Qerror
, Qerror_message
,
2770 build_string ("error"));
2772 Fput (Qquit
, Qerror_conditions
,
2773 Fcons (Qquit
, Qnil
));
2774 Fput (Qquit
, Qerror_message
,
2775 build_string ("Quit"));
2777 Fput (Qwrong_type_argument
, Qerror_conditions
,
2778 Fcons (Qwrong_type_argument
, error_tail
));
2779 Fput (Qwrong_type_argument
, Qerror_message
,
2780 build_string ("Wrong type argument"));
2782 Fput (Qargs_out_of_range
, Qerror_conditions
,
2783 Fcons (Qargs_out_of_range
, error_tail
));
2784 Fput (Qargs_out_of_range
, Qerror_message
,
2785 build_string ("Args out of range"));
2787 Fput (Qvoid_function
, Qerror_conditions
,
2788 Fcons (Qvoid_function
, error_tail
));
2789 Fput (Qvoid_function
, Qerror_message
,
2790 build_string ("Symbol's function definition is void"));
2792 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2793 Fcons (Qcyclic_function_indirection
, error_tail
));
2794 Fput (Qcyclic_function_indirection
, Qerror_message
,
2795 build_string ("Symbol's chain of function indirections contains a loop"));
2797 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2798 Fcons (Qcyclic_variable_indirection
, error_tail
));
2799 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2800 build_string ("Symbol's chain of variable indirections contains a loop"));
2802 Qcircular_list
= intern ("circular-list");
2803 staticpro (&Qcircular_list
);
2804 Fput (Qcircular_list
, Qerror_conditions
,
2805 Fcons (Qcircular_list
, error_tail
));
2806 Fput (Qcircular_list
, Qerror_message
,
2807 build_string ("List contains a loop"));
2809 Fput (Qvoid_variable
, Qerror_conditions
,
2810 Fcons (Qvoid_variable
, error_tail
));
2811 Fput (Qvoid_variable
, Qerror_message
,
2812 build_string ("Symbol's value as variable is void"));
2814 Fput (Qsetting_constant
, Qerror_conditions
,
2815 Fcons (Qsetting_constant
, error_tail
));
2816 Fput (Qsetting_constant
, Qerror_message
,
2817 build_string ("Attempt to set a constant symbol"));
2819 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2820 Fcons (Qinvalid_read_syntax
, error_tail
));
2821 Fput (Qinvalid_read_syntax
, Qerror_message
,
2822 build_string ("Invalid read syntax"));
2824 Fput (Qinvalid_function
, Qerror_conditions
,
2825 Fcons (Qinvalid_function
, error_tail
));
2826 Fput (Qinvalid_function
, Qerror_message
,
2827 build_string ("Invalid function"));
2829 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2830 Fcons (Qwrong_number_of_arguments
, error_tail
));
2831 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2832 build_string ("Wrong number of arguments"));
2834 Fput (Qno_catch
, Qerror_conditions
,
2835 Fcons (Qno_catch
, error_tail
));
2836 Fput (Qno_catch
, Qerror_message
,
2837 build_string ("No catch for tag"));
2839 Fput (Qend_of_file
, Qerror_conditions
,
2840 Fcons (Qend_of_file
, error_tail
));
2841 Fput (Qend_of_file
, Qerror_message
,
2842 build_string ("End of file during parsing"));
2844 arith_tail
= Fcons (Qarith_error
, error_tail
);
2845 Fput (Qarith_error
, Qerror_conditions
,
2847 Fput (Qarith_error
, Qerror_message
,
2848 build_string ("Arithmetic error"));
2850 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2851 Fcons (Qbeginning_of_buffer
, error_tail
));
2852 Fput (Qbeginning_of_buffer
, Qerror_message
,
2853 build_string ("Beginning of buffer"));
2855 Fput (Qend_of_buffer
, Qerror_conditions
,
2856 Fcons (Qend_of_buffer
, error_tail
));
2857 Fput (Qend_of_buffer
, Qerror_message
,
2858 build_string ("End of buffer"));
2860 Fput (Qbuffer_read_only
, Qerror_conditions
,
2861 Fcons (Qbuffer_read_only
, error_tail
));
2862 Fput (Qbuffer_read_only
, Qerror_message
,
2863 build_string ("Buffer is read-only"));
2865 Fput (Qtext_read_only
, Qerror_conditions
,
2866 Fcons (Qtext_read_only
, error_tail
));
2867 Fput (Qtext_read_only
, Qerror_message
,
2868 build_string ("Text is read-only"));
2870 Qrange_error
= intern ("range-error");
2871 Qdomain_error
= intern ("domain-error");
2872 Qsingularity_error
= intern ("singularity-error");
2873 Qoverflow_error
= intern ("overflow-error");
2874 Qunderflow_error
= intern ("underflow-error");
2876 Fput (Qdomain_error
, Qerror_conditions
,
2877 Fcons (Qdomain_error
, arith_tail
));
2878 Fput (Qdomain_error
, Qerror_message
,
2879 build_string ("Arithmetic domain error"));
2881 Fput (Qrange_error
, Qerror_conditions
,
2882 Fcons (Qrange_error
, arith_tail
));
2883 Fput (Qrange_error
, Qerror_message
,
2884 build_string ("Arithmetic range error"));
2886 Fput (Qsingularity_error
, Qerror_conditions
,
2887 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2888 Fput (Qsingularity_error
, Qerror_message
,
2889 build_string ("Arithmetic singularity error"));
2891 Fput (Qoverflow_error
, Qerror_conditions
,
2892 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2893 Fput (Qoverflow_error
, Qerror_message
,
2894 build_string ("Arithmetic overflow error"));
2896 Fput (Qunderflow_error
, Qerror_conditions
,
2897 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2898 Fput (Qunderflow_error
, Qerror_message
,
2899 build_string ("Arithmetic underflow error"));
2901 staticpro (&Qrange_error
);
2902 staticpro (&Qdomain_error
);
2903 staticpro (&Qsingularity_error
);
2904 staticpro (&Qoverflow_error
);
2905 staticpro (&Qunderflow_error
);
2909 staticpro (&Qquote
);
2910 staticpro (&Qlambda
);
2912 staticpro (&Qunbound
);
2913 staticpro (&Qerror_conditions
);
2914 staticpro (&Qerror_message
);
2915 staticpro (&Qtop_level
);
2917 staticpro (&Qerror
);
2919 staticpro (&Qwrong_type_argument
);
2920 staticpro (&Qargs_out_of_range
);
2921 staticpro (&Qvoid_function
);
2922 staticpro (&Qcyclic_function_indirection
);
2923 staticpro (&Qvoid_variable
);
2924 staticpro (&Qsetting_constant
);
2925 staticpro (&Qinvalid_read_syntax
);
2926 staticpro (&Qwrong_number_of_arguments
);
2927 staticpro (&Qinvalid_function
);
2928 staticpro (&Qno_catch
);
2929 staticpro (&Qend_of_file
);
2930 staticpro (&Qarith_error
);
2931 staticpro (&Qbeginning_of_buffer
);
2932 staticpro (&Qend_of_buffer
);
2933 staticpro (&Qbuffer_read_only
);
2934 staticpro (&Qtext_read_only
);
2935 staticpro (&Qmark_inactive
);
2937 staticpro (&Qlistp
);
2938 staticpro (&Qconsp
);
2939 staticpro (&Qsymbolp
);
2940 staticpro (&Qkeywordp
);
2941 staticpro (&Qintegerp
);
2942 staticpro (&Qnatnump
);
2943 staticpro (&Qwholenump
);
2944 staticpro (&Qstringp
);
2945 staticpro (&Qarrayp
);
2946 staticpro (&Qsequencep
);
2947 staticpro (&Qbufferp
);
2948 staticpro (&Qvectorp
);
2949 staticpro (&Qchar_or_string_p
);
2950 staticpro (&Qmarkerp
);
2951 staticpro (&Qbuffer_or_string_p
);
2952 staticpro (&Qinteger_or_marker_p
);
2953 staticpro (&Qfloatp
);
2954 staticpro (&Qnumberp
);
2955 staticpro (&Qnumber_or_marker_p
);
2956 staticpro (&Qchar_table_p
);
2957 staticpro (&Qvector_or_char_table_p
);
2958 staticpro (&Qsubrp
);
2960 staticpro (&Qunevalled
);
2962 staticpro (&Qboundp
);
2963 staticpro (&Qfboundp
);
2965 staticpro (&Qad_advice_info
);
2966 staticpro (&Qad_activate_internal
);
2968 /* Types that type-of returns. */
2969 Qinteger
= intern ("integer");
2970 Qsymbol
= intern ("symbol");
2971 Qstring
= intern ("string");
2972 Qcons
= intern ("cons");
2973 Qmarker
= intern ("marker");
2974 Qoverlay
= intern ("overlay");
2975 Qfloat
= intern ("float");
2976 Qwindow_configuration
= intern ("window-configuration");
2977 Qprocess
= intern ("process");
2978 Qwindow
= intern ("window");
2979 /* Qsubr = intern ("subr"); */
2980 Qcompiled_function
= intern ("compiled-function");
2981 Qbuffer
= intern ("buffer");
2982 Qframe
= intern ("frame");
2983 Qvector
= intern ("vector");
2984 Qchar_table
= intern ("char-table");
2985 Qbool_vector
= intern ("bool-vector");
2986 Qhash_table
= intern ("hash-table");
2988 staticpro (&Qinteger
);
2989 staticpro (&Qsymbol
);
2990 staticpro (&Qstring
);
2992 staticpro (&Qmarker
);
2993 staticpro (&Qoverlay
);
2994 staticpro (&Qfloat
);
2995 staticpro (&Qwindow_configuration
);
2996 staticpro (&Qprocess
);
2997 staticpro (&Qwindow
);
2998 /* staticpro (&Qsubr); */
2999 staticpro (&Qcompiled_function
);
3000 staticpro (&Qbuffer
);
3001 staticpro (&Qframe
);
3002 staticpro (&Qvector
);
3003 staticpro (&Qchar_table
);
3004 staticpro (&Qbool_vector
);
3005 staticpro (&Qhash_table
);
3007 defsubr (&Sindirect_variable
);
3008 defsubr (&Ssubr_interactive_form
);
3011 defsubr (&Stype_of
);
3016 defsubr (&Sintegerp
);
3017 defsubr (&Sinteger_or_marker_p
);
3018 defsubr (&Snumberp
);
3019 defsubr (&Snumber_or_marker_p
);
3021 defsubr (&Snatnump
);
3022 defsubr (&Ssymbolp
);
3023 defsubr (&Skeywordp
);
3024 defsubr (&Sstringp
);
3025 defsubr (&Smultibyte_string_p
);
3026 defsubr (&Svectorp
);
3027 defsubr (&Schar_table_p
);
3028 defsubr (&Svector_or_char_table_p
);
3029 defsubr (&Sbool_vector_p
);
3031 defsubr (&Ssequencep
);
3032 defsubr (&Sbufferp
);
3033 defsubr (&Smarkerp
);
3035 defsubr (&Sbyte_code_function_p
);
3036 defsubr (&Schar_or_string_p
);
3039 defsubr (&Scar_safe
);
3040 defsubr (&Scdr_safe
);
3043 defsubr (&Ssymbol_function
);
3044 defsubr (&Sindirect_function
);
3045 defsubr (&Ssymbol_plist
);
3046 defsubr (&Ssymbol_name
);
3047 defsubr (&Smakunbound
);
3048 defsubr (&Sfmakunbound
);
3050 defsubr (&Sfboundp
);
3052 defsubr (&Sdefalias
);
3053 defsubr (&Ssetplist
);
3054 defsubr (&Ssymbol_value
);
3056 defsubr (&Sdefault_boundp
);
3057 defsubr (&Sdefault_value
);
3058 defsubr (&Sset_default
);
3059 defsubr (&Ssetq_default
);
3060 defsubr (&Smake_variable_buffer_local
);
3061 defsubr (&Smake_local_variable
);
3062 defsubr (&Skill_local_variable
);
3063 defsubr (&Smake_variable_frame_local
);
3064 defsubr (&Slocal_variable_p
);
3065 defsubr (&Slocal_variable_if_set_p
);
3068 defsubr (&Snumber_to_string
);
3069 defsubr (&Sstring_to_number
);
3070 defsubr (&Seqlsign
);
3093 defsubr (&Ssubr_arity
);
3095 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3097 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3098 doc
: /* The largest value that is representable in a Lisp integer. */);
3099 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3101 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3102 doc
: /* The smallest value that is representable in a Lisp integer. */);
3103 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3110 #if defined(USG) && !defined(POSIX_SIGNALS)
3111 /* USG systems forget handlers when they are used;
3112 must reestablish each time */
3113 signal (signo
, arith_error
);
3116 /* VMS systems are like USG. */
3117 signal (signo
, arith_error
);
3121 #else /* not BSD4_1 */
3122 sigsetmask (SIGEMPTYMASK
);
3123 #endif /* not BSD4_1 */
3125 Fsignal (Qarith_error
, Qnil
);
3131 /* Don't do this if just dumping out.
3132 We don't want to call `signal' in this case
3133 so that we don't have trouble with dumping
3134 signal-delivering routines in an inconsistent state. */
3138 #endif /* CANNOT_DUMP */
3139 signal (SIGFPE
, arith_error
);
3142 signal (SIGEMT
, arith_error
);