1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
32 #include "syssignal.h"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
69 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
70 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
71 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
72 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
73 Lisp_Object Qtext_read_only
;
74 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
75 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
76 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
77 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
78 Lisp_Object Qboundp
, Qfboundp
;
79 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
82 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
84 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
85 Lisp_Object Qoverflow_error
, Qunderflow_error
;
88 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
90 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
91 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
93 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
94 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
95 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
97 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
99 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 && XSTRING (SYMBOL_NAME (object
))->data
[0] == ':'
315 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
320 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a vector. */)
325 if (VECTORP (object
))
330 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
331 doc
: /* Return t if OBJECT is a string. */)
335 if (STRINGP (object
))
340 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
342 doc
: /* Return t if OBJECT is a multibyte string. */)
346 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
351 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a char-table. */)
356 if (CHAR_TABLE_P (object
))
361 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
362 Svector_or_char_table_p
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a char-table or vector. */)
367 if (VECTORP (object
) || CHAR_TABLE_P (object
))
372 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
373 doc
: /* Return t if OBJECT is a bool-vector. */)
377 if (BOOL_VECTOR_P (object
))
382 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 if (VECTORP (object
) || STRINGP (object
)
388 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
393 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
394 doc
: /* Return t if OBJECT is a sequence (list or array). */)
396 register Lisp_Object object
;
398 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
399 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
404 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is an editor buffer. */)
409 if (BUFFERP (object
))
414 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
419 if (MARKERP (object
))
424 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a built-in function. */)
434 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
436 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
440 if (COMPILEDP (object
))
445 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
446 doc
: /* Return t if OBJECT is a character (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. */)
633 register Lisp_Object symbol
;
635 CHECK_SYMBOL (symbol
);
636 if (XSYMBOL (symbol
)->constant
)
637 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
638 Fset (symbol
, Qunbound
);
642 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
643 doc
: /* Make SYMBOL's function definition be void. */)
645 register Lisp_Object symbol
;
647 CHECK_SYMBOL (symbol
);
648 if (NILP (symbol
) || EQ (symbol
, Qt
))
649 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
650 XSYMBOL (symbol
)->function
= Qunbound
;
654 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
655 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
657 register Lisp_Object symbol
;
659 CHECK_SYMBOL (symbol
);
660 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
661 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
662 return XSYMBOL (symbol
)->function
;
665 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
666 doc
: /* Return SYMBOL's property list. */)
668 register Lisp_Object symbol
;
670 CHECK_SYMBOL (symbol
);
671 return XSYMBOL (symbol
)->plist
;
674 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
675 doc
: /* Return SYMBOL's name, a string. */)
677 register Lisp_Object symbol
;
679 register Lisp_Object name
;
681 CHECK_SYMBOL (symbol
);
682 name
= SYMBOL_NAME (symbol
);
686 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
687 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
689 register Lisp_Object symbol
, definition
;
691 CHECK_SYMBOL (symbol
);
692 if (NILP (symbol
) || EQ (symbol
, Qt
))
693 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
694 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
695 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
697 XSYMBOL (symbol
)->function
= definition
;
698 /* Handle automatic advice activation */
699 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
701 call2 (Qad_activate_internal
, symbol
, Qnil
);
702 definition
= XSYMBOL (symbol
)->function
;
707 extern Lisp_Object Qfunction_documentation
;
709 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
710 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
711 Associates the function with the current load file, if any. */)
712 (symbol
, definition
, docstring
)
713 register Lisp_Object symbol
, definition
, docstring
;
715 definition
= Ffset (symbol
, definition
);
716 LOADHIST_ATTACH (symbol
);
717 if (!NILP (docstring
))
718 Fput (symbol
, Qfunction_documentation
, docstring
);
722 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
723 doc
: /* Set SYMBOL's property list to NEWVAL, and return NEWVAL. */)
725 register Lisp_Object symbol
, newplist
;
727 CHECK_SYMBOL (symbol
);
728 XSYMBOL (symbol
)->plist
= newplist
;
732 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
733 doc
: /* Return minimum and maximum number of args allowed for SUBR.
734 SUBR must be a built-in function.
735 The returned value is a pair (MIN . MAX). MIN is the minimum number
736 of args. MAX is the maximum number or the symbol `many', for a
737 function with `&rest' args, or `unevalled' for a special form. */)
741 short minargs
, maxargs
;
743 wrong_type_argument (Qsubrp
, subr
);
744 minargs
= XSUBR (subr
)->min_args
;
745 maxargs
= XSUBR (subr
)->max_args
;
747 return Fcons (make_number (minargs
), Qmany
);
748 else if (maxargs
== UNEVALLED
)
749 return Fcons (make_number (minargs
), Qunevalled
);
751 return Fcons (make_number (minargs
), make_number (maxargs
));
754 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
755 doc
: /* Return the interactive form of SUBR or nil if none.
756 SUBR must be a built-in function. Value, if non-nil, is a list
757 \(interactive SPEC). */)
762 wrong_type_argument (Qsubrp
, subr
);
763 if (XSUBR (subr
)->prompt
)
764 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
769 /***********************************************************************
770 Getting and Setting Values of Symbols
771 ***********************************************************************/
773 /* Return the symbol holding SYMBOL's value. Signal
774 `cyclic-variable-indirection' if SYMBOL's chain of variable
775 indirections contains a loop. */
778 indirect_variable (symbol
)
781 Lisp_Object tortoise
, hare
;
783 hare
= tortoise
= symbol
;
785 while (XSYMBOL (hare
)->indirect_variable
)
787 hare
= XSYMBOL (hare
)->value
;
788 if (!XSYMBOL (hare
)->indirect_variable
)
791 hare
= XSYMBOL (hare
)->value
;
792 tortoise
= XSYMBOL (tortoise
)->value
;
794 if (EQ (hare
, tortoise
))
795 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
802 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
803 doc
: /* Return the variable at the end of OBJECT's variable chain.
804 If OBJECT is a symbol, follow all variable indirections and return the final
805 variable. If OBJECT is not a symbol, just return it.
806 Signal a cyclic-variable-indirection error if there is a loop in the
807 variable chain of symbols. */)
811 if (SYMBOLP (object
))
812 object
= indirect_variable (object
);
817 /* Given the raw contents of a symbol value cell,
818 return the Lisp value of the symbol.
819 This does not handle buffer-local variables; use
820 swap_in_symval_forwarding for that. */
823 do_symval_forwarding (valcontents
)
824 register Lisp_Object valcontents
;
826 register Lisp_Object val
;
828 if (MISCP (valcontents
))
829 switch (XMISCTYPE (valcontents
))
831 case Lisp_Misc_Intfwd
:
832 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
835 case Lisp_Misc_Boolfwd
:
836 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
838 case Lisp_Misc_Objfwd
:
839 return *XOBJFWD (valcontents
)->objvar
;
841 case Lisp_Misc_Buffer_Objfwd
:
842 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
843 return PER_BUFFER_VALUE (current_buffer
, offset
);
845 case Lisp_Misc_Kboard_Objfwd
:
846 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
847 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
852 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
853 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
854 buffer-independent contents of the value cell: forwarded just one
855 step past the buffer-localness.
857 BUF non-zero means set the value in buffer BUF instead of the
858 current buffer. This only plays a role for per-buffer variables. */
861 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
863 register Lisp_Object valcontents
, newval
;
866 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
869 switch (XMISCTYPE (valcontents
))
871 case Lisp_Misc_Intfwd
:
872 CHECK_NUMBER (newval
);
873 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
874 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
875 error ("Value out of range for variable `%s'",
876 XSTRING (SYMBOL_NAME (symbol
))->data
);
879 case Lisp_Misc_Boolfwd
:
880 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
883 case Lisp_Misc_Objfwd
:
884 *XOBJFWD (valcontents
)->objvar
= newval
;
887 case Lisp_Misc_Buffer_Objfwd
:
889 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
892 type
= PER_BUFFER_TYPE (offset
);
893 if (XINT (type
) == -1)
894 error ("Variable %s is read-only", XSTRING (SYMBOL_NAME (symbol
))->data
);
896 if (! NILP (type
) && ! NILP (newval
)
897 && XTYPE (newval
) != XINT (type
))
898 buffer_slot_type_mismatch (offset
);
901 buf
= current_buffer
;
902 PER_BUFFER_VALUE (buf
, offset
) = newval
;
906 case Lisp_Misc_Kboard_Objfwd
:
908 char *base
= (char *) current_kboard
;
909 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
910 *(Lisp_Object
*) p
= newval
;
921 valcontents
= SYMBOL_VALUE (symbol
);
922 if (BUFFER_LOCAL_VALUEP (valcontents
)
923 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
924 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
926 SET_SYMBOL_VALUE (symbol
, newval
);
930 /* Set up SYMBOL to refer to its global binding.
931 This makes it safe to alter the status of other bindings. */
934 swap_in_global_binding (symbol
)
937 Lisp_Object valcontents
, cdr
;
939 valcontents
= SYMBOL_VALUE (symbol
);
940 if (!BUFFER_LOCAL_VALUEP (valcontents
)
941 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
943 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
945 /* Unload the previously loaded binding. */
947 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
949 /* Select the global binding in the symbol. */
951 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
953 /* Indicate that the global binding is set up now. */
954 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
955 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
956 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
957 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
960 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
961 VALCONTENTS is the contents of its value cell,
962 which points to a struct Lisp_Buffer_Local_Value.
964 Return the value forwarded one step past the buffer-local stage.
965 This could be another forwarding pointer. */
968 swap_in_symval_forwarding (symbol
, valcontents
)
969 Lisp_Object symbol
, valcontents
;
971 register Lisp_Object tem1
;
973 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
976 || current_buffer
!= XBUFFER (tem1
)
977 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
978 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
980 if (XSYMBOL (symbol
)->indirect_variable
)
981 symbol
= indirect_variable (symbol
);
983 /* Unload the previously loaded binding. */
984 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
986 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
987 /* Choose the new binding. */
988 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
989 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
990 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
993 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
994 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
996 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
998 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1001 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1003 /* Load the new binding. */
1004 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1005 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1006 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1007 store_symval_forwarding (symbol
,
1008 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1011 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1014 /* Find the value of a symbol, returning Qunbound if it's not bound.
1015 This is helpful for code which just wants to get a variable's value
1016 if it has one, without signaling an error.
1017 Note that it must not be possible to quit
1018 within this function. Great care is required for this. */
1021 find_symbol_value (symbol
)
1024 register Lisp_Object valcontents
;
1025 register Lisp_Object val
;
1027 CHECK_SYMBOL (symbol
);
1028 valcontents
= SYMBOL_VALUE (symbol
);
1030 if (BUFFER_LOCAL_VALUEP (valcontents
)
1031 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1032 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1034 if (MISCP (valcontents
))
1036 switch (XMISCTYPE (valcontents
))
1038 case Lisp_Misc_Intfwd
:
1039 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1042 case Lisp_Misc_Boolfwd
:
1043 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1045 case Lisp_Misc_Objfwd
:
1046 return *XOBJFWD (valcontents
)->objvar
;
1048 case Lisp_Misc_Buffer_Objfwd
:
1049 return PER_BUFFER_VALUE (current_buffer
,
1050 XBUFFER_OBJFWD (valcontents
)->offset
);
1052 case Lisp_Misc_Kboard_Objfwd
:
1053 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1054 + (char *)current_kboard
);
1061 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1062 doc
: /* Return SYMBOL's value. Error if that is void. */)
1068 val
= find_symbol_value (symbol
);
1069 if (EQ (val
, Qunbound
))
1070 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1075 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1076 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1078 register Lisp_Object symbol
, newval
;
1080 return set_internal (symbol
, newval
, current_buffer
, 0);
1083 /* Return 1 if SYMBOL currently has a let-binding
1084 which was made in the buffer that is now current. */
1087 let_shadows_buffer_binding_p (symbol
)
1090 struct specbinding
*p
;
1092 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1094 && CONSP (p
->symbol
))
1096 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1097 if ((EQ (symbol
, let_bound_symbol
)
1098 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1099 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1100 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1104 return p
>= specpdl
;
1107 /* Store the value NEWVAL into SYMBOL.
1108 If buffer-locality is an issue, BUF specifies which buffer to use.
1109 (0 stands for the current buffer.)
1111 If BINDFLAG is zero, then if this symbol is supposed to become
1112 local in every buffer where it is set, then we make it local.
1113 If BINDFLAG is nonzero, we don't do that. */
1116 set_internal (symbol
, newval
, buf
, bindflag
)
1117 register Lisp_Object symbol
, newval
;
1121 int voide
= EQ (newval
, Qunbound
);
1123 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1126 buf
= current_buffer
;
1128 /* If restoring in a dead buffer, do nothing. */
1129 if (NILP (buf
->name
))
1132 CHECK_SYMBOL (symbol
);
1133 if (SYMBOL_CONSTANT_P (symbol
)
1134 && (NILP (Fkeywordp (symbol
))
1135 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1136 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1138 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1140 if (BUFFER_OBJFWDP (valcontents
))
1142 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1143 int idx
= PER_BUFFER_IDX (offset
);
1146 && !let_shadows_buffer_binding_p (symbol
))
1147 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1149 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1150 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1152 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1153 if (XSYMBOL (symbol
)->indirect_variable
)
1154 symbol
= indirect_variable (symbol
);
1156 /* What binding is loaded right now? */
1157 current_alist_element
1158 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1160 /* If the current buffer is not the buffer whose binding is
1161 loaded, or if there may be frame-local bindings and the frame
1162 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1163 the default binding is loaded, the loaded binding may be the
1165 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1166 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1167 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1168 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1169 || (BUFFER_LOCAL_VALUEP (valcontents
)
1170 && EQ (XCAR (current_alist_element
),
1171 current_alist_element
)))
1173 /* The currently loaded binding is not necessarily valid.
1174 We need to unload it, and choose a new binding. */
1176 /* Write out `realvalue' to the old loaded binding. */
1177 Fsetcdr (current_alist_element
,
1178 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1180 /* Find the new binding. */
1181 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1182 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1183 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1187 /* This buffer still sees the default value. */
1189 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1190 or if this is `let' rather than `set',
1191 make CURRENT-ALIST-ELEMENT point to itself,
1192 indicating that we're seeing the default value.
1193 Likewise if the variable has been let-bound
1194 in the current buffer. */
1195 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1196 || let_shadows_buffer_binding_p (symbol
))
1198 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1200 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1201 tem1
= Fassq (symbol
,
1202 XFRAME (selected_frame
)->param_alist
);
1205 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1207 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1209 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1210 and we're not within a let that was made for this buffer,
1211 create a new buffer-local binding for the variable.
1212 That means, give this buffer a new assoc for a local value
1213 and load that binding. */
1216 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1217 buf
->local_var_alist
1218 = Fcons (tem1
, buf
->local_var_alist
);
1222 /* Record which binding is now loaded. */
1223 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1226 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1227 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1228 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1230 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1233 /* If storing void (making the symbol void), forward only through
1234 buffer-local indicator, not through Lisp_Objfwd, etc. */
1236 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1238 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1240 /* If we just set a variable whose current binding is frame-local,
1241 store the new value in the frame parameter too. */
1243 if (BUFFER_LOCAL_VALUEP (valcontents
)
1244 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1246 /* What binding is loaded right now? */
1247 current_alist_element
1248 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1250 /* If the current buffer is not the buffer whose binding is
1251 loaded, or if there may be frame-local bindings and the frame
1252 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1253 the default binding is loaded, the loaded binding may be the
1255 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1256 XSETCDR (current_alist_element
, newval
);
1262 /* Access or set a buffer-local symbol's default value. */
1264 /* Return the default value of SYMBOL, but don't check for voidness.
1265 Return Qunbound if it is void. */
1268 default_value (symbol
)
1271 register Lisp_Object valcontents
;
1273 CHECK_SYMBOL (symbol
);
1274 valcontents
= SYMBOL_VALUE (symbol
);
1276 /* For a built-in buffer-local variable, get the default value
1277 rather than letting do_symval_forwarding get the current value. */
1278 if (BUFFER_OBJFWDP (valcontents
))
1280 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1281 if (PER_BUFFER_IDX (offset
) != 0)
1282 return PER_BUFFER_DEFAULT (offset
);
1285 /* Handle user-created local variables. */
1286 if (BUFFER_LOCAL_VALUEP (valcontents
)
1287 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1289 /* If var is set up for a buffer that lacks a local value for it,
1290 the current value is nominally the default value.
1291 But the `realvalue' slot may be more up to date, since
1292 ordinary setq stores just that slot. So use that. */
1293 Lisp_Object current_alist_element
, alist_element_car
;
1294 current_alist_element
1295 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1296 alist_element_car
= XCAR (current_alist_element
);
1297 if (EQ (alist_element_car
, current_alist_element
))
1298 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1300 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1302 /* For other variables, get the current value. */
1303 return do_symval_forwarding (valcontents
);
1306 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1307 doc
: /* Return t if SYMBOL has a non-void default value.
1308 This is the value that is seen in buffers that do not have their own values
1309 for this variable. */)
1313 register Lisp_Object value
;
1315 value
= default_value (symbol
);
1316 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1319 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1320 doc
: /* Return SYMBOL's default value.
1321 This is the value that is seen in buffers that do not have their own values
1322 for this variable. The default value is meaningful for variables with
1323 local bindings in certain buffers. */)
1327 register Lisp_Object value
;
1329 value
= default_value (symbol
);
1330 if (EQ (value
, Qunbound
))
1331 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1335 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1336 doc
: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1337 The default value is seen in buffers that do not have their own values
1338 for this variable. */)
1340 Lisp_Object symbol
, value
;
1342 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1344 CHECK_SYMBOL (symbol
);
1345 valcontents
= SYMBOL_VALUE (symbol
);
1347 /* Handle variables like case-fold-search that have special slots
1348 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1350 if (BUFFER_OBJFWDP (valcontents
))
1352 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1353 int idx
= PER_BUFFER_IDX (offset
);
1355 PER_BUFFER_DEFAULT (offset
) = value
;
1357 /* If this variable is not always local in all buffers,
1358 set it in the buffers that don't nominally have a local value. */
1363 for (b
= all_buffers
; b
; b
= b
->next
)
1364 if (!PER_BUFFER_VALUE_P (b
, idx
))
1365 PER_BUFFER_VALUE (b
, offset
) = value
;
1370 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1371 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1372 return Fset (symbol
, value
);
1374 /* Store new value into the DEFAULT-VALUE slot. */
1375 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1377 /* If the default binding is now loaded, set the REALVALUE slot too. */
1378 current_alist_element
1379 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1380 alist_element_buffer
= Fcar (current_alist_element
);
1381 if (EQ (alist_element_buffer
, current_alist_element
))
1382 store_symval_forwarding (symbol
,
1383 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1389 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1390 doc
: /* Set the default value of variable VAR to VALUE.
1391 VAR, the variable name, is literal (not evaluated);
1392 VALUE is an expression and it is evaluated.
1393 The default value of a variable is seen in buffers
1394 that do not have their own values for the variable.
1396 More generally, you can use multiple variables and values, as in
1397 (setq-default SYMBOL VALUE SYMBOL VALUE...)
1398 This sets each SYMBOL's default value to the corresponding VALUE.
1399 The VALUE for the Nth SYMBOL can refer to the new default values
1401 usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */)
1405 register Lisp_Object args_left
;
1406 register Lisp_Object val
, symbol
;
1407 struct gcpro gcpro1
;
1417 val
= Feval (Fcar (Fcdr (args_left
)));
1418 symbol
= XCAR (args_left
);
1419 Fset_default (symbol
, val
);
1420 args_left
= Fcdr (XCDR (args_left
));
1422 while (!NILP (args_left
));
1428 /* Lisp functions for creating and removing buffer-local variables. */
1430 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1431 1, 1, "vMake Variable Buffer Local: ",
1432 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1433 At any time, the value for the current buffer is in effect,
1434 unless the variable has never been set in this buffer,
1435 in which case the default value is in effect.
1436 Note that binding the variable with `let', or setting it while
1437 a `let'-style binding made in this buffer is in effect,
1438 does not make the variable buffer-local.
1440 The function `default-value' gets the default value and `set-default' sets it. */)
1442 register Lisp_Object variable
;
1444 register Lisp_Object tem
, valcontents
, newval
;
1446 CHECK_SYMBOL (variable
);
1448 valcontents
= SYMBOL_VALUE (variable
);
1449 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1450 error ("Symbol %s may not be buffer-local", XSTRING (SYMBOL_NAME (variable
))->data
);
1452 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1454 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1456 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1459 if (EQ (valcontents
, Qunbound
))
1460 SET_SYMBOL_VALUE (variable
, Qnil
);
1461 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1463 newval
= allocate_misc ();
1464 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1465 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1466 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1467 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1468 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1469 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1470 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1471 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1472 SET_SYMBOL_VALUE (variable
, newval
);
1476 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1477 1, 1, "vMake Local Variable: ",
1478 doc
: /* Make VARIABLE have a separate value in the current buffer.
1479 Other buffers will continue to share a common default value.
1480 \(The buffer-local value of VARIABLE starts out as the same value
1481 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1482 See also `make-variable-buffer-local'.
1484 If the variable is already arranged to become local when set,
1485 this function causes a local value to exist for this buffer,
1486 just as setting the variable would do.
1488 This function returns VARIABLE, and therefore
1489 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1492 Do not use `make-local-variable' to make a hook variable buffer-local.
1493 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1495 register Lisp_Object variable
;
1497 register Lisp_Object tem
, valcontents
;
1499 CHECK_SYMBOL (variable
);
1501 valcontents
= SYMBOL_VALUE (variable
);
1502 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1503 error ("Symbol %s may not be buffer-local", XSTRING (SYMBOL_NAME (variable
))->data
);
1505 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1507 tem
= Fboundp (variable
);
1509 /* Make sure the symbol has a local value in this particular buffer,
1510 by setting it to the same value it already has. */
1511 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1514 /* Make sure symbol is set up to hold per-buffer values. */
1515 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1518 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1520 newval
= allocate_misc ();
1521 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1522 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1523 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1524 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1525 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1526 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1527 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1528 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1529 SET_SYMBOL_VALUE (variable
, newval
);;
1531 /* Make sure this buffer has its own value of symbol. */
1532 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1535 /* Swap out any local binding for some other buffer, and make
1536 sure the current value is permanently recorded, if it's the
1538 find_symbol_value (variable
);
1540 current_buffer
->local_var_alist
1541 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1542 current_buffer
->local_var_alist
);
1544 /* Make sure symbol does not think it is set up for this buffer;
1545 force it to look once again for this buffer's value. */
1547 Lisp_Object
*pvalbuf
;
1549 valcontents
= SYMBOL_VALUE (variable
);
1551 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1552 if (current_buffer
== XBUFFER (*pvalbuf
))
1554 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1558 /* If the symbol forwards into a C variable, then load the binding
1559 for this buffer now. If C code modifies the variable before we
1560 load the binding in, then that new value will clobber the default
1561 binding the next time we unload it. */
1562 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1563 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1564 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1569 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1570 1, 1, "vKill Local Variable: ",
1571 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1572 From now on the default value will apply in this buffer. */)
1574 register Lisp_Object variable
;
1576 register Lisp_Object tem
, valcontents
;
1578 CHECK_SYMBOL (variable
);
1580 valcontents
= SYMBOL_VALUE (variable
);
1582 if (BUFFER_OBJFWDP (valcontents
))
1584 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1585 int idx
= PER_BUFFER_IDX (offset
);
1589 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1590 PER_BUFFER_VALUE (current_buffer
, offset
)
1591 = PER_BUFFER_DEFAULT (offset
);
1596 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1597 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1600 /* Get rid of this buffer's alist element, if any. */
1602 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1604 current_buffer
->local_var_alist
1605 = Fdelq (tem
, current_buffer
->local_var_alist
);
1607 /* If the symbol is set up with the current buffer's binding
1608 loaded, recompute its value. We have to do it now, or else
1609 forwarded objects won't work right. */
1611 Lisp_Object
*pvalbuf
;
1612 valcontents
= SYMBOL_VALUE (variable
);
1613 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1614 if (current_buffer
== XBUFFER (*pvalbuf
))
1617 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1618 find_symbol_value (variable
);
1625 /* Lisp functions for creating and removing buffer-local variables. */
1627 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1628 1, 1, "vMake Variable Frame Local: ",
1629 doc
: /* Enable VARIABLE to have frame-local bindings.
1630 When a frame-local binding exists in the current frame,
1631 it is in effect whenever the current buffer has no buffer-local binding.
1632 A frame-local binding is actual a frame parameter value;
1633 thus, any given frame has a local binding for VARIABLE
1634 if it has a value for the frame parameter named VARIABLE.
1635 See `modify-frame-parameters'. */)
1637 register Lisp_Object variable
;
1639 register Lisp_Object tem
, valcontents
, newval
;
1641 CHECK_SYMBOL (variable
);
1643 valcontents
= SYMBOL_VALUE (variable
);
1644 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1645 || BUFFER_OBJFWDP (valcontents
))
1646 error ("Symbol %s may not be frame-local", XSTRING (SYMBOL_NAME (variable
))->data
);
1648 if (BUFFER_LOCAL_VALUEP (valcontents
)
1649 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1651 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1655 if (EQ (valcontents
, Qunbound
))
1656 SET_SYMBOL_VALUE (variable
, Qnil
);
1657 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1659 newval
= allocate_misc ();
1660 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1661 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1662 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1663 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1664 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1665 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1666 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1667 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1668 SET_SYMBOL_VALUE (variable
, newval
);
1672 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1674 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1675 BUFFER defaults to the current buffer. */)
1677 register Lisp_Object variable
, buffer
;
1679 Lisp_Object valcontents
;
1680 register struct buffer
*buf
;
1683 buf
= current_buffer
;
1686 CHECK_BUFFER (buffer
);
1687 buf
= XBUFFER (buffer
);
1690 CHECK_SYMBOL (variable
);
1692 valcontents
= SYMBOL_VALUE (variable
);
1693 if (BUFFER_LOCAL_VALUEP (valcontents
)
1694 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1696 Lisp_Object tail
, elt
;
1698 variable
= indirect_variable (variable
);
1699 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1702 if (EQ (variable
, XCAR (elt
)))
1706 if (BUFFER_OBJFWDP (valcontents
))
1708 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1709 int idx
= PER_BUFFER_IDX (offset
);
1710 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1716 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1718 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
1719 BUFFER defaults to the current buffer. */)
1721 register Lisp_Object variable
, buffer
;
1723 Lisp_Object valcontents
;
1724 register struct buffer
*buf
;
1727 buf
= current_buffer
;
1730 CHECK_BUFFER (buffer
);
1731 buf
= XBUFFER (buffer
);
1734 CHECK_SYMBOL (variable
);
1736 valcontents
= SYMBOL_VALUE (variable
);
1738 /* This means that make-variable-buffer-local was done. */
1739 if (BUFFER_LOCAL_VALUEP (valcontents
))
1741 /* All these slots become local if they are set. */
1742 if (BUFFER_OBJFWDP (valcontents
))
1744 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1746 Lisp_Object tail
, elt
;
1747 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1750 if (EQ (variable
, XCAR (elt
)))
1757 /* Find the function at the end of a chain of symbol function indirections. */
1759 /* If OBJECT is a symbol, find the end of its function chain and
1760 return the value found there. If OBJECT is not a symbol, just
1761 return it. If there is a cycle in the function chain, signal a
1762 cyclic-function-indirection error.
1764 This is like Findirect_function, except that it doesn't signal an
1765 error if the chain ends up unbound. */
1767 indirect_function (object
)
1768 register Lisp_Object object
;
1770 Lisp_Object tortoise
, hare
;
1772 hare
= tortoise
= object
;
1776 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1778 hare
= XSYMBOL (hare
)->function
;
1779 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1781 hare
= XSYMBOL (hare
)->function
;
1783 tortoise
= XSYMBOL (tortoise
)->function
;
1785 if (EQ (hare
, tortoise
))
1786 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1792 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1793 doc
: /* Return the function at the end of OBJECT's function chain.
1794 If OBJECT is a symbol, follow all function indirections and return the final
1796 If OBJECT is not a symbol, just return it.
1797 Signal a void-function error if the final symbol is unbound.
1798 Signal a cyclic-function-indirection error if there is a loop in the
1799 function chain of symbols. */)
1801 register Lisp_Object object
;
1805 result
= indirect_function (object
);
1807 if (EQ (result
, Qunbound
))
1808 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1812 /* Extract and set vector and string elements */
1814 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1815 doc
: /* Return the element of ARRAY at index IDX.
1816 ARRAY may be a vector, a string, a char-table, a bool-vector,
1817 or a byte-code object. IDX starts at 0. */)
1819 register Lisp_Object array
;
1822 register int idxval
;
1825 idxval
= XINT (idx
);
1826 if (STRINGP (array
))
1830 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1831 args_out_of_range (array
, idx
);
1832 if (! STRING_MULTIBYTE (array
))
1833 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1834 idxval_byte
= string_char_to_byte (array
, idxval
);
1836 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1837 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1838 return make_number (c
);
1840 else if (BOOL_VECTOR_P (array
))
1844 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1845 args_out_of_range (array
, idx
);
1847 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1848 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1850 else if (CHAR_TABLE_P (array
))
1857 args_out_of_range (array
, idx
);
1858 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1860 /* For ASCII and 8-bit European characters, the element is
1861 stored in the top table. */
1862 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1864 val
= XCHAR_TABLE (array
)->defalt
;
1865 while (NILP (val
)) /* Follow parents until we find some value. */
1867 array
= XCHAR_TABLE (array
)->parent
;
1870 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1872 val
= XCHAR_TABLE (array
)->defalt
;
1879 Lisp_Object sub_table
;
1881 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1882 if (code
[1] < 32) code
[1] = -1;
1883 else if (code
[2] < 32) code
[2] = -1;
1885 /* Here, the possible range of CODE[0] (== charset ID) is
1886 128..MAX_CHARSET. Since the top level char table contains
1887 data for multibyte characters after 256th element, we must
1888 increment CODE[0] by 128 to get a correct index. */
1890 code
[3] = -1; /* anchor */
1892 try_parent_char_table
:
1894 for (i
= 0; code
[i
] >= 0; i
++)
1896 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1897 if (SUB_CHAR_TABLE_P (val
))
1902 val
= XCHAR_TABLE (sub_table
)->defalt
;
1905 array
= XCHAR_TABLE (array
)->parent
;
1907 goto try_parent_char_table
;
1912 /* Here, VAL is a sub char table. We try the default value
1914 val
= XCHAR_TABLE (val
)->defalt
;
1917 array
= XCHAR_TABLE (array
)->parent
;
1919 goto try_parent_char_table
;
1927 if (VECTORP (array
))
1928 size
= XVECTOR (array
)->size
;
1929 else if (COMPILEDP (array
))
1930 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1932 wrong_type_argument (Qarrayp
, array
);
1934 if (idxval
< 0 || idxval
>= size
)
1935 args_out_of_range (array
, idx
);
1936 return XVECTOR (array
)->contents
[idxval
];
1940 /* Don't use alloca for relocating string data larger than this, lest
1941 we overflow their stack. The value is the same as what used in
1942 fns.c for base64 handling. */
1943 #define MAX_ALLOCA 16*1024
1945 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1946 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1947 ARRAY may be a vector, a string, a char-table or a bool-vector.
1948 IDX starts at 0. */)
1949 (array
, idx
, newelt
)
1950 register Lisp_Object array
;
1951 Lisp_Object idx
, newelt
;
1953 register int idxval
;
1956 idxval
= XINT (idx
);
1957 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1958 && ! CHAR_TABLE_P (array
))
1959 array
= wrong_type_argument (Qarrayp
, array
);
1960 CHECK_IMPURE (array
);
1962 if (VECTORP (array
))
1964 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1965 args_out_of_range (array
, idx
);
1966 XVECTOR (array
)->contents
[idxval
] = newelt
;
1968 else if (BOOL_VECTOR_P (array
))
1972 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1973 args_out_of_range (array
, idx
);
1975 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1977 if (! NILP (newelt
))
1978 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1980 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1981 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1983 else if (CHAR_TABLE_P (array
))
1986 args_out_of_range (array
, idx
);
1987 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1988 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1994 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1995 if (code
[1] < 32) code
[1] = -1;
1996 else if (code
[2] < 32) code
[2] = -1;
1998 /* See the comment of the corresponding part in Faref. */
2000 code
[3] = -1; /* anchor */
2001 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2003 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2004 if (SUB_CHAR_TABLE_P (val
))
2010 /* VAL is a leaf. Create a sub char table with the
2011 default value VAL or XCHAR_TABLE (array)->defalt
2012 and look into it. */
2014 temp
= make_sub_char_table (NILP (val
)
2015 ? XCHAR_TABLE (array
)->defalt
2017 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2021 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2024 else if (STRING_MULTIBYTE (array
))
2026 int idxval_byte
, prev_bytes
, new_bytes
;
2027 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2029 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2030 args_out_of_range (array
, idx
);
2031 CHECK_NUMBER (newelt
);
2033 idxval_byte
= string_char_to_byte (array
, idxval
);
2034 p1
= &XSTRING (array
)->data
[idxval_byte
];
2035 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2036 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2037 if (prev_bytes
!= new_bytes
)
2039 /* We must relocate the string data. */
2040 int nchars
= XSTRING (array
)->size
;
2041 int nbytes
= STRING_BYTES (XSTRING (array
));
2044 str
= (nbytes
<= MAX_ALLOCA
2045 ? (unsigned char *) alloca (nbytes
)
2046 : (unsigned char *) xmalloc (nbytes
));
2047 bcopy (XSTRING (array
)->data
, str
, nbytes
);
2048 allocate_string_data (XSTRING (array
), nchars
,
2049 nbytes
+ new_bytes
- prev_bytes
);
2050 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2051 p1
= XSTRING (array
)->data
+ idxval_byte
;
2052 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2053 nbytes
- (idxval_byte
+ prev_bytes
));
2054 if (nbytes
> MAX_ALLOCA
)
2056 clear_string_char_byte_cache ();
2063 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2064 args_out_of_range (array
, idx
);
2065 CHECK_NUMBER (newelt
);
2067 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2068 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
2071 /* We must relocate the string data while converting it to
2073 int idxval_byte
, prev_bytes
, new_bytes
;
2074 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2075 unsigned char *origstr
= XSTRING (array
)->data
, *str
;
2078 nchars
= XSTRING (array
)->size
;
2079 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2080 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2082 str
= (nbytes
<= MAX_ALLOCA
2083 ? (unsigned char *) alloca (nbytes
)
2084 : (unsigned char *) xmalloc (nbytes
));
2085 copy_text (XSTRING (array
)->data
, str
, nchars
, 0, 1);
2086 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2088 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2089 allocate_string_data (XSTRING (array
), nchars
,
2090 nbytes
+ new_bytes
- prev_bytes
);
2091 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2092 p1
= XSTRING (array
)->data
+ idxval_byte
;
2095 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2096 nbytes
- (idxval_byte
+ prev_bytes
));
2097 if (nbytes
> MAX_ALLOCA
)
2099 clear_string_char_byte_cache ();
2106 /* Arithmetic functions */
2108 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2111 arithcompare (num1
, num2
, comparison
)
2112 Lisp_Object num1
, num2
;
2113 enum comparison comparison
;
2115 double f1
= 0, f2
= 0;
2118 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2119 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2121 if (FLOATP (num1
) || FLOATP (num2
))
2124 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2125 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2131 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2136 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2141 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2146 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2151 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2156 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2165 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2166 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2168 register Lisp_Object num1
, num2
;
2170 return arithcompare (num1
, num2
, equal
);
2173 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2174 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2176 register Lisp_Object num1
, num2
;
2178 return arithcompare (num1
, num2
, less
);
2181 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2182 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2184 register Lisp_Object num1
, num2
;
2186 return arithcompare (num1
, num2
, grtr
);
2189 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2190 doc
: /* Return t if first arg is less than or equal to second arg.
2191 Both must be numbers or markers. */)
2193 register Lisp_Object num1
, num2
;
2195 return arithcompare (num1
, num2
, less_or_equal
);
2198 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2199 doc
: /* Return t if first arg is greater than or equal to second arg.
2200 Both must be numbers or markers. */)
2202 register Lisp_Object num1
, num2
;
2204 return arithcompare (num1
, num2
, grtr_or_equal
);
2207 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2208 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2210 register Lisp_Object num1
, num2
;
2212 return arithcompare (num1
, num2
, notequal
);
2215 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2216 doc
: /* Return t if NUMBER is zero. */)
2218 register Lisp_Object number
;
2220 CHECK_NUMBER_OR_FLOAT (number
);
2222 if (FLOATP (number
))
2224 if (XFLOAT_DATA (number
) == 0.0)
2234 /* Convert between long values and pairs of Lisp integers. */
2240 unsigned int top
= i
>> 16;
2241 unsigned int bot
= i
& 0xFFFF;
2243 return make_number (bot
);
2244 if (top
== (unsigned long)-1 >> 16)
2245 return Fcons (make_number (-1), make_number (bot
));
2246 return Fcons (make_number (top
), make_number (bot
));
2253 Lisp_Object top
, bot
;
2260 return ((XINT (top
) << 16) | XINT (bot
));
2263 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2264 doc
: /* Convert NUMBER to a string by printing it in decimal.
2265 Uses a minus sign if negative.
2266 NUMBER may be an integer or a floating point number. */)
2270 char buffer
[VALBITS
];
2272 CHECK_NUMBER_OR_FLOAT (number
);
2274 if (FLOATP (number
))
2276 char pigbuf
[350]; /* see comments in float_to_string */
2278 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2279 return build_string (pigbuf
);
2282 if (sizeof (int) == sizeof (EMACS_INT
))
2283 sprintf (buffer
, "%d", XINT (number
));
2284 else if (sizeof (long) == sizeof (EMACS_INT
))
2285 sprintf (buffer
, "%ld", (long) XINT (number
));
2288 return build_string (buffer
);
2292 digit_to_number (character
, base
)
2293 int character
, base
;
2297 if (character
>= '0' && character
<= '9')
2298 digit
= character
- '0';
2299 else if (character
>= 'a' && character
<= 'z')
2300 digit
= character
- 'a' + 10;
2301 else if (character
>= 'A' && character
<= 'Z')
2302 digit
= character
- 'A' + 10;
2312 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2313 doc
: /* Convert STRING to a number by parsing it as a decimal number.
2314 This parses both integers and floating point numbers.
2315 It ignores leading spaces and tabs.
2317 If BASE, interpret STRING as a number in that base. If BASE isn't
2318 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2319 If the base used is not 10, floating point is not recognized. */)
2321 register Lisp_Object string
, base
;
2323 register unsigned char *p
;
2328 CHECK_STRING (string
);
2334 CHECK_NUMBER (base
);
2336 if (b
< 2 || b
> 16)
2337 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2340 /* Skip any whitespace at the front of the number. Some versions of
2341 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2342 p
= XSTRING (string
)->data
;
2343 while (*p
== ' ' || *p
== '\t')
2354 if (isfloat_string (p
) && b
== 10)
2355 val
= make_float (sign
* atof (p
));
2362 int digit
= digit_to_number (*p
++, b
);
2368 val
= make_fixnum_or_float (sign
* v
);
2388 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2389 int, Lisp_Object
*));
2390 extern Lisp_Object
fmod_float ();
2393 arith_driver (code
, nargs
, args
)
2396 register Lisp_Object
*args
;
2398 register Lisp_Object val
;
2399 register int argnum
;
2400 register EMACS_INT accum
= 0;
2401 register EMACS_INT next
;
2403 switch (SWITCH_ENUM_CAST (code
))
2421 for (argnum
= 0; argnum
< nargs
; argnum
++)
2423 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2425 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2428 return float_arith_driver ((double) accum
, argnum
, code
,
2431 next
= XINT (args
[argnum
]);
2432 switch (SWITCH_ENUM_CAST (code
))
2438 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2449 Fsignal (Qarith_error
, Qnil
);
2463 if (!argnum
|| next
> accum
)
2467 if (!argnum
|| next
< accum
)
2473 XSETINT (val
, accum
);
2478 #define isnan(x) ((x) != (x))
2481 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2483 register int argnum
;
2486 register Lisp_Object
*args
;
2488 register Lisp_Object val
;
2491 for (; argnum
< nargs
; argnum
++)
2493 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2494 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2498 next
= XFLOAT_DATA (val
);
2502 args
[argnum
] = val
; /* runs into a compiler bug. */
2503 next
= XINT (args
[argnum
]);
2505 switch (SWITCH_ENUM_CAST (code
))
2511 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2521 if (! IEEE_FLOATING_POINT
&& next
== 0)
2522 Fsignal (Qarith_error
, Qnil
);
2529 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2531 if (!argnum
|| isnan (next
) || next
> accum
)
2535 if (!argnum
|| isnan (next
) || next
< accum
)
2541 return make_float (accum
);
2545 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2546 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2547 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2552 return arith_driver (Aadd
, nargs
, args
);
2555 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2556 doc
: /* Negate number or subtract numbers or markers.
2557 With one arg, negates it. With more than one arg,
2558 subtracts all but the first from the first.
2559 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2564 return arith_driver (Asub
, nargs
, args
);
2567 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2568 doc
: /* Return product of any number of arguments, which are numbers or markers.
2569 usage: (* &rest NUMBERS-OR-MARKERS) */)
2574 return arith_driver (Amult
, nargs
, args
);
2577 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2578 doc
: /* Return first argument divided by all the remaining arguments.
2579 The arguments must be numbers or markers.
2580 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2585 return arith_driver (Adiv
, nargs
, args
);
2588 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2589 doc
: /* Return remainder of X divided by Y.
2590 Both must be integers or markers. */)
2592 register Lisp_Object x
, y
;
2596 CHECK_NUMBER_COERCE_MARKER (x
);
2597 CHECK_NUMBER_COERCE_MARKER (y
);
2599 if (XFASTINT (y
) == 0)
2600 Fsignal (Qarith_error
, Qnil
);
2602 XSETINT (val
, XINT (x
) % XINT (y
));
2616 /* If the magnitude of the result exceeds that of the divisor, or
2617 the sign of the result does not agree with that of the dividend,
2618 iterate with the reduced value. This does not yield a
2619 particularly accurate result, but at least it will be in the
2620 range promised by fmod. */
2622 r
-= f2
* floor (r
/ f2
);
2623 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2627 #endif /* ! HAVE_FMOD */
2629 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2630 doc
: /* Return X modulo Y.
2631 The result falls between zero (inclusive) and Y (exclusive).
2632 Both X and Y must be numbers or markers. */)
2634 register Lisp_Object x
, y
;
2639 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2640 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2642 if (FLOATP (x
) || FLOATP (y
))
2643 return fmod_float (x
, y
);
2649 Fsignal (Qarith_error
, Qnil
);
2653 /* If the "remainder" comes out with the wrong sign, fix it. */
2654 if (i2
< 0 ? i1
> 0 : i1
< 0)
2661 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2662 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2663 The value is always a number; markers are converted to numbers.
2664 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2669 return arith_driver (Amax
, nargs
, args
);
2672 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2673 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2674 The value is always a number; markers are converted to numbers.
2675 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2680 return arith_driver (Amin
, nargs
, args
);
2683 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2684 doc
: /* Return bitwise-and of all the arguments.
2685 Arguments may be integers, or markers converted to integers.
2686 usage: (logand &rest INTS-OR-MARKERS) */)
2691 return arith_driver (Alogand
, nargs
, args
);
2694 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2695 doc
: /* Return bitwise-or of all the arguments.
2696 Arguments may be integers, or markers converted to integers.
2697 usage: (logior &rest INTS-OR-MARKERS) */)
2702 return arith_driver (Alogior
, nargs
, args
);
2705 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2706 doc
: /* Return bitwise-exclusive-or of all the arguments.
2707 Arguments may be integers, or markers converted to integers.
2708 usage: (logxor &rest INTS-OR-MARKERS) */)
2713 return arith_driver (Alogxor
, nargs
, args
);
2716 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2717 doc
: /* Return VALUE with its bits shifted left by COUNT.
2718 If COUNT is negative, shifting is actually to the right.
2719 In this case, the sign bit is duplicated. */)
2721 register Lisp_Object value
, count
;
2723 register Lisp_Object val
;
2725 CHECK_NUMBER (value
);
2726 CHECK_NUMBER (count
);
2728 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2730 else if (XINT (count
) > 0)
2731 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2732 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2733 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2735 XSETINT (val
, XINT (value
) >> -XINT (count
));
2739 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2740 doc
: /* Return VALUE with its bits shifted left by COUNT.
2741 If COUNT is negative, shifting is actually to the right.
2742 In this case, zeros are shifted in on the left. */)
2744 register Lisp_Object value
, count
;
2746 register Lisp_Object val
;
2748 CHECK_NUMBER (value
);
2749 CHECK_NUMBER (count
);
2751 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2753 else if (XINT (count
) > 0)
2754 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2755 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2758 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2762 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2763 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2764 Markers are converted to integers. */)
2766 register Lisp_Object number
;
2768 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2770 if (FLOATP (number
))
2771 return (make_float (1.0 + XFLOAT_DATA (number
)));
2773 XSETINT (number
, XINT (number
) + 1);
2777 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2778 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2779 Markers are converted to integers. */)
2781 register Lisp_Object number
;
2783 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2785 if (FLOATP (number
))
2786 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2788 XSETINT (number
, XINT (number
) - 1);
2792 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2793 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2795 register Lisp_Object number
;
2797 CHECK_NUMBER (number
);
2798 XSETINT (number
, ~XINT (number
));
2805 Lisp_Object error_tail
, arith_tail
;
2807 Qquote
= intern ("quote");
2808 Qlambda
= intern ("lambda");
2809 Qsubr
= intern ("subr");
2810 Qerror_conditions
= intern ("error-conditions");
2811 Qerror_message
= intern ("error-message");
2812 Qtop_level
= intern ("top-level");
2814 Qerror
= intern ("error");
2815 Qquit
= intern ("quit");
2816 Qwrong_type_argument
= intern ("wrong-type-argument");
2817 Qargs_out_of_range
= intern ("args-out-of-range");
2818 Qvoid_function
= intern ("void-function");
2819 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2820 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2821 Qvoid_variable
= intern ("void-variable");
2822 Qsetting_constant
= intern ("setting-constant");
2823 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2825 Qinvalid_function
= intern ("invalid-function");
2826 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2827 Qno_catch
= intern ("no-catch");
2828 Qend_of_file
= intern ("end-of-file");
2829 Qarith_error
= intern ("arith-error");
2830 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2831 Qend_of_buffer
= intern ("end-of-buffer");
2832 Qbuffer_read_only
= intern ("buffer-read-only");
2833 Qtext_read_only
= intern ("text-read-only");
2834 Qmark_inactive
= intern ("mark-inactive");
2836 Qlistp
= intern ("listp");
2837 Qconsp
= intern ("consp");
2838 Qsymbolp
= intern ("symbolp");
2839 Qkeywordp
= intern ("keywordp");
2840 Qintegerp
= intern ("integerp");
2841 Qnatnump
= intern ("natnump");
2842 Qwholenump
= intern ("wholenump");
2843 Qstringp
= intern ("stringp");
2844 Qarrayp
= intern ("arrayp");
2845 Qsequencep
= intern ("sequencep");
2846 Qbufferp
= intern ("bufferp");
2847 Qvectorp
= intern ("vectorp");
2848 Qchar_or_string_p
= intern ("char-or-string-p");
2849 Qmarkerp
= intern ("markerp");
2850 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2851 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2852 Qboundp
= intern ("boundp");
2853 Qfboundp
= intern ("fboundp");
2855 Qfloatp
= intern ("floatp");
2856 Qnumberp
= intern ("numberp");
2857 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2859 Qchar_table_p
= intern ("char-table-p");
2860 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2862 Qsubrp
= intern ("subrp");
2863 Qunevalled
= intern ("unevalled");
2864 Qmany
= intern ("many");
2866 Qcdr
= intern ("cdr");
2868 /* Handle automatic advice activation */
2869 Qad_advice_info
= intern ("ad-advice-info");
2870 Qad_activate_internal
= intern ("ad-activate-internal");
2872 error_tail
= Fcons (Qerror
, Qnil
);
2874 /* ERROR is used as a signaler for random errors for which nothing else is right */
2876 Fput (Qerror
, Qerror_conditions
,
2878 Fput (Qerror
, Qerror_message
,
2879 build_string ("error"));
2881 Fput (Qquit
, Qerror_conditions
,
2882 Fcons (Qquit
, Qnil
));
2883 Fput (Qquit
, Qerror_message
,
2884 build_string ("Quit"));
2886 Fput (Qwrong_type_argument
, Qerror_conditions
,
2887 Fcons (Qwrong_type_argument
, error_tail
));
2888 Fput (Qwrong_type_argument
, Qerror_message
,
2889 build_string ("Wrong type argument"));
2891 Fput (Qargs_out_of_range
, Qerror_conditions
,
2892 Fcons (Qargs_out_of_range
, error_tail
));
2893 Fput (Qargs_out_of_range
, Qerror_message
,
2894 build_string ("Args out of range"));
2896 Fput (Qvoid_function
, Qerror_conditions
,
2897 Fcons (Qvoid_function
, error_tail
));
2898 Fput (Qvoid_function
, Qerror_message
,
2899 build_string ("Symbol's function definition is void"));
2901 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2902 Fcons (Qcyclic_function_indirection
, error_tail
));
2903 Fput (Qcyclic_function_indirection
, Qerror_message
,
2904 build_string ("Symbol's chain of function indirections contains a loop"));
2906 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2907 Fcons (Qcyclic_variable_indirection
, error_tail
));
2908 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2909 build_string ("Symbol's chain of variable indirections contains a loop"));
2911 Qcircular_list
= intern ("circular-list");
2912 staticpro (&Qcircular_list
);
2913 Fput (Qcircular_list
, Qerror_conditions
,
2914 Fcons (Qcircular_list
, error_tail
));
2915 Fput (Qcircular_list
, Qerror_message
,
2916 build_string ("List contains a loop"));
2918 Fput (Qvoid_variable
, Qerror_conditions
,
2919 Fcons (Qvoid_variable
, error_tail
));
2920 Fput (Qvoid_variable
, Qerror_message
,
2921 build_string ("Symbol's value as variable is void"));
2923 Fput (Qsetting_constant
, Qerror_conditions
,
2924 Fcons (Qsetting_constant
, error_tail
));
2925 Fput (Qsetting_constant
, Qerror_message
,
2926 build_string ("Attempt to set a constant symbol"));
2928 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2929 Fcons (Qinvalid_read_syntax
, error_tail
));
2930 Fput (Qinvalid_read_syntax
, Qerror_message
,
2931 build_string ("Invalid read syntax"));
2933 Fput (Qinvalid_function
, Qerror_conditions
,
2934 Fcons (Qinvalid_function
, error_tail
));
2935 Fput (Qinvalid_function
, Qerror_message
,
2936 build_string ("Invalid function"));
2938 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2939 Fcons (Qwrong_number_of_arguments
, error_tail
));
2940 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2941 build_string ("Wrong number of arguments"));
2943 Fput (Qno_catch
, Qerror_conditions
,
2944 Fcons (Qno_catch
, error_tail
));
2945 Fput (Qno_catch
, Qerror_message
,
2946 build_string ("No catch for tag"));
2948 Fput (Qend_of_file
, Qerror_conditions
,
2949 Fcons (Qend_of_file
, error_tail
));
2950 Fput (Qend_of_file
, Qerror_message
,
2951 build_string ("End of file during parsing"));
2953 arith_tail
= Fcons (Qarith_error
, error_tail
);
2954 Fput (Qarith_error
, Qerror_conditions
,
2956 Fput (Qarith_error
, Qerror_message
,
2957 build_string ("Arithmetic error"));
2959 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2960 Fcons (Qbeginning_of_buffer
, error_tail
));
2961 Fput (Qbeginning_of_buffer
, Qerror_message
,
2962 build_string ("Beginning of buffer"));
2964 Fput (Qend_of_buffer
, Qerror_conditions
,
2965 Fcons (Qend_of_buffer
, error_tail
));
2966 Fput (Qend_of_buffer
, Qerror_message
,
2967 build_string ("End of buffer"));
2969 Fput (Qbuffer_read_only
, Qerror_conditions
,
2970 Fcons (Qbuffer_read_only
, error_tail
));
2971 Fput (Qbuffer_read_only
, Qerror_message
,
2972 build_string ("Buffer is read-only"));
2974 Fput (Qtext_read_only
, Qerror_conditions
,
2975 Fcons (Qtext_read_only
, error_tail
));
2976 Fput (Qtext_read_only
, Qerror_message
,
2977 build_string ("Text is read-only"));
2979 Qrange_error
= intern ("range-error");
2980 Qdomain_error
= intern ("domain-error");
2981 Qsingularity_error
= intern ("singularity-error");
2982 Qoverflow_error
= intern ("overflow-error");
2983 Qunderflow_error
= intern ("underflow-error");
2985 Fput (Qdomain_error
, Qerror_conditions
,
2986 Fcons (Qdomain_error
, arith_tail
));
2987 Fput (Qdomain_error
, Qerror_message
,
2988 build_string ("Arithmetic domain error"));
2990 Fput (Qrange_error
, Qerror_conditions
,
2991 Fcons (Qrange_error
, arith_tail
));
2992 Fput (Qrange_error
, Qerror_message
,
2993 build_string ("Arithmetic range error"));
2995 Fput (Qsingularity_error
, Qerror_conditions
,
2996 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2997 Fput (Qsingularity_error
, Qerror_message
,
2998 build_string ("Arithmetic singularity error"));
3000 Fput (Qoverflow_error
, Qerror_conditions
,
3001 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3002 Fput (Qoverflow_error
, Qerror_message
,
3003 build_string ("Arithmetic overflow error"));
3005 Fput (Qunderflow_error
, Qerror_conditions
,
3006 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3007 Fput (Qunderflow_error
, Qerror_message
,
3008 build_string ("Arithmetic underflow error"));
3010 staticpro (&Qrange_error
);
3011 staticpro (&Qdomain_error
);
3012 staticpro (&Qsingularity_error
);
3013 staticpro (&Qoverflow_error
);
3014 staticpro (&Qunderflow_error
);
3018 staticpro (&Qquote
);
3019 staticpro (&Qlambda
);
3021 staticpro (&Qunbound
);
3022 staticpro (&Qerror_conditions
);
3023 staticpro (&Qerror_message
);
3024 staticpro (&Qtop_level
);
3026 staticpro (&Qerror
);
3028 staticpro (&Qwrong_type_argument
);
3029 staticpro (&Qargs_out_of_range
);
3030 staticpro (&Qvoid_function
);
3031 staticpro (&Qcyclic_function_indirection
);
3032 staticpro (&Qvoid_variable
);
3033 staticpro (&Qsetting_constant
);
3034 staticpro (&Qinvalid_read_syntax
);
3035 staticpro (&Qwrong_number_of_arguments
);
3036 staticpro (&Qinvalid_function
);
3037 staticpro (&Qno_catch
);
3038 staticpro (&Qend_of_file
);
3039 staticpro (&Qarith_error
);
3040 staticpro (&Qbeginning_of_buffer
);
3041 staticpro (&Qend_of_buffer
);
3042 staticpro (&Qbuffer_read_only
);
3043 staticpro (&Qtext_read_only
);
3044 staticpro (&Qmark_inactive
);
3046 staticpro (&Qlistp
);
3047 staticpro (&Qconsp
);
3048 staticpro (&Qsymbolp
);
3049 staticpro (&Qkeywordp
);
3050 staticpro (&Qintegerp
);
3051 staticpro (&Qnatnump
);
3052 staticpro (&Qwholenump
);
3053 staticpro (&Qstringp
);
3054 staticpro (&Qarrayp
);
3055 staticpro (&Qsequencep
);
3056 staticpro (&Qbufferp
);
3057 staticpro (&Qvectorp
);
3058 staticpro (&Qchar_or_string_p
);
3059 staticpro (&Qmarkerp
);
3060 staticpro (&Qbuffer_or_string_p
);
3061 staticpro (&Qinteger_or_marker_p
);
3062 staticpro (&Qfloatp
);
3063 staticpro (&Qnumberp
);
3064 staticpro (&Qnumber_or_marker_p
);
3065 staticpro (&Qchar_table_p
);
3066 staticpro (&Qvector_or_char_table_p
);
3067 staticpro (&Qsubrp
);
3069 staticpro (&Qunevalled
);
3071 staticpro (&Qboundp
);
3072 staticpro (&Qfboundp
);
3074 staticpro (&Qad_advice_info
);
3075 staticpro (&Qad_activate_internal
);
3077 /* Types that type-of returns. */
3078 Qinteger
= intern ("integer");
3079 Qsymbol
= intern ("symbol");
3080 Qstring
= intern ("string");
3081 Qcons
= intern ("cons");
3082 Qmarker
= intern ("marker");
3083 Qoverlay
= intern ("overlay");
3084 Qfloat
= intern ("float");
3085 Qwindow_configuration
= intern ("window-configuration");
3086 Qprocess
= intern ("process");
3087 Qwindow
= intern ("window");
3088 /* Qsubr = intern ("subr"); */
3089 Qcompiled_function
= intern ("compiled-function");
3090 Qbuffer
= intern ("buffer");
3091 Qframe
= intern ("frame");
3092 Qvector
= intern ("vector");
3093 Qchar_table
= intern ("char-table");
3094 Qbool_vector
= intern ("bool-vector");
3095 Qhash_table
= intern ("hash-table");
3097 staticpro (&Qinteger
);
3098 staticpro (&Qsymbol
);
3099 staticpro (&Qstring
);
3101 staticpro (&Qmarker
);
3102 staticpro (&Qoverlay
);
3103 staticpro (&Qfloat
);
3104 staticpro (&Qwindow_configuration
);
3105 staticpro (&Qprocess
);
3106 staticpro (&Qwindow
);
3107 /* staticpro (&Qsubr); */
3108 staticpro (&Qcompiled_function
);
3109 staticpro (&Qbuffer
);
3110 staticpro (&Qframe
);
3111 staticpro (&Qvector
);
3112 staticpro (&Qchar_table
);
3113 staticpro (&Qbool_vector
);
3114 staticpro (&Qhash_table
);
3116 defsubr (&Sindirect_variable
);
3117 defsubr (&Ssubr_interactive_form
);
3120 defsubr (&Stype_of
);
3125 defsubr (&Sintegerp
);
3126 defsubr (&Sinteger_or_marker_p
);
3127 defsubr (&Snumberp
);
3128 defsubr (&Snumber_or_marker_p
);
3130 defsubr (&Snatnump
);
3131 defsubr (&Ssymbolp
);
3132 defsubr (&Skeywordp
);
3133 defsubr (&Sstringp
);
3134 defsubr (&Smultibyte_string_p
);
3135 defsubr (&Svectorp
);
3136 defsubr (&Schar_table_p
);
3137 defsubr (&Svector_or_char_table_p
);
3138 defsubr (&Sbool_vector_p
);
3140 defsubr (&Ssequencep
);
3141 defsubr (&Sbufferp
);
3142 defsubr (&Smarkerp
);
3144 defsubr (&Sbyte_code_function_p
);
3145 defsubr (&Schar_or_string_p
);
3148 defsubr (&Scar_safe
);
3149 defsubr (&Scdr_safe
);
3152 defsubr (&Ssymbol_function
);
3153 defsubr (&Sindirect_function
);
3154 defsubr (&Ssymbol_plist
);
3155 defsubr (&Ssymbol_name
);
3156 defsubr (&Smakunbound
);
3157 defsubr (&Sfmakunbound
);
3159 defsubr (&Sfboundp
);
3161 defsubr (&Sdefalias
);
3162 defsubr (&Ssetplist
);
3163 defsubr (&Ssymbol_value
);
3165 defsubr (&Sdefault_boundp
);
3166 defsubr (&Sdefault_value
);
3167 defsubr (&Sset_default
);
3168 defsubr (&Ssetq_default
);
3169 defsubr (&Smake_variable_buffer_local
);
3170 defsubr (&Smake_local_variable
);
3171 defsubr (&Skill_local_variable
);
3172 defsubr (&Smake_variable_frame_local
);
3173 defsubr (&Slocal_variable_p
);
3174 defsubr (&Slocal_variable_if_set_p
);
3177 defsubr (&Snumber_to_string
);
3178 defsubr (&Sstring_to_number
);
3179 defsubr (&Seqlsign
);
3202 defsubr (&Ssubr_arity
);
3204 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3206 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3207 doc
: /* The largest value that is representable in a Lisp integer. */);
3208 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3210 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3211 doc
: /* The smallest value that is representable in a Lisp integer. */);
3212 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3219 #if defined(USG) && !defined(POSIX_SIGNALS)
3220 /* USG systems forget handlers when they are used;
3221 must reestablish each time */
3222 signal (signo
, arith_error
);
3225 /* VMS systems are like USG. */
3226 signal (signo
, arith_error
);
3230 #else /* not BSD4_1 */
3231 sigsetmask (SIGEMPTYMASK
);
3232 #endif /* not BSD4_1 */
3234 Fsignal (Qarith_error
, Qnil
);
3240 /* Don't do this if just dumping out.
3241 We don't want to call `signal' in this case
3242 so that we don't have trouble with dumping
3243 signal-delivering routines in an inconsistent state. */
3247 #endif /* CANNOT_DUMP */
3248 signal (SIGFPE
, arith_error
);
3251 signal (SIGEMT
, arith_error
);