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
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 int most_positive_fixnum
, most_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 (!EQ (Vmocklisp_arguments
, Qt
))
119 if (STRINGP (value
) &&
120 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
121 return Fstring_to_number (value
, Qnil
);
122 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
123 return Fnumber_to_string (value
);
126 /* If VALUE is not even a valid Lisp object, abort here
127 where we can get a backtrace showing where it came from. */
128 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
131 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
132 tem
= call1 (predicate
, value
);
141 error ("Attempt to modify read-only object");
145 args_out_of_range (a1
, a2
)
149 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
153 args_out_of_range_3 (a1
, a2
, a3
)
154 Lisp_Object a1
, a2
, a3
;
157 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
160 /* On some machines, XINT needs a temporary location.
161 Here it is, in case it is needed. */
163 int sign_extend_temp
;
165 /* On a few machines, XINT can only be done by calling this. */
168 sign_extend_lisp_int (num
)
171 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
172 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
174 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
177 /* Data type predicates */
179 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
180 "Return t if the two args are the same Lisp object.")
182 Lisp_Object obj1
, obj2
;
189 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
198 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
199 "Return a symbol representing the type of OBJECT.\n\
200 The symbol returned names the object's basic type;\n\
201 for example, (type-of 1) returns `integer'.")
205 switch (XGCTYPE (object
))
220 switch (XMISCTYPE (object
))
222 case Lisp_Misc_Marker
:
224 case Lisp_Misc_Overlay
:
226 case Lisp_Misc_Float
:
231 case Lisp_Vectorlike
:
232 if (GC_WINDOW_CONFIGURATIONP (object
))
233 return Qwindow_configuration
;
234 if (GC_PROCESSP (object
))
236 if (GC_WINDOWP (object
))
238 if (GC_SUBRP (object
))
240 if (GC_COMPILEDP (object
))
241 return Qcompiled_function
;
242 if (GC_BUFFERP (object
))
244 if (GC_CHAR_TABLE_P (object
))
246 if (GC_BOOL_VECTOR_P (object
))
248 if (GC_FRAMEP (object
))
250 if (GC_HASH_TABLE_P (object
))
262 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
271 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
272 "Return t if OBJECT is not a cons cell. This includes nil.")
281 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
282 "Return t if OBJECT is a list. This includes nil.")
286 if (CONSP (object
) || NILP (object
))
291 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
292 "Return t if OBJECT is not a list. Lists include nil.")
296 if (CONSP (object
) || NILP (object
))
301 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
302 "Return t if OBJECT is a symbol.")
306 if (SYMBOLP (object
))
311 /* Define this in C to avoid unnecessarily consing up the symbol
313 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
314 "Return t if OBJECT is a keyword.\n\
315 This means that it is a symbol with a print name beginning with `:'\n\
316 interned in the initial obarray.")
321 && XSYMBOL (object
)->name
->data
[0] == ':'
322 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
327 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
328 "Return t if OBJECT is a vector.")
332 if (VECTORP (object
))
337 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
338 "Return t if OBJECT is a string.")
342 if (STRINGP (object
))
347 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
348 1, 1, 0, "Return t if OBJECT is a multibyte string.")
352 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
357 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
358 "Return t if OBJECT is a char-table.")
362 if (CHAR_TABLE_P (object
))
367 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
368 Svector_or_char_table_p
, 1, 1, 0,
369 "Return t if OBJECT is a char-table or vector.")
373 if (VECTORP (object
) || CHAR_TABLE_P (object
))
378 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
382 if (BOOL_VECTOR_P (object
))
387 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
391 if (VECTORP (object
) || STRINGP (object
)
392 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
397 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
398 "Return t if OBJECT is a sequence (list or array).")
400 register Lisp_Object object
;
402 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
403 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
408 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
412 if (BUFFERP (object
))
417 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
421 if (MARKERP (object
))
426 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
435 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
436 1, 1, 0, "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 "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, "Return t if OBJECT is an integer.")
459 if (INTEGERP (object
))
464 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
465 "Return t if OBJECT is an integer or a marker (editor pointer).")
467 register Lisp_Object object
;
469 if (MARKERP (object
) || INTEGERP (object
))
474 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
475 "Return t if OBJECT is a nonnegative integer.")
479 if (NATNUMP (object
))
484 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
485 "Return t if OBJECT is a number (floating point or integer).")
489 if (NUMBERP (object
))
495 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
496 Snumber_or_marker_p
, 1, 1, 0,
497 "Return t if OBJECT is a number or a marker.")
501 if (NUMBERP (object
) || MARKERP (object
))
506 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
507 "Return t if OBJECT is a floating point number.")
517 /* Extract and set components of lists */
519 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
520 "Return the car of LIST. If arg is nil, return nil.\n\
521 Error if arg is not nil and not a cons cell. See also `car-safe'.")
523 register Lisp_Object list
;
529 else if (EQ (list
, Qnil
))
532 list
= wrong_type_argument (Qlistp
, list
);
536 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
537 "Return the car of OBJECT if it is a cons cell, or else nil.")
542 return XCAR (object
);
547 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
548 "Return the cdr of LIST. If arg is nil, return nil.\n\
549 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 "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 "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 "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, "Return t if SYMBOL's value is not void.")
606 register Lisp_Object symbol
;
608 Lisp_Object valcontents
;
609 CHECK_SYMBOL (symbol
, 0);
611 valcontents
= SYMBOL_VALUE (symbol
);
613 if (BUFFER_LOCAL_VALUEP (valcontents
)
614 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
615 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
617 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
620 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
622 register Lisp_Object symbol
;
624 CHECK_SYMBOL (symbol
, 0);
625 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
628 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
630 register Lisp_Object symbol
;
632 CHECK_SYMBOL (symbol
, 0);
633 if (XSYMBOL (symbol
)->constant
)
634 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
635 Fset (symbol
, Qunbound
);
639 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
641 register Lisp_Object symbol
;
643 CHECK_SYMBOL (symbol
, 0);
644 if (NILP (symbol
) || EQ (symbol
, Qt
))
645 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
646 XSYMBOL (symbol
)->function
= Qunbound
;
650 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
651 "Return SYMBOL's function definition. Error if that is void.")
653 register Lisp_Object symbol
;
655 CHECK_SYMBOL (symbol
, 0);
656 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
657 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
658 return XSYMBOL (symbol
)->function
;
661 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
663 register Lisp_Object symbol
;
665 CHECK_SYMBOL (symbol
, 0);
666 return XSYMBOL (symbol
)->plist
;
669 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
671 register Lisp_Object symbol
;
673 register Lisp_Object name
;
675 CHECK_SYMBOL (symbol
, 0);
676 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
680 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
681 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
683 register Lisp_Object symbol
, definition
;
685 CHECK_SYMBOL (symbol
, 0);
686 if (NILP (symbol
) || EQ (symbol
, Qt
))
687 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
688 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
689 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
691 XSYMBOL (symbol
)->function
= definition
;
692 /* Handle automatic advice activation */
693 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
695 call2 (Qad_activate_internal
, symbol
, Qnil
);
696 definition
= XSYMBOL (symbol
)->function
;
701 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
702 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
703 Associates the function with the current load file, if any.")
705 register Lisp_Object symbol
, definition
;
707 definition
= Ffset (symbol
, definition
);
708 LOADHIST_ATTACH (symbol
);
712 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
713 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
715 register Lisp_Object symbol
, newplist
;
717 CHECK_SYMBOL (symbol
, 0);
718 XSYMBOL (symbol
)->plist
= newplist
;
722 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
723 "Return minimum and maximum number of args allowed for SUBR.\n\
724 SUBR must be a built-in function.\n\
725 The returned value is a pair (MIN . MAX). MIN is the minimum number\n\
726 of args. MAX is the maximum number or the symbol `many', for a\n\
727 function with `&rest' args, or `unevalled' for a special form.")
731 short minargs
, maxargs
;
733 wrong_type_argument (Qsubrp
, subr
);
734 minargs
= XSUBR (subr
)->min_args
;
735 maxargs
= XSUBR (subr
)->max_args
;
737 return Fcons (make_number (minargs
), Qmany
);
738 else if (maxargs
== UNEVALLED
)
739 return Fcons (make_number (minargs
), Qunevalled
);
741 return Fcons (make_number (minargs
), make_number (maxargs
));
744 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
745 "Return the interactive form of SUBR or nil if none.\n\
746 SUBR must be a built-in function. Value, if non-nil, is a list\n\
747 \(interactive SPEC).")
752 wrong_type_argument (Qsubrp
, subr
);
753 if (XSUBR (subr
)->prompt
)
754 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
759 /***********************************************************************
760 Getting and Setting Values of Symbols
761 ***********************************************************************/
763 /* Return the symbol holding SYMBOL's value. Signal
764 `cyclic-variable-indirection' if SYMBOL's chain of variable
765 indirections contains a loop. */
768 indirect_variable (symbol
)
771 Lisp_Object tortoise
, hare
;
773 hare
= tortoise
= symbol
;
775 while (XSYMBOL (hare
)->indirect_variable
)
777 hare
= XSYMBOL (hare
)->value
;
778 if (!XSYMBOL (hare
)->indirect_variable
)
781 hare
= XSYMBOL (hare
)->value
;
782 tortoise
= XSYMBOL (tortoise
)->value
;
784 if (EQ (hare
, tortoise
))
785 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
792 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
793 "Return the variable at the end of OBJECT's variable chain.\n\
794 If OBJECT is a symbol, follow all variable indirections and return the final\n\
795 variable. If OBJECT is not a symbol, just return it.\n\
796 Signal a cyclic-variable-indirection error if there is a loop in the\n\
797 variable chain of symbols.")
801 if (SYMBOLP (object
))
802 object
= indirect_variable (object
);
807 /* Given the raw contents of a symbol value cell,
808 return the Lisp value of the symbol.
809 This does not handle buffer-local variables; use
810 swap_in_symval_forwarding for that. */
813 do_symval_forwarding (valcontents
)
814 register Lisp_Object valcontents
;
816 register Lisp_Object val
;
818 if (MISCP (valcontents
))
819 switch (XMISCTYPE (valcontents
))
821 case Lisp_Misc_Intfwd
:
822 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
825 case Lisp_Misc_Boolfwd
:
826 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
828 case Lisp_Misc_Objfwd
:
829 return *XOBJFWD (valcontents
)->objvar
;
831 case Lisp_Misc_Buffer_Objfwd
:
832 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
833 return PER_BUFFER_VALUE (current_buffer
, offset
);
835 case Lisp_Misc_Kboard_Objfwd
:
836 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
837 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
842 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
843 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
844 buffer-independent contents of the value cell: forwarded just one
845 step past the buffer-localness.
847 BUF non-zero means set the value in buffer BUF instead of the
848 current buffer. This only plays a role for per-buffer variables. */
851 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
853 register Lisp_Object valcontents
, newval
;
856 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
859 switch (XMISCTYPE (valcontents
))
861 case Lisp_Misc_Intfwd
:
862 CHECK_NUMBER (newval
, 1);
863 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
864 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
865 error ("Value out of range for variable `%s'",
866 XSYMBOL (symbol
)->name
->data
);
869 case Lisp_Misc_Boolfwd
:
870 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
873 case Lisp_Misc_Objfwd
:
874 *XOBJFWD (valcontents
)->objvar
= newval
;
877 case Lisp_Misc_Buffer_Objfwd
:
879 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
882 type
= PER_BUFFER_TYPE (offset
);
883 if (XINT (type
) == -1)
884 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
886 if (! NILP (type
) && ! NILP (newval
)
887 && XTYPE (newval
) != XINT (type
))
888 buffer_slot_type_mismatch (offset
);
891 buf
= current_buffer
;
892 PER_BUFFER_VALUE (buf
, offset
) = newval
;
896 case Lisp_Misc_Kboard_Objfwd
:
898 char *base
= (char *) current_kboard
;
899 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
900 *(Lisp_Object
*) p
= newval
;
911 valcontents
= SYMBOL_VALUE (symbol
);
912 if (BUFFER_LOCAL_VALUEP (valcontents
)
913 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
914 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
916 SET_SYMBOL_VALUE (symbol
, newval
);
920 /* Set up SYMBOL to refer to its global binding.
921 This makes it safe to alter the status of other bindings. */
924 swap_in_global_binding (symbol
)
927 Lisp_Object valcontents
, cdr
;
929 valcontents
= SYMBOL_VALUE (symbol
);
930 if (!BUFFER_LOCAL_VALUEP (valcontents
)
931 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
933 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
935 /* Unload the previously loaded binding. */
937 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
939 /* Select the global binding in the symbol. */
941 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
943 /* Indicate that the global binding is set up now. */
944 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
945 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
946 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
947 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
950 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
951 VALCONTENTS is the contents of its value cell,
952 which points to a struct Lisp_Buffer_Local_Value.
954 Return the value forwarded one step past the buffer-local stage.
955 This could be another forwarding pointer. */
958 swap_in_symval_forwarding (symbol
, valcontents
)
959 Lisp_Object symbol
, valcontents
;
961 register Lisp_Object tem1
;
963 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
966 || current_buffer
!= XBUFFER (tem1
)
967 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
968 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
970 if (XSYMBOL (symbol
)->indirect_variable
)
971 symbol
= indirect_variable (symbol
);
973 /* Unload the previously loaded binding. */
974 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
976 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
977 /* Choose the new binding. */
978 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
979 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
980 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
983 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
984 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
986 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
988 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
991 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
993 /* Load the new binding. */
994 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
995 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
996 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
997 store_symval_forwarding (symbol
,
998 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1001 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1004 /* Find the value of a symbol, returning Qunbound if it's not bound.
1005 This is helpful for code which just wants to get a variable's value
1006 if it has one, without signaling an error.
1007 Note that it must not be possible to quit
1008 within this function. Great care is required for this. */
1011 find_symbol_value (symbol
)
1014 register Lisp_Object valcontents
;
1015 register Lisp_Object val
;
1017 CHECK_SYMBOL (symbol
, 0);
1018 valcontents
= SYMBOL_VALUE (symbol
);
1020 if (BUFFER_LOCAL_VALUEP (valcontents
)
1021 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1022 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1024 if (MISCP (valcontents
))
1026 switch (XMISCTYPE (valcontents
))
1028 case Lisp_Misc_Intfwd
:
1029 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1032 case Lisp_Misc_Boolfwd
:
1033 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1035 case Lisp_Misc_Objfwd
:
1036 return *XOBJFWD (valcontents
)->objvar
;
1038 case Lisp_Misc_Buffer_Objfwd
:
1039 return PER_BUFFER_VALUE (current_buffer
,
1040 XBUFFER_OBJFWD (valcontents
)->offset
);
1042 case Lisp_Misc_Kboard_Objfwd
:
1043 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1044 + (char *)current_kboard
);
1051 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1052 "Return SYMBOL's value. Error if that is void.")
1058 val
= find_symbol_value (symbol
);
1059 if (EQ (val
, Qunbound
))
1060 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1065 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1066 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
1068 register Lisp_Object symbol
, newval
;
1070 return set_internal (symbol
, newval
, current_buffer
, 0);
1073 /* Return 1 if SYMBOL currently has a let-binding
1074 which was made in the buffer that is now current. */
1077 let_shadows_buffer_binding_p (symbol
)
1080 struct specbinding
*p
;
1082 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1084 && CONSP (p
->symbol
))
1086 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1087 if ((EQ (symbol
, let_bound_symbol
)
1088 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1089 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1090 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1094 return p
>= specpdl
;
1097 /* Store the value NEWVAL into SYMBOL.
1098 If buffer-locality is an issue, BUF specifies which buffer to use.
1099 (0 stands for the current buffer.)
1101 If BINDFLAG is zero, then if this symbol is supposed to become
1102 local in every buffer where it is set, then we make it local.
1103 If BINDFLAG is nonzero, we don't do that. */
1106 set_internal (symbol
, newval
, buf
, bindflag
)
1107 register Lisp_Object symbol
, newval
;
1111 int voide
= EQ (newval
, Qunbound
);
1113 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1116 buf
= current_buffer
;
1118 /* If restoring in a dead buffer, do nothing. */
1119 if (NILP (buf
->name
))
1122 CHECK_SYMBOL (symbol
, 0);
1123 if (SYMBOL_CONSTANT_P (symbol
)
1124 && (NILP (Fkeywordp (symbol
))
1125 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1126 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1128 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1130 if (BUFFER_OBJFWDP (valcontents
))
1132 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1133 int idx
= PER_BUFFER_IDX (offset
);
1136 && !let_shadows_buffer_binding_p (symbol
))
1137 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1139 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1140 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1142 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1143 if (XSYMBOL (symbol
)->indirect_variable
)
1144 symbol
= indirect_variable (symbol
);
1146 /* What binding is loaded right now? */
1147 current_alist_element
1148 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1150 /* If the current buffer is not the buffer whose binding is
1151 loaded, or if there may be frame-local bindings and the frame
1152 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1153 the default binding is loaded, the loaded binding may be the
1155 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1156 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1157 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1158 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1159 || (BUFFER_LOCAL_VALUEP (valcontents
)
1160 && EQ (XCAR (current_alist_element
),
1161 current_alist_element
)))
1163 /* The currently loaded binding is not necessarily valid.
1164 We need to unload it, and choose a new binding. */
1166 /* Write out `realvalue' to the old loaded binding. */
1167 Fsetcdr (current_alist_element
,
1168 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1170 /* Find the new binding. */
1171 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1172 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1173 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1177 /* This buffer still sees the default value. */
1179 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1180 or if this is `let' rather than `set',
1181 make CURRENT-ALIST-ELEMENT point to itself,
1182 indicating that we're seeing the default value.
1183 Likewise if the variable has been let-bound
1184 in the current buffer. */
1185 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1186 || let_shadows_buffer_binding_p (symbol
))
1188 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1190 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1191 tem1
= Fassq (symbol
,
1192 XFRAME (selected_frame
)->param_alist
);
1195 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1197 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1199 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1200 and we're not within a let that was made for this buffer,
1201 create a new buffer-local binding for the variable.
1202 That means, give this buffer a new assoc for a local value
1203 and load that binding. */
1206 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1207 buf
->local_var_alist
1208 = Fcons (tem1
, buf
->local_var_alist
);
1212 /* Record which binding is now loaded. */
1213 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1216 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1217 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1218 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1220 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1223 /* If storing void (making the symbol void), forward only through
1224 buffer-local indicator, not through Lisp_Objfwd, etc. */
1226 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1228 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1230 /* If we just set a variable whose current binding is frame-local,
1231 store the new value in the frame parameter too. */
1233 if (BUFFER_LOCAL_VALUEP (valcontents
)
1234 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1236 /* What binding is loaded right now? */
1237 current_alist_element
1238 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1240 /* If the current buffer is not the buffer whose binding is
1241 loaded, or if there may be frame-local bindings and the frame
1242 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1243 the default binding is loaded, the loaded binding may be the
1245 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1246 XSETCDR (current_alist_element
, newval
);
1252 /* Access or set a buffer-local symbol's default value. */
1254 /* Return the default value of SYMBOL, but don't check for voidness.
1255 Return Qunbound if it is void. */
1258 default_value (symbol
)
1261 register Lisp_Object valcontents
;
1263 CHECK_SYMBOL (symbol
, 0);
1264 valcontents
= SYMBOL_VALUE (symbol
);
1266 /* For a built-in buffer-local variable, get the default value
1267 rather than letting do_symval_forwarding get the current value. */
1268 if (BUFFER_OBJFWDP (valcontents
))
1270 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1271 if (PER_BUFFER_IDX (offset
) != 0)
1272 return PER_BUFFER_DEFAULT (offset
);
1275 /* Handle user-created local variables. */
1276 if (BUFFER_LOCAL_VALUEP (valcontents
)
1277 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1279 /* If var is set up for a buffer that lacks a local value for it,
1280 the current value is nominally the default value.
1281 But the `realvalue' slot may be more up to date, since
1282 ordinary setq stores just that slot. So use that. */
1283 Lisp_Object current_alist_element
, alist_element_car
;
1284 current_alist_element
1285 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1286 alist_element_car
= XCAR (current_alist_element
);
1287 if (EQ (alist_element_car
, current_alist_element
))
1288 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1290 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1292 /* For other variables, get the current value. */
1293 return do_symval_forwarding (valcontents
);
1296 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1297 "Return t if SYMBOL has a non-void default value.\n\
1298 This is the value that is seen in buffers that do not have their own values\n\
1299 for this variable.")
1303 register Lisp_Object value
;
1305 value
= default_value (symbol
);
1306 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1309 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1310 "Return SYMBOL's default value.\n\
1311 This is the value that is seen in buffers that do not have their own values\n\
1312 for this variable. The default value is meaningful for variables with\n\
1313 local bindings in certain buffers.")
1317 register Lisp_Object value
;
1319 value
= default_value (symbol
);
1320 if (EQ (value
, Qunbound
))
1321 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1325 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1326 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1327 The default value is seen in buffers that do not have their own values\n\
1328 for this variable.")
1330 Lisp_Object symbol
, value
;
1332 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1334 CHECK_SYMBOL (symbol
, 0);
1335 valcontents
= SYMBOL_VALUE (symbol
);
1337 /* Handle variables like case-fold-search that have special slots
1338 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1340 if (BUFFER_OBJFWDP (valcontents
))
1342 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1343 int idx
= PER_BUFFER_IDX (offset
);
1345 PER_BUFFER_DEFAULT (offset
) = value
;
1347 /* If this variable is not always local in all buffers,
1348 set it in the buffers that don't nominally have a local value. */
1353 for (b
= all_buffers
; b
; b
= b
->next
)
1354 if (!PER_BUFFER_VALUE_P (b
, idx
))
1355 PER_BUFFER_VALUE (b
, offset
) = value
;
1360 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1361 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1362 return Fset (symbol
, value
);
1364 /* Store new value into the DEFAULT-VALUE slot. */
1365 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1367 /* If the default binding is now loaded, set the REALVALUE slot too. */
1368 current_alist_element
1369 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1370 alist_element_buffer
= Fcar (current_alist_element
);
1371 if (EQ (alist_element_buffer
, current_alist_element
))
1372 store_symval_forwarding (symbol
,
1373 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1379 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1380 "Set the default value of variable VAR to VALUE.\n\
1381 VAR, the variable name, is literal (not evaluated);\n\
1382 VALUE is an expression and it is evaluated.\n\
1383 The default value of a variable is seen in buffers\n\
1384 that do not have their own values for the variable.\n\
1386 More generally, you can use multiple variables and values, as in\n\
1387 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1388 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1389 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1394 register Lisp_Object args_left
;
1395 register Lisp_Object val
, symbol
;
1396 struct gcpro gcpro1
;
1406 val
= Feval (Fcar (Fcdr (args_left
)));
1407 symbol
= Fcar (args_left
);
1408 Fset_default (symbol
, val
);
1409 args_left
= Fcdr (Fcdr (args_left
));
1411 while (!NILP (args_left
));
1417 /* Lisp functions for creating and removing buffer-local variables. */
1419 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1420 1, 1, "vMake Variable Buffer Local: ",
1421 "Make VARIABLE become buffer-local whenever it is set.\n\
1422 At any time, the value for the current buffer is in effect,\n\
1423 unless the variable has never been set in this buffer,\n\
1424 in which case the default value is in effect.\n\
1425 Note that binding the variable with `let', or setting it while\n\
1426 a `let'-style binding made in this buffer is in effect,\n\
1427 does not make the variable buffer-local.\n\
1429 The function `default-value' gets the default value and `set-default' sets it.")
1431 register Lisp_Object variable
;
1433 register Lisp_Object tem
, valcontents
, newval
;
1435 CHECK_SYMBOL (variable
, 0);
1437 valcontents
= SYMBOL_VALUE (variable
);
1438 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1439 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1441 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1443 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1445 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1448 if (EQ (valcontents
, Qunbound
))
1449 SET_SYMBOL_VALUE (variable
, Qnil
);
1450 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1452 newval
= allocate_misc ();
1453 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1454 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1455 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1456 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1457 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1458 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1459 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1460 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1461 SET_SYMBOL_VALUE (variable
, newval
);
1465 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1466 1, 1, "vMake Local Variable: ",
1467 "Make VARIABLE have a separate value in the current buffer.\n\
1468 Other buffers will continue to share a common default value.\n\
1469 \(The buffer-local value of VARIABLE starts out as the same value\n\
1470 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1471 See also `make-variable-buffer-local'.\n\
1473 If the variable is already arranged to become local when set,\n\
1474 this function causes a local value to exist for this buffer,\n\
1475 just as setting the variable would do.\n\
1477 This function returns VARIABLE, and therefore\n\
1478 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1481 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1482 Use `make-local-hook' instead.")
1484 register Lisp_Object variable
;
1486 register Lisp_Object tem
, valcontents
;
1488 CHECK_SYMBOL (variable
, 0);
1490 valcontents
= SYMBOL_VALUE (variable
);
1491 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1492 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1494 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1496 tem
= Fboundp (variable
);
1498 /* Make sure the symbol has a local value in this particular buffer,
1499 by setting it to the same value it already has. */
1500 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1503 /* Make sure symbol is set up to hold per-buffer values. */
1504 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1507 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1509 newval
= allocate_misc ();
1510 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1511 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1512 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1513 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1514 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1515 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1516 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1517 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1518 SET_SYMBOL_VALUE (variable
, newval
);;
1520 /* Make sure this buffer has its own value of symbol. */
1521 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1524 /* Swap out any local binding for some other buffer, and make
1525 sure the current value is permanently recorded, if it's the
1527 find_symbol_value (variable
);
1529 current_buffer
->local_var_alist
1530 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1531 current_buffer
->local_var_alist
);
1533 /* Make sure symbol does not think it is set up for this buffer;
1534 force it to look once again for this buffer's value. */
1536 Lisp_Object
*pvalbuf
;
1538 valcontents
= SYMBOL_VALUE (variable
);
1540 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1541 if (current_buffer
== XBUFFER (*pvalbuf
))
1543 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1547 /* If the symbol forwards into a C variable, then load the binding
1548 for this buffer now. If C code modifies the variable before we
1549 load the binding in, then that new value will clobber the default
1550 binding the next time we unload it. */
1551 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1552 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1553 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1558 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1559 1, 1, "vKill Local Variable: ",
1560 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1561 From now on the default value will apply in this buffer.")
1563 register Lisp_Object variable
;
1565 register Lisp_Object tem
, valcontents
;
1567 CHECK_SYMBOL (variable
, 0);
1569 valcontents
= SYMBOL_VALUE (variable
);
1571 if (BUFFER_OBJFWDP (valcontents
))
1573 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1574 int idx
= PER_BUFFER_IDX (offset
);
1578 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1579 PER_BUFFER_VALUE (current_buffer
, offset
)
1580 = PER_BUFFER_DEFAULT (offset
);
1585 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1586 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1589 /* Get rid of this buffer's alist element, if any. */
1591 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1593 current_buffer
->local_var_alist
1594 = Fdelq (tem
, current_buffer
->local_var_alist
);
1596 /* If the symbol is set up with the current buffer's binding
1597 loaded, recompute its value. We have to do it now, or else
1598 forwarded objects won't work right. */
1600 Lisp_Object
*pvalbuf
;
1601 valcontents
= SYMBOL_VALUE (variable
);
1602 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1603 if (current_buffer
== XBUFFER (*pvalbuf
))
1606 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1607 find_symbol_value (variable
);
1614 /* Lisp functions for creating and removing buffer-local variables. */
1616 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1617 1, 1, "vMake Variable Frame Local: ",
1618 "Enable VARIABLE to have frame-local bindings.\n\
1619 When a frame-local binding exists in the current frame,\n\
1620 it is in effect whenever the current buffer has no buffer-local binding.\n\
1621 A frame-local binding is actual a frame parameter value;\n\
1622 thus, any given frame has a local binding for VARIABLE\n\
1623 if it has a value for the frame parameter named VARIABLE.\n\
1624 See `modify-frame-parameters'.")
1626 register Lisp_Object variable
;
1628 register Lisp_Object tem
, valcontents
, newval
;
1630 CHECK_SYMBOL (variable
, 0);
1632 valcontents
= SYMBOL_VALUE (variable
);
1633 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1634 || BUFFER_OBJFWDP (valcontents
))
1635 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1637 if (BUFFER_LOCAL_VALUEP (valcontents
)
1638 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1640 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1644 if (EQ (valcontents
, Qunbound
))
1645 SET_SYMBOL_VALUE (variable
, Qnil
);
1646 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1648 newval
= allocate_misc ();
1649 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1650 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1651 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1652 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1653 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1654 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1655 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1656 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1657 SET_SYMBOL_VALUE (variable
, newval
);
1661 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1663 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1664 BUFFER defaults to the current buffer.")
1666 register Lisp_Object variable
, buffer
;
1668 Lisp_Object valcontents
;
1669 register struct buffer
*buf
;
1672 buf
= current_buffer
;
1675 CHECK_BUFFER (buffer
, 0);
1676 buf
= XBUFFER (buffer
);
1679 CHECK_SYMBOL (variable
, 0);
1681 valcontents
= SYMBOL_VALUE (variable
);
1682 if (BUFFER_LOCAL_VALUEP (valcontents
)
1683 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1685 Lisp_Object tail
, elt
;
1687 variable
= indirect_variable (variable
);
1688 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1691 if (EQ (variable
, XCAR (elt
)))
1695 if (BUFFER_OBJFWDP (valcontents
))
1697 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1698 int idx
= PER_BUFFER_IDX (offset
);
1699 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1705 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1707 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1708 BUFFER defaults to the current buffer.")
1710 register Lisp_Object variable
, buffer
;
1712 Lisp_Object valcontents
;
1713 register struct buffer
*buf
;
1716 buf
= current_buffer
;
1719 CHECK_BUFFER (buffer
, 0);
1720 buf
= XBUFFER (buffer
);
1723 CHECK_SYMBOL (variable
, 0);
1725 valcontents
= SYMBOL_VALUE (variable
);
1727 /* This means that make-variable-buffer-local was done. */
1728 if (BUFFER_LOCAL_VALUEP (valcontents
))
1730 /* All these slots become local if they are set. */
1731 if (BUFFER_OBJFWDP (valcontents
))
1733 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1735 Lisp_Object tail
, elt
;
1736 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1739 if (EQ (variable
, XCAR (elt
)))
1746 /* Find the function at the end of a chain of symbol function indirections. */
1748 /* If OBJECT is a symbol, find the end of its function chain and
1749 return the value found there. If OBJECT is not a symbol, just
1750 return it. If there is a cycle in the function chain, signal a
1751 cyclic-function-indirection error.
1753 This is like Findirect_function, except that it doesn't signal an
1754 error if the chain ends up unbound. */
1756 indirect_function (object
)
1757 register Lisp_Object object
;
1759 Lisp_Object tortoise
, hare
;
1761 hare
= tortoise
= object
;
1765 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1767 hare
= XSYMBOL (hare
)->function
;
1768 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1770 hare
= XSYMBOL (hare
)->function
;
1772 tortoise
= XSYMBOL (tortoise
)->function
;
1774 if (EQ (hare
, tortoise
))
1775 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1781 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1782 "Return the function at the end of OBJECT's function chain.\n\
1783 If OBJECT is a symbol, follow all function indirections and return the final\n\
1784 function binding.\n\
1785 If OBJECT is not a symbol, just return it.\n\
1786 Signal a void-function error if the final symbol is unbound.\n\
1787 Signal a cyclic-function-indirection error if there is a loop in the\n\
1788 function chain of symbols.")
1790 register Lisp_Object object
;
1794 result
= indirect_function (object
);
1796 if (EQ (result
, Qunbound
))
1797 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1801 /* Extract and set vector and string elements */
1803 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1804 "Return the element of ARRAY at index IDX.\n\
1805 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1806 or a byte-code object. IDX starts at 0.")
1808 register Lisp_Object array
;
1811 register int idxval
;
1813 CHECK_NUMBER (idx
, 1);
1814 idxval
= XINT (idx
);
1815 if (STRINGP (array
))
1819 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1820 args_out_of_range (array
, idx
);
1821 if (! STRING_MULTIBYTE (array
))
1822 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1823 idxval_byte
= string_char_to_byte (array
, idxval
);
1825 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1826 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1827 return make_number (c
);
1829 else if (BOOL_VECTOR_P (array
))
1833 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1834 args_out_of_range (array
, idx
);
1836 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1837 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1839 else if (CHAR_TABLE_P (array
))
1846 args_out_of_range (array
, idx
);
1847 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1849 /* For ASCII and 8-bit European characters, the element is
1850 stored in the top table. */
1851 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1853 val
= XCHAR_TABLE (array
)->defalt
;
1854 while (NILP (val
)) /* Follow parents until we find some value. */
1856 array
= XCHAR_TABLE (array
)->parent
;
1859 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1861 val
= XCHAR_TABLE (array
)->defalt
;
1868 Lisp_Object sub_table
;
1870 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1871 if (code
[1] < 32) code
[1] = -1;
1872 else if (code
[2] < 32) code
[2] = -1;
1874 /* Here, the possible range of CODE[0] (== charset ID) is
1875 128..MAX_CHARSET. Since the top level char table contains
1876 data for multibyte characters after 256th element, we must
1877 increment CODE[0] by 128 to get a correct index. */
1879 code
[3] = -1; /* anchor */
1881 try_parent_char_table
:
1883 for (i
= 0; code
[i
] >= 0; i
++)
1885 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1886 if (SUB_CHAR_TABLE_P (val
))
1891 val
= XCHAR_TABLE (sub_table
)->defalt
;
1894 array
= XCHAR_TABLE (array
)->parent
;
1896 goto try_parent_char_table
;
1901 /* Here, VAL is a sub char table. We try the default value
1903 val
= XCHAR_TABLE (val
)->defalt
;
1906 array
= XCHAR_TABLE (array
)->parent
;
1908 goto try_parent_char_table
;
1916 if (VECTORP (array
))
1917 size
= XVECTOR (array
)->size
;
1918 else if (COMPILEDP (array
))
1919 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1921 wrong_type_argument (Qarrayp
, array
);
1923 if (idxval
< 0 || idxval
>= size
)
1924 args_out_of_range (array
, idx
);
1925 return XVECTOR (array
)->contents
[idxval
];
1929 /* Don't use alloca for relocating string data larger than this, lest
1930 we overflow their stack. The value is the same as what used in
1931 fns.c for base64 handling. */
1932 #define MAX_ALLOCA 16*1024
1934 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1935 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1936 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1938 (array
, idx
, newelt
)
1939 register Lisp_Object array
;
1940 Lisp_Object idx
, newelt
;
1942 register int idxval
;
1944 CHECK_NUMBER (idx
, 1);
1945 idxval
= XINT (idx
);
1946 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1947 && ! CHAR_TABLE_P (array
))
1948 array
= wrong_type_argument (Qarrayp
, array
);
1949 CHECK_IMPURE (array
);
1951 if (VECTORP (array
))
1953 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1954 args_out_of_range (array
, idx
);
1955 XVECTOR (array
)->contents
[idxval
] = newelt
;
1957 else if (BOOL_VECTOR_P (array
))
1961 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1962 args_out_of_range (array
, idx
);
1964 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1966 if (! NILP (newelt
))
1967 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1969 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1970 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1972 else if (CHAR_TABLE_P (array
))
1975 args_out_of_range (array
, idx
);
1976 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1977 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1983 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1984 if (code
[1] < 32) code
[1] = -1;
1985 else if (code
[2] < 32) code
[2] = -1;
1987 /* See the comment of the corresponding part in Faref. */
1989 code
[3] = -1; /* anchor */
1990 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1992 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1993 if (SUB_CHAR_TABLE_P (val
))
1999 /* VAL is a leaf. Create a sub char table with the
2000 default value VAL or XCHAR_TABLE (array)->defalt
2001 and look into it. */
2003 temp
= make_sub_char_table (NILP (val
)
2004 ? XCHAR_TABLE (array
)->defalt
2006 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2010 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2013 else if (STRING_MULTIBYTE (array
))
2015 int idxval_byte
, prev_bytes
, new_bytes
;
2016 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2018 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2019 args_out_of_range (array
, idx
);
2020 CHECK_NUMBER (newelt
, 2);
2022 idxval_byte
= string_char_to_byte (array
, idxval
);
2023 p1
= &XSTRING (array
)->data
[idxval_byte
];
2024 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2025 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2026 if (prev_bytes
!= new_bytes
)
2028 /* We must relocate the string data. */
2029 int nchars
= XSTRING (array
)->size
;
2030 int nbytes
= STRING_BYTES (XSTRING (array
));
2033 str
= (nbytes
<= MAX_ALLOCA
2034 ? (unsigned char *) alloca (nbytes
)
2035 : (unsigned char *) xmalloc (nbytes
));
2036 bcopy (XSTRING (array
)->data
, str
, nbytes
);
2037 allocate_string_data (XSTRING (array
), nchars
,
2038 nbytes
+ new_bytes
- prev_bytes
);
2039 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2040 p1
= XSTRING (array
)->data
+ idxval_byte
;
2041 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2042 nbytes
- (idxval_byte
+ prev_bytes
));
2043 if (nbytes
> MAX_ALLOCA
)
2045 clear_string_char_byte_cache ();
2052 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2053 args_out_of_range (array
, idx
);
2054 CHECK_NUMBER (newelt
, 2);
2056 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2057 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
2060 /* We must relocate the string data while converting it to
2062 int idxval_byte
, prev_bytes
, new_bytes
;
2063 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2064 unsigned char *origstr
= XSTRING (array
)->data
, *str
;
2067 nchars
= XSTRING (array
)->size
;
2068 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2069 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2071 str
= (nbytes
<= MAX_ALLOCA
2072 ? (unsigned char *) alloca (nbytes
)
2073 : (unsigned char *) xmalloc (nbytes
));
2074 copy_text (XSTRING (array
)->data
, str
, nchars
, 0, 1);
2075 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2077 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2078 allocate_string_data (XSTRING (array
), nchars
,
2079 nbytes
+ new_bytes
- prev_bytes
);
2080 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2081 p1
= XSTRING (array
)->data
+ idxval_byte
;
2084 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2085 nbytes
- (idxval_byte
+ prev_bytes
));
2086 if (nbytes
> MAX_ALLOCA
)
2088 clear_string_char_byte_cache ();
2095 /* Arithmetic functions */
2097 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2100 arithcompare (num1
, num2
, comparison
)
2101 Lisp_Object num1
, num2
;
2102 enum comparison comparison
;
2104 double f1
= 0, f2
= 0;
2107 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
2108 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
2110 if (FLOATP (num1
) || FLOATP (num2
))
2113 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2114 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2120 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2125 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2130 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2135 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2140 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2145 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2154 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2155 "Return t if two args, both numbers or markers, are equal.")
2157 register Lisp_Object num1
, num2
;
2159 return arithcompare (num1
, num2
, equal
);
2162 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2163 "Return t if first arg is less than second arg. Both must be numbers or markers.")
2165 register Lisp_Object num1
, num2
;
2167 return arithcompare (num1
, num2
, less
);
2170 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2171 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
2173 register Lisp_Object num1
, num2
;
2175 return arithcompare (num1
, num2
, grtr
);
2178 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2179 "Return t if first arg is less than or equal to second arg.\n\
2180 Both must be numbers or markers.")
2182 register Lisp_Object num1
, num2
;
2184 return arithcompare (num1
, num2
, less_or_equal
);
2187 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2188 "Return t if first arg is greater than or equal to second arg.\n\
2189 Both must be numbers or markers.")
2191 register Lisp_Object num1
, num2
;
2193 return arithcompare (num1
, num2
, grtr_or_equal
);
2196 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2197 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
2199 register Lisp_Object num1
, num2
;
2201 return arithcompare (num1
, num2
, notequal
);
2204 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2206 register Lisp_Object number
;
2208 CHECK_NUMBER_OR_FLOAT (number
, 0);
2210 if (FLOATP (number
))
2212 if (XFLOAT_DATA (number
) == 0.0)
2222 /* Convert between long values and pairs of Lisp integers. */
2228 unsigned int top
= i
>> 16;
2229 unsigned int bot
= i
& 0xFFFF;
2231 return make_number (bot
);
2232 if (top
== (unsigned long)-1 >> 16)
2233 return Fcons (make_number (-1), make_number (bot
));
2234 return Fcons (make_number (top
), make_number (bot
));
2241 Lisp_Object top
, bot
;
2248 return ((XINT (top
) << 16) | XINT (bot
));
2251 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2252 "Convert NUMBER to a string by printing it in decimal.\n\
2253 Uses a minus sign if negative.\n\
2254 NUMBER may be an integer or a floating point number.")
2258 char buffer
[VALBITS
];
2260 CHECK_NUMBER_OR_FLOAT (number
, 0);
2262 if (FLOATP (number
))
2264 char pigbuf
[350]; /* see comments in float_to_string */
2266 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2267 return build_string (pigbuf
);
2270 if (sizeof (int) == sizeof (EMACS_INT
))
2271 sprintf (buffer
, "%d", XINT (number
));
2272 else if (sizeof (long) == sizeof (EMACS_INT
))
2273 sprintf (buffer
, "%ld", (long) XINT (number
));
2276 return build_string (buffer
);
2280 digit_to_number (character
, base
)
2281 int character
, base
;
2285 if (character
>= '0' && character
<= '9')
2286 digit
= character
- '0';
2287 else if (character
>= 'a' && character
<= 'z')
2288 digit
= character
- 'a' + 10;
2289 else if (character
>= 'A' && character
<= 'Z')
2290 digit
= character
- 'A' + 10;
2300 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2301 "Convert STRING to a number by parsing it as a decimal number.\n\
2302 This parses both integers and floating point numbers.\n\
2303 It ignores leading spaces and tabs.\n\
2305 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2306 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2307 If the base used is not 10, floating point is not recognized.")
2309 register Lisp_Object string
, base
;
2311 register unsigned char *p
;
2316 CHECK_STRING (string
, 0);
2322 CHECK_NUMBER (base
, 1);
2324 if (b
< 2 || b
> 16)
2325 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2328 /* Skip any whitespace at the front of the number. Some versions of
2329 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2330 p
= XSTRING (string
)->data
;
2331 while (*p
== ' ' || *p
== '\t')
2342 if (isfloat_string (p
) && b
== 10)
2343 val
= make_float (sign
* atof (p
));
2350 int digit
= digit_to_number (*p
++, b
);
2356 val
= make_fixnum_or_float (sign
* v
);
2376 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2377 int, Lisp_Object
*));
2378 extern Lisp_Object
fmod_float ();
2381 arith_driver (code
, nargs
, args
)
2384 register Lisp_Object
*args
;
2386 register Lisp_Object val
;
2387 register int argnum
;
2388 register EMACS_INT accum
= 0;
2389 register EMACS_INT next
;
2391 switch (SWITCH_ENUM_CAST (code
))
2409 for (argnum
= 0; argnum
< nargs
; argnum
++)
2411 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2413 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2416 return float_arith_driver ((double) accum
, argnum
, code
,
2419 next
= XINT (args
[argnum
]);
2420 switch (SWITCH_ENUM_CAST (code
))
2426 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2437 Fsignal (Qarith_error
, Qnil
);
2451 if (!argnum
|| next
> accum
)
2455 if (!argnum
|| next
< accum
)
2461 XSETINT (val
, accum
);
2466 #define isnan(x) ((x) != (x))
2469 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2471 register int argnum
;
2474 register Lisp_Object
*args
;
2476 register Lisp_Object val
;
2479 for (; argnum
< nargs
; argnum
++)
2481 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2482 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2486 next
= XFLOAT_DATA (val
);
2490 args
[argnum
] = val
; /* runs into a compiler bug. */
2491 next
= XINT (args
[argnum
]);
2493 switch (SWITCH_ENUM_CAST (code
))
2499 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2509 if (! IEEE_FLOATING_POINT
&& next
== 0)
2510 Fsignal (Qarith_error
, Qnil
);
2517 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2519 if (!argnum
|| isnan (next
) || next
> accum
)
2523 if (!argnum
|| isnan (next
) || next
< accum
)
2529 return make_float (accum
);
2533 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2534 "Return sum of any number of arguments, which are numbers or markers.")
2539 return arith_driver (Aadd
, nargs
, args
);
2542 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2543 "Negate number or subtract numbers or markers.\n\
2544 With one arg, negates it. With more than one arg,\n\
2545 subtracts all but the first from the first.")
2550 return arith_driver (Asub
, nargs
, args
);
2553 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2554 "Returns product of any number of arguments, which are numbers or markers.")
2559 return arith_driver (Amult
, nargs
, args
);
2562 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2563 "Returns first argument divided by all the remaining arguments.\n\
2564 The arguments must be numbers or markers.")
2569 return arith_driver (Adiv
, nargs
, args
);
2572 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2573 "Returns remainder of X divided by Y.\n\
2574 Both must be integers or markers.")
2576 register Lisp_Object x
, y
;
2580 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2581 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2583 if (XFASTINT (y
) == 0)
2584 Fsignal (Qarith_error
, Qnil
);
2586 XSETINT (val
, XINT (x
) % XINT (y
));
2600 /* If the magnitude of the result exceeds that of the divisor, or
2601 the sign of the result does not agree with that of the dividend,
2602 iterate with the reduced value. This does not yield a
2603 particularly accurate result, but at least it will be in the
2604 range promised by fmod. */
2606 r
-= f2
* floor (r
/ f2
);
2607 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2611 #endif /* ! HAVE_FMOD */
2613 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2614 "Returns X modulo Y.\n\
2615 The result falls between zero (inclusive) and Y (exclusive).\n\
2616 Both X and Y must be numbers or markers.")
2618 register Lisp_Object x
, y
;
2623 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2624 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2626 if (FLOATP (x
) || FLOATP (y
))
2627 return fmod_float (x
, y
);
2633 Fsignal (Qarith_error
, Qnil
);
2637 /* If the "remainder" comes out with the wrong sign, fix it. */
2638 if (i2
< 0 ? i1
> 0 : i1
< 0)
2645 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2646 "Return largest of all the arguments (which must be numbers or markers).\n\
2647 The value is always a number; markers are converted to numbers.")
2652 return arith_driver (Amax
, nargs
, args
);
2655 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2656 "Return smallest of all the arguments (which must be numbers or markers).\n\
2657 The value is always a number; markers are converted to numbers.")
2662 return arith_driver (Amin
, nargs
, args
);
2665 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2666 "Return bitwise-and of all the arguments.\n\
2667 Arguments may be integers, or markers converted to integers.")
2672 return arith_driver (Alogand
, nargs
, args
);
2675 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2676 "Return bitwise-or of all the arguments.\n\
2677 Arguments may be integers, or markers converted to integers.")
2682 return arith_driver (Alogior
, nargs
, args
);
2685 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2686 "Return bitwise-exclusive-or of all the arguments.\n\
2687 Arguments may be integers, or markers converted to integers.")
2692 return arith_driver (Alogxor
, nargs
, args
);
2695 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2696 "Return VALUE with its bits shifted left by COUNT.\n\
2697 If COUNT is negative, shifting is actually to the right.\n\
2698 In this case, the sign bit is duplicated.")
2700 register Lisp_Object value
, count
;
2702 register Lisp_Object val
;
2704 CHECK_NUMBER (value
, 0);
2705 CHECK_NUMBER (count
, 1);
2707 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2709 else if (XINT (count
) > 0)
2710 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2711 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2712 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2714 XSETINT (val
, XINT (value
) >> -XINT (count
));
2718 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2719 "Return VALUE with its bits shifted left by COUNT.\n\
2720 If COUNT is negative, shifting is actually to the right.\n\
2721 In this case, zeros are shifted in on the left.")
2723 register Lisp_Object value
, count
;
2725 register Lisp_Object val
;
2727 CHECK_NUMBER (value
, 0);
2728 CHECK_NUMBER (count
, 1);
2730 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2732 else if (XINT (count
) > 0)
2733 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2734 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2737 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2741 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2742 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2743 Markers are converted to integers.")
2745 register Lisp_Object number
;
2747 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2749 if (FLOATP (number
))
2750 return (make_float (1.0 + XFLOAT_DATA (number
)));
2752 XSETINT (number
, XINT (number
) + 1);
2756 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2757 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2758 Markers are converted to integers.")
2760 register Lisp_Object number
;
2762 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2764 if (FLOATP (number
))
2765 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2767 XSETINT (number
, XINT (number
) - 1);
2771 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2772 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2774 register Lisp_Object number
;
2776 CHECK_NUMBER (number
, 0);
2777 XSETINT (number
, ~XINT (number
));
2784 Lisp_Object error_tail
, arith_tail
;
2786 Qquote
= intern ("quote");
2787 Qlambda
= intern ("lambda");
2788 Qsubr
= intern ("subr");
2789 Qerror_conditions
= intern ("error-conditions");
2790 Qerror_message
= intern ("error-message");
2791 Qtop_level
= intern ("top-level");
2793 Qerror
= intern ("error");
2794 Qquit
= intern ("quit");
2795 Qwrong_type_argument
= intern ("wrong-type-argument");
2796 Qargs_out_of_range
= intern ("args-out-of-range");
2797 Qvoid_function
= intern ("void-function");
2798 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2799 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2800 Qvoid_variable
= intern ("void-variable");
2801 Qsetting_constant
= intern ("setting-constant");
2802 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2804 Qinvalid_function
= intern ("invalid-function");
2805 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2806 Qno_catch
= intern ("no-catch");
2807 Qend_of_file
= intern ("end-of-file");
2808 Qarith_error
= intern ("arith-error");
2809 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2810 Qend_of_buffer
= intern ("end-of-buffer");
2811 Qbuffer_read_only
= intern ("buffer-read-only");
2812 Qtext_read_only
= intern ("text-read-only");
2813 Qmark_inactive
= intern ("mark-inactive");
2815 Qlistp
= intern ("listp");
2816 Qconsp
= intern ("consp");
2817 Qsymbolp
= intern ("symbolp");
2818 Qkeywordp
= intern ("keywordp");
2819 Qintegerp
= intern ("integerp");
2820 Qnatnump
= intern ("natnump");
2821 Qwholenump
= intern ("wholenump");
2822 Qstringp
= intern ("stringp");
2823 Qarrayp
= intern ("arrayp");
2824 Qsequencep
= intern ("sequencep");
2825 Qbufferp
= intern ("bufferp");
2826 Qvectorp
= intern ("vectorp");
2827 Qchar_or_string_p
= intern ("char-or-string-p");
2828 Qmarkerp
= intern ("markerp");
2829 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2830 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2831 Qboundp
= intern ("boundp");
2832 Qfboundp
= intern ("fboundp");
2834 Qfloatp
= intern ("floatp");
2835 Qnumberp
= intern ("numberp");
2836 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2838 Qchar_table_p
= intern ("char-table-p");
2839 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2841 Qsubrp
= intern ("subrp");
2842 Qunevalled
= intern ("unevalled");
2843 Qmany
= intern ("many");
2845 Qcdr
= intern ("cdr");
2847 /* Handle automatic advice activation */
2848 Qad_advice_info
= intern ("ad-advice-info");
2849 Qad_activate_internal
= intern ("ad-activate-internal");
2851 error_tail
= Fcons (Qerror
, Qnil
);
2853 /* ERROR is used as a signaler for random errors for which nothing else is right */
2855 Fput (Qerror
, Qerror_conditions
,
2857 Fput (Qerror
, Qerror_message
,
2858 build_string ("error"));
2860 Fput (Qquit
, Qerror_conditions
,
2861 Fcons (Qquit
, Qnil
));
2862 Fput (Qquit
, Qerror_message
,
2863 build_string ("Quit"));
2865 Fput (Qwrong_type_argument
, Qerror_conditions
,
2866 Fcons (Qwrong_type_argument
, error_tail
));
2867 Fput (Qwrong_type_argument
, Qerror_message
,
2868 build_string ("Wrong type argument"));
2870 Fput (Qargs_out_of_range
, Qerror_conditions
,
2871 Fcons (Qargs_out_of_range
, error_tail
));
2872 Fput (Qargs_out_of_range
, Qerror_message
,
2873 build_string ("Args out of range"));
2875 Fput (Qvoid_function
, Qerror_conditions
,
2876 Fcons (Qvoid_function
, error_tail
));
2877 Fput (Qvoid_function
, Qerror_message
,
2878 build_string ("Symbol's function definition is void"));
2880 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2881 Fcons (Qcyclic_function_indirection
, error_tail
));
2882 Fput (Qcyclic_function_indirection
, Qerror_message
,
2883 build_string ("Symbol's chain of function indirections contains a loop"));
2885 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2886 Fcons (Qcyclic_variable_indirection
, error_tail
));
2887 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2888 build_string ("Symbol's chain of variable indirections contains a loop"));
2890 Qcircular_list
= intern ("circular-list");
2891 staticpro (&Qcircular_list
);
2892 Fput (Qcircular_list
, Qerror_conditions
,
2893 Fcons (Qcircular_list
, error_tail
));
2894 Fput (Qcircular_list
, Qerror_message
,
2895 build_string ("List contains a loop"));
2897 Fput (Qvoid_variable
, Qerror_conditions
,
2898 Fcons (Qvoid_variable
, error_tail
));
2899 Fput (Qvoid_variable
, Qerror_message
,
2900 build_string ("Symbol's value as variable is void"));
2902 Fput (Qsetting_constant
, Qerror_conditions
,
2903 Fcons (Qsetting_constant
, error_tail
));
2904 Fput (Qsetting_constant
, Qerror_message
,
2905 build_string ("Attempt to set a constant symbol"));
2907 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2908 Fcons (Qinvalid_read_syntax
, error_tail
));
2909 Fput (Qinvalid_read_syntax
, Qerror_message
,
2910 build_string ("Invalid read syntax"));
2912 Fput (Qinvalid_function
, Qerror_conditions
,
2913 Fcons (Qinvalid_function
, error_tail
));
2914 Fput (Qinvalid_function
, Qerror_message
,
2915 build_string ("Invalid function"));
2917 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2918 Fcons (Qwrong_number_of_arguments
, error_tail
));
2919 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2920 build_string ("Wrong number of arguments"));
2922 Fput (Qno_catch
, Qerror_conditions
,
2923 Fcons (Qno_catch
, error_tail
));
2924 Fput (Qno_catch
, Qerror_message
,
2925 build_string ("No catch for tag"));
2927 Fput (Qend_of_file
, Qerror_conditions
,
2928 Fcons (Qend_of_file
, error_tail
));
2929 Fput (Qend_of_file
, Qerror_message
,
2930 build_string ("End of file during parsing"));
2932 arith_tail
= Fcons (Qarith_error
, error_tail
);
2933 Fput (Qarith_error
, Qerror_conditions
,
2935 Fput (Qarith_error
, Qerror_message
,
2936 build_string ("Arithmetic error"));
2938 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2939 Fcons (Qbeginning_of_buffer
, error_tail
));
2940 Fput (Qbeginning_of_buffer
, Qerror_message
,
2941 build_string ("Beginning of buffer"));
2943 Fput (Qend_of_buffer
, Qerror_conditions
,
2944 Fcons (Qend_of_buffer
, error_tail
));
2945 Fput (Qend_of_buffer
, Qerror_message
,
2946 build_string ("End of buffer"));
2948 Fput (Qbuffer_read_only
, Qerror_conditions
,
2949 Fcons (Qbuffer_read_only
, error_tail
));
2950 Fput (Qbuffer_read_only
, Qerror_message
,
2951 build_string ("Buffer is read-only"));
2953 Fput (Qtext_read_only
, Qerror_conditions
,
2954 Fcons (Qtext_read_only
, error_tail
));
2955 Fput (Qtext_read_only
, Qerror_message
,
2956 build_string ("Text is read-only"));
2958 Qrange_error
= intern ("range-error");
2959 Qdomain_error
= intern ("domain-error");
2960 Qsingularity_error
= intern ("singularity-error");
2961 Qoverflow_error
= intern ("overflow-error");
2962 Qunderflow_error
= intern ("underflow-error");
2964 Fput (Qdomain_error
, Qerror_conditions
,
2965 Fcons (Qdomain_error
, arith_tail
));
2966 Fput (Qdomain_error
, Qerror_message
,
2967 build_string ("Arithmetic domain error"));
2969 Fput (Qrange_error
, Qerror_conditions
,
2970 Fcons (Qrange_error
, arith_tail
));
2971 Fput (Qrange_error
, Qerror_message
,
2972 build_string ("Arithmetic range error"));
2974 Fput (Qsingularity_error
, Qerror_conditions
,
2975 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2976 Fput (Qsingularity_error
, Qerror_message
,
2977 build_string ("Arithmetic singularity error"));
2979 Fput (Qoverflow_error
, Qerror_conditions
,
2980 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2981 Fput (Qoverflow_error
, Qerror_message
,
2982 build_string ("Arithmetic overflow error"));
2984 Fput (Qunderflow_error
, Qerror_conditions
,
2985 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2986 Fput (Qunderflow_error
, Qerror_message
,
2987 build_string ("Arithmetic underflow error"));
2989 staticpro (&Qrange_error
);
2990 staticpro (&Qdomain_error
);
2991 staticpro (&Qsingularity_error
);
2992 staticpro (&Qoverflow_error
);
2993 staticpro (&Qunderflow_error
);
2997 staticpro (&Qquote
);
2998 staticpro (&Qlambda
);
3000 staticpro (&Qunbound
);
3001 staticpro (&Qerror_conditions
);
3002 staticpro (&Qerror_message
);
3003 staticpro (&Qtop_level
);
3005 staticpro (&Qerror
);
3007 staticpro (&Qwrong_type_argument
);
3008 staticpro (&Qargs_out_of_range
);
3009 staticpro (&Qvoid_function
);
3010 staticpro (&Qcyclic_function_indirection
);
3011 staticpro (&Qvoid_variable
);
3012 staticpro (&Qsetting_constant
);
3013 staticpro (&Qinvalid_read_syntax
);
3014 staticpro (&Qwrong_number_of_arguments
);
3015 staticpro (&Qinvalid_function
);
3016 staticpro (&Qno_catch
);
3017 staticpro (&Qend_of_file
);
3018 staticpro (&Qarith_error
);
3019 staticpro (&Qbeginning_of_buffer
);
3020 staticpro (&Qend_of_buffer
);
3021 staticpro (&Qbuffer_read_only
);
3022 staticpro (&Qtext_read_only
);
3023 staticpro (&Qmark_inactive
);
3025 staticpro (&Qlistp
);
3026 staticpro (&Qconsp
);
3027 staticpro (&Qsymbolp
);
3028 staticpro (&Qkeywordp
);
3029 staticpro (&Qintegerp
);
3030 staticpro (&Qnatnump
);
3031 staticpro (&Qwholenump
);
3032 staticpro (&Qstringp
);
3033 staticpro (&Qarrayp
);
3034 staticpro (&Qsequencep
);
3035 staticpro (&Qbufferp
);
3036 staticpro (&Qvectorp
);
3037 staticpro (&Qchar_or_string_p
);
3038 staticpro (&Qmarkerp
);
3039 staticpro (&Qbuffer_or_string_p
);
3040 staticpro (&Qinteger_or_marker_p
);
3041 staticpro (&Qfloatp
);
3042 staticpro (&Qnumberp
);
3043 staticpro (&Qnumber_or_marker_p
);
3044 staticpro (&Qchar_table_p
);
3045 staticpro (&Qvector_or_char_table_p
);
3046 staticpro (&Qsubrp
);
3048 staticpro (&Qunevalled
);
3050 staticpro (&Qboundp
);
3051 staticpro (&Qfboundp
);
3053 staticpro (&Qad_advice_info
);
3054 staticpro (&Qad_activate_internal
);
3056 /* Types that type-of returns. */
3057 Qinteger
= intern ("integer");
3058 Qsymbol
= intern ("symbol");
3059 Qstring
= intern ("string");
3060 Qcons
= intern ("cons");
3061 Qmarker
= intern ("marker");
3062 Qoverlay
= intern ("overlay");
3063 Qfloat
= intern ("float");
3064 Qwindow_configuration
= intern ("window-configuration");
3065 Qprocess
= intern ("process");
3066 Qwindow
= intern ("window");
3067 /* Qsubr = intern ("subr"); */
3068 Qcompiled_function
= intern ("compiled-function");
3069 Qbuffer
= intern ("buffer");
3070 Qframe
= intern ("frame");
3071 Qvector
= intern ("vector");
3072 Qchar_table
= intern ("char-table");
3073 Qbool_vector
= intern ("bool-vector");
3074 Qhash_table
= intern ("hash-table");
3076 staticpro (&Qinteger
);
3077 staticpro (&Qsymbol
);
3078 staticpro (&Qstring
);
3080 staticpro (&Qmarker
);
3081 staticpro (&Qoverlay
);
3082 staticpro (&Qfloat
);
3083 staticpro (&Qwindow_configuration
);
3084 staticpro (&Qprocess
);
3085 staticpro (&Qwindow
);
3086 /* staticpro (&Qsubr); */
3087 staticpro (&Qcompiled_function
);
3088 staticpro (&Qbuffer
);
3089 staticpro (&Qframe
);
3090 staticpro (&Qvector
);
3091 staticpro (&Qchar_table
);
3092 staticpro (&Qbool_vector
);
3093 staticpro (&Qhash_table
);
3095 defsubr (&Sindirect_variable
);
3096 defsubr (&Ssubr_interactive_form
);
3099 defsubr (&Stype_of
);
3104 defsubr (&Sintegerp
);
3105 defsubr (&Sinteger_or_marker_p
);
3106 defsubr (&Snumberp
);
3107 defsubr (&Snumber_or_marker_p
);
3109 defsubr (&Snatnump
);
3110 defsubr (&Ssymbolp
);
3111 defsubr (&Skeywordp
);
3112 defsubr (&Sstringp
);
3113 defsubr (&Smultibyte_string_p
);
3114 defsubr (&Svectorp
);
3115 defsubr (&Schar_table_p
);
3116 defsubr (&Svector_or_char_table_p
);
3117 defsubr (&Sbool_vector_p
);
3119 defsubr (&Ssequencep
);
3120 defsubr (&Sbufferp
);
3121 defsubr (&Smarkerp
);
3123 defsubr (&Sbyte_code_function_p
);
3124 defsubr (&Schar_or_string_p
);
3127 defsubr (&Scar_safe
);
3128 defsubr (&Scdr_safe
);
3131 defsubr (&Ssymbol_function
);
3132 defsubr (&Sindirect_function
);
3133 defsubr (&Ssymbol_plist
);
3134 defsubr (&Ssymbol_name
);
3135 defsubr (&Smakunbound
);
3136 defsubr (&Sfmakunbound
);
3138 defsubr (&Sfboundp
);
3140 defsubr (&Sdefalias
);
3141 defsubr (&Ssetplist
);
3142 defsubr (&Ssymbol_value
);
3144 defsubr (&Sdefault_boundp
);
3145 defsubr (&Sdefault_value
);
3146 defsubr (&Sset_default
);
3147 defsubr (&Ssetq_default
);
3148 defsubr (&Smake_variable_buffer_local
);
3149 defsubr (&Smake_local_variable
);
3150 defsubr (&Skill_local_variable
);
3151 defsubr (&Smake_variable_frame_local
);
3152 defsubr (&Slocal_variable_p
);
3153 defsubr (&Slocal_variable_if_set_p
);
3156 defsubr (&Snumber_to_string
);
3157 defsubr (&Sstring_to_number
);
3158 defsubr (&Seqlsign
);
3181 defsubr (&Ssubr_arity
);
3183 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3185 DEFVAR_INT ("most-positive-fixnum", &most_positive_fixnum
,
3186 "The largest value that is representable in a Lisp integer.");
3187 most_positive_fixnum
= MOST_POSITIVE_FIXNUM
;
3189 DEFVAR_INT ("most-negative-fixnum", &most_negative_fixnum
,
3190 "The smallest value that is representable in a Lisp integer.");
3191 most_negative_fixnum
= MOST_NEGATIVE_FIXNUM
;
3198 #if defined(USG) && !defined(POSIX_SIGNALS)
3199 /* USG systems forget handlers when they are used;
3200 must reestablish each time */
3201 signal (signo
, arith_error
);
3204 /* VMS systems are like USG. */
3205 signal (signo
, arith_error
);
3209 #else /* not BSD4_1 */
3210 sigsetmask (SIGEMPTYMASK
);
3211 #endif /* not BSD4_1 */
3213 Fsignal (Qarith_error
, Qnil
);
3219 /* Don't do this if just dumping out.
3220 We don't want to call `signal' in this case
3221 so that we don't have trouble with dumping
3222 signal-delivering routines in an inconsistent state. */
3226 #endif /* CANNOT_DUMP */
3227 signal (SIGFPE
, arith_error
);
3230 signal (SIGEMT
, arith_error
);