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 NEWPLIST, and return NEWPLIST. */)
733 register Lisp_Object symbol
, newplist
;
735 CHECK_SYMBOL (symbol
);
736 XSYMBOL (symbol
)->plist
= newplist
;
740 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
741 doc
: /* Return minimum and maximum number of args allowed for SUBR.
742 SUBR must be a built-in function.
743 The returned value is a pair (MIN . MAX). MIN is the minimum number
744 of args. MAX is the maximum number or the symbol `many', for a
745 function with `&rest' args, or `unevalled' for a special form. */)
749 short minargs
, maxargs
;
751 wrong_type_argument (Qsubrp
, subr
);
752 minargs
= XSUBR (subr
)->min_args
;
753 maxargs
= XSUBR (subr
)->max_args
;
755 return Fcons (make_number (minargs
), Qmany
);
756 else if (maxargs
== UNEVALLED
)
757 return Fcons (make_number (minargs
), Qunevalled
);
759 return Fcons (make_number (minargs
), make_number (maxargs
));
762 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
763 doc
: /* Return the interactive form of SUBR or nil if none.
764 SUBR must be a built-in function. Value, if non-nil, is a list
765 \(interactive SPEC). */)
770 wrong_type_argument (Qsubrp
, subr
);
771 if (XSUBR (subr
)->prompt
)
772 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
777 /***********************************************************************
778 Getting and Setting Values of Symbols
779 ***********************************************************************/
781 /* Return the symbol holding SYMBOL's value. Signal
782 `cyclic-variable-indirection' if SYMBOL's chain of variable
783 indirections contains a loop. */
786 indirect_variable (symbol
)
789 Lisp_Object tortoise
, hare
;
791 hare
= tortoise
= symbol
;
793 while (XSYMBOL (hare
)->indirect_variable
)
795 hare
= XSYMBOL (hare
)->value
;
796 if (!XSYMBOL (hare
)->indirect_variable
)
799 hare
= XSYMBOL (hare
)->value
;
800 tortoise
= XSYMBOL (tortoise
)->value
;
802 if (EQ (hare
, tortoise
))
803 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
810 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
811 doc
: /* Return the variable at the end of OBJECT's variable chain.
812 If OBJECT is a symbol, follow all variable indirections and return the final
813 variable. If OBJECT is not a symbol, just return it.
814 Signal a cyclic-variable-indirection error if there is a loop in the
815 variable chain of symbols. */)
819 if (SYMBOLP (object
))
820 object
= indirect_variable (object
);
825 /* Given the raw contents of a symbol value cell,
826 return the Lisp value of the symbol.
827 This does not handle buffer-local variables; use
828 swap_in_symval_forwarding for that. */
831 do_symval_forwarding (valcontents
)
832 register Lisp_Object valcontents
;
834 register Lisp_Object val
;
836 if (MISCP (valcontents
))
837 switch (XMISCTYPE (valcontents
))
839 case Lisp_Misc_Intfwd
:
840 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
843 case Lisp_Misc_Boolfwd
:
844 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
846 case Lisp_Misc_Objfwd
:
847 return *XOBJFWD (valcontents
)->objvar
;
849 case Lisp_Misc_Buffer_Objfwd
:
850 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
851 return PER_BUFFER_VALUE (current_buffer
, offset
);
853 case Lisp_Misc_Kboard_Objfwd
:
854 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
855 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
860 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
861 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
862 buffer-independent contents of the value cell: forwarded just one
863 step past the buffer-localness.
865 BUF non-zero means set the value in buffer BUF instead of the
866 current buffer. This only plays a role for per-buffer variables. */
869 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
871 register Lisp_Object valcontents
, newval
;
874 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
877 switch (XMISCTYPE (valcontents
))
879 case Lisp_Misc_Intfwd
:
880 CHECK_NUMBER (newval
);
881 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
882 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
883 error ("Value out of range for variable `%s'",
884 SDATA (SYMBOL_NAME (symbol
)));
887 case Lisp_Misc_Boolfwd
:
888 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
891 case Lisp_Misc_Objfwd
:
892 *XOBJFWD (valcontents
)->objvar
= newval
;
895 case Lisp_Misc_Buffer_Objfwd
:
897 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
900 type
= PER_BUFFER_TYPE (offset
);
901 if (! NILP (type
) && ! NILP (newval
)
902 && XTYPE (newval
) != XINT (type
))
903 buffer_slot_type_mismatch (offset
);
906 buf
= current_buffer
;
907 PER_BUFFER_VALUE (buf
, offset
) = newval
;
911 case Lisp_Misc_Kboard_Objfwd
:
913 char *base
= (char *) current_kboard
;
914 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
915 *(Lisp_Object
*) p
= newval
;
926 valcontents
= SYMBOL_VALUE (symbol
);
927 if (BUFFER_LOCAL_VALUEP (valcontents
)
928 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
929 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
931 SET_SYMBOL_VALUE (symbol
, newval
);
935 /* Set up SYMBOL to refer to its global binding.
936 This makes it safe to alter the status of other bindings. */
939 swap_in_global_binding (symbol
)
942 Lisp_Object valcontents
, cdr
;
944 valcontents
= SYMBOL_VALUE (symbol
);
945 if (!BUFFER_LOCAL_VALUEP (valcontents
)
946 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
948 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
950 /* Unload the previously loaded binding. */
952 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
954 /* Select the global binding in the symbol. */
956 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
958 /* Indicate that the global binding is set up now. */
959 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
960 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
961 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
962 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
965 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
966 VALCONTENTS is the contents of its value cell,
967 which points to a struct Lisp_Buffer_Local_Value.
969 Return the value forwarded one step past the buffer-local stage.
970 This could be another forwarding pointer. */
973 swap_in_symval_forwarding (symbol
, valcontents
)
974 Lisp_Object symbol
, valcontents
;
976 register Lisp_Object tem1
;
978 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
981 || current_buffer
!= XBUFFER (tem1
)
982 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
983 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
985 if (XSYMBOL (symbol
)->indirect_variable
)
986 symbol
= indirect_variable (symbol
);
988 /* Unload the previously loaded binding. */
989 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
991 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
992 /* Choose the new binding. */
993 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
994 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
995 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
998 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
999 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1001 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1003 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1006 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1008 /* Load the new binding. */
1009 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1010 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1011 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1012 store_symval_forwarding (symbol
,
1013 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1016 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1019 /* Find the value of a symbol, returning Qunbound if it's not bound.
1020 This is helpful for code which just wants to get a variable's value
1021 if it has one, without signaling an error.
1022 Note that it must not be possible to quit
1023 within this function. Great care is required for this. */
1026 find_symbol_value (symbol
)
1029 register Lisp_Object valcontents
;
1030 register Lisp_Object val
;
1032 CHECK_SYMBOL (symbol
);
1033 valcontents
= SYMBOL_VALUE (symbol
);
1035 if (BUFFER_LOCAL_VALUEP (valcontents
)
1036 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1037 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1039 if (MISCP (valcontents
))
1041 switch (XMISCTYPE (valcontents
))
1043 case Lisp_Misc_Intfwd
:
1044 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1047 case Lisp_Misc_Boolfwd
:
1048 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1050 case Lisp_Misc_Objfwd
:
1051 return *XOBJFWD (valcontents
)->objvar
;
1053 case Lisp_Misc_Buffer_Objfwd
:
1054 return PER_BUFFER_VALUE (current_buffer
,
1055 XBUFFER_OBJFWD (valcontents
)->offset
);
1057 case Lisp_Misc_Kboard_Objfwd
:
1058 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1059 + (char *)current_kboard
);
1066 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1067 doc
: /* Return SYMBOL's value. Error if that is void. */)
1073 val
= find_symbol_value (symbol
);
1074 if (EQ (val
, Qunbound
))
1075 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1080 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1081 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1083 register Lisp_Object symbol
, newval
;
1085 return set_internal (symbol
, newval
, current_buffer
, 0);
1088 /* Return 1 if SYMBOL currently has a let-binding
1089 which was made in the buffer that is now current. */
1092 let_shadows_buffer_binding_p (symbol
)
1095 volatile struct specbinding
*p
;
1097 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1099 && CONSP (p
->symbol
))
1101 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1102 if ((EQ (symbol
, let_bound_symbol
)
1103 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1104 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1105 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1109 return p
>= specpdl
;
1112 /* Store the value NEWVAL into SYMBOL.
1113 If buffer-locality is an issue, BUF specifies which buffer to use.
1114 (0 stands for the current buffer.)
1116 If BINDFLAG is zero, then if this symbol is supposed to become
1117 local in every buffer where it is set, then we make it local.
1118 If BINDFLAG is nonzero, we don't do that. */
1121 set_internal (symbol
, newval
, buf
, bindflag
)
1122 register Lisp_Object symbol
, newval
;
1126 int voide
= EQ (newval
, Qunbound
);
1128 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1131 buf
= current_buffer
;
1133 /* If restoring in a dead buffer, do nothing. */
1134 if (NILP (buf
->name
))
1137 CHECK_SYMBOL (symbol
);
1138 if (SYMBOL_CONSTANT_P (symbol
)
1139 && (NILP (Fkeywordp (symbol
))
1140 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1141 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1143 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1145 if (BUFFER_OBJFWDP (valcontents
))
1147 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1148 int idx
= PER_BUFFER_IDX (offset
);
1151 && !let_shadows_buffer_binding_p (symbol
))
1152 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1154 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1155 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1157 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1158 if (XSYMBOL (symbol
)->indirect_variable
)
1159 symbol
= indirect_variable (symbol
);
1161 /* What binding is loaded right now? */
1162 current_alist_element
1163 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1165 /* If the current buffer is not the buffer whose binding is
1166 loaded, or if there may be frame-local bindings and the frame
1167 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1168 the default binding is loaded, the loaded binding may be the
1170 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1171 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1172 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1173 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1174 || (BUFFER_LOCAL_VALUEP (valcontents
)
1175 && EQ (XCAR (current_alist_element
),
1176 current_alist_element
)))
1178 /* The currently loaded binding is not necessarily valid.
1179 We need to unload it, and choose a new binding. */
1181 /* Write out `realvalue' to the old loaded binding. */
1182 Fsetcdr (current_alist_element
,
1183 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1185 /* Find the new binding. */
1186 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1187 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1188 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1192 /* This buffer still sees the default value. */
1194 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1195 or if this is `let' rather than `set',
1196 make CURRENT-ALIST-ELEMENT point to itself,
1197 indicating that we're seeing the default value.
1198 Likewise if the variable has been let-bound
1199 in the current buffer. */
1200 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1201 || let_shadows_buffer_binding_p (symbol
))
1203 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1205 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1206 tem1
= Fassq (symbol
,
1207 XFRAME (selected_frame
)->param_alist
);
1210 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1212 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1214 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1215 and we're not within a let that was made for this buffer,
1216 create a new buffer-local binding for the variable.
1217 That means, give this buffer a new assoc for a local value
1218 and load that binding. */
1221 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1222 buf
->local_var_alist
1223 = Fcons (tem1
, buf
->local_var_alist
);
1227 /* Record which binding is now loaded. */
1228 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1231 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1232 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1233 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1235 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1238 /* If storing void (making the symbol void), forward only through
1239 buffer-local indicator, not through Lisp_Objfwd, etc. */
1241 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1243 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1245 /* If we just set a variable whose current binding is frame-local,
1246 store the new value in the frame parameter too. */
1248 if (BUFFER_LOCAL_VALUEP (valcontents
)
1249 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1251 /* What binding is loaded right now? */
1252 current_alist_element
1253 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1255 /* If the current buffer is not the buffer whose binding is
1256 loaded, or if there may be frame-local bindings and the frame
1257 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1258 the default binding is loaded, the loaded binding may be the
1260 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1261 XSETCDR (current_alist_element
, newval
);
1267 /* Access or set a buffer-local symbol's default value. */
1269 /* Return the default value of SYMBOL, but don't check for voidness.
1270 Return Qunbound if it is void. */
1273 default_value (symbol
)
1276 register Lisp_Object valcontents
;
1278 CHECK_SYMBOL (symbol
);
1279 valcontents
= SYMBOL_VALUE (symbol
);
1281 /* For a built-in buffer-local variable, get the default value
1282 rather than letting do_symval_forwarding get the current value. */
1283 if (BUFFER_OBJFWDP (valcontents
))
1285 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1286 if (PER_BUFFER_IDX (offset
) != 0)
1287 return PER_BUFFER_DEFAULT (offset
);
1290 /* Handle user-created local variables. */
1291 if (BUFFER_LOCAL_VALUEP (valcontents
)
1292 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1294 /* If var is set up for a buffer that lacks a local value for it,
1295 the current value is nominally the default value.
1296 But the `realvalue' slot may be more up to date, since
1297 ordinary setq stores just that slot. So use that. */
1298 Lisp_Object current_alist_element
, alist_element_car
;
1299 current_alist_element
1300 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1301 alist_element_car
= XCAR (current_alist_element
);
1302 if (EQ (alist_element_car
, current_alist_element
))
1303 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1305 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1307 /* For other variables, get the current value. */
1308 return do_symval_forwarding (valcontents
);
1311 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1312 doc
: /* Return t if SYMBOL has a non-void default value.
1313 This is the value that is seen in buffers that do not have their own values
1314 for this variable. */)
1318 register Lisp_Object value
;
1320 value
= default_value (symbol
);
1321 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1324 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1325 doc
: /* Return SYMBOL's default value.
1326 This is the value that is seen in buffers that do not have their own values
1327 for this variable. The default value is meaningful for variables with
1328 local bindings in certain buffers. */)
1332 register Lisp_Object value
;
1334 value
= default_value (symbol
);
1335 if (EQ (value
, Qunbound
))
1336 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1340 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1341 doc
: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1342 The default value is seen in buffers that do not have their own values
1343 for this variable. */)
1345 Lisp_Object symbol
, value
;
1347 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1349 CHECK_SYMBOL (symbol
);
1350 valcontents
= SYMBOL_VALUE (symbol
);
1352 /* Handle variables like case-fold-search that have special slots
1353 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1355 if (BUFFER_OBJFWDP (valcontents
))
1357 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1358 int idx
= PER_BUFFER_IDX (offset
);
1360 PER_BUFFER_DEFAULT (offset
) = value
;
1362 /* If this variable is not always local in all buffers,
1363 set it in the buffers that don't nominally have a local value. */
1368 for (b
= all_buffers
; b
; b
= b
->next
)
1369 if (!PER_BUFFER_VALUE_P (b
, idx
))
1370 PER_BUFFER_VALUE (b
, offset
) = value
;
1375 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1376 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1377 return Fset (symbol
, value
);
1379 /* Store new value into the DEFAULT-VALUE slot. */
1380 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1382 /* If the default binding is now loaded, set the REALVALUE slot too. */
1383 current_alist_element
1384 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1385 alist_element_buffer
= Fcar (current_alist_element
);
1386 if (EQ (alist_element_buffer
, current_alist_element
))
1387 store_symval_forwarding (symbol
,
1388 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1394 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1395 doc
: /* Set the default value of variable VAR to VALUE.
1396 VAR, the variable name, is literal (not evaluated);
1397 VALUE is an expression: it is evaluated and its value returned.
1398 The default value of a variable is seen in buffers
1399 that do not have their own values for the variable.
1401 More generally, you can use multiple variables and values, as in
1402 (setq-default SYMBOL VALUE SYMBOL VALUE...)
1403 This sets each SYMBOL's default value to the corresponding VALUE.
1404 The VALUE for the Nth SYMBOL can refer to the new default values
1406 usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */)
1410 register Lisp_Object args_left
;
1411 register Lisp_Object val
, symbol
;
1412 struct gcpro gcpro1
;
1422 val
= Feval (Fcar (Fcdr (args_left
)));
1423 symbol
= XCAR (args_left
);
1424 Fset_default (symbol
, val
);
1425 args_left
= Fcdr (XCDR (args_left
));
1427 while (!NILP (args_left
));
1433 /* Lisp functions for creating and removing buffer-local variables. */
1435 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1436 1, 1, "vMake Variable Buffer Local: ",
1437 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1438 At any time, the value for the current buffer is in effect,
1439 unless the variable has never been set in this buffer,
1440 in which case the default value is in effect.
1441 Note that binding the variable with `let', or setting it while
1442 a `let'-style binding made in this buffer is in effect,
1443 does not make the variable buffer-local. Return VARIABLE.
1445 The function `default-value' gets the default value and `set-default' sets it. */)
1447 register Lisp_Object variable
;
1449 register Lisp_Object tem
, valcontents
, newval
;
1451 CHECK_SYMBOL (variable
);
1452 variable
= indirect_variable (variable
);
1454 valcontents
= SYMBOL_VALUE (variable
);
1455 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1456 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1458 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1460 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1462 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1465 if (EQ (valcontents
, Qunbound
))
1466 SET_SYMBOL_VALUE (variable
, Qnil
);
1467 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1469 newval
= allocate_misc ();
1470 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1471 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1472 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1473 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1474 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1475 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1476 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1477 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1478 SET_SYMBOL_VALUE (variable
, newval
);
1482 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1483 1, 1, "vMake Local Variable: ",
1484 doc
: /* Make VARIABLE have a separate value in the current buffer.
1485 Other buffers will continue to share a common default value.
1486 \(The buffer-local value of VARIABLE starts out as the same value
1487 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1488 See also `make-variable-buffer-local'. Return VARIABLE.
1490 If the variable is already arranged to become local when set,
1491 this function causes a local value to exist for this buffer,
1492 just as setting the variable would do.
1494 This function returns VARIABLE, and therefore
1495 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1498 Do not use `make-local-variable' to make a hook variable buffer-local.
1499 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1501 register Lisp_Object variable
;
1503 register Lisp_Object tem
, valcontents
;
1505 CHECK_SYMBOL (variable
);
1506 variable
= indirect_variable (variable
);
1508 valcontents
= SYMBOL_VALUE (variable
);
1509 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1510 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1512 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1514 tem
= Fboundp (variable
);
1516 /* Make sure the symbol has a local value in this particular buffer,
1517 by setting it to the same value it already has. */
1518 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1521 /* Make sure symbol is set up to hold per-buffer values. */
1522 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1525 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1527 newval
= allocate_misc ();
1528 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1529 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1530 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1531 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1532 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1533 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1534 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1535 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1536 SET_SYMBOL_VALUE (variable
, newval
);;
1538 /* Make sure this buffer has its own value of symbol. */
1539 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1542 /* Swap out any local binding for some other buffer, and make
1543 sure the current value is permanently recorded, if it's the
1545 find_symbol_value (variable
);
1547 current_buffer
->local_var_alist
1548 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1549 current_buffer
->local_var_alist
);
1551 /* Make sure symbol does not think it is set up for this buffer;
1552 force it to look once again for this buffer's value. */
1554 Lisp_Object
*pvalbuf
;
1556 valcontents
= SYMBOL_VALUE (variable
);
1558 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1559 if (current_buffer
== XBUFFER (*pvalbuf
))
1561 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1565 /* If the symbol forwards into a C variable, then load the binding
1566 for this buffer now. If C code modifies the variable before we
1567 load the binding in, then that new value will clobber the default
1568 binding the next time we unload it. */
1569 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1570 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1571 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1576 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1577 1, 1, "vKill Local Variable: ",
1578 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1579 From now on the default value will apply in this buffer. Return VARIABLE. */)
1581 register Lisp_Object variable
;
1583 register Lisp_Object tem
, valcontents
;
1585 CHECK_SYMBOL (variable
);
1586 variable
= indirect_variable (variable
);
1588 valcontents
= SYMBOL_VALUE (variable
);
1590 if (BUFFER_OBJFWDP (valcontents
))
1592 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1593 int idx
= PER_BUFFER_IDX (offset
);
1597 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1598 PER_BUFFER_VALUE (current_buffer
, offset
)
1599 = PER_BUFFER_DEFAULT (offset
);
1604 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1605 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1608 /* Get rid of this buffer's alist element, if any. */
1610 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1612 current_buffer
->local_var_alist
1613 = Fdelq (tem
, current_buffer
->local_var_alist
);
1615 /* If the symbol is set up with the current buffer's binding
1616 loaded, recompute its value. We have to do it now, or else
1617 forwarded objects won't work right. */
1619 Lisp_Object
*pvalbuf
, buf
;
1620 valcontents
= SYMBOL_VALUE (variable
);
1621 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1622 XSETBUFFER (buf
, current_buffer
);
1623 if (EQ (buf
, *pvalbuf
))
1626 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1627 find_symbol_value (variable
);
1634 /* Lisp functions for creating and removing buffer-local variables. */
1636 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1637 1, 1, "vMake Variable Frame Local: ",
1638 doc
: /* Enable VARIABLE to have frame-local bindings.
1639 When a frame-local binding exists in the current frame,
1640 it is in effect whenever the current buffer has no buffer-local binding.
1641 A frame-local binding is actually a frame parameter value;
1642 thus, any given frame has a local binding for VARIABLE if it has
1643 a value for the frame parameter named VARIABLE. Return VARIABLE.
1644 See `modify-frame-parameters' for how to set frame parameters. */)
1646 register Lisp_Object variable
;
1648 register Lisp_Object tem
, valcontents
, newval
;
1650 CHECK_SYMBOL (variable
);
1651 variable
= indirect_variable (variable
);
1653 valcontents
= SYMBOL_VALUE (variable
);
1654 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1655 || BUFFER_OBJFWDP (valcontents
))
1656 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1658 if (BUFFER_LOCAL_VALUEP (valcontents
)
1659 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1661 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1665 if (EQ (valcontents
, Qunbound
))
1666 SET_SYMBOL_VALUE (variable
, Qnil
);
1667 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1669 newval
= allocate_misc ();
1670 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1671 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1672 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1673 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1674 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1675 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1676 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1677 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1678 SET_SYMBOL_VALUE (variable
, newval
);
1682 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1684 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1685 BUFFER defaults to the current buffer. */)
1687 register Lisp_Object variable
, buffer
;
1689 Lisp_Object valcontents
;
1690 register struct buffer
*buf
;
1693 buf
= current_buffer
;
1696 CHECK_BUFFER (buffer
);
1697 buf
= XBUFFER (buffer
);
1700 CHECK_SYMBOL (variable
);
1701 variable
= indirect_variable (variable
);
1703 valcontents
= SYMBOL_VALUE (variable
);
1704 if (BUFFER_LOCAL_VALUEP (valcontents
)
1705 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1707 Lisp_Object tail
, elt
;
1709 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1712 if (EQ (variable
, XCAR (elt
)))
1716 if (BUFFER_OBJFWDP (valcontents
))
1718 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1719 int idx
= PER_BUFFER_IDX (offset
);
1720 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1726 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1728 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
1729 BUFFER defaults to the current buffer. */)
1731 register Lisp_Object variable
, buffer
;
1733 Lisp_Object valcontents
;
1734 register struct buffer
*buf
;
1737 buf
= current_buffer
;
1740 CHECK_BUFFER (buffer
);
1741 buf
= XBUFFER (buffer
);
1744 CHECK_SYMBOL (variable
);
1745 variable
= indirect_variable (variable
);
1747 valcontents
= SYMBOL_VALUE (variable
);
1749 /* This means that make-variable-buffer-local was done. */
1750 if (BUFFER_LOCAL_VALUEP (valcontents
))
1752 /* All these slots become local if they are set. */
1753 if (BUFFER_OBJFWDP (valcontents
))
1755 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1757 Lisp_Object tail
, elt
;
1758 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1761 if (EQ (variable
, XCAR (elt
)))
1768 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1770 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1771 If the current binding is buffer-local, the value is the current buffer.
1772 If the current binding is frame-local, the value is the selected frame.
1773 If the current binding is global (the default), the value is nil. */)
1775 register Lisp_Object variable
;
1777 Lisp_Object valcontents
;
1779 CHECK_SYMBOL (variable
);
1780 variable
= indirect_variable (variable
);
1782 /* Make sure the current binding is actually swapped in. */
1783 find_symbol_value (variable
);
1785 valcontents
= XSYMBOL (variable
)->value
;
1787 if (BUFFER_LOCAL_VALUEP (valcontents
)
1788 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1789 || BUFFER_OBJFWDP (valcontents
))
1791 /* For a local variable, record both the symbol and which
1792 buffer's or frame's value we are saving. */
1793 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1794 return Fcurrent_buffer ();
1795 else if (!BUFFER_OBJFWDP (valcontents
)
1796 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1797 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1803 /* Find the function at the end of a chain of symbol function indirections. */
1805 /* If OBJECT is a symbol, find the end of its function chain and
1806 return the value found there. If OBJECT is not a symbol, just
1807 return it. If there is a cycle in the function chain, signal a
1808 cyclic-function-indirection error.
1810 This is like Findirect_function, except that it doesn't signal an
1811 error if the chain ends up unbound. */
1813 indirect_function (object
)
1814 register Lisp_Object object
;
1816 Lisp_Object tortoise
, hare
;
1818 hare
= tortoise
= object
;
1822 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1824 hare
= XSYMBOL (hare
)->function
;
1825 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1827 hare
= XSYMBOL (hare
)->function
;
1829 tortoise
= XSYMBOL (tortoise
)->function
;
1831 if (EQ (hare
, tortoise
))
1832 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1838 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1839 doc
: /* Return the function at the end of OBJECT's function chain.
1840 If OBJECT is a symbol, follow all function indirections and return the final
1842 If OBJECT is not a symbol, just return it.
1843 Signal a void-function error if the final symbol is unbound.
1844 Signal a cyclic-function-indirection error if there is a loop in the
1845 function chain of symbols. */)
1847 register Lisp_Object object
;
1851 result
= indirect_function (object
);
1853 if (EQ (result
, Qunbound
))
1854 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1858 /* Extract and set vector and string elements */
1860 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1861 doc
: /* Return the element of ARRAY at index IDX.
1862 ARRAY may be a vector, a string, a char-table, a bool-vector,
1863 or a byte-code object. IDX starts at 0. */)
1865 register Lisp_Object array
;
1868 register int idxval
;
1871 idxval
= XINT (idx
);
1872 if (STRINGP (array
))
1876 if (idxval
< 0 || idxval
>= SCHARS (array
))
1877 args_out_of_range (array
, idx
);
1878 if (! STRING_MULTIBYTE (array
))
1879 return make_number ((unsigned char) SREF (array
, idxval
));
1880 idxval_byte
= string_char_to_byte (array
, idxval
);
1882 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1883 SBYTES (array
) - idxval_byte
);
1884 return make_number (c
);
1886 else if (BOOL_VECTOR_P (array
))
1890 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1891 args_out_of_range (array
, idx
);
1893 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1894 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1896 else if (CHAR_TABLE_P (array
))
1903 args_out_of_range (array
, idx
);
1904 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1906 /* For ASCII and 8-bit European characters, the element is
1907 stored in the top table. */
1908 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1910 val
= XCHAR_TABLE (array
)->defalt
;
1911 while (NILP (val
)) /* Follow parents until we find some value. */
1913 array
= XCHAR_TABLE (array
)->parent
;
1916 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1918 val
= XCHAR_TABLE (array
)->defalt
;
1925 Lisp_Object sub_table
;
1927 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1928 if (code
[1] < 32) code
[1] = -1;
1929 else if (code
[2] < 32) code
[2] = -1;
1931 /* Here, the possible range of CODE[0] (== charset ID) is
1932 128..MAX_CHARSET. Since the top level char table contains
1933 data for multibyte characters after 256th element, we must
1934 increment CODE[0] by 128 to get a correct index. */
1936 code
[3] = -1; /* anchor */
1938 try_parent_char_table
:
1940 for (i
= 0; code
[i
] >= 0; i
++)
1942 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1943 if (SUB_CHAR_TABLE_P (val
))
1948 val
= XCHAR_TABLE (sub_table
)->defalt
;
1951 array
= XCHAR_TABLE (array
)->parent
;
1953 goto try_parent_char_table
;
1958 /* Here, VAL is a sub char table. We try the default value
1960 val
= XCHAR_TABLE (val
)->defalt
;
1963 array
= XCHAR_TABLE (array
)->parent
;
1965 goto try_parent_char_table
;
1973 if (VECTORP (array
))
1974 size
= XVECTOR (array
)->size
;
1975 else if (COMPILEDP (array
))
1976 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1978 wrong_type_argument (Qarrayp
, array
);
1980 if (idxval
< 0 || idxval
>= size
)
1981 args_out_of_range (array
, idx
);
1982 return XVECTOR (array
)->contents
[idxval
];
1986 /* Don't use alloca for relocating string data larger than this, lest
1987 we overflow their stack. The value is the same as what used in
1988 fns.c for base64 handling. */
1989 #define MAX_ALLOCA 16*1024
1991 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1992 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1993 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
1994 bool-vector. IDX starts at 0. */)
1995 (array
, idx
, newelt
)
1996 register Lisp_Object array
;
1997 Lisp_Object idx
, newelt
;
1999 register int idxval
;
2002 idxval
= XINT (idx
);
2003 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2004 && ! CHAR_TABLE_P (array
))
2005 array
= wrong_type_argument (Qarrayp
, array
);
2006 CHECK_IMPURE (array
);
2008 if (VECTORP (array
))
2010 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2011 args_out_of_range (array
, idx
);
2012 XVECTOR (array
)->contents
[idxval
] = newelt
;
2014 else if (BOOL_VECTOR_P (array
))
2018 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2019 args_out_of_range (array
, idx
);
2021 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
2023 if (! NILP (newelt
))
2024 val
|= 1 << (idxval
% BITS_PER_CHAR
);
2026 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
2027 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
2029 else if (CHAR_TABLE_P (array
))
2032 args_out_of_range (array
, idx
);
2033 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2034 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2040 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2041 if (code
[1] < 32) code
[1] = -1;
2042 else if (code
[2] < 32) code
[2] = -1;
2044 /* See the comment of the corresponding part in Faref. */
2046 code
[3] = -1; /* anchor */
2047 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2049 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2050 if (SUB_CHAR_TABLE_P (val
))
2056 /* VAL is a leaf. Create a sub char table with the
2057 default value VAL or XCHAR_TABLE (array)->defalt
2058 and look into it. */
2060 temp
= make_sub_char_table (NILP (val
)
2061 ? XCHAR_TABLE (array
)->defalt
2063 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2067 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2070 else if (STRING_MULTIBYTE (array
))
2072 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2073 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2075 if (idxval
< 0 || idxval
>= SCHARS (array
))
2076 args_out_of_range (array
, idx
);
2077 CHECK_NUMBER (newelt
);
2079 nbytes
= SBYTES (array
);
2081 idxval_byte
= string_char_to_byte (array
, idxval
);
2082 p1
= SDATA (array
) + idxval_byte
;
2083 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2084 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2085 if (prev_bytes
!= new_bytes
)
2087 /* We must relocate the string data. */
2088 int nchars
= SCHARS (array
);
2091 str
= (nbytes
<= MAX_ALLOCA
2092 ? (unsigned char *) alloca (nbytes
)
2093 : (unsigned char *) xmalloc (nbytes
));
2094 bcopy (SDATA (array
), str
, nbytes
);
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
;
2099 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2100 nbytes
- (idxval_byte
+ prev_bytes
));
2101 if (nbytes
> MAX_ALLOCA
)
2103 clear_string_char_byte_cache ();
2110 if (idxval
< 0 || idxval
>= SCHARS (array
))
2111 args_out_of_range (array
, idx
);
2112 CHECK_NUMBER (newelt
);
2114 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2115 SSET (array
, idxval
, XINT (newelt
));
2118 /* We must relocate the string data while converting it to
2120 int idxval_byte
, prev_bytes
, new_bytes
;
2121 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2122 unsigned char *origstr
= SDATA (array
), *str
;
2125 nchars
= SCHARS (array
);
2126 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2127 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2129 str
= (nbytes
<= MAX_ALLOCA
2130 ? (unsigned char *) alloca (nbytes
)
2131 : (unsigned char *) xmalloc (nbytes
));
2132 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2133 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2135 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2136 allocate_string_data (XSTRING (array
), nchars
,
2137 nbytes
+ new_bytes
- prev_bytes
);
2138 bcopy (str
, SDATA (array
), idxval_byte
);
2139 p1
= SDATA (array
) + idxval_byte
;
2142 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2143 nbytes
- (idxval_byte
+ prev_bytes
));
2144 if (nbytes
> MAX_ALLOCA
)
2146 clear_string_char_byte_cache ();
2153 /* Arithmetic functions */
2155 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2158 arithcompare (num1
, num2
, comparison
)
2159 Lisp_Object num1
, num2
;
2160 enum comparison comparison
;
2162 double f1
= 0, f2
= 0;
2165 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2166 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2168 if (FLOATP (num1
) || FLOATP (num2
))
2171 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2172 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2178 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2183 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2188 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2193 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2198 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2203 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2212 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2213 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2215 register Lisp_Object num1
, num2
;
2217 return arithcompare (num1
, num2
, equal
);
2220 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2221 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2223 register Lisp_Object num1
, num2
;
2225 return arithcompare (num1
, num2
, less
);
2228 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2229 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2231 register Lisp_Object num1
, num2
;
2233 return arithcompare (num1
, num2
, grtr
);
2236 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2237 doc
: /* Return t if first arg is less than or equal to second arg.
2238 Both must be numbers or markers. */)
2240 register Lisp_Object num1
, num2
;
2242 return arithcompare (num1
, num2
, less_or_equal
);
2245 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2246 doc
: /* Return t if first arg is greater than or equal to second arg.
2247 Both must be numbers or markers. */)
2249 register Lisp_Object num1
, num2
;
2251 return arithcompare (num1
, num2
, grtr_or_equal
);
2254 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2255 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2257 register Lisp_Object num1
, num2
;
2259 return arithcompare (num1
, num2
, notequal
);
2262 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2263 doc
: /* Return t if NUMBER is zero. */)
2265 register Lisp_Object number
;
2267 CHECK_NUMBER_OR_FLOAT (number
);
2269 if (FLOATP (number
))
2271 if (XFLOAT_DATA (number
) == 0.0)
2281 /* Convert between long values and pairs of Lisp integers. */
2287 unsigned long top
= i
>> 16;
2288 unsigned int bot
= i
& 0xFFFF;
2290 return make_number (bot
);
2291 if (top
== (unsigned long)-1 >> 16)
2292 return Fcons (make_number (-1), make_number (bot
));
2293 return Fcons (make_number (top
), make_number (bot
));
2300 Lisp_Object top
, bot
;
2307 return ((XINT (top
) << 16) | XINT (bot
));
2310 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2311 doc
: /* Return the decimal representation of NUMBER as a string.
2312 Uses a minus sign if negative.
2313 NUMBER may be an integer or a floating point number. */)
2317 char buffer
[VALBITS
];
2319 CHECK_NUMBER_OR_FLOAT (number
);
2321 if (FLOATP (number
))
2323 char pigbuf
[350]; /* see comments in float_to_string */
2325 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2326 return build_string (pigbuf
);
2329 if (sizeof (int) == sizeof (EMACS_INT
))
2330 sprintf (buffer
, "%d", XINT (number
));
2331 else if (sizeof (long) == sizeof (EMACS_INT
))
2332 sprintf (buffer
, "%ld", (long) XINT (number
));
2335 return build_string (buffer
);
2339 digit_to_number (character
, base
)
2340 int character
, base
;
2344 if (character
>= '0' && character
<= '9')
2345 digit
= character
- '0';
2346 else if (character
>= 'a' && character
<= 'z')
2347 digit
= character
- 'a' + 10;
2348 else if (character
>= 'A' && character
<= 'Z')
2349 digit
= character
- 'A' + 10;
2359 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2360 doc
: /* Parse STRING as a decimal number and return the number.
2361 This parses both integers and floating point numbers.
2362 It ignores leading spaces and tabs.
2364 If BASE, interpret STRING as a number in that base. If BASE isn't
2365 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2366 If the base used is not 10, floating point is not recognized. */)
2368 register Lisp_Object string
, base
;
2370 register unsigned char *p
;
2375 CHECK_STRING (string
);
2381 CHECK_NUMBER (base
);
2383 if (b
< 2 || b
> 16)
2384 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2387 /* Skip any whitespace at the front of the number. Some versions of
2388 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2390 while (*p
== ' ' || *p
== '\t')
2401 if (isfloat_string (p
) && b
== 10)
2402 val
= make_float (sign
* atof (p
));
2409 int digit
= digit_to_number (*p
++, b
);
2415 val
= make_fixnum_or_float (sign
* v
);
2435 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2436 int, Lisp_Object
*));
2437 extern Lisp_Object
fmod_float ();
2440 arith_driver (code
, nargs
, args
)
2443 register Lisp_Object
*args
;
2445 register Lisp_Object val
;
2446 register int argnum
;
2447 register EMACS_INT accum
= 0;
2448 register EMACS_INT next
;
2450 switch (SWITCH_ENUM_CAST (code
))
2468 for (argnum
= 0; argnum
< nargs
; argnum
++)
2470 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2472 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2475 return float_arith_driver ((double) accum
, argnum
, code
,
2478 next
= XINT (args
[argnum
]);
2479 switch (SWITCH_ENUM_CAST (code
))
2485 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2496 Fsignal (Qarith_error
, Qnil
);
2510 if (!argnum
|| next
> accum
)
2514 if (!argnum
|| next
< accum
)
2520 XSETINT (val
, accum
);
2525 #define isnan(x) ((x) != (x))
2528 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2530 register int argnum
;
2533 register Lisp_Object
*args
;
2535 register Lisp_Object val
;
2538 for (; argnum
< nargs
; argnum
++)
2540 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2541 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2545 next
= XFLOAT_DATA (val
);
2549 args
[argnum
] = val
; /* runs into a compiler bug. */
2550 next
= XINT (args
[argnum
]);
2552 switch (SWITCH_ENUM_CAST (code
))
2558 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2568 if (! IEEE_FLOATING_POINT
&& next
== 0)
2569 Fsignal (Qarith_error
, Qnil
);
2576 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2578 if (!argnum
|| isnan (next
) || next
> accum
)
2582 if (!argnum
|| isnan (next
) || next
< accum
)
2588 return make_float (accum
);
2592 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2593 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2594 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2599 return arith_driver (Aadd
, nargs
, args
);
2602 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2603 doc
: /* Negate number or subtract numbers or markers and return the result.
2604 With one arg, negates it. With more than one arg,
2605 subtracts all but the first from the first.
2606 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2611 return arith_driver (Asub
, nargs
, args
);
2614 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2615 doc
: /* Return product of any number of arguments, which are numbers or markers.
2616 usage: (* &rest NUMBERS-OR-MARKERS) */)
2621 return arith_driver (Amult
, nargs
, args
);
2624 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2625 doc
: /* Return first argument divided by all the remaining arguments.
2626 The arguments must be numbers or markers.
2627 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2632 return arith_driver (Adiv
, nargs
, args
);
2635 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2636 doc
: /* Return remainder of X divided by Y.
2637 Both must be integers or markers. */)
2639 register Lisp_Object x
, y
;
2643 CHECK_NUMBER_COERCE_MARKER (x
);
2644 CHECK_NUMBER_COERCE_MARKER (y
);
2646 if (XFASTINT (y
) == 0)
2647 Fsignal (Qarith_error
, Qnil
);
2649 XSETINT (val
, XINT (x
) % XINT (y
));
2663 /* If the magnitude of the result exceeds that of the divisor, or
2664 the sign of the result does not agree with that of the dividend,
2665 iterate with the reduced value. This does not yield a
2666 particularly accurate result, but at least it will be in the
2667 range promised by fmod. */
2669 r
-= f2
* floor (r
/ f2
);
2670 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2674 #endif /* ! HAVE_FMOD */
2676 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2677 doc
: /* Return X modulo Y.
2678 The result falls between zero (inclusive) and Y (exclusive).
2679 Both X and Y must be numbers or markers. */)
2681 register Lisp_Object x
, y
;
2686 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2687 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2689 if (FLOATP (x
) || FLOATP (y
))
2690 return fmod_float (x
, y
);
2696 Fsignal (Qarith_error
, Qnil
);
2700 /* If the "remainder" comes out with the wrong sign, fix it. */
2701 if (i2
< 0 ? i1
> 0 : i1
< 0)
2708 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2709 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2710 The value is always a number; markers are converted to numbers.
2711 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2716 return arith_driver (Amax
, nargs
, args
);
2719 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2720 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2721 The value is always a number; markers are converted to numbers.
2722 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2727 return arith_driver (Amin
, nargs
, args
);
2730 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2731 doc
: /* Return bitwise-and of all the arguments.
2732 Arguments may be integers, or markers converted to integers.
2733 usage: (logand &rest INTS-OR-MARKERS) */)
2738 return arith_driver (Alogand
, nargs
, args
);
2741 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2742 doc
: /* Return bitwise-or of all the arguments.
2743 Arguments may be integers, or markers converted to integers.
2744 usage: (logior &rest INTS-OR-MARKERS) */)
2749 return arith_driver (Alogior
, nargs
, args
);
2752 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2753 doc
: /* Return bitwise-exclusive-or of all the arguments.
2754 Arguments may be integers, or markers converted to integers.
2755 usage: (logxor &rest INTS-OR-MARKERS) */)
2760 return arith_driver (Alogxor
, nargs
, args
);
2763 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2764 doc
: /* Return VALUE with its bits shifted left by COUNT.
2765 If COUNT is negative, shifting is actually to the right.
2766 In this case, the sign bit is duplicated. */)
2768 register Lisp_Object value
, count
;
2770 register Lisp_Object val
;
2772 CHECK_NUMBER (value
);
2773 CHECK_NUMBER (count
);
2775 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2777 else if (XINT (count
) > 0)
2778 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2779 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2780 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2782 XSETINT (val
, XINT (value
) >> -XINT (count
));
2786 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2787 doc
: /* Return VALUE with its bits shifted left by COUNT.
2788 If COUNT is negative, shifting is actually to the right.
2789 In this case, zeros are shifted in on the left. */)
2791 register Lisp_Object value
, count
;
2793 register Lisp_Object val
;
2795 CHECK_NUMBER (value
);
2796 CHECK_NUMBER (count
);
2798 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2800 else if (XINT (count
) > 0)
2801 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2802 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2805 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2809 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2810 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2811 Markers are converted to integers. */)
2813 register Lisp_Object number
;
2815 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2817 if (FLOATP (number
))
2818 return (make_float (1.0 + XFLOAT_DATA (number
)));
2820 XSETINT (number
, XINT (number
) + 1);
2824 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2825 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2826 Markers are converted to integers. */)
2828 register Lisp_Object number
;
2830 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2832 if (FLOATP (number
))
2833 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2835 XSETINT (number
, XINT (number
) - 1);
2839 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2840 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2842 register Lisp_Object number
;
2844 CHECK_NUMBER (number
);
2845 XSETINT (number
, ~XINT (number
));
2852 Lisp_Object error_tail
, arith_tail
;
2854 Qquote
= intern ("quote");
2855 Qlambda
= intern ("lambda");
2856 Qsubr
= intern ("subr");
2857 Qerror_conditions
= intern ("error-conditions");
2858 Qerror_message
= intern ("error-message");
2859 Qtop_level
= intern ("top-level");
2861 Qerror
= intern ("error");
2862 Qquit
= intern ("quit");
2863 Qwrong_type_argument
= intern ("wrong-type-argument");
2864 Qargs_out_of_range
= intern ("args-out-of-range");
2865 Qvoid_function
= intern ("void-function");
2866 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2867 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2868 Qvoid_variable
= intern ("void-variable");
2869 Qsetting_constant
= intern ("setting-constant");
2870 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2872 Qinvalid_function
= intern ("invalid-function");
2873 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2874 Qno_catch
= intern ("no-catch");
2875 Qend_of_file
= intern ("end-of-file");
2876 Qarith_error
= intern ("arith-error");
2877 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2878 Qend_of_buffer
= intern ("end-of-buffer");
2879 Qbuffer_read_only
= intern ("buffer-read-only");
2880 Qtext_read_only
= intern ("text-read-only");
2881 Qmark_inactive
= intern ("mark-inactive");
2883 Qlistp
= intern ("listp");
2884 Qconsp
= intern ("consp");
2885 Qsymbolp
= intern ("symbolp");
2886 Qkeywordp
= intern ("keywordp");
2887 Qintegerp
= intern ("integerp");
2888 Qnatnump
= intern ("natnump");
2889 Qwholenump
= intern ("wholenump");
2890 Qstringp
= intern ("stringp");
2891 Qarrayp
= intern ("arrayp");
2892 Qsequencep
= intern ("sequencep");
2893 Qbufferp
= intern ("bufferp");
2894 Qvectorp
= intern ("vectorp");
2895 Qchar_or_string_p
= intern ("char-or-string-p");
2896 Qmarkerp
= intern ("markerp");
2897 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2898 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2899 Qboundp
= intern ("boundp");
2900 Qfboundp
= intern ("fboundp");
2902 Qfloatp
= intern ("floatp");
2903 Qnumberp
= intern ("numberp");
2904 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2906 Qchar_table_p
= intern ("char-table-p");
2907 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2909 Qsubrp
= intern ("subrp");
2910 Qunevalled
= intern ("unevalled");
2911 Qmany
= intern ("many");
2913 Qcdr
= intern ("cdr");
2915 /* Handle automatic advice activation */
2916 Qad_advice_info
= intern ("ad-advice-info");
2917 Qad_activate_internal
= intern ("ad-activate-internal");
2919 error_tail
= Fcons (Qerror
, Qnil
);
2921 /* ERROR is used as a signaler for random errors for which nothing else is right */
2923 Fput (Qerror
, Qerror_conditions
,
2925 Fput (Qerror
, Qerror_message
,
2926 build_string ("error"));
2928 Fput (Qquit
, Qerror_conditions
,
2929 Fcons (Qquit
, Qnil
));
2930 Fput (Qquit
, Qerror_message
,
2931 build_string ("Quit"));
2933 Fput (Qwrong_type_argument
, Qerror_conditions
,
2934 Fcons (Qwrong_type_argument
, error_tail
));
2935 Fput (Qwrong_type_argument
, Qerror_message
,
2936 build_string ("Wrong type argument"));
2938 Fput (Qargs_out_of_range
, Qerror_conditions
,
2939 Fcons (Qargs_out_of_range
, error_tail
));
2940 Fput (Qargs_out_of_range
, Qerror_message
,
2941 build_string ("Args out of range"));
2943 Fput (Qvoid_function
, Qerror_conditions
,
2944 Fcons (Qvoid_function
, error_tail
));
2945 Fput (Qvoid_function
, Qerror_message
,
2946 build_string ("Symbol's function definition is void"));
2948 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2949 Fcons (Qcyclic_function_indirection
, error_tail
));
2950 Fput (Qcyclic_function_indirection
, Qerror_message
,
2951 build_string ("Symbol's chain of function indirections contains a loop"));
2953 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2954 Fcons (Qcyclic_variable_indirection
, error_tail
));
2955 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2956 build_string ("Symbol's chain of variable indirections contains a loop"));
2958 Qcircular_list
= intern ("circular-list");
2959 staticpro (&Qcircular_list
);
2960 Fput (Qcircular_list
, Qerror_conditions
,
2961 Fcons (Qcircular_list
, error_tail
));
2962 Fput (Qcircular_list
, Qerror_message
,
2963 build_string ("List contains a loop"));
2965 Fput (Qvoid_variable
, Qerror_conditions
,
2966 Fcons (Qvoid_variable
, error_tail
));
2967 Fput (Qvoid_variable
, Qerror_message
,
2968 build_string ("Symbol's value as variable is void"));
2970 Fput (Qsetting_constant
, Qerror_conditions
,
2971 Fcons (Qsetting_constant
, error_tail
));
2972 Fput (Qsetting_constant
, Qerror_message
,
2973 build_string ("Attempt to set a constant symbol"));
2975 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2976 Fcons (Qinvalid_read_syntax
, error_tail
));
2977 Fput (Qinvalid_read_syntax
, Qerror_message
,
2978 build_string ("Invalid read syntax"));
2980 Fput (Qinvalid_function
, Qerror_conditions
,
2981 Fcons (Qinvalid_function
, error_tail
));
2982 Fput (Qinvalid_function
, Qerror_message
,
2983 build_string ("Invalid function"));
2985 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2986 Fcons (Qwrong_number_of_arguments
, error_tail
));
2987 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2988 build_string ("Wrong number of arguments"));
2990 Fput (Qno_catch
, Qerror_conditions
,
2991 Fcons (Qno_catch
, error_tail
));
2992 Fput (Qno_catch
, Qerror_message
,
2993 build_string ("No catch for tag"));
2995 Fput (Qend_of_file
, Qerror_conditions
,
2996 Fcons (Qend_of_file
, error_tail
));
2997 Fput (Qend_of_file
, Qerror_message
,
2998 build_string ("End of file during parsing"));
3000 arith_tail
= Fcons (Qarith_error
, error_tail
);
3001 Fput (Qarith_error
, Qerror_conditions
,
3003 Fput (Qarith_error
, Qerror_message
,
3004 build_string ("Arithmetic error"));
3006 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3007 Fcons (Qbeginning_of_buffer
, error_tail
));
3008 Fput (Qbeginning_of_buffer
, Qerror_message
,
3009 build_string ("Beginning of buffer"));
3011 Fput (Qend_of_buffer
, Qerror_conditions
,
3012 Fcons (Qend_of_buffer
, error_tail
));
3013 Fput (Qend_of_buffer
, Qerror_message
,
3014 build_string ("End of buffer"));
3016 Fput (Qbuffer_read_only
, Qerror_conditions
,
3017 Fcons (Qbuffer_read_only
, error_tail
));
3018 Fput (Qbuffer_read_only
, Qerror_message
,
3019 build_string ("Buffer is read-only"));
3021 Fput (Qtext_read_only
, Qerror_conditions
,
3022 Fcons (Qtext_read_only
, error_tail
));
3023 Fput (Qtext_read_only
, Qerror_message
,
3024 build_string ("Text is read-only"));
3026 Qrange_error
= intern ("range-error");
3027 Qdomain_error
= intern ("domain-error");
3028 Qsingularity_error
= intern ("singularity-error");
3029 Qoverflow_error
= intern ("overflow-error");
3030 Qunderflow_error
= intern ("underflow-error");
3032 Fput (Qdomain_error
, Qerror_conditions
,
3033 Fcons (Qdomain_error
, arith_tail
));
3034 Fput (Qdomain_error
, Qerror_message
,
3035 build_string ("Arithmetic domain error"));
3037 Fput (Qrange_error
, Qerror_conditions
,
3038 Fcons (Qrange_error
, arith_tail
));
3039 Fput (Qrange_error
, Qerror_message
,
3040 build_string ("Arithmetic range error"));
3042 Fput (Qsingularity_error
, Qerror_conditions
,
3043 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3044 Fput (Qsingularity_error
, Qerror_message
,
3045 build_string ("Arithmetic singularity error"));
3047 Fput (Qoverflow_error
, Qerror_conditions
,
3048 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3049 Fput (Qoverflow_error
, Qerror_message
,
3050 build_string ("Arithmetic overflow error"));
3052 Fput (Qunderflow_error
, Qerror_conditions
,
3053 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3054 Fput (Qunderflow_error
, Qerror_message
,
3055 build_string ("Arithmetic underflow error"));
3057 staticpro (&Qrange_error
);
3058 staticpro (&Qdomain_error
);
3059 staticpro (&Qsingularity_error
);
3060 staticpro (&Qoverflow_error
);
3061 staticpro (&Qunderflow_error
);
3065 staticpro (&Qquote
);
3066 staticpro (&Qlambda
);
3068 staticpro (&Qunbound
);
3069 staticpro (&Qerror_conditions
);
3070 staticpro (&Qerror_message
);
3071 staticpro (&Qtop_level
);
3073 staticpro (&Qerror
);
3075 staticpro (&Qwrong_type_argument
);
3076 staticpro (&Qargs_out_of_range
);
3077 staticpro (&Qvoid_function
);
3078 staticpro (&Qcyclic_function_indirection
);
3079 staticpro (&Qvoid_variable
);
3080 staticpro (&Qsetting_constant
);
3081 staticpro (&Qinvalid_read_syntax
);
3082 staticpro (&Qwrong_number_of_arguments
);
3083 staticpro (&Qinvalid_function
);
3084 staticpro (&Qno_catch
);
3085 staticpro (&Qend_of_file
);
3086 staticpro (&Qarith_error
);
3087 staticpro (&Qbeginning_of_buffer
);
3088 staticpro (&Qend_of_buffer
);
3089 staticpro (&Qbuffer_read_only
);
3090 staticpro (&Qtext_read_only
);
3091 staticpro (&Qmark_inactive
);
3093 staticpro (&Qlistp
);
3094 staticpro (&Qconsp
);
3095 staticpro (&Qsymbolp
);
3096 staticpro (&Qkeywordp
);
3097 staticpro (&Qintegerp
);
3098 staticpro (&Qnatnump
);
3099 staticpro (&Qwholenump
);
3100 staticpro (&Qstringp
);
3101 staticpro (&Qarrayp
);
3102 staticpro (&Qsequencep
);
3103 staticpro (&Qbufferp
);
3104 staticpro (&Qvectorp
);
3105 staticpro (&Qchar_or_string_p
);
3106 staticpro (&Qmarkerp
);
3107 staticpro (&Qbuffer_or_string_p
);
3108 staticpro (&Qinteger_or_marker_p
);
3109 staticpro (&Qfloatp
);
3110 staticpro (&Qnumberp
);
3111 staticpro (&Qnumber_or_marker_p
);
3112 staticpro (&Qchar_table_p
);
3113 staticpro (&Qvector_or_char_table_p
);
3114 staticpro (&Qsubrp
);
3116 staticpro (&Qunevalled
);
3118 staticpro (&Qboundp
);
3119 staticpro (&Qfboundp
);
3121 staticpro (&Qad_advice_info
);
3122 staticpro (&Qad_activate_internal
);
3124 /* Types that type-of returns. */
3125 Qinteger
= intern ("integer");
3126 Qsymbol
= intern ("symbol");
3127 Qstring
= intern ("string");
3128 Qcons
= intern ("cons");
3129 Qmarker
= intern ("marker");
3130 Qoverlay
= intern ("overlay");
3131 Qfloat
= intern ("float");
3132 Qwindow_configuration
= intern ("window-configuration");
3133 Qprocess
= intern ("process");
3134 Qwindow
= intern ("window");
3135 /* Qsubr = intern ("subr"); */
3136 Qcompiled_function
= intern ("compiled-function");
3137 Qbuffer
= intern ("buffer");
3138 Qframe
= intern ("frame");
3139 Qvector
= intern ("vector");
3140 Qchar_table
= intern ("char-table");
3141 Qbool_vector
= intern ("bool-vector");
3142 Qhash_table
= intern ("hash-table");
3144 staticpro (&Qinteger
);
3145 staticpro (&Qsymbol
);
3146 staticpro (&Qstring
);
3148 staticpro (&Qmarker
);
3149 staticpro (&Qoverlay
);
3150 staticpro (&Qfloat
);
3151 staticpro (&Qwindow_configuration
);
3152 staticpro (&Qprocess
);
3153 staticpro (&Qwindow
);
3154 /* staticpro (&Qsubr); */
3155 staticpro (&Qcompiled_function
);
3156 staticpro (&Qbuffer
);
3157 staticpro (&Qframe
);
3158 staticpro (&Qvector
);
3159 staticpro (&Qchar_table
);
3160 staticpro (&Qbool_vector
);
3161 staticpro (&Qhash_table
);
3163 defsubr (&Sindirect_variable
);
3164 defsubr (&Ssubr_interactive_form
);
3167 defsubr (&Stype_of
);
3172 defsubr (&Sintegerp
);
3173 defsubr (&Sinteger_or_marker_p
);
3174 defsubr (&Snumberp
);
3175 defsubr (&Snumber_or_marker_p
);
3177 defsubr (&Snatnump
);
3178 defsubr (&Ssymbolp
);
3179 defsubr (&Skeywordp
);
3180 defsubr (&Sstringp
);
3181 defsubr (&Smultibyte_string_p
);
3182 defsubr (&Svectorp
);
3183 defsubr (&Schar_table_p
);
3184 defsubr (&Svector_or_char_table_p
);
3185 defsubr (&Sbool_vector_p
);
3187 defsubr (&Ssequencep
);
3188 defsubr (&Sbufferp
);
3189 defsubr (&Smarkerp
);
3191 defsubr (&Sbyte_code_function_p
);
3192 defsubr (&Schar_or_string_p
);
3195 defsubr (&Scar_safe
);
3196 defsubr (&Scdr_safe
);
3199 defsubr (&Ssymbol_function
);
3200 defsubr (&Sindirect_function
);
3201 defsubr (&Ssymbol_plist
);
3202 defsubr (&Ssymbol_name
);
3203 defsubr (&Smakunbound
);
3204 defsubr (&Sfmakunbound
);
3206 defsubr (&Sfboundp
);
3208 defsubr (&Sdefalias
);
3209 defsubr (&Ssetplist
);
3210 defsubr (&Ssymbol_value
);
3212 defsubr (&Sdefault_boundp
);
3213 defsubr (&Sdefault_value
);
3214 defsubr (&Sset_default
);
3215 defsubr (&Ssetq_default
);
3216 defsubr (&Smake_variable_buffer_local
);
3217 defsubr (&Smake_local_variable
);
3218 defsubr (&Skill_local_variable
);
3219 defsubr (&Smake_variable_frame_local
);
3220 defsubr (&Slocal_variable_p
);
3221 defsubr (&Slocal_variable_if_set_p
);
3222 defsubr (&Svariable_binding_locus
);
3225 defsubr (&Snumber_to_string
);
3226 defsubr (&Sstring_to_number
);
3227 defsubr (&Seqlsign
);
3250 defsubr (&Ssubr_arity
);
3252 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3254 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3255 doc
: /* The largest value that is representable in a Lisp integer. */);
3256 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3258 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3259 doc
: /* The smallest value that is representable in a Lisp integer. */);
3260 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3267 #if defined(USG) && !defined(POSIX_SIGNALS)
3268 /* USG systems forget handlers when they are used;
3269 must reestablish each time */
3270 signal (signo
, arith_error
);
3273 /* VMS systems are like USG. */
3274 signal (signo
, arith_error
);
3278 #else /* not BSD4_1 */
3279 sigsetmask (SIGEMPTYMASK
);
3280 #endif /* not BSD4_1 */
3282 Fsignal (Qarith_error
, Qnil
);
3288 /* Don't do this if just dumping out.
3289 We don't want to call `signal' in this case
3290 so that we don't have trouble with dumping
3291 signal-delivering routines in an inconsistent state. */
3295 #endif /* CANNOT_DUMP */
3296 signal (SIGFPE
, arith_error
);
3299 signal (SIGEMT
, arith_error
);
3303 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3304 (do not change this comment) */