1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
32 #include "syssignal.h"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
69 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
70 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
71 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
72 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
73 Lisp_Object Qtext_read_only
;
74 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
75 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
76 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
77 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
78 Lisp_Object Qboundp
, Qfboundp
;
79 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
82 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
84 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
85 Lisp_Object Qoverflow_error
, Qunderflow_error
;
88 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
90 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
91 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
93 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
94 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
95 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
97 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
99 int most_positive_fixnum
, most_negative_fixnum
;
103 circular_list_error (list
)
106 Fsignal (Qcircular_list
, list
);
111 wrong_type_argument (predicate
, value
)
112 register Lisp_Object predicate
, value
;
114 register Lisp_Object tem
;
117 if (!EQ (Vmocklisp_arguments
, Qt
))
119 if (STRINGP (value
) &&
120 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
121 return Fstring_to_number (value
, Qnil
);
122 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
123 return Fnumber_to_string (value
);
126 /* If VALUE is not even a valid Lisp object, abort here
127 where we can get a backtrace showing where it came from. */
128 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
131 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
132 tem
= call1 (predicate
, value
);
141 error ("Attempt to modify read-only object");
145 args_out_of_range (a1
, a2
)
149 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
153 args_out_of_range_3 (a1
, a2
, a3
)
154 Lisp_Object a1
, a2
, a3
;
157 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
160 /* On some machines, XINT needs a temporary location.
161 Here it is, in case it is needed. */
163 int sign_extend_temp
;
165 /* On a few machines, XINT can only be done by calling this. */
168 sign_extend_lisp_int (num
)
171 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
172 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
174 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
177 /* Data type predicates */
179 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
180 doc
: /* Return t if the two args are the same Lisp object. */)
182 Lisp_Object obj1
, obj2
;
189 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
190 doc
: /* Return t if OBJECT is nil. */)
199 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
200 doc
: /* Return a symbol representing the type of OBJECT.
201 The symbol returned names the object's basic type;
202 for example, (type-of 1) returns `integer'. */)
206 switch (XGCTYPE (object
))
221 switch (XMISCTYPE (object
))
223 case Lisp_Misc_Marker
:
225 case Lisp_Misc_Overlay
:
227 case Lisp_Misc_Float
:
232 case Lisp_Vectorlike
:
233 if (GC_WINDOW_CONFIGURATIONP (object
))
234 return Qwindow_configuration
;
235 if (GC_PROCESSP (object
))
237 if (GC_WINDOWP (object
))
239 if (GC_SUBRP (object
))
241 if (GC_COMPILEDP (object
))
242 return Qcompiled_function
;
243 if (GC_BUFFERP (object
))
245 if (GC_CHAR_TABLE_P (object
))
247 if (GC_BOOL_VECTOR_P (object
))
249 if (GC_FRAMEP (object
))
251 if (GC_HASH_TABLE_P (object
))
263 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
264 doc
: /* Return t if OBJECT is a cons cell. */)
273 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
274 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
283 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
284 doc
: /* Return t if OBJECT is a list. This includes nil. */)
288 if (CONSP (object
) || NILP (object
))
293 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
294 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
298 if (CONSP (object
) || NILP (object
))
303 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
304 doc
: /* Return t if OBJECT is a symbol. */)
308 if (SYMBOLP (object
))
313 /* Define this in C to avoid unnecessarily consing up the symbol
315 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is a keyword.
317 This means that it is a symbol with a print name beginning with `:'
318 interned in the initial obarray. */)
323 && XSYMBOL (object
)->name
->data
[0] == ':'
324 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
329 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
330 doc
: /* Return t if OBJECT is a vector. */)
334 if (VECTORP (object
))
339 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
340 doc
: /* Return t if OBJECT is a string. */)
344 if (STRINGP (object
))
349 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
351 doc
: /* Return t if OBJECT is a multibyte string. */)
355 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
360 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
361 doc
: /* Return t if OBJECT is a char-table. */)
365 if (CHAR_TABLE_P (object
))
370 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
371 Svector_or_char_table_p
, 1, 1, 0,
372 doc
: /* Return t if OBJECT is a char-table or vector. */)
376 if (VECTORP (object
) || CHAR_TABLE_P (object
))
381 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
382 doc
: /* Return t if OBJECT is a bool-vector. */)
386 if (BOOL_VECTOR_P (object
))
391 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
392 doc
: /* Return t if OBJECT is an array (string or vector). */)
396 if (VECTORP (object
) || STRINGP (object
)
397 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
402 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
403 doc
: /* Return t if OBJECT is a sequence (list or array). */)
405 register Lisp_Object object
;
407 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
408 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
413 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
414 doc
: /* Return t if OBJECT is an editor buffer. */)
418 if (BUFFERP (object
))
423 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
424 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
428 if (MARKERP (object
))
433 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
434 doc
: /* Return t if OBJECT is a built-in function. */)
443 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
445 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
449 if (COMPILEDP (object
))
454 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
455 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
457 register Lisp_Object object
;
459 if (INTEGERP (object
) || STRINGP (object
))
464 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
465 doc
: /* Return t if OBJECT is an integer. */)
469 if (INTEGERP (object
))
474 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
475 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
477 register Lisp_Object object
;
479 if (MARKERP (object
) || INTEGERP (object
))
484 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
485 doc
: /* Return t if OBJECT is a nonnegative integer. */)
489 if (NATNUMP (object
))
494 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
495 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
499 if (NUMBERP (object
))
505 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
506 Snumber_or_marker_p
, 1, 1, 0,
507 doc
: /* Return t if OBJECT is a number or a marker. */)
511 if (NUMBERP (object
) || MARKERP (object
))
516 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
517 doc
: /* Return t if OBJECT is a floating point number. */)
527 /* Extract and set components of lists */
529 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
530 doc
: /* Return the car of LIST. If arg is nil, return nil.
531 Error if arg is not nil and not a cons cell. See also `car-safe'. */)
533 register Lisp_Object list
;
539 else if (EQ (list
, Qnil
))
542 list
= wrong_type_argument (Qlistp
, list
);
546 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
547 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
552 return XCAR (object
);
557 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
558 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
559 Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
561 register Lisp_Object list
;
567 else if (EQ (list
, Qnil
))
570 list
= wrong_type_argument (Qlistp
, list
);
574 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
575 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
580 return XCDR (object
);
585 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
586 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
588 register Lisp_Object cell
, newcar
;
591 cell
= wrong_type_argument (Qconsp
, cell
);
594 XSETCAR (cell
, newcar
);
598 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
599 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
601 register Lisp_Object cell
, newcdr
;
604 cell
= wrong_type_argument (Qconsp
, cell
);
607 XSETCDR (cell
, newcdr
);
611 /* Extract and set components of symbols */
613 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
614 doc
: /* Return t if SYMBOL's value is not void. */)
616 register Lisp_Object symbol
;
618 Lisp_Object valcontents
;
619 CHECK_SYMBOL (symbol
);
621 valcontents
= SYMBOL_VALUE (symbol
);
623 if (BUFFER_LOCAL_VALUEP (valcontents
)
624 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
625 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
627 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
630 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
631 doc
: /* Return t if SYMBOL's function definition is not void. */)
633 register Lisp_Object symbol
;
635 CHECK_SYMBOL (symbol
);
636 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
639 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
640 doc
: /* Make SYMBOL's value be void. */)
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
);
645 if (XSYMBOL (symbol
)->constant
)
646 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
647 Fset (symbol
, Qunbound
);
651 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
652 doc
: /* Make SYMBOL's function definition be void. */)
654 register Lisp_Object symbol
;
656 CHECK_SYMBOL (symbol
);
657 if (NILP (symbol
) || EQ (symbol
, Qt
))
658 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
659 XSYMBOL (symbol
)->function
= Qunbound
;
663 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
664 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
666 register Lisp_Object symbol
;
668 CHECK_SYMBOL (symbol
);
669 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
670 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
671 return XSYMBOL (symbol
)->function
;
674 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
675 doc
: /* Return SYMBOL's property list. */)
677 register Lisp_Object symbol
;
679 CHECK_SYMBOL (symbol
);
680 return XSYMBOL (symbol
)->plist
;
683 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
684 doc
: /* Return SYMBOL's name, a string. */)
686 register Lisp_Object symbol
;
688 register Lisp_Object name
;
690 CHECK_SYMBOL (symbol
);
691 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
695 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
696 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
698 register Lisp_Object symbol
, definition
;
700 CHECK_SYMBOL (symbol
);
701 if (NILP (symbol
) || EQ (symbol
, Qt
))
702 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
703 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
704 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
706 XSYMBOL (symbol
)->function
= definition
;
707 /* Handle automatic advice activation */
708 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
710 call2 (Qad_activate_internal
, symbol
, Qnil
);
711 definition
= XSYMBOL (symbol
)->function
;
716 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
717 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
718 Associates the function with the current load file, if any. */)
720 register Lisp_Object symbol
, definition
;
722 definition
= Ffset (symbol
, definition
);
723 LOADHIST_ATTACH (symbol
);
727 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
728 doc
: /* Set SYMBOL's property list to NEWVAL, and return NEWVAL. */)
730 register Lisp_Object symbol
, newplist
;
732 CHECK_SYMBOL (symbol
);
733 XSYMBOL (symbol
)->plist
= newplist
;
737 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
738 doc
: /* Return minimum and maximum number of args allowed for SUBR.
739 SUBR must be a built-in function.
740 The returned value is a pair (MIN . MAX). MIN is the minimum number
741 of args. MAX is the maximum number or the symbol `many', for a
742 function with `&rest' args, or `unevalled' for a special form. */)
746 short minargs
, maxargs
;
748 wrong_type_argument (Qsubrp
, subr
);
749 minargs
= XSUBR (subr
)->min_args
;
750 maxargs
= XSUBR (subr
)->max_args
;
752 return Fcons (make_number (minargs
), Qmany
);
753 else if (maxargs
== UNEVALLED
)
754 return Fcons (make_number (minargs
), Qunevalled
);
756 return Fcons (make_number (minargs
), make_number (maxargs
));
759 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
760 doc
: /* Return the interactive form of SUBR or nil if none.
761 SUBR must be a built-in function. Value, if non-nil, is a list
762 \(interactive SPEC). */)
767 wrong_type_argument (Qsubrp
, subr
);
768 if (XSUBR (subr
)->prompt
)
769 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
774 /***********************************************************************
775 Getting and Setting Values of Symbols
776 ***********************************************************************/
778 /* Return the symbol holding SYMBOL's value. Signal
779 `cyclic-variable-indirection' if SYMBOL's chain of variable
780 indirections contains a loop. */
783 indirect_variable (symbol
)
786 Lisp_Object tortoise
, hare
;
788 hare
= tortoise
= symbol
;
790 while (XSYMBOL (hare
)->indirect_variable
)
792 hare
= XSYMBOL (hare
)->value
;
793 if (!XSYMBOL (hare
)->indirect_variable
)
796 hare
= XSYMBOL (hare
)->value
;
797 tortoise
= XSYMBOL (tortoise
)->value
;
799 if (EQ (hare
, tortoise
))
800 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
807 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
808 doc
: /* Return the variable at the end of OBJECT's variable chain.
809 If OBJECT is a symbol, follow all variable indirections and return the final
810 variable. If OBJECT is not a symbol, just return it.
811 Signal a cyclic-variable-indirection error if there is a loop in the
812 variable chain of symbols. */)
816 if (SYMBOLP (object
))
817 object
= indirect_variable (object
);
822 /* Given the raw contents of a symbol value cell,
823 return the Lisp value of the symbol.
824 This does not handle buffer-local variables; use
825 swap_in_symval_forwarding for that. */
828 do_symval_forwarding (valcontents
)
829 register Lisp_Object valcontents
;
831 register Lisp_Object val
;
833 if (MISCP (valcontents
))
834 switch (XMISCTYPE (valcontents
))
836 case Lisp_Misc_Intfwd
:
837 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
840 case Lisp_Misc_Boolfwd
:
841 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
843 case Lisp_Misc_Objfwd
:
844 return *XOBJFWD (valcontents
)->objvar
;
846 case Lisp_Misc_Buffer_Objfwd
:
847 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
848 return PER_BUFFER_VALUE (current_buffer
, offset
);
850 case Lisp_Misc_Kboard_Objfwd
:
851 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
852 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
857 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
858 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
859 buffer-independent contents of the value cell: forwarded just one
860 step past the buffer-localness.
862 BUF non-zero means set the value in buffer BUF instead of the
863 current buffer. This only plays a role for per-buffer variables. */
866 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
868 register Lisp_Object valcontents
, newval
;
871 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
874 switch (XMISCTYPE (valcontents
))
876 case Lisp_Misc_Intfwd
:
877 CHECK_NUMBER (newval
);
878 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
879 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
880 error ("Value out of range for variable `%s'",
881 XSYMBOL (symbol
)->name
->data
);
884 case Lisp_Misc_Boolfwd
:
885 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
888 case Lisp_Misc_Objfwd
:
889 *XOBJFWD (valcontents
)->objvar
= newval
;
892 case Lisp_Misc_Buffer_Objfwd
:
894 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
897 type
= PER_BUFFER_TYPE (offset
);
898 if (XINT (type
) == -1)
899 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
901 if (! NILP (type
) && ! NILP (newval
)
902 && XTYPE (newval
) != XINT (type
))
903 buffer_slot_type_mismatch (offset
);
906 buf
= current_buffer
;
907 PER_BUFFER_VALUE (buf
, offset
) = newval
;
911 case Lisp_Misc_Kboard_Objfwd
:
913 char *base
= (char *) current_kboard
;
914 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
915 *(Lisp_Object
*) p
= newval
;
926 valcontents
= SYMBOL_VALUE (symbol
);
927 if (BUFFER_LOCAL_VALUEP (valcontents
)
928 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
929 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
931 SET_SYMBOL_VALUE (symbol
, newval
);
935 /* Set up SYMBOL to refer to its global binding.
936 This makes it safe to alter the status of other bindings. */
939 swap_in_global_binding (symbol
)
942 Lisp_Object valcontents
, cdr
;
944 valcontents
= SYMBOL_VALUE (symbol
);
945 if (!BUFFER_LOCAL_VALUEP (valcontents
)
946 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
948 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
950 /* Unload the previously loaded binding. */
952 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
954 /* Select the global binding in the symbol. */
956 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
958 /* Indicate that the global binding is set up now. */
959 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
960 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
961 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
962 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
965 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
966 VALCONTENTS is the contents of its value cell,
967 which points to a struct Lisp_Buffer_Local_Value.
969 Return the value forwarded one step past the buffer-local stage.
970 This could be another forwarding pointer. */
973 swap_in_symval_forwarding (symbol
, valcontents
)
974 Lisp_Object symbol
, valcontents
;
976 register Lisp_Object tem1
;
978 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
981 || current_buffer
!= XBUFFER (tem1
)
982 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
983 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
985 if (XSYMBOL (symbol
)->indirect_variable
)
986 symbol
= indirect_variable (symbol
);
988 /* Unload the previously loaded binding. */
989 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
991 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
992 /* Choose the new binding. */
993 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
994 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
995 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
998 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
999 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1001 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1003 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1006 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1008 /* Load the new binding. */
1009 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1010 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1011 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1012 store_symval_forwarding (symbol
,
1013 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1016 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1019 /* Find the value of a symbol, returning Qunbound if it's not bound.
1020 This is helpful for code which just wants to get a variable's value
1021 if it has one, without signaling an error.
1022 Note that it must not be possible to quit
1023 within this function. Great care is required for this. */
1026 find_symbol_value (symbol
)
1029 register Lisp_Object valcontents
;
1030 register Lisp_Object val
;
1032 CHECK_SYMBOL (symbol
);
1033 valcontents
= SYMBOL_VALUE (symbol
);
1035 if (BUFFER_LOCAL_VALUEP (valcontents
)
1036 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1037 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1039 if (MISCP (valcontents
))
1041 switch (XMISCTYPE (valcontents
))
1043 case Lisp_Misc_Intfwd
:
1044 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1047 case Lisp_Misc_Boolfwd
:
1048 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1050 case Lisp_Misc_Objfwd
:
1051 return *XOBJFWD (valcontents
)->objvar
;
1053 case Lisp_Misc_Buffer_Objfwd
:
1054 return PER_BUFFER_VALUE (current_buffer
,
1055 XBUFFER_OBJFWD (valcontents
)->offset
);
1057 case Lisp_Misc_Kboard_Objfwd
:
1058 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1059 + (char *)current_kboard
);
1066 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1067 doc
: /* Return SYMBOL's value. Error if that is void. */)
1073 val
= find_symbol_value (symbol
);
1074 if (EQ (val
, Qunbound
))
1075 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1080 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1081 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1083 register Lisp_Object symbol
, newval
;
1085 return set_internal (symbol
, newval
, current_buffer
, 0);
1088 /* Return 1 if SYMBOL currently has a let-binding
1089 which was made in the buffer that is now current. */
1092 let_shadows_buffer_binding_p (symbol
)
1095 struct specbinding
*p
;
1097 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1099 && CONSP (p
->symbol
))
1101 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1102 if ((EQ (symbol
, let_bound_symbol
)
1103 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1104 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1105 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1109 return p
>= specpdl
;
1112 /* Store the value NEWVAL into SYMBOL.
1113 If buffer-locality is an issue, BUF specifies which buffer to use.
1114 (0 stands for the current buffer.)
1116 If BINDFLAG is zero, then if this symbol is supposed to become
1117 local in every buffer where it is set, then we make it local.
1118 If BINDFLAG is nonzero, we don't do that. */
1121 set_internal (symbol
, newval
, buf
, bindflag
)
1122 register Lisp_Object symbol
, newval
;
1126 int voide
= EQ (newval
, Qunbound
);
1128 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1131 buf
= current_buffer
;
1133 /* If restoring in a dead buffer, do nothing. */
1134 if (NILP (buf
->name
))
1137 CHECK_SYMBOL (symbol
);
1138 if (SYMBOL_CONSTANT_P (symbol
)
1139 && (NILP (Fkeywordp (symbol
))
1140 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1141 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1143 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1145 if (BUFFER_OBJFWDP (valcontents
))
1147 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1148 int idx
= PER_BUFFER_IDX (offset
);
1151 && !let_shadows_buffer_binding_p (symbol
))
1152 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1154 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1155 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1157 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1158 if (XSYMBOL (symbol
)->indirect_variable
)
1159 symbol
= indirect_variable (symbol
);
1161 /* What binding is loaded right now? */
1162 current_alist_element
1163 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1165 /* If the current buffer is not the buffer whose binding is
1166 loaded, or if there may be frame-local bindings and the frame
1167 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1168 the default binding is loaded, the loaded binding may be the
1170 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1171 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1172 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1173 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1174 || (BUFFER_LOCAL_VALUEP (valcontents
)
1175 && EQ (XCAR (current_alist_element
),
1176 current_alist_element
)))
1178 /* The currently loaded binding is not necessarily valid.
1179 We need to unload it, and choose a new binding. */
1181 /* Write out `realvalue' to the old loaded binding. */
1182 Fsetcdr (current_alist_element
,
1183 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1185 /* Find the new binding. */
1186 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1187 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1188 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1192 /* This buffer still sees the default value. */
1194 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1195 or if this is `let' rather than `set',
1196 make CURRENT-ALIST-ELEMENT point to itself,
1197 indicating that we're seeing the default value.
1198 Likewise if the variable has been let-bound
1199 in the current buffer. */
1200 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1201 || let_shadows_buffer_binding_p (symbol
))
1203 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1205 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1206 tem1
= Fassq (symbol
,
1207 XFRAME (selected_frame
)->param_alist
);
1210 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1212 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1214 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1215 and we're not within a let that was made for this buffer,
1216 create a new buffer-local binding for the variable.
1217 That means, give this buffer a new assoc for a local value
1218 and load that binding. */
1221 tem1
= Fcons (symbol
, Fcdr (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 and it is evaluated.
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
= Fcar (args_left
);
1424 Fset_default (symbol
, val
);
1425 args_left
= Fcdr (Fcdr (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.
1445 The function `default-value' gets the default value and `set-default' sets it. */)
1447 register Lisp_Object variable
;
1449 register Lisp_Object tem
, valcontents
, newval
;
1451 CHECK_SYMBOL (variable
);
1453 valcontents
= SYMBOL_VALUE (variable
);
1454 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1455 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1457 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1459 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1461 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1464 if (EQ (valcontents
, Qunbound
))
1465 SET_SYMBOL_VALUE (variable
, Qnil
);
1466 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1468 newval
= allocate_misc ();
1469 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1470 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1471 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1472 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1473 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1474 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1475 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1476 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1477 SET_SYMBOL_VALUE (variable
, newval
);
1481 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1482 1, 1, "vMake Local Variable: ",
1483 doc
: /* Make VARIABLE have a separate value in the current buffer.
1484 Other buffers will continue to share a common default value.
1485 \(The buffer-local value of VARIABLE starts out as the same value
1486 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1487 See also `make-variable-buffer-local'.
1489 If the variable is already arranged to become local when set,
1490 this function causes a local value to exist for this buffer,
1491 just as setting the variable would do.
1493 This function returns VARIABLE, and therefore
1494 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1497 Do not use `make-local-variable' to make a hook variable buffer-local.
1498 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1500 register Lisp_Object variable
;
1502 register Lisp_Object tem
, valcontents
;
1504 CHECK_SYMBOL (variable
);
1506 valcontents
= SYMBOL_VALUE (variable
);
1507 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1508 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1510 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1512 tem
= Fboundp (variable
);
1514 /* Make sure the symbol has a local value in this particular buffer,
1515 by setting it to the same value it already has. */
1516 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1519 /* Make sure symbol is set up to hold per-buffer values. */
1520 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1523 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1525 newval
= allocate_misc ();
1526 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1527 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1528 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1529 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1530 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1531 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1532 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1533 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1534 SET_SYMBOL_VALUE (variable
, newval
);;
1536 /* Make sure this buffer has its own value of symbol. */
1537 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1540 /* Swap out any local binding for some other buffer, and make
1541 sure the current value is permanently recorded, if it's the
1543 find_symbol_value (variable
);
1545 current_buffer
->local_var_alist
1546 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1547 current_buffer
->local_var_alist
);
1549 /* Make sure symbol does not think it is set up for this buffer;
1550 force it to look once again for this buffer's value. */
1552 Lisp_Object
*pvalbuf
;
1554 valcontents
= SYMBOL_VALUE (variable
);
1556 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1557 if (current_buffer
== XBUFFER (*pvalbuf
))
1559 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1563 /* If the symbol forwards into a C variable, then load the binding
1564 for this buffer now. If C code modifies the variable before we
1565 load the binding in, then that new value will clobber the default
1566 binding the next time we unload it. */
1567 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1568 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1569 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1574 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1575 1, 1, "vKill Local Variable: ",
1576 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1577 From now on the default value will apply in this buffer. */)
1579 register Lisp_Object variable
;
1581 register Lisp_Object tem
, valcontents
;
1583 CHECK_SYMBOL (variable
);
1585 valcontents
= SYMBOL_VALUE (variable
);
1587 if (BUFFER_OBJFWDP (valcontents
))
1589 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1590 int idx
= PER_BUFFER_IDX (offset
);
1594 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1595 PER_BUFFER_VALUE (current_buffer
, offset
)
1596 = PER_BUFFER_DEFAULT (offset
);
1601 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1602 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1605 /* Get rid of this buffer's alist element, if any. */
1607 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1609 current_buffer
->local_var_alist
1610 = Fdelq (tem
, current_buffer
->local_var_alist
);
1612 /* If the symbol is set up with the current buffer's binding
1613 loaded, recompute its value. We have to do it now, or else
1614 forwarded objects won't work right. */
1616 Lisp_Object
*pvalbuf
;
1617 valcontents
= SYMBOL_VALUE (variable
);
1618 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1619 if (current_buffer
== XBUFFER (*pvalbuf
))
1622 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1623 find_symbol_value (variable
);
1630 /* Lisp functions for creating and removing buffer-local variables. */
1632 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1633 1, 1, "vMake Variable Frame Local: ",
1634 doc
: /* Enable VARIABLE to have frame-local bindings.
1635 When a frame-local binding exists in the current frame,
1636 it is in effect whenever the current buffer has no buffer-local binding.
1637 A frame-local binding is actual a frame parameter value;
1638 thus, any given frame has a local binding for VARIABLE
1639 if it has a value for the frame parameter named VARIABLE.
1640 See `modify-frame-parameters'. */)
1642 register Lisp_Object variable
;
1644 register Lisp_Object tem
, valcontents
, newval
;
1646 CHECK_SYMBOL (variable
);
1648 valcontents
= SYMBOL_VALUE (variable
);
1649 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1650 || BUFFER_OBJFWDP (valcontents
))
1651 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1653 if (BUFFER_LOCAL_VALUEP (valcontents
)
1654 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1656 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1660 if (EQ (valcontents
, Qunbound
))
1661 SET_SYMBOL_VALUE (variable
, Qnil
);
1662 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1664 newval
= allocate_misc ();
1665 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1666 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1667 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1668 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1669 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1670 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1671 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1672 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1673 SET_SYMBOL_VALUE (variable
, newval
);
1677 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1679 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1680 BUFFER defaults to the current buffer. */)
1682 register Lisp_Object variable
, buffer
;
1684 Lisp_Object valcontents
;
1685 register struct buffer
*buf
;
1688 buf
= current_buffer
;
1691 CHECK_BUFFER (buffer
);
1692 buf
= XBUFFER (buffer
);
1695 CHECK_SYMBOL (variable
);
1697 valcontents
= SYMBOL_VALUE (variable
);
1698 if (BUFFER_LOCAL_VALUEP (valcontents
)
1699 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1701 Lisp_Object tail
, elt
;
1703 variable
= indirect_variable (variable
);
1704 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1707 if (EQ (variable
, XCAR (elt
)))
1711 if (BUFFER_OBJFWDP (valcontents
))
1713 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1714 int idx
= PER_BUFFER_IDX (offset
);
1715 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1721 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1723 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
1724 BUFFER defaults to the current buffer. */)
1726 register Lisp_Object variable
, buffer
;
1728 Lisp_Object valcontents
;
1729 register struct buffer
*buf
;
1732 buf
= current_buffer
;
1735 CHECK_BUFFER (buffer
);
1736 buf
= XBUFFER (buffer
);
1739 CHECK_SYMBOL (variable
);
1741 valcontents
= SYMBOL_VALUE (variable
);
1743 /* This means that make-variable-buffer-local was done. */
1744 if (BUFFER_LOCAL_VALUEP (valcontents
))
1746 /* All these slots become local if they are set. */
1747 if (BUFFER_OBJFWDP (valcontents
))
1749 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1751 Lisp_Object tail
, elt
;
1752 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1755 if (EQ (variable
, XCAR (elt
)))
1762 /* Find the function at the end of a chain of symbol function indirections. */
1764 /* If OBJECT is a symbol, find the end of its function chain and
1765 return the value found there. If OBJECT is not a symbol, just
1766 return it. If there is a cycle in the function chain, signal a
1767 cyclic-function-indirection error.
1769 This is like Findirect_function, except that it doesn't signal an
1770 error if the chain ends up unbound. */
1772 indirect_function (object
)
1773 register Lisp_Object object
;
1775 Lisp_Object tortoise
, hare
;
1777 hare
= tortoise
= object
;
1781 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1783 hare
= XSYMBOL (hare
)->function
;
1784 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1786 hare
= XSYMBOL (hare
)->function
;
1788 tortoise
= XSYMBOL (tortoise
)->function
;
1790 if (EQ (hare
, tortoise
))
1791 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1797 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1798 doc
: /* Return the function at the end of OBJECT's function chain.
1799 If OBJECT is a symbol, follow all function indirections and return the final
1801 If OBJECT is not a symbol, just return it.
1802 Signal a void-function error if the final symbol is unbound.
1803 Signal a cyclic-function-indirection error if there is a loop in the
1804 function chain of symbols. */)
1806 register Lisp_Object object
;
1810 result
= indirect_function (object
);
1812 if (EQ (result
, Qunbound
))
1813 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1817 /* Extract and set vector and string elements */
1819 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1820 doc
: /* Return the element of ARRAY at index IDX.
1821 ARRAY may be a vector, a string, a char-table, a bool-vector,
1822 or a byte-code object. IDX starts at 0. */)
1824 register Lisp_Object array
;
1827 register int idxval
;
1830 idxval
= XINT (idx
);
1831 if (STRINGP (array
))
1835 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1836 args_out_of_range (array
, idx
);
1837 if (! STRING_MULTIBYTE (array
))
1838 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1839 idxval_byte
= string_char_to_byte (array
, idxval
);
1841 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1842 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1843 return make_number (c
);
1845 else if (BOOL_VECTOR_P (array
))
1849 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1850 args_out_of_range (array
, idx
);
1852 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1853 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1855 else if (CHAR_TABLE_P (array
))
1862 args_out_of_range (array
, idx
);
1863 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1865 /* For ASCII and 8-bit European characters, the element is
1866 stored in the top table. */
1867 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1869 val
= XCHAR_TABLE (array
)->defalt
;
1870 while (NILP (val
)) /* Follow parents until we find some value. */
1872 array
= XCHAR_TABLE (array
)->parent
;
1875 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1877 val
= XCHAR_TABLE (array
)->defalt
;
1884 Lisp_Object sub_table
;
1886 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1887 if (code
[1] < 32) code
[1] = -1;
1888 else if (code
[2] < 32) code
[2] = -1;
1890 /* Here, the possible range of CODE[0] (== charset ID) is
1891 128..MAX_CHARSET. Since the top level char table contains
1892 data for multibyte characters after 256th element, we must
1893 increment CODE[0] by 128 to get a correct index. */
1895 code
[3] = -1; /* anchor */
1897 try_parent_char_table
:
1899 for (i
= 0; code
[i
] >= 0; i
++)
1901 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1902 if (SUB_CHAR_TABLE_P (val
))
1907 val
= XCHAR_TABLE (sub_table
)->defalt
;
1910 array
= XCHAR_TABLE (array
)->parent
;
1912 goto try_parent_char_table
;
1917 /* Here, VAL is a sub char table. We try the default value
1919 val
= XCHAR_TABLE (val
)->defalt
;
1922 array
= XCHAR_TABLE (array
)->parent
;
1924 goto try_parent_char_table
;
1932 if (VECTORP (array
))
1933 size
= XVECTOR (array
)->size
;
1934 else if (COMPILEDP (array
))
1935 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1937 wrong_type_argument (Qarrayp
, array
);
1939 if (idxval
< 0 || idxval
>= size
)
1940 args_out_of_range (array
, idx
);
1941 return XVECTOR (array
)->contents
[idxval
];
1945 /* Don't use alloca for relocating string data larger than this, lest
1946 we overflow their stack. The value is the same as what used in
1947 fns.c for base64 handling. */
1948 #define MAX_ALLOCA 16*1024
1950 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1951 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1952 ARRAY may be a vector, a string, a char-table or a bool-vector.
1953 IDX starts at 0. */)
1954 (array
, idx
, newelt
)
1955 register Lisp_Object array
;
1956 Lisp_Object idx
, newelt
;
1958 register int idxval
;
1961 idxval
= XINT (idx
);
1962 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1963 && ! CHAR_TABLE_P (array
))
1964 array
= wrong_type_argument (Qarrayp
, array
);
1965 CHECK_IMPURE (array
);
1967 if (VECTORP (array
))
1969 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1970 args_out_of_range (array
, idx
);
1971 XVECTOR (array
)->contents
[idxval
] = newelt
;
1973 else if (BOOL_VECTOR_P (array
))
1977 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1978 args_out_of_range (array
, idx
);
1980 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1982 if (! NILP (newelt
))
1983 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1985 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1986 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1988 else if (CHAR_TABLE_P (array
))
1991 args_out_of_range (array
, idx
);
1992 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1993 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1999 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2000 if (code
[1] < 32) code
[1] = -1;
2001 else if (code
[2] < 32) code
[2] = -1;
2003 /* See the comment of the corresponding part in Faref. */
2005 code
[3] = -1; /* anchor */
2006 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2008 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2009 if (SUB_CHAR_TABLE_P (val
))
2015 /* VAL is a leaf. Create a sub char table with the
2016 default value VAL or XCHAR_TABLE (array)->defalt
2017 and look into it. */
2019 temp
= make_sub_char_table (NILP (val
)
2020 ? XCHAR_TABLE (array
)->defalt
2022 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2026 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2029 else if (STRING_MULTIBYTE (array
))
2031 int idxval_byte
, prev_bytes
, new_bytes
;
2032 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2034 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2035 args_out_of_range (array
, idx
);
2036 CHECK_NUMBER (newelt
);
2038 idxval_byte
= string_char_to_byte (array
, idxval
);
2039 p1
= &XSTRING (array
)->data
[idxval_byte
];
2040 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2041 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2042 if (prev_bytes
!= new_bytes
)
2044 /* We must relocate the string data. */
2045 int nchars
= XSTRING (array
)->size
;
2046 int nbytes
= STRING_BYTES (XSTRING (array
));
2049 str
= (nbytes
<= MAX_ALLOCA
2050 ? (unsigned char *) alloca (nbytes
)
2051 : (unsigned char *) xmalloc (nbytes
));
2052 bcopy (XSTRING (array
)->data
, str
, nbytes
);
2053 allocate_string_data (XSTRING (array
), nchars
,
2054 nbytes
+ new_bytes
- prev_bytes
);
2055 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2056 p1
= XSTRING (array
)->data
+ idxval_byte
;
2057 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2058 nbytes
- (idxval_byte
+ prev_bytes
));
2059 if (nbytes
> MAX_ALLOCA
)
2061 clear_string_char_byte_cache ();
2068 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2069 args_out_of_range (array
, idx
);
2070 CHECK_NUMBER (newelt
);
2072 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2073 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
2076 /* We must relocate the string data while converting it to
2078 int idxval_byte
, prev_bytes
, new_bytes
;
2079 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2080 unsigned char *origstr
= XSTRING (array
)->data
, *str
;
2083 nchars
= XSTRING (array
)->size
;
2084 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2085 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2087 str
= (nbytes
<= MAX_ALLOCA
2088 ? (unsigned char *) alloca (nbytes
)
2089 : (unsigned char *) xmalloc (nbytes
));
2090 copy_text (XSTRING (array
)->data
, str
, nchars
, 0, 1);
2091 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2093 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2094 allocate_string_data (XSTRING (array
), nchars
,
2095 nbytes
+ new_bytes
- prev_bytes
);
2096 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2097 p1
= XSTRING (array
)->data
+ idxval_byte
;
2100 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2101 nbytes
- (idxval_byte
+ prev_bytes
));
2102 if (nbytes
> MAX_ALLOCA
)
2104 clear_string_char_byte_cache ();
2111 /* Arithmetic functions */
2113 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2116 arithcompare (num1
, num2
, comparison
)
2117 Lisp_Object num1
, num2
;
2118 enum comparison comparison
;
2120 double f1
= 0, f2
= 0;
2123 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2124 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2126 if (FLOATP (num1
) || FLOATP (num2
))
2129 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2130 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : 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
))
2161 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2170 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2171 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2173 register Lisp_Object num1
, num2
;
2175 return arithcompare (num1
, num2
, equal
);
2178 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2179 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2181 register Lisp_Object num1
, num2
;
2183 return arithcompare (num1
, num2
, less
);
2186 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2187 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2189 register Lisp_Object num1
, num2
;
2191 return arithcompare (num1
, num2
, grtr
);
2194 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2195 doc
: /* Return t if first arg is less than or equal to second arg.
2196 Both must be numbers or markers. */)
2198 register Lisp_Object num1
, num2
;
2200 return arithcompare (num1
, num2
, less_or_equal
);
2203 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2204 doc
: /* Return t if first arg is greater than or equal to second arg.
2205 Both must be numbers or markers. */)
2207 register Lisp_Object num1
, num2
;
2209 return arithcompare (num1
, num2
, grtr_or_equal
);
2212 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2213 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2215 register Lisp_Object num1
, num2
;
2217 return arithcompare (num1
, num2
, notequal
);
2220 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2221 doc
: /* Return t if NUMBER is zero. */)
2223 register Lisp_Object number
;
2225 CHECK_NUMBER_OR_FLOAT (number
);
2227 if (FLOATP (number
))
2229 if (XFLOAT_DATA (number
) == 0.0)
2239 /* Convert between long values and pairs of Lisp integers. */
2245 unsigned int top
= i
>> 16;
2246 unsigned int bot
= i
& 0xFFFF;
2248 return make_number (bot
);
2249 if (top
== (unsigned long)-1 >> 16)
2250 return Fcons (make_number (-1), make_number (bot
));
2251 return Fcons (make_number (top
), make_number (bot
));
2258 Lisp_Object top
, bot
;
2265 return ((XINT (top
) << 16) | XINT (bot
));
2268 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2269 doc
: /* Convert NUMBER to a string by printing it in decimal.
2270 Uses a minus sign if negative.
2271 NUMBER may be an integer or a floating point number. */)
2275 char buffer
[VALBITS
];
2277 CHECK_NUMBER_OR_FLOAT (number
);
2279 if (FLOATP (number
))
2281 char pigbuf
[350]; /* see comments in float_to_string */
2283 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2284 return build_string (pigbuf
);
2287 if (sizeof (int) == sizeof (EMACS_INT
))
2288 sprintf (buffer
, "%d", XINT (number
));
2289 else if (sizeof (long) == sizeof (EMACS_INT
))
2290 sprintf (buffer
, "%ld", (long) XINT (number
));
2293 return build_string (buffer
);
2297 digit_to_number (character
, base
)
2298 int character
, base
;
2302 if (character
>= '0' && character
<= '9')
2303 digit
= character
- '0';
2304 else if (character
>= 'a' && character
<= 'z')
2305 digit
= character
- 'a' + 10;
2306 else if (character
>= 'A' && character
<= 'Z')
2307 digit
= character
- 'A' + 10;
2317 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2318 doc
: /* Convert STRING to a number by parsing it as a decimal number.
2319 This parses both integers and floating point numbers.
2320 It ignores leading spaces and tabs.
2322 If BASE, interpret STRING as a number in that base. If BASE isn't
2323 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2324 If the base used is not 10, floating point is not recognized. */)
2326 register Lisp_Object string
, base
;
2328 register unsigned char *p
;
2333 CHECK_STRING (string
);
2339 CHECK_NUMBER (base
);
2341 if (b
< 2 || b
> 16)
2342 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2345 /* Skip any whitespace at the front of the number. Some versions of
2346 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2347 p
= XSTRING (string
)->data
;
2348 while (*p
== ' ' || *p
== '\t')
2359 if (isfloat_string (p
) && b
== 10)
2360 val
= make_float (sign
* atof (p
));
2367 int digit
= digit_to_number (*p
++, b
);
2373 val
= make_fixnum_or_float (sign
* v
);
2393 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2394 int, Lisp_Object
*));
2395 extern Lisp_Object
fmod_float ();
2398 arith_driver (code
, nargs
, args
)
2401 register Lisp_Object
*args
;
2403 register Lisp_Object val
;
2404 register int argnum
;
2405 register EMACS_INT accum
= 0;
2406 register EMACS_INT next
;
2408 switch (SWITCH_ENUM_CAST (code
))
2426 for (argnum
= 0; argnum
< nargs
; argnum
++)
2428 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2430 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2433 return float_arith_driver ((double) accum
, argnum
, code
,
2436 next
= XINT (args
[argnum
]);
2437 switch (SWITCH_ENUM_CAST (code
))
2443 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2454 Fsignal (Qarith_error
, Qnil
);
2468 if (!argnum
|| next
> accum
)
2472 if (!argnum
|| next
< accum
)
2478 XSETINT (val
, accum
);
2483 #define isnan(x) ((x) != (x))
2486 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2488 register int argnum
;
2491 register Lisp_Object
*args
;
2493 register Lisp_Object val
;
2496 for (; argnum
< nargs
; argnum
++)
2498 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2499 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2503 next
= XFLOAT_DATA (val
);
2507 args
[argnum
] = val
; /* runs into a compiler bug. */
2508 next
= XINT (args
[argnum
]);
2510 switch (SWITCH_ENUM_CAST (code
))
2516 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2526 if (! IEEE_FLOATING_POINT
&& next
== 0)
2527 Fsignal (Qarith_error
, Qnil
);
2534 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2536 if (!argnum
|| isnan (next
) || next
> accum
)
2540 if (!argnum
|| isnan (next
) || next
< accum
)
2546 return make_float (accum
);
2550 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2551 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2552 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2557 return arith_driver (Aadd
, nargs
, args
);
2560 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2561 doc
: /* Negate number or subtract numbers or markers.
2562 With one arg, negates it. With more than one arg,
2563 subtracts all but the first from the first.
2564 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2569 return arith_driver (Asub
, nargs
, args
);
2572 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2573 doc
: /* Return product of any number of arguments, which are numbers or markers.
2574 usage: (* &rest NUMBERS-OR-MARKERS) */)
2579 return arith_driver (Amult
, nargs
, args
);
2582 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2583 doc
: /* Return first argument divided by all the remaining arguments.
2584 The arguments must be numbers or markers.
2585 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2590 return arith_driver (Adiv
, nargs
, args
);
2593 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2594 doc
: /* Return remainder of X divided by Y.
2595 Both must be integers or markers. */)
2597 register Lisp_Object x
, y
;
2601 CHECK_NUMBER_COERCE_MARKER (x
);
2602 CHECK_NUMBER_COERCE_MARKER (y
);
2604 if (XFASTINT (y
) == 0)
2605 Fsignal (Qarith_error
, Qnil
);
2607 XSETINT (val
, XINT (x
) % XINT (y
));
2621 /* If the magnitude of the result exceeds that of the divisor, or
2622 the sign of the result does not agree with that of the dividend,
2623 iterate with the reduced value. This does not yield a
2624 particularly accurate result, but at least it will be in the
2625 range promised by fmod. */
2627 r
-= f2
* floor (r
/ f2
);
2628 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2632 #endif /* ! HAVE_FMOD */
2634 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2635 doc
: /* Return X modulo Y.
2636 The result falls between zero (inclusive) and Y (exclusive).
2637 Both X and Y must be numbers or markers. */)
2639 register Lisp_Object x
, y
;
2644 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2645 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2647 if (FLOATP (x
) || FLOATP (y
))
2648 return fmod_float (x
, y
);
2654 Fsignal (Qarith_error
, Qnil
);
2658 /* If the "remainder" comes out with the wrong sign, fix it. */
2659 if (i2
< 0 ? i1
> 0 : i1
< 0)
2666 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2667 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2668 The value is always a number; markers are converted to numbers.
2669 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2674 return arith_driver (Amax
, nargs
, args
);
2677 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2678 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2679 The value is always a number; markers are converted to numbers.
2680 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2685 return arith_driver (Amin
, nargs
, args
);
2688 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2689 doc
: /* Return bitwise-and of all the arguments.
2690 Arguments may be integers, or markers converted to integers.
2691 usage: (logand &rest INTS-OR-MARKERS) */)
2696 return arith_driver (Alogand
, nargs
, args
);
2699 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2700 doc
: /* Return bitwise-or of all the arguments.
2701 Arguments may be integers, or markers converted to integers.
2702 usage: (logior &rest INTS-OR-MARKERS) */)
2707 return arith_driver (Alogior
, nargs
, args
);
2710 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2711 doc
: /* Return bitwise-exclusive-or of all the arguments.
2712 Arguments may be integers, or markers converted to integers.
2713 usage: (logxor &rest INTS-OR-MARKERS) */)
2718 return arith_driver (Alogxor
, nargs
, args
);
2721 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2722 doc
: /* Return VALUE with its bits shifted left by COUNT.
2723 If COUNT is negative, shifting is actually to the right.
2724 In this case, the sign bit is duplicated. */)
2726 register Lisp_Object value
, count
;
2728 register Lisp_Object val
;
2730 CHECK_NUMBER (value
);
2731 CHECK_NUMBER (count
);
2733 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2735 else if (XINT (count
) > 0)
2736 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2737 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2738 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2740 XSETINT (val
, XINT (value
) >> -XINT (count
));
2744 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2745 doc
: /* Return VALUE with its bits shifted left by COUNT.
2746 If COUNT is negative, shifting is actually to the right.
2747 In this case, zeros are shifted in on the left. */)
2749 register Lisp_Object value
, count
;
2751 register Lisp_Object val
;
2753 CHECK_NUMBER (value
);
2754 CHECK_NUMBER (count
);
2756 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2758 else if (XINT (count
) > 0)
2759 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2760 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2763 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2767 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2768 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2769 Markers are converted to integers. */)
2771 register Lisp_Object number
;
2773 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2775 if (FLOATP (number
))
2776 return (make_float (1.0 + XFLOAT_DATA (number
)));
2778 XSETINT (number
, XINT (number
) + 1);
2782 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2783 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2784 Markers are converted to integers. */)
2786 register Lisp_Object number
;
2788 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2790 if (FLOATP (number
))
2791 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2793 XSETINT (number
, XINT (number
) - 1);
2797 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2798 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2800 register Lisp_Object number
;
2802 CHECK_NUMBER (number
);
2803 XSETINT (number
, ~XINT (number
));
2810 Lisp_Object error_tail
, arith_tail
;
2812 Qquote
= intern ("quote");
2813 Qlambda
= intern ("lambda");
2814 Qsubr
= intern ("subr");
2815 Qerror_conditions
= intern ("error-conditions");
2816 Qerror_message
= intern ("error-message");
2817 Qtop_level
= intern ("top-level");
2819 Qerror
= intern ("error");
2820 Qquit
= intern ("quit");
2821 Qwrong_type_argument
= intern ("wrong-type-argument");
2822 Qargs_out_of_range
= intern ("args-out-of-range");
2823 Qvoid_function
= intern ("void-function");
2824 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2825 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2826 Qvoid_variable
= intern ("void-variable");
2827 Qsetting_constant
= intern ("setting-constant");
2828 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2830 Qinvalid_function
= intern ("invalid-function");
2831 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2832 Qno_catch
= intern ("no-catch");
2833 Qend_of_file
= intern ("end-of-file");
2834 Qarith_error
= intern ("arith-error");
2835 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2836 Qend_of_buffer
= intern ("end-of-buffer");
2837 Qbuffer_read_only
= intern ("buffer-read-only");
2838 Qtext_read_only
= intern ("text-read-only");
2839 Qmark_inactive
= intern ("mark-inactive");
2841 Qlistp
= intern ("listp");
2842 Qconsp
= intern ("consp");
2843 Qsymbolp
= intern ("symbolp");
2844 Qkeywordp
= intern ("keywordp");
2845 Qintegerp
= intern ("integerp");
2846 Qnatnump
= intern ("natnump");
2847 Qwholenump
= intern ("wholenump");
2848 Qstringp
= intern ("stringp");
2849 Qarrayp
= intern ("arrayp");
2850 Qsequencep
= intern ("sequencep");
2851 Qbufferp
= intern ("bufferp");
2852 Qvectorp
= intern ("vectorp");
2853 Qchar_or_string_p
= intern ("char-or-string-p");
2854 Qmarkerp
= intern ("markerp");
2855 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2856 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2857 Qboundp
= intern ("boundp");
2858 Qfboundp
= intern ("fboundp");
2860 Qfloatp
= intern ("floatp");
2861 Qnumberp
= intern ("numberp");
2862 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2864 Qchar_table_p
= intern ("char-table-p");
2865 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2867 Qsubrp
= intern ("subrp");
2868 Qunevalled
= intern ("unevalled");
2869 Qmany
= intern ("many");
2871 Qcdr
= intern ("cdr");
2873 /* Handle automatic advice activation */
2874 Qad_advice_info
= intern ("ad-advice-info");
2875 Qad_activate_internal
= intern ("ad-activate-internal");
2877 error_tail
= Fcons (Qerror
, Qnil
);
2879 /* ERROR is used as a signaler for random errors for which nothing else is right */
2881 Fput (Qerror
, Qerror_conditions
,
2883 Fput (Qerror
, Qerror_message
,
2884 build_string ("error"));
2886 Fput (Qquit
, Qerror_conditions
,
2887 Fcons (Qquit
, Qnil
));
2888 Fput (Qquit
, Qerror_message
,
2889 build_string ("Quit"));
2891 Fput (Qwrong_type_argument
, Qerror_conditions
,
2892 Fcons (Qwrong_type_argument
, error_tail
));
2893 Fput (Qwrong_type_argument
, Qerror_message
,
2894 build_string ("Wrong type argument"));
2896 Fput (Qargs_out_of_range
, Qerror_conditions
,
2897 Fcons (Qargs_out_of_range
, error_tail
));
2898 Fput (Qargs_out_of_range
, Qerror_message
,
2899 build_string ("Args out of range"));
2901 Fput (Qvoid_function
, Qerror_conditions
,
2902 Fcons (Qvoid_function
, error_tail
));
2903 Fput (Qvoid_function
, Qerror_message
,
2904 build_string ("Symbol's function definition is void"));
2906 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2907 Fcons (Qcyclic_function_indirection
, error_tail
));
2908 Fput (Qcyclic_function_indirection
, Qerror_message
,
2909 build_string ("Symbol's chain of function indirections contains a loop"));
2911 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2912 Fcons (Qcyclic_variable_indirection
, error_tail
));
2913 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2914 build_string ("Symbol's chain of variable indirections contains a loop"));
2916 Qcircular_list
= intern ("circular-list");
2917 staticpro (&Qcircular_list
);
2918 Fput (Qcircular_list
, Qerror_conditions
,
2919 Fcons (Qcircular_list
, error_tail
));
2920 Fput (Qcircular_list
, Qerror_message
,
2921 build_string ("List contains a loop"));
2923 Fput (Qvoid_variable
, Qerror_conditions
,
2924 Fcons (Qvoid_variable
, error_tail
));
2925 Fput (Qvoid_variable
, Qerror_message
,
2926 build_string ("Symbol's value as variable is void"));
2928 Fput (Qsetting_constant
, Qerror_conditions
,
2929 Fcons (Qsetting_constant
, error_tail
));
2930 Fput (Qsetting_constant
, Qerror_message
,
2931 build_string ("Attempt to set a constant symbol"));
2933 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2934 Fcons (Qinvalid_read_syntax
, error_tail
));
2935 Fput (Qinvalid_read_syntax
, Qerror_message
,
2936 build_string ("Invalid read syntax"));
2938 Fput (Qinvalid_function
, Qerror_conditions
,
2939 Fcons (Qinvalid_function
, error_tail
));
2940 Fput (Qinvalid_function
, Qerror_message
,
2941 build_string ("Invalid function"));
2943 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2944 Fcons (Qwrong_number_of_arguments
, error_tail
));
2945 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2946 build_string ("Wrong number of arguments"));
2948 Fput (Qno_catch
, Qerror_conditions
,
2949 Fcons (Qno_catch
, error_tail
));
2950 Fput (Qno_catch
, Qerror_message
,
2951 build_string ("No catch for tag"));
2953 Fput (Qend_of_file
, Qerror_conditions
,
2954 Fcons (Qend_of_file
, error_tail
));
2955 Fput (Qend_of_file
, Qerror_message
,
2956 build_string ("End of file during parsing"));
2958 arith_tail
= Fcons (Qarith_error
, error_tail
);
2959 Fput (Qarith_error
, Qerror_conditions
,
2961 Fput (Qarith_error
, Qerror_message
,
2962 build_string ("Arithmetic error"));
2964 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2965 Fcons (Qbeginning_of_buffer
, error_tail
));
2966 Fput (Qbeginning_of_buffer
, Qerror_message
,
2967 build_string ("Beginning of buffer"));
2969 Fput (Qend_of_buffer
, Qerror_conditions
,
2970 Fcons (Qend_of_buffer
, error_tail
));
2971 Fput (Qend_of_buffer
, Qerror_message
,
2972 build_string ("End of buffer"));
2974 Fput (Qbuffer_read_only
, Qerror_conditions
,
2975 Fcons (Qbuffer_read_only
, error_tail
));
2976 Fput (Qbuffer_read_only
, Qerror_message
,
2977 build_string ("Buffer is read-only"));
2979 Fput (Qtext_read_only
, Qerror_conditions
,
2980 Fcons (Qtext_read_only
, error_tail
));
2981 Fput (Qtext_read_only
, Qerror_message
,
2982 build_string ("Text is read-only"));
2984 Qrange_error
= intern ("range-error");
2985 Qdomain_error
= intern ("domain-error");
2986 Qsingularity_error
= intern ("singularity-error");
2987 Qoverflow_error
= intern ("overflow-error");
2988 Qunderflow_error
= intern ("underflow-error");
2990 Fput (Qdomain_error
, Qerror_conditions
,
2991 Fcons (Qdomain_error
, arith_tail
));
2992 Fput (Qdomain_error
, Qerror_message
,
2993 build_string ("Arithmetic domain error"));
2995 Fput (Qrange_error
, Qerror_conditions
,
2996 Fcons (Qrange_error
, arith_tail
));
2997 Fput (Qrange_error
, Qerror_message
,
2998 build_string ("Arithmetic range error"));
3000 Fput (Qsingularity_error
, Qerror_conditions
,
3001 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3002 Fput (Qsingularity_error
, Qerror_message
,
3003 build_string ("Arithmetic singularity error"));
3005 Fput (Qoverflow_error
, Qerror_conditions
,
3006 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3007 Fput (Qoverflow_error
, Qerror_message
,
3008 build_string ("Arithmetic overflow error"));
3010 Fput (Qunderflow_error
, Qerror_conditions
,
3011 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3012 Fput (Qunderflow_error
, Qerror_message
,
3013 build_string ("Arithmetic underflow error"));
3015 staticpro (&Qrange_error
);
3016 staticpro (&Qdomain_error
);
3017 staticpro (&Qsingularity_error
);
3018 staticpro (&Qoverflow_error
);
3019 staticpro (&Qunderflow_error
);
3023 staticpro (&Qquote
);
3024 staticpro (&Qlambda
);
3026 staticpro (&Qunbound
);
3027 staticpro (&Qerror_conditions
);
3028 staticpro (&Qerror_message
);
3029 staticpro (&Qtop_level
);
3031 staticpro (&Qerror
);
3033 staticpro (&Qwrong_type_argument
);
3034 staticpro (&Qargs_out_of_range
);
3035 staticpro (&Qvoid_function
);
3036 staticpro (&Qcyclic_function_indirection
);
3037 staticpro (&Qvoid_variable
);
3038 staticpro (&Qsetting_constant
);
3039 staticpro (&Qinvalid_read_syntax
);
3040 staticpro (&Qwrong_number_of_arguments
);
3041 staticpro (&Qinvalid_function
);
3042 staticpro (&Qno_catch
);
3043 staticpro (&Qend_of_file
);
3044 staticpro (&Qarith_error
);
3045 staticpro (&Qbeginning_of_buffer
);
3046 staticpro (&Qend_of_buffer
);
3047 staticpro (&Qbuffer_read_only
);
3048 staticpro (&Qtext_read_only
);
3049 staticpro (&Qmark_inactive
);
3051 staticpro (&Qlistp
);
3052 staticpro (&Qconsp
);
3053 staticpro (&Qsymbolp
);
3054 staticpro (&Qkeywordp
);
3055 staticpro (&Qintegerp
);
3056 staticpro (&Qnatnump
);
3057 staticpro (&Qwholenump
);
3058 staticpro (&Qstringp
);
3059 staticpro (&Qarrayp
);
3060 staticpro (&Qsequencep
);
3061 staticpro (&Qbufferp
);
3062 staticpro (&Qvectorp
);
3063 staticpro (&Qchar_or_string_p
);
3064 staticpro (&Qmarkerp
);
3065 staticpro (&Qbuffer_or_string_p
);
3066 staticpro (&Qinteger_or_marker_p
);
3067 staticpro (&Qfloatp
);
3068 staticpro (&Qnumberp
);
3069 staticpro (&Qnumber_or_marker_p
);
3070 staticpro (&Qchar_table_p
);
3071 staticpro (&Qvector_or_char_table_p
);
3072 staticpro (&Qsubrp
);
3074 staticpro (&Qunevalled
);
3076 staticpro (&Qboundp
);
3077 staticpro (&Qfboundp
);
3079 staticpro (&Qad_advice_info
);
3080 staticpro (&Qad_activate_internal
);
3082 /* Types that type-of returns. */
3083 Qinteger
= intern ("integer");
3084 Qsymbol
= intern ("symbol");
3085 Qstring
= intern ("string");
3086 Qcons
= intern ("cons");
3087 Qmarker
= intern ("marker");
3088 Qoverlay
= intern ("overlay");
3089 Qfloat
= intern ("float");
3090 Qwindow_configuration
= intern ("window-configuration");
3091 Qprocess
= intern ("process");
3092 Qwindow
= intern ("window");
3093 /* Qsubr = intern ("subr"); */
3094 Qcompiled_function
= intern ("compiled-function");
3095 Qbuffer
= intern ("buffer");
3096 Qframe
= intern ("frame");
3097 Qvector
= intern ("vector");
3098 Qchar_table
= intern ("char-table");
3099 Qbool_vector
= intern ("bool-vector");
3100 Qhash_table
= intern ("hash-table");
3102 staticpro (&Qinteger
);
3103 staticpro (&Qsymbol
);
3104 staticpro (&Qstring
);
3106 staticpro (&Qmarker
);
3107 staticpro (&Qoverlay
);
3108 staticpro (&Qfloat
);
3109 staticpro (&Qwindow_configuration
);
3110 staticpro (&Qprocess
);
3111 staticpro (&Qwindow
);
3112 /* staticpro (&Qsubr); */
3113 staticpro (&Qcompiled_function
);
3114 staticpro (&Qbuffer
);
3115 staticpro (&Qframe
);
3116 staticpro (&Qvector
);
3117 staticpro (&Qchar_table
);
3118 staticpro (&Qbool_vector
);
3119 staticpro (&Qhash_table
);
3121 defsubr (&Sindirect_variable
);
3122 defsubr (&Ssubr_interactive_form
);
3125 defsubr (&Stype_of
);
3130 defsubr (&Sintegerp
);
3131 defsubr (&Sinteger_or_marker_p
);
3132 defsubr (&Snumberp
);
3133 defsubr (&Snumber_or_marker_p
);
3135 defsubr (&Snatnump
);
3136 defsubr (&Ssymbolp
);
3137 defsubr (&Skeywordp
);
3138 defsubr (&Sstringp
);
3139 defsubr (&Smultibyte_string_p
);
3140 defsubr (&Svectorp
);
3141 defsubr (&Schar_table_p
);
3142 defsubr (&Svector_or_char_table_p
);
3143 defsubr (&Sbool_vector_p
);
3145 defsubr (&Ssequencep
);
3146 defsubr (&Sbufferp
);
3147 defsubr (&Smarkerp
);
3149 defsubr (&Sbyte_code_function_p
);
3150 defsubr (&Schar_or_string_p
);
3153 defsubr (&Scar_safe
);
3154 defsubr (&Scdr_safe
);
3157 defsubr (&Ssymbol_function
);
3158 defsubr (&Sindirect_function
);
3159 defsubr (&Ssymbol_plist
);
3160 defsubr (&Ssymbol_name
);
3161 defsubr (&Smakunbound
);
3162 defsubr (&Sfmakunbound
);
3164 defsubr (&Sfboundp
);
3166 defsubr (&Sdefalias
);
3167 defsubr (&Ssetplist
);
3168 defsubr (&Ssymbol_value
);
3170 defsubr (&Sdefault_boundp
);
3171 defsubr (&Sdefault_value
);
3172 defsubr (&Sset_default
);
3173 defsubr (&Ssetq_default
);
3174 defsubr (&Smake_variable_buffer_local
);
3175 defsubr (&Smake_local_variable
);
3176 defsubr (&Skill_local_variable
);
3177 defsubr (&Smake_variable_frame_local
);
3178 defsubr (&Slocal_variable_p
);
3179 defsubr (&Slocal_variable_if_set_p
);
3182 defsubr (&Snumber_to_string
);
3183 defsubr (&Sstring_to_number
);
3184 defsubr (&Seqlsign
);
3207 defsubr (&Ssubr_arity
);
3209 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3211 DEFVAR_INT ("most-positive-fixnum", &most_positive_fixnum
,
3212 doc
: /* The largest value that is representable in a Lisp integer. */);
3213 most_positive_fixnum
= MOST_POSITIVE_FIXNUM
;
3215 DEFVAR_INT ("most-negative-fixnum", &most_negative_fixnum
,
3216 doc
: /* The smallest value that is representable in a Lisp integer. */);
3217 most_negative_fixnum
= MOST_NEGATIVE_FIXNUM
;
3224 #if defined(USG) && !defined(POSIX_SIGNALS)
3225 /* USG systems forget handlers when they are used;
3226 must reestablish each time */
3227 signal (signo
, arith_error
);
3230 /* VMS systems are like USG. */
3231 signal (signo
, arith_error
);
3235 #else /* not BSD4_1 */
3236 sigsetmask (SIGEMPTYMASK
);
3237 #endif /* not BSD4_1 */
3239 Fsignal (Qarith_error
, Qnil
);
3245 /* Don't do this if just dumping out.
3246 We don't want to call `signal' in this case
3247 so that we don't have trouble with dumping
3248 signal-delivering routines in an inconsistent state. */
3252 #endif /* CANNOT_DUMP */
3253 signal (SIGFPE
, arith_error
);
3256 signal (SIGEMT
, arith_error
);