1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 2003
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
32 #include "syssignal.h"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
69 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
70 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
71 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
72 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
73 Lisp_Object Qtext_read_only
;
74 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
75 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
76 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
77 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
78 Lisp_Object Qboundp
, Qfboundp
;
79 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
82 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
84 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
85 Lisp_Object Qoverflow_error
, Qunderflow_error
;
88 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
90 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
91 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
93 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
94 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
95 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
97 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
99 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
103 circular_list_error (list
)
106 Fsignal (Qcircular_list
, list
);
111 wrong_type_argument (predicate
, value
)
112 register Lisp_Object predicate
, value
;
114 register Lisp_Object tem
;
117 /* If VALUE is not even a valid Lisp object, abort here
118 where we can get a backtrace showing where it came from. */
119 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
122 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
123 tem
= call1 (predicate
, value
);
132 error ("Attempt to modify read-only object");
136 args_out_of_range (a1
, a2
)
140 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
144 args_out_of_range_3 (a1
, a2
, a3
)
145 Lisp_Object a1
, a2
, a3
;
148 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
151 /* On some machines, XINT needs a temporary location.
152 Here it is, in case it is needed. */
154 int sign_extend_temp
;
156 /* On a few machines, XINT can only be done by calling this. */
159 sign_extend_lisp_int (num
)
162 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
163 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
165 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
168 /* Data type predicates */
170 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
171 doc
: /* Return t if the two args are the same Lisp object. */)
173 Lisp_Object obj1
, obj2
;
180 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
181 doc
: /* Return t if OBJECT is nil. */)
190 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
191 doc
: /* Return a symbol representing the type of OBJECT.
192 The symbol returned names the object's basic type;
193 for example, (type-of 1) returns `integer'. */)
197 switch (XGCTYPE (object
))
212 switch (XMISCTYPE (object
))
214 case Lisp_Misc_Marker
:
216 case Lisp_Misc_Overlay
:
218 case Lisp_Misc_Float
:
223 case Lisp_Vectorlike
:
224 if (GC_WINDOW_CONFIGURATIONP (object
))
225 return Qwindow_configuration
;
226 if (GC_PROCESSP (object
))
228 if (GC_WINDOWP (object
))
230 if (GC_SUBRP (object
))
232 if (GC_COMPILEDP (object
))
233 return Qcompiled_function
;
234 if (GC_BUFFERP (object
))
236 if (GC_CHAR_TABLE_P (object
))
238 if (GC_BOOL_VECTOR_P (object
))
240 if (GC_FRAMEP (object
))
242 if (GC_HASH_TABLE_P (object
))
254 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
255 doc
: /* Return t if OBJECT is a cons cell. */)
264 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
265 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
274 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
275 doc
: /* Return t if OBJECT is a list. This includes nil. */)
279 if (CONSP (object
) || NILP (object
))
284 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
285 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
289 if (CONSP (object
) || NILP (object
))
294 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
295 doc
: /* Return t if OBJECT is a symbol. */)
299 if (SYMBOLP (object
))
304 /* Define this in C to avoid unnecessarily consing up the symbol
306 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is a keyword.
308 This means that it is a symbol with a print name beginning with `:'
309 interned in the initial obarray. */)
314 && SREF (SYMBOL_NAME (object
), 0) == ':'
315 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
320 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a vector. */)
325 if (VECTORP (object
))
330 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
331 doc
: /* Return t if OBJECT is a string. */)
335 if (STRINGP (object
))
340 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
342 doc
: /* Return t if OBJECT is a multibyte string. */)
346 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
351 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a char-table. */)
356 if (CHAR_TABLE_P (object
))
361 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
362 Svector_or_char_table_p
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a char-table or vector. */)
367 if (VECTORP (object
) || CHAR_TABLE_P (object
))
372 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
373 doc
: /* Return t if OBJECT is a bool-vector. */)
377 if (BOOL_VECTOR_P (object
))
382 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 if (VECTORP (object
) || STRINGP (object
)
388 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
393 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
394 doc
: /* Return t if OBJECT is a sequence (list or array). */)
396 register Lisp_Object object
;
398 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
399 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
404 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is an editor buffer. */)
409 if (BUFFERP (object
))
414 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
419 if (MARKERP (object
))
424 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a built-in function. */)
434 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
436 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
440 if (COMPILEDP (object
))
445 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
446 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
448 register Lisp_Object object
;
450 if (INTEGERP (object
) || STRINGP (object
))
455 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
456 doc
: /* Return t if OBJECT is an integer. */)
460 if (INTEGERP (object
))
465 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
466 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
468 register Lisp_Object object
;
470 if (MARKERP (object
) || INTEGERP (object
))
475 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
476 doc
: /* Return t if OBJECT is a nonnegative integer. */)
480 if (NATNUMP (object
))
485 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
486 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
490 if (NUMBERP (object
))
496 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
497 Snumber_or_marker_p
, 1, 1, 0,
498 doc
: /* Return t if OBJECT is a number or a marker. */)
502 if (NUMBERP (object
) || MARKERP (object
))
507 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
508 doc
: /* Return t if OBJECT is a floating point number. */)
518 /* Extract and set components of lists */
520 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
521 doc
: /* Return the car of LIST. If arg is nil, return nil.
522 Error if arg is not nil and not a cons cell. See also `car-safe'. */)
524 register Lisp_Object list
;
530 else if (EQ (list
, Qnil
))
533 list
= wrong_type_argument (Qlistp
, list
);
537 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
538 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
543 return XCAR (object
);
548 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
549 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
550 Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
552 register Lisp_Object list
;
558 else if (EQ (list
, Qnil
))
561 list
= wrong_type_argument (Qlistp
, list
);
565 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
566 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
571 return XCDR (object
);
576 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
577 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
579 register Lisp_Object cell
, newcar
;
582 cell
= wrong_type_argument (Qconsp
, cell
);
585 XSETCAR (cell
, newcar
);
589 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
590 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
592 register Lisp_Object cell
, newcdr
;
595 cell
= wrong_type_argument (Qconsp
, cell
);
598 XSETCDR (cell
, newcdr
);
602 /* Extract and set components of symbols */
604 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
605 doc
: /* Return t if SYMBOL's value is not void. */)
607 register Lisp_Object symbol
;
609 Lisp_Object valcontents
;
610 CHECK_SYMBOL (symbol
);
612 valcontents
= SYMBOL_VALUE (symbol
);
614 if (BUFFER_LOCAL_VALUEP (valcontents
)
615 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
616 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
618 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
621 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
622 doc
: /* Return t if SYMBOL's function definition is not void. */)
624 register Lisp_Object symbol
;
626 CHECK_SYMBOL (symbol
);
627 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
630 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
631 doc
: /* Make SYMBOL's value be void.
634 register Lisp_Object symbol
;
636 CHECK_SYMBOL (symbol
);
637 if (XSYMBOL (symbol
)->constant
)
638 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
639 Fset (symbol
, Qunbound
);
643 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
644 doc
: /* Make SYMBOL's function definition be void.
647 register Lisp_Object symbol
;
649 CHECK_SYMBOL (symbol
);
650 if (NILP (symbol
) || EQ (symbol
, Qt
))
651 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
652 XSYMBOL (symbol
)->function
= Qunbound
;
656 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
657 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
659 register Lisp_Object symbol
;
661 CHECK_SYMBOL (symbol
);
662 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
663 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
664 return XSYMBOL (symbol
)->function
;
667 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
668 doc
: /* Return SYMBOL's property list. */)
670 register Lisp_Object symbol
;
672 CHECK_SYMBOL (symbol
);
673 return XSYMBOL (symbol
)->plist
;
676 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
677 doc
: /* Return SYMBOL's name, a string. */)
679 register Lisp_Object symbol
;
681 register Lisp_Object name
;
683 CHECK_SYMBOL (symbol
);
684 name
= SYMBOL_NAME (symbol
);
688 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
689 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
691 register Lisp_Object symbol
, definition
;
693 CHECK_SYMBOL (symbol
);
694 if (NILP (symbol
) || EQ (symbol
, Qt
))
695 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
696 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
697 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
699 XSYMBOL (symbol
)->function
= definition
;
700 /* Handle automatic advice activation */
701 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
703 call2 (Qad_activate_internal
, symbol
, Qnil
);
704 definition
= XSYMBOL (symbol
)->function
;
709 extern Lisp_Object Qfunction_documentation
;
711 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
712 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
713 Associates the function with the current load file, if any.
714 The optional third argument DOCSTRING specifies the documentation string
715 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
716 determined by DEFINITION. */)
717 (symbol
, definition
, docstring
)
718 register Lisp_Object symbol
, definition
, docstring
;
720 if (CONSP (XSYMBOL (symbol
)->function
)
721 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
722 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
723 definition
= Ffset (symbol
, definition
);
724 LOADHIST_ATTACH (symbol
);
725 if (!NILP (docstring
))
726 Fput (symbol
, Qfunction_documentation
, docstring
);
730 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
731 doc
: /* Set SYMBOL's property list to NEWVAL, and return NEWVAL. */)
733 register Lisp_Object symbol
, newplist
;
735 CHECK_SYMBOL (symbol
);
736 XSYMBOL (symbol
)->plist
= newplist
;
740 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
741 doc
: /* Return minimum and maximum number of args allowed for SUBR.
742 SUBR must be a built-in function.
743 The returned value is a pair (MIN . MAX). MIN is the minimum number
744 of args. MAX is the maximum number or the symbol `many', for a
745 function with `&rest' args, or `unevalled' for a special form. */)
749 short minargs
, maxargs
;
751 wrong_type_argument (Qsubrp
, subr
);
752 minargs
= XSUBR (subr
)->min_args
;
753 maxargs
= XSUBR (subr
)->max_args
;
755 return Fcons (make_number (minargs
), Qmany
);
756 else if (maxargs
== UNEVALLED
)
757 return Fcons (make_number (minargs
), Qunevalled
);
759 return Fcons (make_number (minargs
), make_number (maxargs
));
762 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
763 doc
: /* Return the interactive form of SUBR or nil if none.
764 SUBR must be a built-in function. Value, if non-nil, is a list
765 \(interactive SPEC). */)
770 wrong_type_argument (Qsubrp
, subr
);
771 if (XSUBR (subr
)->prompt
)
772 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
777 /***********************************************************************
778 Getting and Setting Values of Symbols
779 ***********************************************************************/
781 /* Return the symbol holding SYMBOL's value. Signal
782 `cyclic-variable-indirection' if SYMBOL's chain of variable
783 indirections contains a loop. */
786 indirect_variable (symbol
)
789 Lisp_Object tortoise
, hare
;
791 hare
= tortoise
= symbol
;
793 while (XSYMBOL (hare
)->indirect_variable
)
795 hare
= XSYMBOL (hare
)->value
;
796 if (!XSYMBOL (hare
)->indirect_variable
)
799 hare
= XSYMBOL (hare
)->value
;
800 tortoise
= XSYMBOL (tortoise
)->value
;
802 if (EQ (hare
, tortoise
))
803 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
810 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
811 doc
: /* Return the variable at the end of OBJECT's variable chain.
812 If OBJECT is a symbol, follow all variable indirections and return the final
813 variable. If OBJECT is not a symbol, just return it.
814 Signal a cyclic-variable-indirection error if there is a loop in the
815 variable chain of symbols. */)
819 if (SYMBOLP (object
))
820 object
= indirect_variable (object
);
825 /* Given the raw contents of a symbol value cell,
826 return the Lisp value of the symbol.
827 This does not handle buffer-local variables; use
828 swap_in_symval_forwarding for that. */
831 do_symval_forwarding (valcontents
)
832 register Lisp_Object valcontents
;
834 register Lisp_Object val
;
836 if (MISCP (valcontents
))
837 switch (XMISCTYPE (valcontents
))
839 case Lisp_Misc_Intfwd
:
840 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
843 case Lisp_Misc_Boolfwd
:
844 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
846 case Lisp_Misc_Objfwd
:
847 return *XOBJFWD (valcontents
)->objvar
;
849 case Lisp_Misc_Buffer_Objfwd
:
850 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
851 return PER_BUFFER_VALUE (current_buffer
, offset
);
853 case Lisp_Misc_Kboard_Objfwd
:
854 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
855 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
860 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
861 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
862 buffer-independent contents of the value cell: forwarded just one
863 step past the buffer-localness.
865 BUF non-zero means set the value in buffer BUF instead of the
866 current buffer. This only plays a role for per-buffer variables. */
869 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
871 register Lisp_Object valcontents
, newval
;
874 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
877 switch (XMISCTYPE (valcontents
))
879 case Lisp_Misc_Intfwd
:
880 CHECK_NUMBER (newval
);
881 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
882 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
883 error ("Value out of range for variable `%s'",
884 SDATA (SYMBOL_NAME (symbol
)));
887 case Lisp_Misc_Boolfwd
:
888 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
891 case Lisp_Misc_Objfwd
:
892 *XOBJFWD (valcontents
)->objvar
= newval
;
895 case Lisp_Misc_Buffer_Objfwd
:
897 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
900 type
= PER_BUFFER_TYPE (offset
);
901 if (! NILP (type
) && ! NILP (newval
)
902 && XTYPE (newval
) != XINT (type
))
903 buffer_slot_type_mismatch (offset
);
906 buf
= current_buffer
;
907 PER_BUFFER_VALUE (buf
, offset
) = newval
;
911 case Lisp_Misc_Kboard_Objfwd
:
913 char *base
= (char *) current_kboard
;
914 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
915 *(Lisp_Object
*) p
= newval
;
926 valcontents
= SYMBOL_VALUE (symbol
);
927 if (BUFFER_LOCAL_VALUEP (valcontents
)
928 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
929 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
931 SET_SYMBOL_VALUE (symbol
, newval
);
935 /* Set up SYMBOL to refer to its global binding.
936 This makes it safe to alter the status of other bindings. */
939 swap_in_global_binding (symbol
)
942 Lisp_Object valcontents
, cdr
;
944 valcontents
= SYMBOL_VALUE (symbol
);
945 if (!BUFFER_LOCAL_VALUEP (valcontents
)
946 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
948 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
950 /* Unload the previously loaded binding. */
952 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
954 /* Select the global binding in the symbol. */
956 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
958 /* Indicate that the global binding is set up now. */
959 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
960 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
961 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
962 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
965 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
966 VALCONTENTS is the contents of its value cell,
967 which points to a struct Lisp_Buffer_Local_Value.
969 Return the value forwarded one step past the buffer-local stage.
970 This could be another forwarding pointer. */
973 swap_in_symval_forwarding (symbol
, valcontents
)
974 Lisp_Object symbol
, valcontents
;
976 register Lisp_Object tem1
;
978 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
981 || current_buffer
!= XBUFFER (tem1
)
982 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
983 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
985 if (XSYMBOL (symbol
)->indirect_variable
)
986 symbol
= indirect_variable (symbol
);
988 /* Unload the previously loaded binding. */
989 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
991 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
992 /* Choose the new binding. */
993 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
994 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
995 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
998 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
999 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1001 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1003 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1006 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1008 /* Load the new binding. */
1009 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1010 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1011 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1012 store_symval_forwarding (symbol
,
1013 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1016 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1019 /* Find the value of a symbol, returning Qunbound if it's not bound.
1020 This is helpful for code which just wants to get a variable's value
1021 if it has one, without signaling an error.
1022 Note that it must not be possible to quit
1023 within this function. Great care is required for this. */
1026 find_symbol_value (symbol
)
1029 register Lisp_Object valcontents
;
1030 register Lisp_Object val
;
1032 CHECK_SYMBOL (symbol
);
1033 valcontents
= SYMBOL_VALUE (symbol
);
1035 if (BUFFER_LOCAL_VALUEP (valcontents
)
1036 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1037 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1039 if (MISCP (valcontents
))
1041 switch (XMISCTYPE (valcontents
))
1043 case Lisp_Misc_Intfwd
:
1044 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1047 case Lisp_Misc_Boolfwd
:
1048 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1050 case Lisp_Misc_Objfwd
:
1051 return *XOBJFWD (valcontents
)->objvar
;
1053 case Lisp_Misc_Buffer_Objfwd
:
1054 return PER_BUFFER_VALUE (current_buffer
,
1055 XBUFFER_OBJFWD (valcontents
)->offset
);
1057 case Lisp_Misc_Kboard_Objfwd
:
1058 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1059 + (char *)current_kboard
);
1066 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1067 doc
: /* Return SYMBOL's value. Error if that is void. */)
1073 val
= find_symbol_value (symbol
);
1074 if (EQ (val
, Qunbound
))
1075 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1080 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1081 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1083 register Lisp_Object symbol
, newval
;
1085 return set_internal (symbol
, newval
, current_buffer
, 0);
1088 /* Return 1 if SYMBOL currently has a let-binding
1089 which was made in the buffer that is now current. */
1092 let_shadows_buffer_binding_p (symbol
)
1095 struct specbinding
*p
;
1097 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1099 && CONSP (p
->symbol
))
1101 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1102 if ((EQ (symbol
, let_bound_symbol
)
1103 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1104 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1105 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1109 return p
>= specpdl
;
1112 /* Store the value NEWVAL into SYMBOL.
1113 If buffer-locality is an issue, BUF specifies which buffer to use.
1114 (0 stands for the current buffer.)
1116 If BINDFLAG is zero, then if this symbol is supposed to become
1117 local in every buffer where it is set, then we make it local.
1118 If BINDFLAG is nonzero, we don't do that. */
1121 set_internal (symbol
, newval
, buf
, bindflag
)
1122 register Lisp_Object symbol
, newval
;
1126 int voide
= EQ (newval
, Qunbound
);
1128 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1131 buf
= current_buffer
;
1133 /* If restoring in a dead buffer, do nothing. */
1134 if (NILP (buf
->name
))
1137 CHECK_SYMBOL (symbol
);
1138 if (SYMBOL_CONSTANT_P (symbol
)
1139 && (NILP (Fkeywordp (symbol
))
1140 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1141 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1143 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1145 if (BUFFER_OBJFWDP (valcontents
))
1147 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1148 int idx
= PER_BUFFER_IDX (offset
);
1151 && !let_shadows_buffer_binding_p (symbol
))
1152 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1154 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1155 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1157 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1158 if (XSYMBOL (symbol
)->indirect_variable
)
1159 symbol
= indirect_variable (symbol
);
1161 /* What binding is loaded right now? */
1162 current_alist_element
1163 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1165 /* If the current buffer is not the buffer whose binding is
1166 loaded, or if there may be frame-local bindings and the frame
1167 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1168 the default binding is loaded, the loaded binding may be the
1170 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1171 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1172 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1173 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1174 || (BUFFER_LOCAL_VALUEP (valcontents
)
1175 && EQ (XCAR (current_alist_element
),
1176 current_alist_element
)))
1178 /* The currently loaded binding is not necessarily valid.
1179 We need to unload it, and choose a new binding. */
1181 /* Write out `realvalue' to the old loaded binding. */
1182 Fsetcdr (current_alist_element
,
1183 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1185 /* Find the new binding. */
1186 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1187 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1188 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1192 /* This buffer still sees the default value. */
1194 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1195 or if this is `let' rather than `set',
1196 make CURRENT-ALIST-ELEMENT point to itself,
1197 indicating that we're seeing the default value.
1198 Likewise if the variable has been let-bound
1199 in the current buffer. */
1200 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1201 || let_shadows_buffer_binding_p (symbol
))
1203 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1205 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1206 tem1
= Fassq (symbol
,
1207 XFRAME (selected_frame
)->param_alist
);
1210 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1212 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1214 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1215 and we're not within a let that was made for this buffer,
1216 create a new buffer-local binding for the variable.
1217 That means, give this buffer a new assoc for a local value
1218 and load that binding. */
1221 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1222 buf
->local_var_alist
1223 = Fcons (tem1
, buf
->local_var_alist
);
1227 /* Record which binding is now loaded. */
1228 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1231 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1232 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1233 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1235 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1238 /* If storing void (making the symbol void), forward only through
1239 buffer-local indicator, not through Lisp_Objfwd, etc. */
1241 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1243 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1245 /* If we just set a variable whose current binding is frame-local,
1246 store the new value in the frame parameter too. */
1248 if (BUFFER_LOCAL_VALUEP (valcontents
)
1249 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1251 /* What binding is loaded right now? */
1252 current_alist_element
1253 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1255 /* If the current buffer is not the buffer whose binding is
1256 loaded, or if there may be frame-local bindings and the frame
1257 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1258 the default binding is loaded, the loaded binding may be the
1260 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1261 XSETCDR (current_alist_element
, newval
);
1267 /* Access or set a buffer-local symbol's default value. */
1269 /* Return the default value of SYMBOL, but don't check for voidness.
1270 Return Qunbound if it is void. */
1273 default_value (symbol
)
1276 register Lisp_Object valcontents
;
1278 CHECK_SYMBOL (symbol
);
1279 valcontents
= SYMBOL_VALUE (symbol
);
1281 /* For a built-in buffer-local variable, get the default value
1282 rather than letting do_symval_forwarding get the current value. */
1283 if (BUFFER_OBJFWDP (valcontents
))
1285 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1286 if (PER_BUFFER_IDX (offset
) != 0)
1287 return PER_BUFFER_DEFAULT (offset
);
1290 /* Handle user-created local variables. */
1291 if (BUFFER_LOCAL_VALUEP (valcontents
)
1292 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1294 /* If var is set up for a buffer that lacks a local value for it,
1295 the current value is nominally the default value.
1296 But the `realvalue' slot may be more up to date, since
1297 ordinary setq stores just that slot. So use that. */
1298 Lisp_Object current_alist_element
, alist_element_car
;
1299 current_alist_element
1300 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1301 alist_element_car
= XCAR (current_alist_element
);
1302 if (EQ (alist_element_car
, current_alist_element
))
1303 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1305 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1307 /* For other variables, get the current value. */
1308 return do_symval_forwarding (valcontents
);
1311 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1312 doc
: /* Return t if SYMBOL has a non-void default value.
1313 This is the value that is seen in buffers that do not have their own values
1314 for this variable. */)
1318 register Lisp_Object value
;
1320 value
= default_value (symbol
);
1321 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1324 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1325 doc
: /* Return SYMBOL's default value.
1326 This is the value that is seen in buffers that do not have their own values
1327 for this variable. The default value is meaningful for variables with
1328 local bindings in certain buffers. */)
1332 register Lisp_Object value
;
1334 value
= default_value (symbol
);
1335 if (EQ (value
, Qunbound
))
1336 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1340 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1341 doc
: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1342 The default value is seen in buffers that do not have their own values
1343 for this variable. */)
1345 Lisp_Object symbol
, value
;
1347 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1349 CHECK_SYMBOL (symbol
);
1350 valcontents
= SYMBOL_VALUE (symbol
);
1352 /* Handle variables like case-fold-search that have special slots
1353 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1355 if (BUFFER_OBJFWDP (valcontents
))
1357 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1358 int idx
= PER_BUFFER_IDX (offset
);
1360 PER_BUFFER_DEFAULT (offset
) = value
;
1362 /* If this variable is not always local in all buffers,
1363 set it in the buffers that don't nominally have a local value. */
1368 for (b
= all_buffers
; b
; b
= b
->next
)
1369 if (!PER_BUFFER_VALUE_P (b
, idx
))
1370 PER_BUFFER_VALUE (b
, offset
) = value
;
1375 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1376 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1377 return Fset (symbol
, value
);
1379 /* Store new value into the DEFAULT-VALUE slot. */
1380 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1382 /* If the default binding is now loaded, set the REALVALUE slot too. */
1383 current_alist_element
1384 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1385 alist_element_buffer
= Fcar (current_alist_element
);
1386 if (EQ (alist_element_buffer
, current_alist_element
))
1387 store_symval_forwarding (symbol
,
1388 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1394 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1395 doc
: /* Set the default value of variable VAR to VALUE.
1396 VAR, the variable name, is literal (not evaluated);
1397 VALUE is an expression: it is evaluated and its value returned.
1398 The default value of a variable is seen in buffers
1399 that do not have their own values for the variable.
1401 More generally, you can use multiple variables and values, as in
1402 (setq-default SYMBOL VALUE SYMBOL VALUE...)
1403 This sets each SYMBOL's default value to the corresponding VALUE.
1404 The VALUE for the Nth SYMBOL can refer to the new default values
1406 usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */)
1410 register Lisp_Object args_left
;
1411 register Lisp_Object val
, symbol
;
1412 struct gcpro gcpro1
;
1422 val
= Feval (Fcar (Fcdr (args_left
)));
1423 symbol
= XCAR (args_left
);
1424 Fset_default (symbol
, val
);
1425 args_left
= Fcdr (XCDR (args_left
));
1427 while (!NILP (args_left
));
1433 /* Lisp functions for creating and removing buffer-local variables. */
1435 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1436 1, 1, "vMake Variable Buffer Local: ",
1437 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1438 At any time, the value for the current buffer is in effect,
1439 unless the variable has never been set in this buffer,
1440 in which case the default value is in effect.
1441 Note that binding the variable with `let', or setting it while
1442 a `let'-style binding made in this buffer is in effect,
1443 does not make the variable buffer-local. Return VARIABLE.
1445 The function `default-value' gets the default value and `set-default' sets it. */)
1447 register Lisp_Object variable
;
1449 register Lisp_Object tem
, valcontents
, newval
;
1451 CHECK_SYMBOL (variable
);
1453 valcontents
= SYMBOL_VALUE (variable
);
1454 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1455 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1457 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1459 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1461 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1464 if (EQ (valcontents
, Qunbound
))
1465 SET_SYMBOL_VALUE (variable
, Qnil
);
1466 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1468 newval
= allocate_misc ();
1469 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1470 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1471 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1472 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1473 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1474 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1475 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1476 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1477 SET_SYMBOL_VALUE (variable
, newval
);
1481 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1482 1, 1, "vMake Local Variable: ",
1483 doc
: /* Make VARIABLE have a separate value in the current buffer.
1484 Other buffers will continue to share a common default value.
1485 \(The buffer-local value of VARIABLE starts out as the same value
1486 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1487 See also `make-variable-buffer-local'. Return VARIABLE.
1489 If the variable is already arranged to become local when set,
1490 this function causes a local value to exist for this buffer,
1491 just as setting the variable would do.
1493 This function returns VARIABLE, and therefore
1494 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1497 Do not use `make-local-variable' to make a hook variable buffer-local.
1498 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1500 register Lisp_Object variable
;
1502 register Lisp_Object tem
, valcontents
;
1504 CHECK_SYMBOL (variable
);
1506 valcontents
= SYMBOL_VALUE (variable
);
1507 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1508 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1510 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1512 tem
= Fboundp (variable
);
1514 /* Make sure the symbol has a local value in this particular buffer,
1515 by setting it to the same value it already has. */
1516 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1519 /* Make sure symbol is set up to hold per-buffer values. */
1520 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1523 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1525 newval
= allocate_misc ();
1526 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1527 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1528 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1529 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1530 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1531 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1532 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1533 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1534 SET_SYMBOL_VALUE (variable
, newval
);;
1536 /* Make sure this buffer has its own value of symbol. */
1537 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1540 /* Swap out any local binding for some other buffer, and make
1541 sure the current value is permanently recorded, if it's the
1543 find_symbol_value (variable
);
1545 current_buffer
->local_var_alist
1546 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1547 current_buffer
->local_var_alist
);
1549 /* Make sure symbol does not think it is set up for this buffer;
1550 force it to look once again for this buffer's value. */
1552 Lisp_Object
*pvalbuf
;
1554 valcontents
= SYMBOL_VALUE (variable
);
1556 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1557 if (current_buffer
== XBUFFER (*pvalbuf
))
1559 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1563 /* If the symbol forwards into a C variable, then load the binding
1564 for this buffer now. If C code modifies the variable before we
1565 load the binding in, then that new value will clobber the default
1566 binding the next time we unload it. */
1567 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1568 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1569 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1574 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1575 1, 1, "vKill Local Variable: ",
1576 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1577 From now on the default value will apply in this buffer. Return VARIABLE. */)
1579 register Lisp_Object variable
;
1581 register Lisp_Object tem
, valcontents
;
1583 CHECK_SYMBOL (variable
);
1585 valcontents
= SYMBOL_VALUE (variable
);
1587 if (BUFFER_OBJFWDP (valcontents
))
1589 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1590 int idx
= PER_BUFFER_IDX (offset
);
1594 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1595 PER_BUFFER_VALUE (current_buffer
, offset
)
1596 = PER_BUFFER_DEFAULT (offset
);
1601 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1602 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1605 /* Get rid of this buffer's alist element, if any. */
1607 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1609 current_buffer
->local_var_alist
1610 = Fdelq (tem
, current_buffer
->local_var_alist
);
1612 /* If the symbol is set up with the current buffer's binding
1613 loaded, recompute its value. We have to do it now, or else
1614 forwarded objects won't work right. */
1616 Lisp_Object
*pvalbuf
, buf
;
1617 valcontents
= SYMBOL_VALUE (variable
);
1618 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1619 XSETBUFFER (buf
, current_buffer
);
1620 if (EQ (buf
, *pvalbuf
))
1623 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1624 find_symbol_value (variable
);
1631 /* Lisp functions for creating and removing buffer-local variables. */
1633 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1634 1, 1, "vMake Variable Frame Local: ",
1635 doc
: /* Enable VARIABLE to have frame-local bindings.
1636 When a frame-local binding exists in the current frame,
1637 it is in effect whenever the current buffer has no buffer-local binding.
1638 A frame-local binding is actually a frame parameter value;
1639 thus, any given frame has a local binding for VARIABLE if it has
1640 a value for the frame parameter named VARIABLE. Return VARIABLE.
1641 See `modify-frame-parameters' for how to set frame parameters. */)
1643 register Lisp_Object variable
;
1645 register Lisp_Object tem
, valcontents
, newval
;
1647 CHECK_SYMBOL (variable
);
1649 valcontents
= SYMBOL_VALUE (variable
);
1650 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1651 || BUFFER_OBJFWDP (valcontents
))
1652 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1654 if (BUFFER_LOCAL_VALUEP (valcontents
)
1655 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1657 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1661 if (EQ (valcontents
, Qunbound
))
1662 SET_SYMBOL_VALUE (variable
, Qnil
);
1663 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1665 newval
= allocate_misc ();
1666 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1667 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1668 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1669 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1670 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1671 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1672 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1673 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1674 SET_SYMBOL_VALUE (variable
, newval
);
1678 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1680 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1681 BUFFER defaults to the current buffer. */)
1683 register Lisp_Object variable
, buffer
;
1685 Lisp_Object valcontents
;
1686 register struct buffer
*buf
;
1689 buf
= current_buffer
;
1692 CHECK_BUFFER (buffer
);
1693 buf
= XBUFFER (buffer
);
1696 CHECK_SYMBOL (variable
);
1698 valcontents
= SYMBOL_VALUE (variable
);
1699 if (BUFFER_LOCAL_VALUEP (valcontents
)
1700 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1702 Lisp_Object tail
, elt
;
1704 variable
= indirect_variable (variable
);
1705 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1708 if (EQ (variable
, XCAR (elt
)))
1712 if (BUFFER_OBJFWDP (valcontents
))
1714 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1715 int idx
= PER_BUFFER_IDX (offset
);
1716 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1722 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1724 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
1725 BUFFER defaults to the current buffer. */)
1727 register Lisp_Object variable
, buffer
;
1729 Lisp_Object valcontents
;
1730 register struct buffer
*buf
;
1733 buf
= current_buffer
;
1736 CHECK_BUFFER (buffer
);
1737 buf
= XBUFFER (buffer
);
1740 CHECK_SYMBOL (variable
);
1742 valcontents
= SYMBOL_VALUE (variable
);
1744 /* This means that make-variable-buffer-local was done. */
1745 if (BUFFER_LOCAL_VALUEP (valcontents
))
1747 /* All these slots become local if they are set. */
1748 if (BUFFER_OBJFWDP (valcontents
))
1750 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1752 Lisp_Object tail
, elt
;
1753 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1756 if (EQ (variable
, XCAR (elt
)))
1763 /* Find the function at the end of a chain of symbol function indirections. */
1765 /* If OBJECT is a symbol, find the end of its function chain and
1766 return the value found there. If OBJECT is not a symbol, just
1767 return it. If there is a cycle in the function chain, signal a
1768 cyclic-function-indirection error.
1770 This is like Findirect_function, except that it doesn't signal an
1771 error if the chain ends up unbound. */
1773 indirect_function (object
)
1774 register Lisp_Object object
;
1776 Lisp_Object tortoise
, hare
;
1778 hare
= tortoise
= object
;
1782 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1784 hare
= XSYMBOL (hare
)->function
;
1785 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1787 hare
= XSYMBOL (hare
)->function
;
1789 tortoise
= XSYMBOL (tortoise
)->function
;
1791 if (EQ (hare
, tortoise
))
1792 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1798 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1799 doc
: /* Return the function at the end of OBJECT's function chain.
1800 If OBJECT is a symbol, follow all function indirections and return the final
1802 If OBJECT is not a symbol, just return it.
1803 Signal a void-function error if the final symbol is unbound.
1804 Signal a cyclic-function-indirection error if there is a loop in the
1805 function chain of symbols. */)
1807 register Lisp_Object object
;
1811 result
= indirect_function (object
);
1813 if (EQ (result
, Qunbound
))
1814 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1818 /* Extract and set vector and string elements */
1820 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1821 doc
: /* Return the element of ARRAY at index IDX.
1822 ARRAY may be a vector, a string, a char-table, a bool-vector,
1823 or a byte-code object. IDX starts at 0. */)
1825 register Lisp_Object array
;
1828 register int idxval
;
1831 idxval
= XINT (idx
);
1832 if (STRINGP (array
))
1836 if (idxval
< 0 || idxval
>= SCHARS (array
))
1837 args_out_of_range (array
, idx
);
1838 if (! STRING_MULTIBYTE (array
))
1839 return make_number ((unsigned char) SREF (array
, idxval
));
1840 idxval_byte
= string_char_to_byte (array
, idxval
);
1842 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1843 SBYTES (array
) - idxval_byte
);
1844 return make_number (c
);
1846 else if (BOOL_VECTOR_P (array
))
1850 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1851 args_out_of_range (array
, idx
);
1853 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1854 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1856 else if (CHAR_TABLE_P (array
))
1863 args_out_of_range (array
, idx
);
1864 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1866 /* For ASCII and 8-bit European characters, the element is
1867 stored in the top table. */
1868 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1870 val
= XCHAR_TABLE (array
)->defalt
;
1871 while (NILP (val
)) /* Follow parents until we find some value. */
1873 array
= XCHAR_TABLE (array
)->parent
;
1876 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1878 val
= XCHAR_TABLE (array
)->defalt
;
1885 Lisp_Object sub_table
;
1887 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1888 if (code
[1] < 32) code
[1] = -1;
1889 else if (code
[2] < 32) code
[2] = -1;
1891 /* Here, the possible range of CODE[0] (== charset ID) is
1892 128..MAX_CHARSET. Since the top level char table contains
1893 data for multibyte characters after 256th element, we must
1894 increment CODE[0] by 128 to get a correct index. */
1896 code
[3] = -1; /* anchor */
1898 try_parent_char_table
:
1900 for (i
= 0; code
[i
] >= 0; i
++)
1902 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1903 if (SUB_CHAR_TABLE_P (val
))
1908 val
= XCHAR_TABLE (sub_table
)->defalt
;
1911 array
= XCHAR_TABLE (array
)->parent
;
1913 goto try_parent_char_table
;
1918 /* Here, VAL is a sub char table. We try the default value
1920 val
= XCHAR_TABLE (val
)->defalt
;
1923 array
= XCHAR_TABLE (array
)->parent
;
1925 goto try_parent_char_table
;
1933 if (VECTORP (array
))
1934 size
= XVECTOR (array
)->size
;
1935 else if (COMPILEDP (array
))
1936 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1938 wrong_type_argument (Qarrayp
, array
);
1940 if (idxval
< 0 || idxval
>= size
)
1941 args_out_of_range (array
, idx
);
1942 return XVECTOR (array
)->contents
[idxval
];
1946 /* Don't use alloca for relocating string data larger than this, lest
1947 we overflow their stack. The value is the same as what used in
1948 fns.c for base64 handling. */
1949 #define MAX_ALLOCA 16*1024
1951 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1952 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1953 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
1954 bool-vector. IDX starts at 0. */)
1955 (array
, idx
, newelt
)
1956 register Lisp_Object array
;
1957 Lisp_Object idx
, newelt
;
1959 register int idxval
;
1962 idxval
= XINT (idx
);
1963 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1964 && ! CHAR_TABLE_P (array
))
1965 array
= wrong_type_argument (Qarrayp
, array
);
1966 CHECK_IMPURE (array
);
1968 if (VECTORP (array
))
1970 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1971 args_out_of_range (array
, idx
);
1972 XVECTOR (array
)->contents
[idxval
] = newelt
;
1974 else if (BOOL_VECTOR_P (array
))
1978 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1979 args_out_of_range (array
, idx
);
1981 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1983 if (! NILP (newelt
))
1984 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1986 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1987 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1989 else if (CHAR_TABLE_P (array
))
1992 args_out_of_range (array
, idx
);
1993 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1994 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2000 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2001 if (code
[1] < 32) code
[1] = -1;
2002 else if (code
[2] < 32) code
[2] = -1;
2004 /* See the comment of the corresponding part in Faref. */
2006 code
[3] = -1; /* anchor */
2007 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2009 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2010 if (SUB_CHAR_TABLE_P (val
))
2016 /* VAL is a leaf. Create a sub char table with the
2017 default value VAL or XCHAR_TABLE (array)->defalt
2018 and look into it. */
2020 temp
= make_sub_char_table (NILP (val
)
2021 ? XCHAR_TABLE (array
)->defalt
2023 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2027 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2030 else if (STRING_MULTIBYTE (array
))
2032 int idxval_byte
, prev_bytes
, new_bytes
;
2033 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2035 if (idxval
< 0 || idxval
>= SCHARS (array
))
2036 args_out_of_range (array
, idx
);
2037 CHECK_NUMBER (newelt
);
2039 idxval_byte
= string_char_to_byte (array
, idxval
);
2040 p1
= SDATA (array
) + idxval_byte
;
2041 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2042 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2043 if (prev_bytes
!= new_bytes
)
2045 /* We must relocate the string data. */
2046 int nchars
= SCHARS (array
);
2047 int nbytes
= SBYTES (array
);
2050 str
= (nbytes
<= MAX_ALLOCA
2051 ? (unsigned char *) alloca (nbytes
)
2052 : (unsigned char *) xmalloc (nbytes
));
2053 bcopy (SDATA (array
), str
, nbytes
);
2054 allocate_string_data (XSTRING (array
), nchars
,
2055 nbytes
+ new_bytes
- prev_bytes
);
2056 bcopy (str
, SDATA (array
), idxval_byte
);
2057 p1
= SDATA (array
) + idxval_byte
;
2058 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2059 nbytes
- (idxval_byte
+ prev_bytes
));
2060 if (nbytes
> MAX_ALLOCA
)
2062 clear_string_char_byte_cache ();
2069 if (idxval
< 0 || idxval
>= SCHARS (array
))
2070 args_out_of_range (array
, idx
);
2071 CHECK_NUMBER (newelt
);
2073 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2074 SSET (array
, idxval
, XINT (newelt
));
2077 /* We must relocate the string data while converting it to
2079 int idxval_byte
, prev_bytes
, new_bytes
;
2080 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2081 unsigned char *origstr
= SDATA (array
), *str
;
2084 nchars
= SCHARS (array
);
2085 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2086 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2088 str
= (nbytes
<= MAX_ALLOCA
2089 ? (unsigned char *) alloca (nbytes
)
2090 : (unsigned char *) xmalloc (nbytes
));
2091 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2092 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2094 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2095 allocate_string_data (XSTRING (array
), nchars
,
2096 nbytes
+ new_bytes
- prev_bytes
);
2097 bcopy (str
, SDATA (array
), idxval_byte
);
2098 p1
= SDATA (array
) + idxval_byte
;
2101 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2102 nbytes
- (idxval_byte
+ prev_bytes
));
2103 if (nbytes
> MAX_ALLOCA
)
2105 clear_string_char_byte_cache ();
2112 /* Arithmetic functions */
2114 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2117 arithcompare (num1
, num2
, comparison
)
2118 Lisp_Object num1
, num2
;
2119 enum comparison comparison
;
2121 double f1
= 0, f2
= 0;
2124 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2125 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2127 if (FLOATP (num1
) || FLOATP (num2
))
2130 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2131 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2137 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2142 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2147 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2152 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2157 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2162 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2171 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2172 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2174 register Lisp_Object num1
, num2
;
2176 return arithcompare (num1
, num2
, equal
);
2179 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2180 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2182 register Lisp_Object num1
, num2
;
2184 return arithcompare (num1
, num2
, less
);
2187 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2188 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2190 register Lisp_Object num1
, num2
;
2192 return arithcompare (num1
, num2
, grtr
);
2195 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2196 doc
: /* Return t if first arg is less than or equal to second arg.
2197 Both must be numbers or markers. */)
2199 register Lisp_Object num1
, num2
;
2201 return arithcompare (num1
, num2
, less_or_equal
);
2204 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2205 doc
: /* Return t if first arg is greater than or equal to second arg.
2206 Both must be numbers or markers. */)
2208 register Lisp_Object num1
, num2
;
2210 return arithcompare (num1
, num2
, grtr_or_equal
);
2213 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2214 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2216 register Lisp_Object num1
, num2
;
2218 return arithcompare (num1
, num2
, notequal
);
2221 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2222 doc
: /* Return t if NUMBER is zero. */)
2224 register Lisp_Object number
;
2226 CHECK_NUMBER_OR_FLOAT (number
);
2228 if (FLOATP (number
))
2230 if (XFLOAT_DATA (number
) == 0.0)
2240 /* Convert between long values and pairs of Lisp integers. */
2246 unsigned long top
= i
>> 16;
2247 unsigned int bot
= i
& 0xFFFF;
2249 return make_number (bot
);
2250 if (top
== (unsigned long)-1 >> 16)
2251 return Fcons (make_number (-1), make_number (bot
));
2252 return Fcons (make_number (top
), make_number (bot
));
2259 Lisp_Object top
, bot
;
2266 return ((XINT (top
) << 16) | XINT (bot
));
2269 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2270 doc
: /* Return the decimal representation of NUMBER as a string.
2271 Uses a minus sign if negative.
2272 NUMBER may be an integer or a floating point number. */)
2276 char buffer
[VALBITS
];
2278 CHECK_NUMBER_OR_FLOAT (number
);
2280 if (FLOATP (number
))
2282 char pigbuf
[350]; /* see comments in float_to_string */
2284 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2285 return build_string (pigbuf
);
2288 if (sizeof (int) == sizeof (EMACS_INT
))
2289 sprintf (buffer
, "%d", XINT (number
));
2290 else if (sizeof (long) == sizeof (EMACS_INT
))
2291 sprintf (buffer
, "%ld", (long) XINT (number
));
2294 return build_string (buffer
);
2298 digit_to_number (character
, base
)
2299 int character
, base
;
2303 if (character
>= '0' && character
<= '9')
2304 digit
= character
- '0';
2305 else if (character
>= 'a' && character
<= 'z')
2306 digit
= character
- 'a' + 10;
2307 else if (character
>= 'A' && character
<= 'Z')
2308 digit
= character
- 'A' + 10;
2318 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2319 doc
: /* Parse STRING as a decimal number and return the number.
2320 This parses both integers and floating point numbers.
2321 It ignores leading spaces and tabs.
2323 If BASE, interpret STRING as a number in that base. If BASE isn't
2324 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2325 If the base used is not 10, floating point is not recognized. */)
2327 register Lisp_Object string
, base
;
2329 register unsigned char *p
;
2334 CHECK_STRING (string
);
2340 CHECK_NUMBER (base
);
2342 if (b
< 2 || b
> 16)
2343 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2346 /* Skip any whitespace at the front of the number. Some versions of
2347 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2349 while (*p
== ' ' || *p
== '\t')
2360 if (isfloat_string (p
) && b
== 10)
2361 val
= make_float (sign
* atof (p
));
2368 int digit
= digit_to_number (*p
++, b
);
2374 val
= make_fixnum_or_float (sign
* v
);
2394 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2395 int, Lisp_Object
*));
2396 extern Lisp_Object
fmod_float ();
2399 arith_driver (code
, nargs
, args
)
2402 register Lisp_Object
*args
;
2404 register Lisp_Object val
;
2405 register int argnum
;
2406 register EMACS_INT accum
= 0;
2407 register EMACS_INT next
;
2409 switch (SWITCH_ENUM_CAST (code
))
2427 for (argnum
= 0; argnum
< nargs
; argnum
++)
2429 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2431 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2434 return float_arith_driver ((double) accum
, argnum
, code
,
2437 next
= XINT (args
[argnum
]);
2438 switch (SWITCH_ENUM_CAST (code
))
2444 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2455 Fsignal (Qarith_error
, Qnil
);
2469 if (!argnum
|| next
> accum
)
2473 if (!argnum
|| next
< accum
)
2479 XSETINT (val
, accum
);
2484 #define isnan(x) ((x) != (x))
2487 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2489 register int argnum
;
2492 register Lisp_Object
*args
;
2494 register Lisp_Object val
;
2497 for (; argnum
< nargs
; argnum
++)
2499 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2500 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2504 next
= XFLOAT_DATA (val
);
2508 args
[argnum
] = val
; /* runs into a compiler bug. */
2509 next
= XINT (args
[argnum
]);
2511 switch (SWITCH_ENUM_CAST (code
))
2517 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2527 if (! IEEE_FLOATING_POINT
&& next
== 0)
2528 Fsignal (Qarith_error
, Qnil
);
2535 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2537 if (!argnum
|| isnan (next
) || next
> accum
)
2541 if (!argnum
|| isnan (next
) || next
< accum
)
2547 return make_float (accum
);
2551 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2552 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2553 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2558 return arith_driver (Aadd
, nargs
, args
);
2561 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2562 doc
: /* Negate number or subtract numbers or markers and return the result.
2563 With one arg, negates it. With more than one arg,
2564 subtracts all but the first from the first.
2565 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2570 return arith_driver (Asub
, nargs
, args
);
2573 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2574 doc
: /* Return product of any number of arguments, which are numbers or markers.
2575 usage: (* &rest NUMBERS-OR-MARKERS) */)
2580 return arith_driver (Amult
, nargs
, args
);
2583 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2584 doc
: /* Return first argument divided by all the remaining arguments.
2585 The arguments must be numbers or markers.
2586 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2591 return arith_driver (Adiv
, nargs
, args
);
2594 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2595 doc
: /* Return remainder of X divided by Y.
2596 Both must be integers or markers. */)
2598 register Lisp_Object x
, y
;
2602 CHECK_NUMBER_COERCE_MARKER (x
);
2603 CHECK_NUMBER_COERCE_MARKER (y
);
2605 if (XFASTINT (y
) == 0)
2606 Fsignal (Qarith_error
, Qnil
);
2608 XSETINT (val
, XINT (x
) % XINT (y
));
2622 /* If the magnitude of the result exceeds that of the divisor, or
2623 the sign of the result does not agree with that of the dividend,
2624 iterate with the reduced value. This does not yield a
2625 particularly accurate result, but at least it will be in the
2626 range promised by fmod. */
2628 r
-= f2
* floor (r
/ f2
);
2629 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2633 #endif /* ! HAVE_FMOD */
2635 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2636 doc
: /* Return X modulo Y.
2637 The result falls between zero (inclusive) and Y (exclusive).
2638 Both X and Y must be numbers or markers. */)
2640 register Lisp_Object x
, y
;
2645 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2646 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2648 if (FLOATP (x
) || FLOATP (y
))
2649 return fmod_float (x
, y
);
2655 Fsignal (Qarith_error
, Qnil
);
2659 /* If the "remainder" comes out with the wrong sign, fix it. */
2660 if (i2
< 0 ? i1
> 0 : i1
< 0)
2667 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2668 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2669 The value is always a number; markers are converted to numbers.
2670 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2675 return arith_driver (Amax
, nargs
, args
);
2678 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2679 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2680 The value is always a number; markers are converted to numbers.
2681 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2686 return arith_driver (Amin
, nargs
, args
);
2689 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2690 doc
: /* Return bitwise-and of all the arguments.
2691 Arguments may be integers, or markers converted to integers.
2692 usage: (logand &rest INTS-OR-MARKERS) */)
2697 return arith_driver (Alogand
, nargs
, args
);
2700 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2701 doc
: /* Return bitwise-or of all the arguments.
2702 Arguments may be integers, or markers converted to integers.
2703 usage: (logior &rest INTS-OR-MARKERS) */)
2708 return arith_driver (Alogior
, nargs
, args
);
2711 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2712 doc
: /* Return bitwise-exclusive-or of all the arguments.
2713 Arguments may be integers, or markers converted to integers.
2714 usage: (logxor &rest INTS-OR-MARKERS) */)
2719 return arith_driver (Alogxor
, nargs
, args
);
2722 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2723 doc
: /* Return VALUE with its bits shifted left by COUNT.
2724 If COUNT is negative, shifting is actually to the right.
2725 In this case, the sign bit is duplicated. */)
2727 register Lisp_Object value
, count
;
2729 register Lisp_Object val
;
2731 CHECK_NUMBER (value
);
2732 CHECK_NUMBER (count
);
2734 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2736 else if (XINT (count
) > 0)
2737 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2738 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2739 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2741 XSETINT (val
, XINT (value
) >> -XINT (count
));
2745 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2746 doc
: /* Return VALUE with its bits shifted left by COUNT.
2747 If COUNT is negative, shifting is actually to the right.
2748 In this case, zeros are shifted in on the left. */)
2750 register Lisp_Object value
, count
;
2752 register Lisp_Object val
;
2754 CHECK_NUMBER (value
);
2755 CHECK_NUMBER (count
);
2757 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2759 else if (XINT (count
) > 0)
2760 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2761 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2764 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2768 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2769 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2770 Markers are converted to integers. */)
2772 register Lisp_Object number
;
2774 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2776 if (FLOATP (number
))
2777 return (make_float (1.0 + XFLOAT_DATA (number
)));
2779 XSETINT (number
, XINT (number
) + 1);
2783 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2784 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2785 Markers are converted to integers. */)
2787 register Lisp_Object number
;
2789 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2791 if (FLOATP (number
))
2792 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2794 XSETINT (number
, XINT (number
) - 1);
2798 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2799 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2801 register Lisp_Object number
;
2803 CHECK_NUMBER (number
);
2804 XSETINT (number
, ~XINT (number
));
2811 Lisp_Object error_tail
, arith_tail
;
2813 Qquote
= intern ("quote");
2814 Qlambda
= intern ("lambda");
2815 Qsubr
= intern ("subr");
2816 Qerror_conditions
= intern ("error-conditions");
2817 Qerror_message
= intern ("error-message");
2818 Qtop_level
= intern ("top-level");
2820 Qerror
= intern ("error");
2821 Qquit
= intern ("quit");
2822 Qwrong_type_argument
= intern ("wrong-type-argument");
2823 Qargs_out_of_range
= intern ("args-out-of-range");
2824 Qvoid_function
= intern ("void-function");
2825 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2826 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2827 Qvoid_variable
= intern ("void-variable");
2828 Qsetting_constant
= intern ("setting-constant");
2829 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2831 Qinvalid_function
= intern ("invalid-function");
2832 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2833 Qno_catch
= intern ("no-catch");
2834 Qend_of_file
= intern ("end-of-file");
2835 Qarith_error
= intern ("arith-error");
2836 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2837 Qend_of_buffer
= intern ("end-of-buffer");
2838 Qbuffer_read_only
= intern ("buffer-read-only");
2839 Qtext_read_only
= intern ("text-read-only");
2840 Qmark_inactive
= intern ("mark-inactive");
2842 Qlistp
= intern ("listp");
2843 Qconsp
= intern ("consp");
2844 Qsymbolp
= intern ("symbolp");
2845 Qkeywordp
= intern ("keywordp");
2846 Qintegerp
= intern ("integerp");
2847 Qnatnump
= intern ("natnump");
2848 Qwholenump
= intern ("wholenump");
2849 Qstringp
= intern ("stringp");
2850 Qarrayp
= intern ("arrayp");
2851 Qsequencep
= intern ("sequencep");
2852 Qbufferp
= intern ("bufferp");
2853 Qvectorp
= intern ("vectorp");
2854 Qchar_or_string_p
= intern ("char-or-string-p");
2855 Qmarkerp
= intern ("markerp");
2856 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2857 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2858 Qboundp
= intern ("boundp");
2859 Qfboundp
= intern ("fboundp");
2861 Qfloatp
= intern ("floatp");
2862 Qnumberp
= intern ("numberp");
2863 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2865 Qchar_table_p
= intern ("char-table-p");
2866 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2868 Qsubrp
= intern ("subrp");
2869 Qunevalled
= intern ("unevalled");
2870 Qmany
= intern ("many");
2872 Qcdr
= intern ("cdr");
2874 /* Handle automatic advice activation */
2875 Qad_advice_info
= intern ("ad-advice-info");
2876 Qad_activate_internal
= intern ("ad-activate-internal");
2878 error_tail
= Fcons (Qerror
, Qnil
);
2880 /* ERROR is used as a signaler for random errors for which nothing else is right */
2882 Fput (Qerror
, Qerror_conditions
,
2884 Fput (Qerror
, Qerror_message
,
2885 build_string ("error"));
2887 Fput (Qquit
, Qerror_conditions
,
2888 Fcons (Qquit
, Qnil
));
2889 Fput (Qquit
, Qerror_message
,
2890 build_string ("Quit"));
2892 Fput (Qwrong_type_argument
, Qerror_conditions
,
2893 Fcons (Qwrong_type_argument
, error_tail
));
2894 Fput (Qwrong_type_argument
, Qerror_message
,
2895 build_string ("Wrong type argument"));
2897 Fput (Qargs_out_of_range
, Qerror_conditions
,
2898 Fcons (Qargs_out_of_range
, error_tail
));
2899 Fput (Qargs_out_of_range
, Qerror_message
,
2900 build_string ("Args out of range"));
2902 Fput (Qvoid_function
, Qerror_conditions
,
2903 Fcons (Qvoid_function
, error_tail
));
2904 Fput (Qvoid_function
, Qerror_message
,
2905 build_string ("Symbol's function definition is void"));
2907 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2908 Fcons (Qcyclic_function_indirection
, error_tail
));
2909 Fput (Qcyclic_function_indirection
, Qerror_message
,
2910 build_string ("Symbol's chain of function indirections contains a loop"));
2912 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2913 Fcons (Qcyclic_variable_indirection
, error_tail
));
2914 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2915 build_string ("Symbol's chain of variable indirections contains a loop"));
2917 Qcircular_list
= intern ("circular-list");
2918 staticpro (&Qcircular_list
);
2919 Fput (Qcircular_list
, Qerror_conditions
,
2920 Fcons (Qcircular_list
, error_tail
));
2921 Fput (Qcircular_list
, Qerror_message
,
2922 build_string ("List contains a loop"));
2924 Fput (Qvoid_variable
, Qerror_conditions
,
2925 Fcons (Qvoid_variable
, error_tail
));
2926 Fput (Qvoid_variable
, Qerror_message
,
2927 build_string ("Symbol's value as variable is void"));
2929 Fput (Qsetting_constant
, Qerror_conditions
,
2930 Fcons (Qsetting_constant
, error_tail
));
2931 Fput (Qsetting_constant
, Qerror_message
,
2932 build_string ("Attempt to set a constant symbol"));
2934 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2935 Fcons (Qinvalid_read_syntax
, error_tail
));
2936 Fput (Qinvalid_read_syntax
, Qerror_message
,
2937 build_string ("Invalid read syntax"));
2939 Fput (Qinvalid_function
, Qerror_conditions
,
2940 Fcons (Qinvalid_function
, error_tail
));
2941 Fput (Qinvalid_function
, Qerror_message
,
2942 build_string ("Invalid function"));
2944 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2945 Fcons (Qwrong_number_of_arguments
, error_tail
));
2946 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2947 build_string ("Wrong number of arguments"));
2949 Fput (Qno_catch
, Qerror_conditions
,
2950 Fcons (Qno_catch
, error_tail
));
2951 Fput (Qno_catch
, Qerror_message
,
2952 build_string ("No catch for tag"));
2954 Fput (Qend_of_file
, Qerror_conditions
,
2955 Fcons (Qend_of_file
, error_tail
));
2956 Fput (Qend_of_file
, Qerror_message
,
2957 build_string ("End of file during parsing"));
2959 arith_tail
= Fcons (Qarith_error
, error_tail
);
2960 Fput (Qarith_error
, Qerror_conditions
,
2962 Fput (Qarith_error
, Qerror_message
,
2963 build_string ("Arithmetic error"));
2965 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2966 Fcons (Qbeginning_of_buffer
, error_tail
));
2967 Fput (Qbeginning_of_buffer
, Qerror_message
,
2968 build_string ("Beginning of buffer"));
2970 Fput (Qend_of_buffer
, Qerror_conditions
,
2971 Fcons (Qend_of_buffer
, error_tail
));
2972 Fput (Qend_of_buffer
, Qerror_message
,
2973 build_string ("End of buffer"));
2975 Fput (Qbuffer_read_only
, Qerror_conditions
,
2976 Fcons (Qbuffer_read_only
, error_tail
));
2977 Fput (Qbuffer_read_only
, Qerror_message
,
2978 build_string ("Buffer is read-only"));
2980 Fput (Qtext_read_only
, Qerror_conditions
,
2981 Fcons (Qtext_read_only
, error_tail
));
2982 Fput (Qtext_read_only
, Qerror_message
,
2983 build_string ("Text is read-only"));
2985 Qrange_error
= intern ("range-error");
2986 Qdomain_error
= intern ("domain-error");
2987 Qsingularity_error
= intern ("singularity-error");
2988 Qoverflow_error
= intern ("overflow-error");
2989 Qunderflow_error
= intern ("underflow-error");
2991 Fput (Qdomain_error
, Qerror_conditions
,
2992 Fcons (Qdomain_error
, arith_tail
));
2993 Fput (Qdomain_error
, Qerror_message
,
2994 build_string ("Arithmetic domain error"));
2996 Fput (Qrange_error
, Qerror_conditions
,
2997 Fcons (Qrange_error
, arith_tail
));
2998 Fput (Qrange_error
, Qerror_message
,
2999 build_string ("Arithmetic range error"));
3001 Fput (Qsingularity_error
, Qerror_conditions
,
3002 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3003 Fput (Qsingularity_error
, Qerror_message
,
3004 build_string ("Arithmetic singularity error"));
3006 Fput (Qoverflow_error
, Qerror_conditions
,
3007 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3008 Fput (Qoverflow_error
, Qerror_message
,
3009 build_string ("Arithmetic overflow error"));
3011 Fput (Qunderflow_error
, Qerror_conditions
,
3012 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3013 Fput (Qunderflow_error
, Qerror_message
,
3014 build_string ("Arithmetic underflow error"));
3016 staticpro (&Qrange_error
);
3017 staticpro (&Qdomain_error
);
3018 staticpro (&Qsingularity_error
);
3019 staticpro (&Qoverflow_error
);
3020 staticpro (&Qunderflow_error
);
3024 staticpro (&Qquote
);
3025 staticpro (&Qlambda
);
3027 staticpro (&Qunbound
);
3028 staticpro (&Qerror_conditions
);
3029 staticpro (&Qerror_message
);
3030 staticpro (&Qtop_level
);
3032 staticpro (&Qerror
);
3034 staticpro (&Qwrong_type_argument
);
3035 staticpro (&Qargs_out_of_range
);
3036 staticpro (&Qvoid_function
);
3037 staticpro (&Qcyclic_function_indirection
);
3038 staticpro (&Qvoid_variable
);
3039 staticpro (&Qsetting_constant
);
3040 staticpro (&Qinvalid_read_syntax
);
3041 staticpro (&Qwrong_number_of_arguments
);
3042 staticpro (&Qinvalid_function
);
3043 staticpro (&Qno_catch
);
3044 staticpro (&Qend_of_file
);
3045 staticpro (&Qarith_error
);
3046 staticpro (&Qbeginning_of_buffer
);
3047 staticpro (&Qend_of_buffer
);
3048 staticpro (&Qbuffer_read_only
);
3049 staticpro (&Qtext_read_only
);
3050 staticpro (&Qmark_inactive
);
3052 staticpro (&Qlistp
);
3053 staticpro (&Qconsp
);
3054 staticpro (&Qsymbolp
);
3055 staticpro (&Qkeywordp
);
3056 staticpro (&Qintegerp
);
3057 staticpro (&Qnatnump
);
3058 staticpro (&Qwholenump
);
3059 staticpro (&Qstringp
);
3060 staticpro (&Qarrayp
);
3061 staticpro (&Qsequencep
);
3062 staticpro (&Qbufferp
);
3063 staticpro (&Qvectorp
);
3064 staticpro (&Qchar_or_string_p
);
3065 staticpro (&Qmarkerp
);
3066 staticpro (&Qbuffer_or_string_p
);
3067 staticpro (&Qinteger_or_marker_p
);
3068 staticpro (&Qfloatp
);
3069 staticpro (&Qnumberp
);
3070 staticpro (&Qnumber_or_marker_p
);
3071 staticpro (&Qchar_table_p
);
3072 staticpro (&Qvector_or_char_table_p
);
3073 staticpro (&Qsubrp
);
3075 staticpro (&Qunevalled
);
3077 staticpro (&Qboundp
);
3078 staticpro (&Qfboundp
);
3080 staticpro (&Qad_advice_info
);
3081 staticpro (&Qad_activate_internal
);
3083 /* Types that type-of returns. */
3084 Qinteger
= intern ("integer");
3085 Qsymbol
= intern ("symbol");
3086 Qstring
= intern ("string");
3087 Qcons
= intern ("cons");
3088 Qmarker
= intern ("marker");
3089 Qoverlay
= intern ("overlay");
3090 Qfloat
= intern ("float");
3091 Qwindow_configuration
= intern ("window-configuration");
3092 Qprocess
= intern ("process");
3093 Qwindow
= intern ("window");
3094 /* Qsubr = intern ("subr"); */
3095 Qcompiled_function
= intern ("compiled-function");
3096 Qbuffer
= intern ("buffer");
3097 Qframe
= intern ("frame");
3098 Qvector
= intern ("vector");
3099 Qchar_table
= intern ("char-table");
3100 Qbool_vector
= intern ("bool-vector");
3101 Qhash_table
= intern ("hash-table");
3103 staticpro (&Qinteger
);
3104 staticpro (&Qsymbol
);
3105 staticpro (&Qstring
);
3107 staticpro (&Qmarker
);
3108 staticpro (&Qoverlay
);
3109 staticpro (&Qfloat
);
3110 staticpro (&Qwindow_configuration
);
3111 staticpro (&Qprocess
);
3112 staticpro (&Qwindow
);
3113 /* staticpro (&Qsubr); */
3114 staticpro (&Qcompiled_function
);
3115 staticpro (&Qbuffer
);
3116 staticpro (&Qframe
);
3117 staticpro (&Qvector
);
3118 staticpro (&Qchar_table
);
3119 staticpro (&Qbool_vector
);
3120 staticpro (&Qhash_table
);
3122 defsubr (&Sindirect_variable
);
3123 defsubr (&Ssubr_interactive_form
);
3126 defsubr (&Stype_of
);
3131 defsubr (&Sintegerp
);
3132 defsubr (&Sinteger_or_marker_p
);
3133 defsubr (&Snumberp
);
3134 defsubr (&Snumber_or_marker_p
);
3136 defsubr (&Snatnump
);
3137 defsubr (&Ssymbolp
);
3138 defsubr (&Skeywordp
);
3139 defsubr (&Sstringp
);
3140 defsubr (&Smultibyte_string_p
);
3141 defsubr (&Svectorp
);
3142 defsubr (&Schar_table_p
);
3143 defsubr (&Svector_or_char_table_p
);
3144 defsubr (&Sbool_vector_p
);
3146 defsubr (&Ssequencep
);
3147 defsubr (&Sbufferp
);
3148 defsubr (&Smarkerp
);
3150 defsubr (&Sbyte_code_function_p
);
3151 defsubr (&Schar_or_string_p
);
3154 defsubr (&Scar_safe
);
3155 defsubr (&Scdr_safe
);
3158 defsubr (&Ssymbol_function
);
3159 defsubr (&Sindirect_function
);
3160 defsubr (&Ssymbol_plist
);
3161 defsubr (&Ssymbol_name
);
3162 defsubr (&Smakunbound
);
3163 defsubr (&Sfmakunbound
);
3165 defsubr (&Sfboundp
);
3167 defsubr (&Sdefalias
);
3168 defsubr (&Ssetplist
);
3169 defsubr (&Ssymbol_value
);
3171 defsubr (&Sdefault_boundp
);
3172 defsubr (&Sdefault_value
);
3173 defsubr (&Sset_default
);
3174 defsubr (&Ssetq_default
);
3175 defsubr (&Smake_variable_buffer_local
);
3176 defsubr (&Smake_local_variable
);
3177 defsubr (&Skill_local_variable
);
3178 defsubr (&Smake_variable_frame_local
);
3179 defsubr (&Slocal_variable_p
);
3180 defsubr (&Slocal_variable_if_set_p
);
3183 defsubr (&Snumber_to_string
);
3184 defsubr (&Sstring_to_number
);
3185 defsubr (&Seqlsign
);
3208 defsubr (&Ssubr_arity
);
3210 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3212 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3213 doc
: /* The largest value that is representable in a Lisp integer. */);
3214 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3216 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3217 doc
: /* The smallest value that is representable in a Lisp integer. */);
3218 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3225 #if defined(USG) && !defined(POSIX_SIGNALS)
3226 /* USG systems forget handlers when they are used;
3227 must reestablish each time */
3228 signal (signo
, arith_error
);
3231 /* VMS systems are like USG. */
3232 signal (signo
, arith_error
);
3236 #else /* not BSD4_1 */
3237 sigsetmask (SIGEMPTYMASK
);
3238 #endif /* not BSD4_1 */
3240 Fsignal (Qarith_error
, Qnil
);
3246 /* Don't do this if just dumping out.
3247 We don't want to call `signal' in this case
3248 so that we don't have trouble with dumping
3249 signal-delivering routines in an inconsistent state. */
3253 #endif /* CANNOT_DUMP */
3254 signal (SIGFPE
, arith_error
);
3257 signal (SIGEMT
, arith_error
);