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
, 0);
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
, 0);
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
, 0);
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
, 0);
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
, 0);
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
, 0);
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
, 0);
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
, 0);
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
, 0);
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
, 1);
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
, 0);
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
, 0);
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
, 0);
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
, 0);
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
1405 of previous SYMs. */)
1409 register Lisp_Object args_left
;
1410 register Lisp_Object val
, symbol
;
1411 struct gcpro gcpro1
;
1421 val
= Feval (Fcar (Fcdr (args_left
)));
1422 symbol
= Fcar (args_left
);
1423 Fset_default (symbol
, val
);
1424 args_left
= Fcdr (Fcdr (args_left
));
1426 while (!NILP (args_left
));
1432 /* Lisp functions for creating and removing buffer-local variables. */
1434 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1435 1, 1, "vMake Variable Buffer Local: ",
1436 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1437 At any time, the value for the current buffer is in effect,
1438 unless the variable has never been set in this buffer,
1439 in which case the default value is in effect.
1440 Note that binding the variable with `let', or setting it while
1441 a `let'-style binding made in this buffer is in effect,
1442 does not make the variable buffer-local.
1444 The function `default-value' gets the default value and `set-default' sets it. */)
1446 register Lisp_Object variable
;
1448 register Lisp_Object tem
, valcontents
, newval
;
1450 CHECK_SYMBOL (variable
, 0);
1452 valcontents
= SYMBOL_VALUE (variable
);
1453 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1454 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1456 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1458 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1460 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1463 if (EQ (valcontents
, Qunbound
))
1464 SET_SYMBOL_VALUE (variable
, Qnil
);
1465 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1467 newval
= allocate_misc ();
1468 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1469 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1470 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1471 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1472 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1473 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1474 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1475 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1476 SET_SYMBOL_VALUE (variable
, newval
);
1480 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1481 1, 1, "vMake Local Variable: ",
1482 doc
: /* Make VARIABLE have a separate value in the current buffer.
1483 Other buffers will continue to share a common default value.
1484 \(The buffer-local value of VARIABLE starts out as the same value
1485 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1486 See also `make-variable-buffer-local'.
1488 If the variable is already arranged to become local when set,
1489 this function causes a local value to exist for this buffer,
1490 just as setting the variable would do.
1492 This function returns VARIABLE, and therefore
1493 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1496 Do not use `make-local-variable' to make a hook variable buffer-local.
1497 Use `make-local-hook' instead. */)
1499 register Lisp_Object variable
;
1501 register Lisp_Object tem
, valcontents
;
1503 CHECK_SYMBOL (variable
, 0);
1505 valcontents
= SYMBOL_VALUE (variable
);
1506 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1507 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1509 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1511 tem
= Fboundp (variable
);
1513 /* Make sure the symbol has a local value in this particular buffer,
1514 by setting it to the same value it already has. */
1515 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1518 /* Make sure symbol is set up to hold per-buffer values. */
1519 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1522 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1524 newval
= allocate_misc ();
1525 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1526 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1527 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1528 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1529 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1530 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1531 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1532 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1533 SET_SYMBOL_VALUE (variable
, newval
);;
1535 /* Make sure this buffer has its own value of symbol. */
1536 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1539 /* Swap out any local binding for some other buffer, and make
1540 sure the current value is permanently recorded, if it's the
1542 find_symbol_value (variable
);
1544 current_buffer
->local_var_alist
1545 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1546 current_buffer
->local_var_alist
);
1548 /* Make sure symbol does not think it is set up for this buffer;
1549 force it to look once again for this buffer's value. */
1551 Lisp_Object
*pvalbuf
;
1553 valcontents
= SYMBOL_VALUE (variable
);
1555 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1556 if (current_buffer
== XBUFFER (*pvalbuf
))
1558 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1562 /* If the symbol forwards into a C variable, then load the binding
1563 for this buffer now. If C code modifies the variable before we
1564 load the binding in, then that new value will clobber the default
1565 binding the next time we unload it. */
1566 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1567 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1568 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1573 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1574 1, 1, "vKill Local Variable: ",
1575 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1576 From now on the default value will apply in this buffer. */)
1578 register Lisp_Object variable
;
1580 register Lisp_Object tem
, valcontents
;
1582 CHECK_SYMBOL (variable
, 0);
1584 valcontents
= SYMBOL_VALUE (variable
);
1586 if (BUFFER_OBJFWDP (valcontents
))
1588 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1589 int idx
= PER_BUFFER_IDX (offset
);
1593 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1594 PER_BUFFER_VALUE (current_buffer
, offset
)
1595 = PER_BUFFER_DEFAULT (offset
);
1600 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1601 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1604 /* Get rid of this buffer's alist element, if any. */
1606 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1608 current_buffer
->local_var_alist
1609 = Fdelq (tem
, current_buffer
->local_var_alist
);
1611 /* If the symbol is set up with the current buffer's binding
1612 loaded, recompute its value. We have to do it now, or else
1613 forwarded objects won't work right. */
1615 Lisp_Object
*pvalbuf
;
1616 valcontents
= SYMBOL_VALUE (variable
);
1617 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1618 if (current_buffer
== XBUFFER (*pvalbuf
))
1621 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1622 find_symbol_value (variable
);
1629 /* Lisp functions for creating and removing buffer-local variables. */
1631 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1632 1, 1, "vMake Variable Frame Local: ",
1633 doc
: /* Enable VARIABLE to have frame-local bindings.
1634 When a frame-local binding exists in the current frame,
1635 it is in effect whenever the current buffer has no buffer-local binding.
1636 A frame-local binding is actual a frame parameter value;
1637 thus, any given frame has a local binding for VARIABLE
1638 if it has a value for the frame parameter named VARIABLE.
1639 See `modify-frame-parameters'. */)
1641 register Lisp_Object variable
;
1643 register Lisp_Object tem
, valcontents
, newval
;
1645 CHECK_SYMBOL (variable
, 0);
1647 valcontents
= SYMBOL_VALUE (variable
);
1648 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1649 || BUFFER_OBJFWDP (valcontents
))
1650 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1652 if (BUFFER_LOCAL_VALUEP (valcontents
)
1653 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1655 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1659 if (EQ (valcontents
, Qunbound
))
1660 SET_SYMBOL_VALUE (variable
, Qnil
);
1661 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1663 newval
= allocate_misc ();
1664 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1665 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1666 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1667 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1668 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1669 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1670 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1671 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1672 SET_SYMBOL_VALUE (variable
, newval
);
1676 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1678 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1679 BUFFER defaults to the current buffer. */)
1681 register Lisp_Object variable
, buffer
;
1683 Lisp_Object valcontents
;
1684 register struct buffer
*buf
;
1687 buf
= current_buffer
;
1690 CHECK_BUFFER (buffer
, 0);
1691 buf
= XBUFFER (buffer
);
1694 CHECK_SYMBOL (variable
, 0);
1696 valcontents
= SYMBOL_VALUE (variable
);
1697 if (BUFFER_LOCAL_VALUEP (valcontents
)
1698 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1700 Lisp_Object tail
, elt
;
1702 variable
= indirect_variable (variable
);
1703 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1706 if (EQ (variable
, XCAR (elt
)))
1710 if (BUFFER_OBJFWDP (valcontents
))
1712 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1713 int idx
= PER_BUFFER_IDX (offset
);
1714 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1720 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1722 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
1723 BUFFER defaults to the current buffer. */)
1725 register Lisp_Object variable
, buffer
;
1727 Lisp_Object valcontents
;
1728 register struct buffer
*buf
;
1731 buf
= current_buffer
;
1734 CHECK_BUFFER (buffer
, 0);
1735 buf
= XBUFFER (buffer
);
1738 CHECK_SYMBOL (variable
, 0);
1740 valcontents
= SYMBOL_VALUE (variable
);
1742 /* This means that make-variable-buffer-local was done. */
1743 if (BUFFER_LOCAL_VALUEP (valcontents
))
1745 /* All these slots become local if they are set. */
1746 if (BUFFER_OBJFWDP (valcontents
))
1748 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1750 Lisp_Object tail
, elt
;
1751 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1754 if (EQ (variable
, XCAR (elt
)))
1761 /* Find the function at the end of a chain of symbol function indirections. */
1763 /* If OBJECT is a symbol, find the end of its function chain and
1764 return the value found there. If OBJECT is not a symbol, just
1765 return it. If there is a cycle in the function chain, signal a
1766 cyclic-function-indirection error.
1768 This is like Findirect_function, except that it doesn't signal an
1769 error if the chain ends up unbound. */
1771 indirect_function (object
)
1772 register Lisp_Object object
;
1774 Lisp_Object tortoise
, hare
;
1776 hare
= tortoise
= object
;
1780 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1782 hare
= XSYMBOL (hare
)->function
;
1783 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1785 hare
= XSYMBOL (hare
)->function
;
1787 tortoise
= XSYMBOL (tortoise
)->function
;
1789 if (EQ (hare
, tortoise
))
1790 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1796 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1797 doc
: /* Return the function at the end of OBJECT's function chain.
1798 If OBJECT is a symbol, follow all function indirections and return the final
1800 If OBJECT is not a symbol, just return it.
1801 Signal a void-function error if the final symbol is unbound.
1802 Signal a cyclic-function-indirection error if there is a loop in the
1803 function chain of symbols. */)
1805 register Lisp_Object object
;
1809 result
= indirect_function (object
);
1811 if (EQ (result
, Qunbound
))
1812 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1816 /* Extract and set vector and string elements */
1818 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1819 doc
: /* Return the element of ARRAY at index IDX.
1820 ARRAY may be a vector, a string, a char-table, a bool-vector,
1821 or a byte-code object. IDX starts at 0. */)
1823 register Lisp_Object array
;
1826 register int idxval
;
1828 CHECK_NUMBER (idx
, 1);
1829 idxval
= XINT (idx
);
1830 if (STRINGP (array
))
1834 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1835 args_out_of_range (array
, idx
);
1836 if (! STRING_MULTIBYTE (array
))
1837 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1838 idxval_byte
= string_char_to_byte (array
, idxval
);
1840 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1841 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1842 return make_number (c
);
1844 else if (BOOL_VECTOR_P (array
))
1848 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1849 args_out_of_range (array
, idx
);
1851 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1852 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1854 else if (CHAR_TABLE_P (array
))
1861 args_out_of_range (array
, idx
);
1862 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1864 /* For ASCII and 8-bit European characters, the element is
1865 stored in the top table. */
1866 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1868 val
= XCHAR_TABLE (array
)->defalt
;
1869 while (NILP (val
)) /* Follow parents until we find some value. */
1871 array
= XCHAR_TABLE (array
)->parent
;
1874 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1876 val
= XCHAR_TABLE (array
)->defalt
;
1883 Lisp_Object sub_table
;
1885 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1886 if (code
[1] < 32) code
[1] = -1;
1887 else if (code
[2] < 32) code
[2] = -1;
1889 /* Here, the possible range of CODE[0] (== charset ID) is
1890 128..MAX_CHARSET. Since the top level char table contains
1891 data for multibyte characters after 256th element, we must
1892 increment CODE[0] by 128 to get a correct index. */
1894 code
[3] = -1; /* anchor */
1896 try_parent_char_table
:
1898 for (i
= 0; code
[i
] >= 0; i
++)
1900 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1901 if (SUB_CHAR_TABLE_P (val
))
1906 val
= XCHAR_TABLE (sub_table
)->defalt
;
1909 array
= XCHAR_TABLE (array
)->parent
;
1911 goto try_parent_char_table
;
1916 /* Here, VAL is a sub char table. We try the default value
1918 val
= XCHAR_TABLE (val
)->defalt
;
1921 array
= XCHAR_TABLE (array
)->parent
;
1923 goto try_parent_char_table
;
1931 if (VECTORP (array
))
1932 size
= XVECTOR (array
)->size
;
1933 else if (COMPILEDP (array
))
1934 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1936 wrong_type_argument (Qarrayp
, array
);
1938 if (idxval
< 0 || idxval
>= size
)
1939 args_out_of_range (array
, idx
);
1940 return XVECTOR (array
)->contents
[idxval
];
1944 /* Don't use alloca for relocating string data larger than this, lest
1945 we overflow their stack. The value is the same as what used in
1946 fns.c for base64 handling. */
1947 #define MAX_ALLOCA 16*1024
1949 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1950 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1951 ARRAY may be a vector, a string, a char-table or a bool-vector.
1952 IDX starts at 0. */)
1953 (array
, idx
, newelt
)
1954 register Lisp_Object array
;
1955 Lisp_Object idx
, newelt
;
1957 register int idxval
;
1959 CHECK_NUMBER (idx
, 1);
1960 idxval
= XINT (idx
);
1961 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1962 && ! CHAR_TABLE_P (array
))
1963 array
= wrong_type_argument (Qarrayp
, array
);
1964 CHECK_IMPURE (array
);
1966 if (VECTORP (array
))
1968 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1969 args_out_of_range (array
, idx
);
1970 XVECTOR (array
)->contents
[idxval
] = newelt
;
1972 else if (BOOL_VECTOR_P (array
))
1976 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1977 args_out_of_range (array
, idx
);
1979 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1981 if (! NILP (newelt
))
1982 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1984 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1985 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1987 else if (CHAR_TABLE_P (array
))
1990 args_out_of_range (array
, idx
);
1991 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1992 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1998 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1999 if (code
[1] < 32) code
[1] = -1;
2000 else if (code
[2] < 32) code
[2] = -1;
2002 /* See the comment of the corresponding part in Faref. */
2004 code
[3] = -1; /* anchor */
2005 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2007 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2008 if (SUB_CHAR_TABLE_P (val
))
2014 /* VAL is a leaf. Create a sub char table with the
2015 default value VAL or XCHAR_TABLE (array)->defalt
2016 and look into it. */
2018 temp
= make_sub_char_table (NILP (val
)
2019 ? XCHAR_TABLE (array
)->defalt
2021 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2025 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2028 else if (STRING_MULTIBYTE (array
))
2030 int idxval_byte
, prev_bytes
, new_bytes
;
2031 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2033 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2034 args_out_of_range (array
, idx
);
2035 CHECK_NUMBER (newelt
, 2);
2037 idxval_byte
= string_char_to_byte (array
, idxval
);
2038 p1
= &XSTRING (array
)->data
[idxval_byte
];
2039 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2040 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2041 if (prev_bytes
!= new_bytes
)
2043 /* We must relocate the string data. */
2044 int nchars
= XSTRING (array
)->size
;
2045 int nbytes
= STRING_BYTES (XSTRING (array
));
2048 str
= (nbytes
<= MAX_ALLOCA
2049 ? (unsigned char *) alloca (nbytes
)
2050 : (unsigned char *) xmalloc (nbytes
));
2051 bcopy (XSTRING (array
)->data
, str
, nbytes
);
2052 allocate_string_data (XSTRING (array
), nchars
,
2053 nbytes
+ new_bytes
- prev_bytes
);
2054 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2055 p1
= XSTRING (array
)->data
+ idxval_byte
;
2056 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2057 nbytes
- (idxval_byte
+ prev_bytes
));
2058 if (nbytes
> MAX_ALLOCA
)
2060 clear_string_char_byte_cache ();
2067 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2068 args_out_of_range (array
, idx
);
2069 CHECK_NUMBER (newelt
, 2);
2071 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2072 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
2075 /* We must relocate the string data while converting it to
2077 int idxval_byte
, prev_bytes
, new_bytes
;
2078 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2079 unsigned char *origstr
= XSTRING (array
)->data
, *str
;
2082 nchars
= XSTRING (array
)->size
;
2083 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2084 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2086 str
= (nbytes
<= MAX_ALLOCA
2087 ? (unsigned char *) alloca (nbytes
)
2088 : (unsigned char *) xmalloc (nbytes
));
2089 copy_text (XSTRING (array
)->data
, str
, nchars
, 0, 1);
2090 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2092 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2093 allocate_string_data (XSTRING (array
), nchars
,
2094 nbytes
+ new_bytes
- prev_bytes
);
2095 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2096 p1
= XSTRING (array
)->data
+ idxval_byte
;
2099 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2100 nbytes
- (idxval_byte
+ prev_bytes
));
2101 if (nbytes
> MAX_ALLOCA
)
2103 clear_string_char_byte_cache ();
2110 /* Arithmetic functions */
2112 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2115 arithcompare (num1
, num2
, comparison
)
2116 Lisp_Object num1
, num2
;
2117 enum comparison comparison
;
2119 double f1
= 0, f2
= 0;
2122 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
2123 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
2125 if (FLOATP (num1
) || FLOATP (num2
))
2128 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2129 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2135 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2140 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2145 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2150 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2155 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2160 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2169 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2170 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2172 register Lisp_Object num1
, num2
;
2174 return arithcompare (num1
, num2
, equal
);
2177 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2178 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2180 register Lisp_Object num1
, num2
;
2182 return arithcompare (num1
, num2
, less
);
2185 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2186 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2188 register Lisp_Object num1
, num2
;
2190 return arithcompare (num1
, num2
, grtr
);
2193 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2194 doc
: /* Return t if first arg is less than or equal to second arg.
2195 Both must be numbers or markers. */)
2197 register Lisp_Object num1
, num2
;
2199 return arithcompare (num1
, num2
, less_or_equal
);
2202 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2203 doc
: /* Return t if first arg is greater than or equal to second arg.
2204 Both must be numbers or markers. */)
2206 register Lisp_Object num1
, num2
;
2208 return arithcompare (num1
, num2
, grtr_or_equal
);
2211 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2212 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2214 register Lisp_Object num1
, num2
;
2216 return arithcompare (num1
, num2
, notequal
);
2219 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2220 doc
: /* Return t if NUMBER is zero. */)
2222 register Lisp_Object number
;
2224 CHECK_NUMBER_OR_FLOAT (number
, 0);
2226 if (FLOATP (number
))
2228 if (XFLOAT_DATA (number
) == 0.0)
2238 /* Convert between long values and pairs of Lisp integers. */
2244 unsigned int top
= i
>> 16;
2245 unsigned int bot
= i
& 0xFFFF;
2247 return make_number (bot
);
2248 if (top
== (unsigned long)-1 >> 16)
2249 return Fcons (make_number (-1), make_number (bot
));
2250 return Fcons (make_number (top
), make_number (bot
));
2257 Lisp_Object top
, bot
;
2264 return ((XINT (top
) << 16) | XINT (bot
));
2267 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2268 doc
: /* Convert NUMBER to a string by printing it in decimal.
2269 Uses a minus sign if negative.
2270 NUMBER may be an integer or a floating point number. */)
2274 char buffer
[VALBITS
];
2276 CHECK_NUMBER_OR_FLOAT (number
, 0);
2278 if (FLOATP (number
))
2280 char pigbuf
[350]; /* see comments in float_to_string */
2282 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2283 return build_string (pigbuf
);
2286 if (sizeof (int) == sizeof (EMACS_INT
))
2287 sprintf (buffer
, "%d", XINT (number
));
2288 else if (sizeof (long) == sizeof (EMACS_INT
))
2289 sprintf (buffer
, "%ld", (long) XINT (number
));
2292 return build_string (buffer
);
2296 digit_to_number (character
, base
)
2297 int character
, base
;
2301 if (character
>= '0' && character
<= '9')
2302 digit
= character
- '0';
2303 else if (character
>= 'a' && character
<= 'z')
2304 digit
= character
- 'a' + 10;
2305 else if (character
>= 'A' && character
<= 'Z')
2306 digit
= character
- 'A' + 10;
2316 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2317 doc
: /* Convert STRING to a number by parsing it as a decimal number.
2318 This parses both integers and floating point numbers.
2319 It ignores leading spaces and tabs.
2321 If BASE, interpret STRING as a number in that base. If BASE isn't
2322 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2323 If the base used is not 10, floating point is not recognized. */)
2325 register Lisp_Object string
, base
;
2327 register unsigned char *p
;
2332 CHECK_STRING (string
, 0);
2338 CHECK_NUMBER (base
, 1);
2340 if (b
< 2 || b
> 16)
2341 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2344 /* Skip any whitespace at the front of the number. Some versions of
2345 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2346 p
= XSTRING (string
)->data
;
2347 while (*p
== ' ' || *p
== '\t')
2358 if (isfloat_string (p
) && b
== 10)
2359 val
= make_float (sign
* atof (p
));
2366 int digit
= digit_to_number (*p
++, b
);
2372 val
= make_fixnum_or_float (sign
* v
);
2392 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2393 int, Lisp_Object
*));
2394 extern Lisp_Object
fmod_float ();
2397 arith_driver (code
, nargs
, args
)
2400 register Lisp_Object
*args
;
2402 register Lisp_Object val
;
2403 register int argnum
;
2404 register EMACS_INT accum
= 0;
2405 register EMACS_INT next
;
2407 switch (SWITCH_ENUM_CAST (code
))
2425 for (argnum
= 0; argnum
< nargs
; argnum
++)
2427 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2429 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2432 return float_arith_driver ((double) accum
, argnum
, code
,
2435 next
= XINT (args
[argnum
]);
2436 switch (SWITCH_ENUM_CAST (code
))
2442 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2453 Fsignal (Qarith_error
, Qnil
);
2467 if (!argnum
|| next
> accum
)
2471 if (!argnum
|| next
< accum
)
2477 XSETINT (val
, accum
);
2482 #define isnan(x) ((x) != (x))
2485 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2487 register int argnum
;
2490 register Lisp_Object
*args
;
2492 register Lisp_Object val
;
2495 for (; argnum
< nargs
; argnum
++)
2497 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2498 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2502 next
= XFLOAT_DATA (val
);
2506 args
[argnum
] = val
; /* runs into a compiler bug. */
2507 next
= XINT (args
[argnum
]);
2509 switch (SWITCH_ENUM_CAST (code
))
2515 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2525 if (! IEEE_FLOATING_POINT
&& next
== 0)
2526 Fsignal (Qarith_error
, Qnil
);
2533 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2535 if (!argnum
|| isnan (next
) || next
> accum
)
2539 if (!argnum
|| isnan (next
) || next
< accum
)
2545 return make_float (accum
);
2549 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2550 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2551 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2556 return arith_driver (Aadd
, nargs
, args
);
2559 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2560 doc
: /* Negate number or subtract numbers or markers.
2561 With one arg, negates it. With more than one arg,
2562 subtracts all but the first from the first.
2563 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2568 return arith_driver (Asub
, nargs
, args
);
2571 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2572 doc
: /* Returns product of any number of arguments, which are numbers or markers.
2573 usage: (* &rest NUMBERS-OR-MARKERS) */)
2578 return arith_driver (Amult
, nargs
, args
);
2581 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2582 doc
: /* Returns first argument divided by all the remaining arguments.
2583 The arguments must be numbers or markers.
2584 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2589 return arith_driver (Adiv
, nargs
, args
);
2592 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2593 doc
: /* Returns remainder of X divided by Y.
2594 Both must be integers or markers. */)
2596 register Lisp_Object x
, y
;
2600 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2601 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2603 if (XFASTINT (y
) == 0)
2604 Fsignal (Qarith_error
, Qnil
);
2606 XSETINT (val
, XINT (x
) % XINT (y
));
2620 /* If the magnitude of the result exceeds that of the divisor, or
2621 the sign of the result does not agree with that of the dividend,
2622 iterate with the reduced value. This does not yield a
2623 particularly accurate result, but at least it will be in the
2624 range promised by fmod. */
2626 r
-= f2
* floor (r
/ f2
);
2627 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2631 #endif /* ! HAVE_FMOD */
2633 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2634 doc
: /* Returns X modulo Y.
2635 The result falls between zero (inclusive) and Y (exclusive).
2636 Both X and Y must be numbers or markers. */)
2638 register Lisp_Object x
, y
;
2643 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2644 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2646 if (FLOATP (x
) || FLOATP (y
))
2647 return fmod_float (x
, y
);
2653 Fsignal (Qarith_error
, Qnil
);
2657 /* If the "remainder" comes out with the wrong sign, fix it. */
2658 if (i2
< 0 ? i1
> 0 : i1
< 0)
2665 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2666 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2667 The value is always a number; markers are converted to numbers.
2668 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2673 return arith_driver (Amax
, nargs
, args
);
2676 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2677 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2678 The value is always a number; markers are converted to numbers.
2679 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2684 return arith_driver (Amin
, nargs
, args
);
2687 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2688 doc
: /* Return bitwise-and of all the arguments.
2689 Arguments may be integers, or markers converted to integers.
2690 usage: (logand &rest INTS-OR-MARKERS) */)
2695 return arith_driver (Alogand
, nargs
, args
);
2698 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2699 doc
: /* Return bitwise-or of all the arguments.
2700 Arguments may be integers, or markers converted to integers.
2701 usage: (logior &rest INTS-OR-MARKERS) */)
2706 return arith_driver (Alogior
, nargs
, args
);
2709 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2710 doc
: /* Return bitwise-exclusive-or of all the arguments.
2711 Arguments may be integers, or markers converted to integers.
2712 usage: (logxor &rest INTS-OR-MARKERS) */)
2717 return arith_driver (Alogxor
, nargs
, args
);
2720 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2721 doc
: /* Return VALUE with its bits shifted left by COUNT.
2722 If COUNT is negative, shifting is actually to the right.
2723 In this case, the sign bit is duplicated. */)
2725 register Lisp_Object value
, count
;
2727 register Lisp_Object val
;
2729 CHECK_NUMBER (value
, 0);
2730 CHECK_NUMBER (count
, 1);
2732 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2734 else if (XINT (count
) > 0)
2735 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2736 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2737 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2739 XSETINT (val
, XINT (value
) >> -XINT (count
));
2743 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2744 doc
: /* Return VALUE with its bits shifted left by COUNT.
2745 If COUNT is negative, shifting is actually to the right.
2746 In this case, zeros are shifted in on the left. */)
2748 register Lisp_Object value
, count
;
2750 register Lisp_Object val
;
2752 CHECK_NUMBER (value
, 0);
2753 CHECK_NUMBER (count
, 1);
2755 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2757 else if (XINT (count
) > 0)
2758 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2759 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2762 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2766 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2767 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2768 Markers are converted to integers. */)
2770 register Lisp_Object number
;
2772 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2774 if (FLOATP (number
))
2775 return (make_float (1.0 + XFLOAT_DATA (number
)));
2777 XSETINT (number
, XINT (number
) + 1);
2781 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2782 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2783 Markers are converted to integers. */)
2785 register Lisp_Object number
;
2787 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2789 if (FLOATP (number
))
2790 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2792 XSETINT (number
, XINT (number
) - 1);
2796 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2797 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2799 register Lisp_Object number
;
2801 CHECK_NUMBER (number
, 0);
2802 XSETINT (number
, ~XINT (number
));
2809 Lisp_Object error_tail
, arith_tail
;
2811 Qquote
= intern ("quote");
2812 Qlambda
= intern ("lambda");
2813 Qsubr
= intern ("subr");
2814 Qerror_conditions
= intern ("error-conditions");
2815 Qerror_message
= intern ("error-message");
2816 Qtop_level
= intern ("top-level");
2818 Qerror
= intern ("error");
2819 Qquit
= intern ("quit");
2820 Qwrong_type_argument
= intern ("wrong-type-argument");
2821 Qargs_out_of_range
= intern ("args-out-of-range");
2822 Qvoid_function
= intern ("void-function");
2823 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2824 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2825 Qvoid_variable
= intern ("void-variable");
2826 Qsetting_constant
= intern ("setting-constant");
2827 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2829 Qinvalid_function
= intern ("invalid-function");
2830 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2831 Qno_catch
= intern ("no-catch");
2832 Qend_of_file
= intern ("end-of-file");
2833 Qarith_error
= intern ("arith-error");
2834 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2835 Qend_of_buffer
= intern ("end-of-buffer");
2836 Qbuffer_read_only
= intern ("buffer-read-only");
2837 Qtext_read_only
= intern ("text-read-only");
2838 Qmark_inactive
= intern ("mark-inactive");
2840 Qlistp
= intern ("listp");
2841 Qconsp
= intern ("consp");
2842 Qsymbolp
= intern ("symbolp");
2843 Qkeywordp
= intern ("keywordp");
2844 Qintegerp
= intern ("integerp");
2845 Qnatnump
= intern ("natnump");
2846 Qwholenump
= intern ("wholenump");
2847 Qstringp
= intern ("stringp");
2848 Qarrayp
= intern ("arrayp");
2849 Qsequencep
= intern ("sequencep");
2850 Qbufferp
= intern ("bufferp");
2851 Qvectorp
= intern ("vectorp");
2852 Qchar_or_string_p
= intern ("char-or-string-p");
2853 Qmarkerp
= intern ("markerp");
2854 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2855 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2856 Qboundp
= intern ("boundp");
2857 Qfboundp
= intern ("fboundp");
2859 Qfloatp
= intern ("floatp");
2860 Qnumberp
= intern ("numberp");
2861 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2863 Qchar_table_p
= intern ("char-table-p");
2864 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2866 Qsubrp
= intern ("subrp");
2867 Qunevalled
= intern ("unevalled");
2868 Qmany
= intern ("many");
2870 Qcdr
= intern ("cdr");
2872 /* Handle automatic advice activation */
2873 Qad_advice_info
= intern ("ad-advice-info");
2874 Qad_activate_internal
= intern ("ad-activate-internal");
2876 error_tail
= Fcons (Qerror
, Qnil
);
2878 /* ERROR is used as a signaler for random errors for which nothing else is right */
2880 Fput (Qerror
, Qerror_conditions
,
2882 Fput (Qerror
, Qerror_message
,
2883 build_string ("error"));
2885 Fput (Qquit
, Qerror_conditions
,
2886 Fcons (Qquit
, Qnil
));
2887 Fput (Qquit
, Qerror_message
,
2888 build_string ("Quit"));
2890 Fput (Qwrong_type_argument
, Qerror_conditions
,
2891 Fcons (Qwrong_type_argument
, error_tail
));
2892 Fput (Qwrong_type_argument
, Qerror_message
,
2893 build_string ("Wrong type argument"));
2895 Fput (Qargs_out_of_range
, Qerror_conditions
,
2896 Fcons (Qargs_out_of_range
, error_tail
));
2897 Fput (Qargs_out_of_range
, Qerror_message
,
2898 build_string ("Args out of range"));
2900 Fput (Qvoid_function
, Qerror_conditions
,
2901 Fcons (Qvoid_function
, error_tail
));
2902 Fput (Qvoid_function
, Qerror_message
,
2903 build_string ("Symbol's function definition is void"));
2905 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2906 Fcons (Qcyclic_function_indirection
, error_tail
));
2907 Fput (Qcyclic_function_indirection
, Qerror_message
,
2908 build_string ("Symbol's chain of function indirections contains a loop"));
2910 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2911 Fcons (Qcyclic_variable_indirection
, error_tail
));
2912 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2913 build_string ("Symbol's chain of variable indirections contains a loop"));
2915 Qcircular_list
= intern ("circular-list");
2916 staticpro (&Qcircular_list
);
2917 Fput (Qcircular_list
, Qerror_conditions
,
2918 Fcons (Qcircular_list
, error_tail
));
2919 Fput (Qcircular_list
, Qerror_message
,
2920 build_string ("List contains a loop"));
2922 Fput (Qvoid_variable
, Qerror_conditions
,
2923 Fcons (Qvoid_variable
, error_tail
));
2924 Fput (Qvoid_variable
, Qerror_message
,
2925 build_string ("Symbol's value as variable is void"));
2927 Fput (Qsetting_constant
, Qerror_conditions
,
2928 Fcons (Qsetting_constant
, error_tail
));
2929 Fput (Qsetting_constant
, Qerror_message
,
2930 build_string ("Attempt to set a constant symbol"));
2932 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2933 Fcons (Qinvalid_read_syntax
, error_tail
));
2934 Fput (Qinvalid_read_syntax
, Qerror_message
,
2935 build_string ("Invalid read syntax"));
2937 Fput (Qinvalid_function
, Qerror_conditions
,
2938 Fcons (Qinvalid_function
, error_tail
));
2939 Fput (Qinvalid_function
, Qerror_message
,
2940 build_string ("Invalid function"));
2942 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2943 Fcons (Qwrong_number_of_arguments
, error_tail
));
2944 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2945 build_string ("Wrong number of arguments"));
2947 Fput (Qno_catch
, Qerror_conditions
,
2948 Fcons (Qno_catch
, error_tail
));
2949 Fput (Qno_catch
, Qerror_message
,
2950 build_string ("No catch for tag"));
2952 Fput (Qend_of_file
, Qerror_conditions
,
2953 Fcons (Qend_of_file
, error_tail
));
2954 Fput (Qend_of_file
, Qerror_message
,
2955 build_string ("End of file during parsing"));
2957 arith_tail
= Fcons (Qarith_error
, error_tail
);
2958 Fput (Qarith_error
, Qerror_conditions
,
2960 Fput (Qarith_error
, Qerror_message
,
2961 build_string ("Arithmetic error"));
2963 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2964 Fcons (Qbeginning_of_buffer
, error_tail
));
2965 Fput (Qbeginning_of_buffer
, Qerror_message
,
2966 build_string ("Beginning of buffer"));
2968 Fput (Qend_of_buffer
, Qerror_conditions
,
2969 Fcons (Qend_of_buffer
, error_tail
));
2970 Fput (Qend_of_buffer
, Qerror_message
,
2971 build_string ("End of buffer"));
2973 Fput (Qbuffer_read_only
, Qerror_conditions
,
2974 Fcons (Qbuffer_read_only
, error_tail
));
2975 Fput (Qbuffer_read_only
, Qerror_message
,
2976 build_string ("Buffer is read-only"));
2978 Fput (Qtext_read_only
, Qerror_conditions
,
2979 Fcons (Qtext_read_only
, error_tail
));
2980 Fput (Qtext_read_only
, Qerror_message
,
2981 build_string ("Text is read-only"));
2983 Qrange_error
= intern ("range-error");
2984 Qdomain_error
= intern ("domain-error");
2985 Qsingularity_error
= intern ("singularity-error");
2986 Qoverflow_error
= intern ("overflow-error");
2987 Qunderflow_error
= intern ("underflow-error");
2989 Fput (Qdomain_error
, Qerror_conditions
,
2990 Fcons (Qdomain_error
, arith_tail
));
2991 Fput (Qdomain_error
, Qerror_message
,
2992 build_string ("Arithmetic domain error"));
2994 Fput (Qrange_error
, Qerror_conditions
,
2995 Fcons (Qrange_error
, arith_tail
));
2996 Fput (Qrange_error
, Qerror_message
,
2997 build_string ("Arithmetic range error"));
2999 Fput (Qsingularity_error
, Qerror_conditions
,
3000 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3001 Fput (Qsingularity_error
, Qerror_message
,
3002 build_string ("Arithmetic singularity error"));
3004 Fput (Qoverflow_error
, Qerror_conditions
,
3005 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3006 Fput (Qoverflow_error
, Qerror_message
,
3007 build_string ("Arithmetic overflow error"));
3009 Fput (Qunderflow_error
, Qerror_conditions
,
3010 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3011 Fput (Qunderflow_error
, Qerror_message
,
3012 build_string ("Arithmetic underflow error"));
3014 staticpro (&Qrange_error
);
3015 staticpro (&Qdomain_error
);
3016 staticpro (&Qsingularity_error
);
3017 staticpro (&Qoverflow_error
);
3018 staticpro (&Qunderflow_error
);
3022 staticpro (&Qquote
);
3023 staticpro (&Qlambda
);
3025 staticpro (&Qunbound
);
3026 staticpro (&Qerror_conditions
);
3027 staticpro (&Qerror_message
);
3028 staticpro (&Qtop_level
);
3030 staticpro (&Qerror
);
3032 staticpro (&Qwrong_type_argument
);
3033 staticpro (&Qargs_out_of_range
);
3034 staticpro (&Qvoid_function
);
3035 staticpro (&Qcyclic_function_indirection
);
3036 staticpro (&Qvoid_variable
);
3037 staticpro (&Qsetting_constant
);
3038 staticpro (&Qinvalid_read_syntax
);
3039 staticpro (&Qwrong_number_of_arguments
);
3040 staticpro (&Qinvalid_function
);
3041 staticpro (&Qno_catch
);
3042 staticpro (&Qend_of_file
);
3043 staticpro (&Qarith_error
);
3044 staticpro (&Qbeginning_of_buffer
);
3045 staticpro (&Qend_of_buffer
);
3046 staticpro (&Qbuffer_read_only
);
3047 staticpro (&Qtext_read_only
);
3048 staticpro (&Qmark_inactive
);
3050 staticpro (&Qlistp
);
3051 staticpro (&Qconsp
);
3052 staticpro (&Qsymbolp
);
3053 staticpro (&Qkeywordp
);
3054 staticpro (&Qintegerp
);
3055 staticpro (&Qnatnump
);
3056 staticpro (&Qwholenump
);
3057 staticpro (&Qstringp
);
3058 staticpro (&Qarrayp
);
3059 staticpro (&Qsequencep
);
3060 staticpro (&Qbufferp
);
3061 staticpro (&Qvectorp
);
3062 staticpro (&Qchar_or_string_p
);
3063 staticpro (&Qmarkerp
);
3064 staticpro (&Qbuffer_or_string_p
);
3065 staticpro (&Qinteger_or_marker_p
);
3066 staticpro (&Qfloatp
);
3067 staticpro (&Qnumberp
);
3068 staticpro (&Qnumber_or_marker_p
);
3069 staticpro (&Qchar_table_p
);
3070 staticpro (&Qvector_or_char_table_p
);
3071 staticpro (&Qsubrp
);
3073 staticpro (&Qunevalled
);
3075 staticpro (&Qboundp
);
3076 staticpro (&Qfboundp
);
3078 staticpro (&Qad_advice_info
);
3079 staticpro (&Qad_activate_internal
);
3081 /* Types that type-of returns. */
3082 Qinteger
= intern ("integer");
3083 Qsymbol
= intern ("symbol");
3084 Qstring
= intern ("string");
3085 Qcons
= intern ("cons");
3086 Qmarker
= intern ("marker");
3087 Qoverlay
= intern ("overlay");
3088 Qfloat
= intern ("float");
3089 Qwindow_configuration
= intern ("window-configuration");
3090 Qprocess
= intern ("process");
3091 Qwindow
= intern ("window");
3092 /* Qsubr = intern ("subr"); */
3093 Qcompiled_function
= intern ("compiled-function");
3094 Qbuffer
= intern ("buffer");
3095 Qframe
= intern ("frame");
3096 Qvector
= intern ("vector");
3097 Qchar_table
= intern ("char-table");
3098 Qbool_vector
= intern ("bool-vector");
3099 Qhash_table
= intern ("hash-table");
3101 staticpro (&Qinteger
);
3102 staticpro (&Qsymbol
);
3103 staticpro (&Qstring
);
3105 staticpro (&Qmarker
);
3106 staticpro (&Qoverlay
);
3107 staticpro (&Qfloat
);
3108 staticpro (&Qwindow_configuration
);
3109 staticpro (&Qprocess
);
3110 staticpro (&Qwindow
);
3111 /* staticpro (&Qsubr); */
3112 staticpro (&Qcompiled_function
);
3113 staticpro (&Qbuffer
);
3114 staticpro (&Qframe
);
3115 staticpro (&Qvector
);
3116 staticpro (&Qchar_table
);
3117 staticpro (&Qbool_vector
);
3118 staticpro (&Qhash_table
);
3120 defsubr (&Sindirect_variable
);
3121 defsubr (&Ssubr_interactive_form
);
3124 defsubr (&Stype_of
);
3129 defsubr (&Sintegerp
);
3130 defsubr (&Sinteger_or_marker_p
);
3131 defsubr (&Snumberp
);
3132 defsubr (&Snumber_or_marker_p
);
3134 defsubr (&Snatnump
);
3135 defsubr (&Ssymbolp
);
3136 defsubr (&Skeywordp
);
3137 defsubr (&Sstringp
);
3138 defsubr (&Smultibyte_string_p
);
3139 defsubr (&Svectorp
);
3140 defsubr (&Schar_table_p
);
3141 defsubr (&Svector_or_char_table_p
);
3142 defsubr (&Sbool_vector_p
);
3144 defsubr (&Ssequencep
);
3145 defsubr (&Sbufferp
);
3146 defsubr (&Smarkerp
);
3148 defsubr (&Sbyte_code_function_p
);
3149 defsubr (&Schar_or_string_p
);
3152 defsubr (&Scar_safe
);
3153 defsubr (&Scdr_safe
);
3156 defsubr (&Ssymbol_function
);
3157 defsubr (&Sindirect_function
);
3158 defsubr (&Ssymbol_plist
);
3159 defsubr (&Ssymbol_name
);
3160 defsubr (&Smakunbound
);
3161 defsubr (&Sfmakunbound
);
3163 defsubr (&Sfboundp
);
3165 defsubr (&Sdefalias
);
3166 defsubr (&Ssetplist
);
3167 defsubr (&Ssymbol_value
);
3169 defsubr (&Sdefault_boundp
);
3170 defsubr (&Sdefault_value
);
3171 defsubr (&Sset_default
);
3172 defsubr (&Ssetq_default
);
3173 defsubr (&Smake_variable_buffer_local
);
3174 defsubr (&Smake_local_variable
);
3175 defsubr (&Skill_local_variable
);
3176 defsubr (&Smake_variable_frame_local
);
3177 defsubr (&Slocal_variable_p
);
3178 defsubr (&Slocal_variable_if_set_p
);
3181 defsubr (&Snumber_to_string
);
3182 defsubr (&Sstring_to_number
);
3183 defsubr (&Seqlsign
);
3206 defsubr (&Ssubr_arity
);
3208 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3210 DEFVAR_INT ("most-positive-fixnum", &most_positive_fixnum
,
3211 doc
: /* The largest value that is representable in a Lisp integer. */);
3212 most_positive_fixnum
= MOST_POSITIVE_FIXNUM
;
3214 DEFVAR_INT ("most-negative-fixnum", &most_negative_fixnum
,
3215 doc
: /* The smallest value that is representable in a Lisp integer. */);
3216 most_negative_fixnum
= MOST_NEGATIVE_FIXNUM
;
3223 #if defined(USG) && !defined(POSIX_SIGNALS)
3224 /* USG systems forget handlers when they are used;
3225 must reestablish each time */
3226 signal (signo
, arith_error
);
3229 /* VMS systems are like USG. */
3230 signal (signo
, arith_error
);
3234 #else /* not BSD4_1 */
3235 sigsetmask (SIGEMPTYMASK
);
3236 #endif /* not BSD4_1 */
3238 Fsignal (Qarith_error
, Qnil
);
3244 /* Don't do this if just dumping out.
3245 We don't want to call `signal' in this case
3246 so that we don't have trouble with dumping
3247 signal-delivering routines in an inconsistent state. */
3251 #endif /* CANNOT_DUMP */
3252 signal (SIGFPE
, arith_error
);
3255 signal (SIGEMT
, arith_error
);