1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007 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 3, 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., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
28 #include "character.h"
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
;
75 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
76 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
77 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
78 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
79 Lisp_Object Qboundp
, Qfboundp
;
80 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
83 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
85 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
86 Lisp_Object Qoverflow_error
, Qunderflow_error
;
89 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
92 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
93 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
95 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
96 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
97 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
99 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
101 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
105 circular_list_error (list
)
108 xsignal (Qcircular_list
, list
);
113 wrong_type_argument (predicate
, value
)
114 register Lisp_Object predicate
, value
;
116 /* If VALUE is not even a valid Lisp object, abort here
117 where we can get a backtrace showing where it came from. */
118 if ((unsigned int) XTYPE (value
) >= Lisp_Type_Limit
)
121 xsignal2 (Qwrong_type_argument
, predicate
, value
);
127 error ("Attempt to modify read-only object");
131 args_out_of_range (a1
, a2
)
134 xsignal2 (Qargs_out_of_range
, a1
, a2
);
138 args_out_of_range_3 (a1
, a2
, a3
)
139 Lisp_Object a1
, a2
, a3
;
141 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
144 /* On some machines, XINT needs a temporary location.
145 Here it is, in case it is needed. */
147 int sign_extend_temp
;
149 /* On a few machines, XINT can only be done by calling this. */
152 sign_extend_lisp_int (num
)
155 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
156 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
158 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
161 /* Data type predicates */
163 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
164 doc
: /* Return t if the two args are the same Lisp object. */)
166 Lisp_Object obj1
, obj2
;
173 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
174 doc
: /* Return t if OBJECT is nil. */)
183 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
184 doc
: /* Return a symbol representing the type of OBJECT.
185 The symbol returned names the object's basic type;
186 for example, (type-of 1) returns `integer'. */)
190 switch (XTYPE (object
))
205 switch (XMISCTYPE (object
))
207 case Lisp_Misc_Marker
:
209 case Lisp_Misc_Overlay
:
211 case Lisp_Misc_Float
:
216 case Lisp_Vectorlike
:
217 if (WINDOW_CONFIGURATIONP (object
))
218 return Qwindow_configuration
;
219 if (PROCESSP (object
))
221 if (WINDOWP (object
))
225 if (COMPILEDP (object
))
226 return Qcompiled_function
;
227 if (BUFFERP (object
))
229 if (CHAR_TABLE_P (object
))
231 if (BOOL_VECTOR_P (object
))
235 if (HASH_TABLE_P (object
))
247 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
248 doc
: /* Return t if OBJECT is a cons cell. */)
257 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
258 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
267 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
268 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
269 Otherwise, return nil. */)
273 if (CONSP (object
) || NILP (object
))
278 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
279 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
283 if (CONSP (object
) || NILP (object
))
288 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
289 doc
: /* Return t if OBJECT is a symbol. */)
293 if (SYMBOLP (object
))
298 /* Define this in C to avoid unnecessarily consing up the symbol
300 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
301 doc
: /* Return t if OBJECT is a keyword.
302 This means that it is a symbol with a print name beginning with `:'
303 interned in the initial obarray. */)
308 && SREF (SYMBOL_NAME (object
), 0) == ':'
309 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
314 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
315 doc
: /* Return t if OBJECT is a vector. */)
319 if (VECTORP (object
))
324 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a string. */)
329 if (STRINGP (object
))
334 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
336 doc
: /* Return t if OBJECT is a multibyte string. */)
340 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
345 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
346 doc
: /* Return t if OBJECT is a char-table. */)
350 if (CHAR_TABLE_P (object
))
355 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
356 Svector_or_char_table_p
, 1, 1, 0,
357 doc
: /* Return t if OBJECT is a char-table or vector. */)
361 if (VECTORP (object
) || CHAR_TABLE_P (object
))
366 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
367 doc
: /* Return t if OBJECT is a bool-vector. */)
371 if (BOOL_VECTOR_P (object
))
376 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is an array (string or vector). */)
386 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is a sequence (list or array). */)
389 register Lisp_Object object
;
391 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
396 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is an editor buffer. */)
401 if (BUFFERP (object
))
406 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
411 if (MARKERP (object
))
416 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
417 doc
: /* Return t if OBJECT is a built-in function. */)
426 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
428 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
432 if (COMPILEDP (object
))
437 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
438 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
440 register Lisp_Object object
;
442 if (CHARACTERP (object
) || STRINGP (object
))
447 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
448 doc
: /* Return t if OBJECT is an integer. */)
452 if (INTEGERP (object
))
457 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
458 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
460 register Lisp_Object object
;
462 if (MARKERP (object
) || INTEGERP (object
))
467 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
468 doc
: /* Return t if OBJECT is a nonnegative integer. */)
472 if (NATNUMP (object
))
477 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
478 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
482 if (NUMBERP (object
))
488 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
489 Snumber_or_marker_p
, 1, 1, 0,
490 doc
: /* Return t if OBJECT is a number or a marker. */)
494 if (NUMBERP (object
) || MARKERP (object
))
499 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
500 doc
: /* Return t if OBJECT is a floating point number. */)
510 /* Extract and set components of lists */
512 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
513 doc
: /* Return the car of LIST. If arg is nil, return nil.
514 Error if arg is not nil and not a cons cell. See also `car-safe'.
516 See Info node `(elisp)Cons Cells' for a discussion of related basic
517 Lisp concepts such as car, cdr, cons cell and list. */)
519 register Lisp_Object list
;
524 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
525 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
529 return CAR_SAFE (object
);
532 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
533 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
534 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
536 See Info node `(elisp)Cons Cells' for a discussion of related basic
537 Lisp concepts such as cdr, car, cons cell and list. */)
539 register Lisp_Object list
;
544 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
545 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
549 return CDR_SAFE (object
);
552 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
553 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
555 register Lisp_Object cell
, newcar
;
559 XSETCAR (cell
, newcar
);
563 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
564 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
566 register Lisp_Object cell
, newcdr
;
570 XSETCDR (cell
, newcdr
);
574 /* Extract and set components of symbols */
576 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
577 doc
: /* Return t if SYMBOL's value is not void. */)
579 register Lisp_Object symbol
;
581 Lisp_Object valcontents
;
582 CHECK_SYMBOL (symbol
);
584 valcontents
= SYMBOL_VALUE (symbol
);
586 if (BUFFER_LOCAL_VALUEP (valcontents
)
587 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
588 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
590 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
593 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
594 doc
: /* Return t if SYMBOL's function definition is not void. */)
596 register Lisp_Object symbol
;
598 CHECK_SYMBOL (symbol
);
599 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
602 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
603 doc
: /* Make SYMBOL's value be void.
606 register Lisp_Object symbol
;
608 CHECK_SYMBOL (symbol
);
609 if (SYMBOL_CONSTANT_P (symbol
))
610 xsignal1 (Qsetting_constant
, symbol
);
611 Fset (symbol
, Qunbound
);
615 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
616 doc
: /* Make SYMBOL's function definition be void.
619 register Lisp_Object symbol
;
621 CHECK_SYMBOL (symbol
);
622 if (NILP (symbol
) || EQ (symbol
, Qt
))
623 xsignal1 (Qsetting_constant
, symbol
);
624 XSYMBOL (symbol
)->function
= Qunbound
;
628 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
629 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
);
634 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
635 return XSYMBOL (symbol
)->function
;
636 xsignal1 (Qvoid_function
, symbol
);
639 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
640 doc
: /* Return SYMBOL's property list. */)
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
);
645 return XSYMBOL (symbol
)->plist
;
648 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
649 doc
: /* Return SYMBOL's name, a string. */)
651 register Lisp_Object symbol
;
653 register Lisp_Object name
;
655 CHECK_SYMBOL (symbol
);
656 name
= SYMBOL_NAME (symbol
);
660 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
661 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
663 register Lisp_Object symbol
, definition
;
665 CHECK_SYMBOL (symbol
);
666 if (NILP (symbol
) || EQ (symbol
, Qt
))
667 xsignal1 (Qsetting_constant
, symbol
);
668 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
669 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
671 XSYMBOL (symbol
)->function
= definition
;
672 /* Handle automatic advice activation */
673 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
675 call2 (Qad_activate_internal
, symbol
, Qnil
);
676 definition
= XSYMBOL (symbol
)->function
;
681 extern Lisp_Object Qfunction_documentation
;
683 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
684 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
685 Associates the function with the current load file, if any.
686 The optional third argument DOCSTRING specifies the documentation string
687 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
688 determined by DEFINITION. */)
689 (symbol
, definition
, docstring
)
690 register Lisp_Object symbol
, definition
, docstring
;
692 CHECK_SYMBOL (symbol
);
693 if (CONSP (XSYMBOL (symbol
)->function
)
694 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
695 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
696 definition
= Ffset (symbol
, definition
);
697 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
698 if (!NILP (docstring
))
699 Fput (symbol
, Qfunction_documentation
, docstring
);
703 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
704 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
706 register Lisp_Object symbol
, newplist
;
708 CHECK_SYMBOL (symbol
);
709 XSYMBOL (symbol
)->plist
= newplist
;
713 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
714 doc
: /* Return minimum and maximum number of args allowed for SUBR.
715 SUBR must be a built-in function.
716 The returned value is a pair (MIN . MAX). MIN is the minimum number
717 of args. MAX is the maximum number or the symbol `many', for a
718 function with `&rest' args, or `unevalled' for a special form. */)
722 short minargs
, maxargs
;
724 minargs
= XSUBR (subr
)->min_args
;
725 maxargs
= XSUBR (subr
)->max_args
;
727 return Fcons (make_number (minargs
), Qmany
);
728 else if (maxargs
== UNEVALLED
)
729 return Fcons (make_number (minargs
), Qunevalled
);
731 return Fcons (make_number (minargs
), make_number (maxargs
));
734 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
735 doc
: /* Return name of subroutine SUBR.
736 SUBR must be a built-in function. */)
742 name
= XSUBR (subr
)->symbol_name
;
743 return make_string (name
, strlen (name
));
746 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
747 doc
: /* Return the interactive form of CMD or nil if none.
748 If CMD is not a command, the return value is nil.
749 Value, if non-nil, is a list \(interactive SPEC). */)
753 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
755 if (NILP (fun
) || EQ (fun
, Qunbound
))
758 /* Use an `interactive-form' property if present, analogous to the
759 function-documentation property. */
761 while (SYMBOLP (fun
))
763 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
767 fun
= Fsymbol_function (fun
);
772 if (XSUBR (fun
)->prompt
)
773 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
775 else if (COMPILEDP (fun
))
777 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
778 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
780 else if (CONSP (fun
))
782 Lisp_Object funcar
= XCAR (fun
);
783 if (EQ (funcar
, Qlambda
))
784 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
785 else if (EQ (funcar
, Qautoload
))
789 do_autoload (fun
, cmd
);
791 return Finteractive_form (cmd
);
798 /***********************************************************************
799 Getting and Setting Values of Symbols
800 ***********************************************************************/
802 /* Return the symbol holding SYMBOL's value. Signal
803 `cyclic-variable-indirection' if SYMBOL's chain of variable
804 indirections contains a loop. */
807 indirect_variable (symbol
)
810 Lisp_Object tortoise
, hare
;
812 hare
= tortoise
= symbol
;
814 while (XSYMBOL (hare
)->indirect_variable
)
816 hare
= XSYMBOL (hare
)->value
;
817 if (!XSYMBOL (hare
)->indirect_variable
)
820 hare
= XSYMBOL (hare
)->value
;
821 tortoise
= XSYMBOL (tortoise
)->value
;
823 if (EQ (hare
, tortoise
))
824 xsignal1 (Qcyclic_variable_indirection
, symbol
);
831 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
832 doc
: /* Return the variable at the end of OBJECT's variable chain.
833 If OBJECT is a symbol, follow all variable indirections and return the final
834 variable. If OBJECT is not a symbol, just return it.
835 Signal a cyclic-variable-indirection error if there is a loop in the
836 variable chain of symbols. */)
840 if (SYMBOLP (object
))
841 object
= indirect_variable (object
);
846 /* Given the raw contents of a symbol value cell,
847 return the Lisp value of the symbol.
848 This does not handle buffer-local variables; use
849 swap_in_symval_forwarding for that. */
852 do_symval_forwarding (valcontents
)
853 register Lisp_Object valcontents
;
855 register Lisp_Object val
;
857 if (MISCP (valcontents
))
858 switch (XMISCTYPE (valcontents
))
860 case Lisp_Misc_Intfwd
:
861 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
864 case Lisp_Misc_Boolfwd
:
865 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
867 case Lisp_Misc_Objfwd
:
868 return *XOBJFWD (valcontents
)->objvar
;
870 case Lisp_Misc_Buffer_Objfwd
:
871 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
872 return PER_BUFFER_VALUE (current_buffer
, offset
);
874 case Lisp_Misc_Kboard_Objfwd
:
875 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
876 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
881 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
882 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
883 buffer-independent contents of the value cell: forwarded just one
884 step past the buffer-localness.
886 BUF non-zero means set the value in buffer BUF instead of the
887 current buffer. This only plays a role for per-buffer variables. */
890 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
892 register Lisp_Object valcontents
, newval
;
895 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
898 switch (XMISCTYPE (valcontents
))
900 case Lisp_Misc_Intfwd
:
901 CHECK_NUMBER (newval
);
902 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
903 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
904 error ("Value out of range for variable `%s'",
905 SDATA (SYMBOL_NAME (symbol
)));
908 case Lisp_Misc_Boolfwd
:
909 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
912 case Lisp_Misc_Objfwd
:
913 *XOBJFWD (valcontents
)->objvar
= newval
;
915 /* If this variable is a default for something stored
916 in the buffer itself, such as default-fill-column,
917 find the buffers that don't have local values for it
919 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
920 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
922 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
923 - (char *) &buffer_defaults
);
924 int idx
= PER_BUFFER_IDX (offset
);
931 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
936 buf
= Fcdr (XCAR (tail
));
937 if (!BUFFERP (buf
)) continue;
940 if (! PER_BUFFER_VALUE_P (b
, idx
))
941 PER_BUFFER_VALUE (b
, offset
) = newval
;
946 case Lisp_Misc_Buffer_Objfwd
:
948 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
951 type
= PER_BUFFER_TYPE (offset
);
952 if (! NILP (type
) && ! NILP (newval
)
953 && XTYPE (newval
) != XINT (type
))
954 buffer_slot_type_mismatch (offset
);
957 buf
= current_buffer
;
958 PER_BUFFER_VALUE (buf
, offset
) = newval
;
962 case Lisp_Misc_Kboard_Objfwd
:
964 char *base
= (char *) current_kboard
;
965 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
966 *(Lisp_Object
*) p
= newval
;
977 valcontents
= SYMBOL_VALUE (symbol
);
978 if (BUFFER_LOCAL_VALUEP (valcontents
)
979 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
980 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
982 SET_SYMBOL_VALUE (symbol
, newval
);
986 /* Set up SYMBOL to refer to its global binding.
987 This makes it safe to alter the status of other bindings. */
990 swap_in_global_binding (symbol
)
993 Lisp_Object valcontents
, cdr
;
995 valcontents
= SYMBOL_VALUE (symbol
);
996 if (!BUFFER_LOCAL_VALUEP (valcontents
)
997 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
999 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1001 /* Unload the previously loaded binding. */
1002 Fsetcdr (XCAR (cdr
),
1003 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1005 /* Select the global binding in the symbol. */
1007 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1009 /* Indicate that the global binding is set up now. */
1010 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1011 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1012 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1013 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1016 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1017 VALCONTENTS is the contents of its value cell,
1018 which points to a struct Lisp_Buffer_Local_Value.
1020 Return the value forwarded one step past the buffer-local stage.
1021 This could be another forwarding pointer. */
1024 swap_in_symval_forwarding (symbol
, valcontents
)
1025 Lisp_Object symbol
, valcontents
;
1027 register Lisp_Object tem1
;
1029 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1032 || current_buffer
!= XBUFFER (tem1
)
1033 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1034 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1036 if (XSYMBOL (symbol
)->indirect_variable
)
1037 symbol
= indirect_variable (symbol
);
1039 /* Unload the previously loaded binding. */
1040 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1042 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1043 /* Choose the new binding. */
1044 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1045 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1046 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1049 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1050 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1052 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1054 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1057 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1059 /* Load the new binding. */
1060 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1061 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1062 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1063 store_symval_forwarding (symbol
,
1064 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1067 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1070 /* Find the value of a symbol, returning Qunbound if it's not bound.
1071 This is helpful for code which just wants to get a variable's value
1072 if it has one, without signaling an error.
1073 Note that it must not be possible to quit
1074 within this function. Great care is required for this. */
1077 find_symbol_value (symbol
)
1080 register Lisp_Object valcontents
;
1081 register Lisp_Object val
;
1083 CHECK_SYMBOL (symbol
);
1084 valcontents
= SYMBOL_VALUE (symbol
);
1086 if (BUFFER_LOCAL_VALUEP (valcontents
)
1087 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1088 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1090 if (MISCP (valcontents
))
1092 switch (XMISCTYPE (valcontents
))
1094 case Lisp_Misc_Intfwd
:
1095 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1098 case Lisp_Misc_Boolfwd
:
1099 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1101 case Lisp_Misc_Objfwd
:
1102 return *XOBJFWD (valcontents
)->objvar
;
1104 case Lisp_Misc_Buffer_Objfwd
:
1105 return PER_BUFFER_VALUE (current_buffer
,
1106 XBUFFER_OBJFWD (valcontents
)->offset
);
1108 case Lisp_Misc_Kboard_Objfwd
:
1109 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1110 + (char *)current_kboard
);
1117 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1118 doc
: /* Return SYMBOL's value. Error if that is void. */)
1124 val
= find_symbol_value (symbol
);
1125 if (!EQ (val
, Qunbound
))
1128 xsignal1 (Qvoid_variable
, symbol
);
1131 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1132 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1134 register Lisp_Object symbol
, newval
;
1136 return set_internal (symbol
, newval
, current_buffer
, 0);
1139 /* Return 1 if SYMBOL currently has a let-binding
1140 which was made in the buffer that is now current. */
1143 let_shadows_buffer_binding_p (symbol
)
1146 volatile struct specbinding
*p
;
1148 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1150 && CONSP (p
->symbol
))
1152 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1153 if ((EQ (symbol
, let_bound_symbol
)
1154 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1155 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1156 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1160 return p
>= specpdl
;
1163 /* Store the value NEWVAL into SYMBOL.
1164 If buffer-locality is an issue, BUF specifies which buffer to use.
1165 (0 stands for the current buffer.)
1167 If BINDFLAG is zero, then if this symbol is supposed to become
1168 local in every buffer where it is set, then we make it local.
1169 If BINDFLAG is nonzero, we don't do that. */
1172 set_internal (symbol
, newval
, buf
, bindflag
)
1173 register Lisp_Object symbol
, newval
;
1177 int voide
= EQ (newval
, Qunbound
);
1179 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1182 buf
= current_buffer
;
1184 /* If restoring in a dead buffer, do nothing. */
1185 if (NILP (buf
->name
))
1188 CHECK_SYMBOL (symbol
);
1189 if (SYMBOL_CONSTANT_P (symbol
)
1190 && (NILP (Fkeywordp (symbol
))
1191 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1192 xsignal1 (Qsetting_constant
, symbol
);
1194 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1196 if (BUFFER_OBJFWDP (valcontents
))
1198 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1199 int idx
= PER_BUFFER_IDX (offset
);
1202 && !let_shadows_buffer_binding_p (symbol
))
1203 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1205 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1206 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1208 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1209 if (XSYMBOL (symbol
)->indirect_variable
)
1210 symbol
= indirect_variable (symbol
);
1212 /* What binding is loaded right now? */
1213 current_alist_element
1214 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1216 /* If the current buffer is not the buffer whose binding is
1217 loaded, or if there may be frame-local bindings and the frame
1218 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1219 the default binding is loaded, the loaded binding may be the
1221 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1222 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1223 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1224 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1225 || (BUFFER_LOCAL_VALUEP (valcontents
)
1226 && EQ (XCAR (current_alist_element
),
1227 current_alist_element
)))
1229 /* The currently loaded binding is not necessarily valid.
1230 We need to unload it, and choose a new binding. */
1232 /* Write out `realvalue' to the old loaded binding. */
1233 Fsetcdr (current_alist_element
,
1234 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1236 /* Find the new binding. */
1237 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1238 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1239 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1243 /* This buffer still sees the default value. */
1245 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1246 or if this is `let' rather than `set',
1247 make CURRENT-ALIST-ELEMENT point to itself,
1248 indicating that we're seeing the default value.
1249 Likewise if the variable has been let-bound
1250 in the current buffer. */
1251 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1252 || let_shadows_buffer_binding_p (symbol
))
1254 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1256 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1257 tem1
= Fassq (symbol
,
1258 XFRAME (selected_frame
)->param_alist
);
1261 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1263 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1265 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1266 and we're not within a let that was made for this buffer,
1267 create a new buffer-local binding for the variable.
1268 That means, give this buffer a new assoc for a local value
1269 and load that binding. */
1272 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1273 buf
->local_var_alist
1274 = Fcons (tem1
, buf
->local_var_alist
);
1278 /* Record which binding is now loaded. */
1279 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1282 /* Set `buffer' and `frame' slots for the binding now loaded. */
1283 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1284 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1286 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1289 /* If storing void (making the symbol void), forward only through
1290 buffer-local indicator, not through Lisp_Objfwd, etc. */
1292 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1294 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1296 /* If we just set a variable whose current binding is frame-local,
1297 store the new value in the frame parameter too. */
1299 if (BUFFER_LOCAL_VALUEP (valcontents
)
1300 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1302 /* What binding is loaded right now? */
1303 current_alist_element
1304 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1306 /* If the current buffer is not the buffer whose binding is
1307 loaded, or if there may be frame-local bindings and the frame
1308 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1309 the default binding is loaded, the loaded binding may be the
1311 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1312 XSETCDR (current_alist_element
, newval
);
1318 /* Access or set a buffer-local symbol's default value. */
1320 /* Return the default value of SYMBOL, but don't check for voidness.
1321 Return Qunbound if it is void. */
1324 default_value (symbol
)
1327 register Lisp_Object valcontents
;
1329 CHECK_SYMBOL (symbol
);
1330 valcontents
= SYMBOL_VALUE (symbol
);
1332 /* For a built-in buffer-local variable, get the default value
1333 rather than letting do_symval_forwarding get the current value. */
1334 if (BUFFER_OBJFWDP (valcontents
))
1336 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1337 if (PER_BUFFER_IDX (offset
) != 0)
1338 return PER_BUFFER_DEFAULT (offset
);
1341 /* Handle user-created local variables. */
1342 if (BUFFER_LOCAL_VALUEP (valcontents
)
1343 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1345 /* If var is set up for a buffer that lacks a local value for it,
1346 the current value is nominally the default value.
1347 But the `realvalue' slot may be more up to date, since
1348 ordinary setq stores just that slot. So use that. */
1349 Lisp_Object current_alist_element
, alist_element_car
;
1350 current_alist_element
1351 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1352 alist_element_car
= XCAR (current_alist_element
);
1353 if (EQ (alist_element_car
, current_alist_element
))
1354 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1356 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1358 /* For other variables, get the current value. */
1359 return do_symval_forwarding (valcontents
);
1362 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1363 doc
: /* Return t if SYMBOL has a non-void default value.
1364 This is the value that is seen in buffers that do not have their own values
1365 for this variable. */)
1369 register Lisp_Object value
;
1371 value
= default_value (symbol
);
1372 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1375 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1376 doc
: /* Return SYMBOL's default value.
1377 This is the value that is seen in buffers that do not have their own values
1378 for this variable. The default value is meaningful for variables with
1379 local bindings in certain buffers. */)
1383 register Lisp_Object value
;
1385 value
= default_value (symbol
);
1386 if (!EQ (value
, Qunbound
))
1389 xsignal1 (Qvoid_variable
, symbol
);
1392 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1393 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1394 The default value is seen in buffers that do not have their own values
1395 for this variable. */)
1397 Lisp_Object symbol
, value
;
1399 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1401 CHECK_SYMBOL (symbol
);
1402 valcontents
= SYMBOL_VALUE (symbol
);
1404 /* Handle variables like case-fold-search that have special slots
1405 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1407 if (BUFFER_OBJFWDP (valcontents
))
1409 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1410 int idx
= PER_BUFFER_IDX (offset
);
1412 PER_BUFFER_DEFAULT (offset
) = value
;
1414 /* If this variable is not always local in all buffers,
1415 set it in the buffers that don't nominally have a local value. */
1420 for (b
= all_buffers
; b
; b
= b
->next
)
1421 if (!PER_BUFFER_VALUE_P (b
, idx
))
1422 PER_BUFFER_VALUE (b
, offset
) = value
;
1427 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1428 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1429 return Fset (symbol
, value
);
1431 /* Store new value into the DEFAULT-VALUE slot. */
1432 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1434 /* If the default binding is now loaded, set the REALVALUE slot too. */
1435 current_alist_element
1436 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1437 alist_element_buffer
= Fcar (current_alist_element
);
1438 if (EQ (alist_element_buffer
, current_alist_element
))
1439 store_symval_forwarding (symbol
,
1440 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1446 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1447 doc
: /* Set the default value of variable VAR to VALUE.
1448 VAR, the variable name, is literal (not evaluated);
1449 VALUE is an expression: it is evaluated and its value returned.
1450 The default value of a variable is seen in buffers
1451 that do not have their own values for the variable.
1453 More generally, you can use multiple variables and values, as in
1454 (setq-default VAR VALUE VAR VALUE...)
1455 This sets each VAR's default value to the corresponding VALUE.
1456 The VALUE for the Nth VAR can refer to the new default values
1458 usage: (setq-default [VAR VALUE]...) */)
1462 register Lisp_Object args_left
;
1463 register Lisp_Object val
, symbol
;
1464 struct gcpro gcpro1
;
1474 val
= Feval (Fcar (Fcdr (args_left
)));
1475 symbol
= XCAR (args_left
);
1476 Fset_default (symbol
, val
);
1477 args_left
= Fcdr (XCDR (args_left
));
1479 while (!NILP (args_left
));
1485 /* Lisp functions for creating and removing buffer-local variables. */
1487 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1488 1, 1, "vMake Variable Buffer Local: ",
1489 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1490 At any time, the value for the current buffer is in effect,
1491 unless the variable has never been set in this buffer,
1492 in which case the default value is in effect.
1493 Note that binding the variable with `let', or setting it while
1494 a `let'-style binding made in this buffer is in effect,
1495 does not make the variable buffer-local. Return VARIABLE.
1497 In most cases it is better to use `make-local-variable',
1498 which makes a variable local in just one buffer.
1500 The function `default-value' gets the default value and `set-default' sets it. */)
1502 register Lisp_Object variable
;
1504 register Lisp_Object tem
, valcontents
, newval
;
1506 CHECK_SYMBOL (variable
);
1507 variable
= indirect_variable (variable
);
1509 valcontents
= SYMBOL_VALUE (variable
);
1510 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1511 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1513 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1515 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1517 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1520 if (EQ (valcontents
, Qunbound
))
1521 SET_SYMBOL_VALUE (variable
, Qnil
);
1522 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1524 newval
= allocate_misc ();
1525 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1526 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1527 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
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
);
1537 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1538 1, 1, "vMake Local Variable: ",
1539 doc
: /* Make VARIABLE have a separate value in the current buffer.
1540 Other buffers will continue to share a common default value.
1541 \(The buffer-local value of VARIABLE starts out as the same value
1542 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1545 If the variable is already arranged to become local when set,
1546 this function causes a local value to exist for this buffer,
1547 just as setting the variable would do.
1549 This function returns VARIABLE, and therefore
1550 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1553 See also `make-variable-buffer-local'.
1555 Do not use `make-local-variable' to make a hook variable buffer-local.
1556 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1558 register Lisp_Object variable
;
1560 register Lisp_Object tem
, valcontents
;
1562 CHECK_SYMBOL (variable
);
1563 variable
= indirect_variable (variable
);
1565 valcontents
= SYMBOL_VALUE (variable
);
1566 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1567 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1569 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1571 tem
= Fboundp (variable
);
1573 /* Make sure the symbol has a local value in this particular buffer,
1574 by setting it to the same value it already has. */
1575 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1578 /* Make sure symbol is set up to hold per-buffer values. */
1579 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1582 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1584 newval
= allocate_misc ();
1585 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1586 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1587 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1588 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1589 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1590 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1591 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1592 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1593 SET_SYMBOL_VALUE (variable
, newval
);
1595 /* Make sure this buffer has its own value of symbol. */
1596 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1599 /* Swap out any local binding for some other buffer, and make
1600 sure the current value is permanently recorded, if it's the
1602 find_symbol_value (variable
);
1604 current_buffer
->local_var_alist
1605 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1606 current_buffer
->local_var_alist
);
1608 /* Make sure symbol does not think it is set up for this buffer;
1609 force it to look once again for this buffer's value. */
1611 Lisp_Object
*pvalbuf
;
1613 valcontents
= SYMBOL_VALUE (variable
);
1615 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1616 if (current_buffer
== XBUFFER (*pvalbuf
))
1618 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1622 /* If the symbol forwards into a C variable, then load the binding
1623 for this buffer now. If C code modifies the variable before we
1624 load the binding in, then that new value will clobber the default
1625 binding the next time we unload it. */
1626 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1627 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1628 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1633 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1634 1, 1, "vKill Local Variable: ",
1635 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1636 From now on the default value will apply in this buffer. Return VARIABLE. */)
1638 register Lisp_Object variable
;
1640 register Lisp_Object tem
, valcontents
;
1642 CHECK_SYMBOL (variable
);
1643 variable
= indirect_variable (variable
);
1645 valcontents
= SYMBOL_VALUE (variable
);
1647 if (BUFFER_OBJFWDP (valcontents
))
1649 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1650 int idx
= PER_BUFFER_IDX (offset
);
1654 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1655 PER_BUFFER_VALUE (current_buffer
, offset
)
1656 = PER_BUFFER_DEFAULT (offset
);
1661 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1662 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1665 /* Get rid of this buffer's alist element, if any. */
1667 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1669 current_buffer
->local_var_alist
1670 = Fdelq (tem
, current_buffer
->local_var_alist
);
1672 /* If the symbol is set up with the current buffer's binding
1673 loaded, recompute its value. We have to do it now, or else
1674 forwarded objects won't work right. */
1676 Lisp_Object
*pvalbuf
, buf
;
1677 valcontents
= SYMBOL_VALUE (variable
);
1678 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1679 XSETBUFFER (buf
, current_buffer
);
1680 if (EQ (buf
, *pvalbuf
))
1683 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1684 find_symbol_value (variable
);
1691 /* Lisp functions for creating and removing buffer-local variables. */
1693 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1694 1, 1, "vMake Variable Frame Local: ",
1695 doc
: /* Enable VARIABLE to have frame-local bindings.
1696 This does not create any frame-local bindings for VARIABLE,
1697 it just makes them possible.
1699 A frame-local binding is actually a frame parameter value.
1700 If a frame F has a value for the frame parameter named VARIABLE,
1701 that also acts as a frame-local binding for VARIABLE in F--
1702 provided this function has been called to enable VARIABLE
1703 to have frame-local bindings at all.
1705 The only way to create a frame-local binding for VARIABLE in a frame
1706 is to set the VARIABLE frame parameter of that frame. See
1707 `modify-frame-parameters' for how to set frame parameters.
1709 Buffer-local bindings take precedence over frame-local bindings. */)
1711 register Lisp_Object variable
;
1713 register Lisp_Object tem
, valcontents
, newval
;
1715 CHECK_SYMBOL (variable
);
1716 variable
= indirect_variable (variable
);
1718 valcontents
= SYMBOL_VALUE (variable
);
1719 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1720 || BUFFER_OBJFWDP (valcontents
))
1721 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1723 if (BUFFER_LOCAL_VALUEP (valcontents
)
1724 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1726 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1730 if (EQ (valcontents
, Qunbound
))
1731 SET_SYMBOL_VALUE (variable
, Qnil
);
1732 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1734 newval
= allocate_misc ();
1735 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1736 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1737 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1738 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1739 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1740 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1741 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1742 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1743 SET_SYMBOL_VALUE (variable
, newval
);
1747 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1749 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1750 BUFFER defaults to the current buffer. */)
1752 register Lisp_Object variable
, buffer
;
1754 Lisp_Object valcontents
;
1755 register struct buffer
*buf
;
1758 buf
= current_buffer
;
1761 CHECK_BUFFER (buffer
);
1762 buf
= XBUFFER (buffer
);
1765 CHECK_SYMBOL (variable
);
1766 variable
= indirect_variable (variable
);
1768 valcontents
= SYMBOL_VALUE (variable
);
1769 if (BUFFER_LOCAL_VALUEP (valcontents
)
1770 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1772 Lisp_Object tail
, elt
;
1774 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1777 if (EQ (variable
, XCAR (elt
)))
1781 if (BUFFER_OBJFWDP (valcontents
))
1783 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1784 int idx
= PER_BUFFER_IDX (offset
);
1785 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1791 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1793 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1794 More precisely, this means that setting the variable \(with `set' or`setq'),
1795 while it does not have a `let'-style binding that was made in BUFFER,
1796 will produce a buffer local binding. See Info node
1797 `(elisp)Creating Buffer-Local'.
1798 BUFFER defaults to the current buffer. */)
1800 register Lisp_Object variable
, buffer
;
1802 Lisp_Object valcontents
;
1803 register struct buffer
*buf
;
1806 buf
= current_buffer
;
1809 CHECK_BUFFER (buffer
);
1810 buf
= XBUFFER (buffer
);
1813 CHECK_SYMBOL (variable
);
1814 variable
= indirect_variable (variable
);
1816 valcontents
= SYMBOL_VALUE (variable
);
1818 /* This means that make-variable-buffer-local was done. */
1819 if (BUFFER_LOCAL_VALUEP (valcontents
))
1821 /* All these slots become local if they are set. */
1822 if (BUFFER_OBJFWDP (valcontents
))
1824 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1826 Lisp_Object tail
, elt
;
1827 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1830 if (EQ (variable
, XCAR (elt
)))
1837 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1839 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1840 If the current binding is buffer-local, the value is the current buffer.
1841 If the current binding is frame-local, the value is the selected frame.
1842 If the current binding is global (the default), the value is nil. */)
1844 register Lisp_Object variable
;
1846 Lisp_Object valcontents
;
1848 CHECK_SYMBOL (variable
);
1849 variable
= indirect_variable (variable
);
1851 /* Make sure the current binding is actually swapped in. */
1852 find_symbol_value (variable
);
1854 valcontents
= XSYMBOL (variable
)->value
;
1856 if (BUFFER_LOCAL_VALUEP (valcontents
)
1857 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1858 || BUFFER_OBJFWDP (valcontents
))
1860 /* For a local variable, record both the symbol and which
1861 buffer's or frame's value we are saving. */
1862 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1863 return Fcurrent_buffer ();
1864 else if (!BUFFER_OBJFWDP (valcontents
)
1865 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1866 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1872 /* Find the function at the end of a chain of symbol function indirections. */
1874 /* If OBJECT is a symbol, find the end of its function chain and
1875 return the value found there. If OBJECT is not a symbol, just
1876 return it. If there is a cycle in the function chain, signal a
1877 cyclic-function-indirection error.
1879 This is like Findirect_function, except that it doesn't signal an
1880 error if the chain ends up unbound. */
1882 indirect_function (object
)
1883 register Lisp_Object object
;
1885 Lisp_Object tortoise
, hare
;
1887 hare
= tortoise
= object
;
1891 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1893 hare
= XSYMBOL (hare
)->function
;
1894 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1896 hare
= XSYMBOL (hare
)->function
;
1898 tortoise
= XSYMBOL (tortoise
)->function
;
1900 if (EQ (hare
, tortoise
))
1901 xsignal1 (Qcyclic_function_indirection
, object
);
1907 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1908 doc
: /* Return the function at the end of OBJECT's function chain.
1909 If OBJECT is not a symbol, just return it. Otherwise, follow all
1910 function indirections to find the final function binding and return it.
1911 If the final symbol in the chain is unbound, signal a void-function error.
1912 Optional arg NOERROR non-nil means to return nil instead of signalling.
1913 Signal a cyclic-function-indirection error if there is a loop in the
1914 function chain of symbols. */)
1916 register Lisp_Object object
;
1917 Lisp_Object noerror
;
1921 /* Optimize for no indirection. */
1923 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1924 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1925 result
= indirect_function (result
);
1926 if (!EQ (result
, Qunbound
))
1930 xsignal1 (Qvoid_function
, object
);
1935 /* Extract and set vector and string elements */
1937 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1938 doc
: /* Return the element of ARRAY at index IDX.
1939 ARRAY may be a vector, a string, a char-table, a bool-vector,
1940 or a byte-code object. IDX starts at 0. */)
1942 register Lisp_Object array
;
1945 register int idxval
;
1948 idxval
= XINT (idx
);
1949 if (STRINGP (array
))
1953 if (idxval
< 0 || idxval
>= SCHARS (array
))
1954 args_out_of_range (array
, idx
);
1955 if (! STRING_MULTIBYTE (array
))
1956 return make_number ((unsigned char) SREF (array
, idxval
));
1957 idxval_byte
= string_char_to_byte (array
, idxval
);
1959 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1960 SBYTES (array
) - idxval_byte
);
1961 return make_number (c
);
1963 else if (BOOL_VECTOR_P (array
))
1967 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1968 args_out_of_range (array
, idx
);
1970 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1971 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1973 else if (CHAR_TABLE_P (array
))
1975 CHECK_CHARACTER (idx
);
1976 return CHAR_TABLE_REF (array
, idxval
);
1981 if (VECTORP (array
))
1982 size
= XVECTOR (array
)->size
;
1983 else if (COMPILEDP (array
))
1984 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1986 wrong_type_argument (Qarrayp
, array
);
1988 if (idxval
< 0 || idxval
>= size
)
1989 args_out_of_range (array
, idx
);
1990 return XVECTOR (array
)->contents
[idxval
];
1994 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1995 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1996 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
1997 bool-vector. IDX starts at 0. */)
1998 (array
, idx
, newelt
)
1999 register Lisp_Object array
;
2000 Lisp_Object idx
, newelt
;
2002 register int idxval
;
2005 idxval
= XINT (idx
);
2006 CHECK_ARRAY (array
, Qarrayp
);
2007 CHECK_IMPURE (array
);
2009 if (VECTORP (array
))
2011 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2012 args_out_of_range (array
, idx
);
2013 XVECTOR (array
)->contents
[idxval
] = newelt
;
2015 else if (BOOL_VECTOR_P (array
))
2019 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2020 args_out_of_range (array
, idx
);
2022 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2024 if (! NILP (newelt
))
2025 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2027 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2028 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2030 else if (CHAR_TABLE_P (array
))
2032 CHECK_CHARACTER (idx
);
2033 CHAR_TABLE_SET (array
, idxval
, newelt
);
2035 else if (STRING_MULTIBYTE (array
))
2037 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2038 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2040 if (idxval
< 0 || idxval
>= SCHARS (array
))
2041 args_out_of_range (array
, idx
);
2042 CHECK_CHARACTER (newelt
);
2044 nbytes
= SBYTES (array
);
2046 idxval_byte
= string_char_to_byte (array
, idxval
);
2047 p1
= SDATA (array
) + idxval_byte
;
2048 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2049 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2050 if (prev_bytes
!= new_bytes
)
2052 /* We must relocate the string data. */
2053 int nchars
= SCHARS (array
);
2057 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2058 bcopy (SDATA (array
), str
, nbytes
);
2059 allocate_string_data (XSTRING (array
), nchars
,
2060 nbytes
+ new_bytes
- prev_bytes
);
2061 bcopy (str
, SDATA (array
), idxval_byte
);
2062 p1
= SDATA (array
) + idxval_byte
;
2063 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2064 nbytes
- (idxval_byte
+ prev_bytes
));
2066 clear_string_char_byte_cache ();
2073 if (idxval
< 0 || idxval
>= SCHARS (array
))
2074 args_out_of_range (array
, idx
);
2075 CHECK_NUMBER (newelt
);
2077 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2078 args_out_of_range (array
, newelt
);
2079 SSET (array
, idxval
, XINT (newelt
));
2085 /* Arithmetic functions */
2087 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2090 arithcompare (num1
, num2
, comparison
)
2091 Lisp_Object num1
, num2
;
2092 enum comparison comparison
;
2094 double f1
= 0, f2
= 0;
2097 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2098 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2100 if (FLOATP (num1
) || FLOATP (num2
))
2103 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2104 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2110 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2115 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2120 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2125 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2130 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2135 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2144 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2145 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2147 register Lisp_Object num1
, num2
;
2149 return arithcompare (num1
, num2
, equal
);
2152 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2153 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2155 register Lisp_Object num1
, num2
;
2157 return arithcompare (num1
, num2
, less
);
2160 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2161 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2163 register Lisp_Object num1
, num2
;
2165 return arithcompare (num1
, num2
, grtr
);
2168 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2169 doc
: /* Return t if first arg is less than or equal to second arg.
2170 Both must be numbers or markers. */)
2172 register Lisp_Object num1
, num2
;
2174 return arithcompare (num1
, num2
, less_or_equal
);
2177 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2178 doc
: /* Return t if first arg is greater than or equal to second arg.
2179 Both must be numbers or markers. */)
2181 register Lisp_Object num1
, num2
;
2183 return arithcompare (num1
, num2
, grtr_or_equal
);
2186 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2187 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2189 register Lisp_Object num1
, num2
;
2191 return arithcompare (num1
, num2
, notequal
);
2194 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2195 doc
: /* Return t if NUMBER is zero. */)
2197 register Lisp_Object number
;
2199 CHECK_NUMBER_OR_FLOAT (number
);
2201 if (FLOATP (number
))
2203 if (XFLOAT_DATA (number
) == 0.0)
2213 /* Convert between long values and pairs of Lisp integers.
2214 Note that long_to_cons returns a single Lisp integer
2215 when the value fits in one. */
2221 unsigned long top
= i
>> 16;
2222 unsigned int bot
= i
& 0xFFFF;
2224 return make_number (bot
);
2225 if (top
== (unsigned long)-1 >> 16)
2226 return Fcons (make_number (-1), make_number (bot
));
2227 return Fcons (make_number (top
), make_number (bot
));
2234 Lisp_Object top
, bot
;
2241 return ((XINT (top
) << 16) | XINT (bot
));
2244 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2245 doc
: /* Return the decimal representation of NUMBER as a string.
2246 Uses a minus sign if negative.
2247 NUMBER may be an integer or a floating point number. */)
2251 char buffer
[VALBITS
];
2253 CHECK_NUMBER_OR_FLOAT (number
);
2255 if (FLOATP (number
))
2257 char pigbuf
[350]; /* see comments in float_to_string */
2259 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2260 return build_string (pigbuf
);
2263 if (sizeof (int) == sizeof (EMACS_INT
))
2264 sprintf (buffer
, "%d", XINT (number
));
2265 else if (sizeof (long) == sizeof (EMACS_INT
))
2266 sprintf (buffer
, "%ld", (long) XINT (number
));
2269 return build_string (buffer
);
2273 digit_to_number (character
, base
)
2274 int character
, base
;
2278 if (character
>= '0' && character
<= '9')
2279 digit
= character
- '0';
2280 else if (character
>= 'a' && character
<= 'z')
2281 digit
= character
- 'a' + 10;
2282 else if (character
>= 'A' && character
<= 'Z')
2283 digit
= character
- 'A' + 10;
2293 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2294 doc
: /* Parse STRING as a decimal number and return the number.
2295 This parses both integers and floating point numbers.
2296 It ignores leading spaces and tabs.
2298 If BASE, interpret STRING as a number in that base. If BASE isn't
2299 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2300 If the base used is not 10, floating point is not recognized. */)
2302 register Lisp_Object string
, base
;
2304 register unsigned char *p
;
2309 CHECK_STRING (string
);
2315 CHECK_NUMBER (base
);
2317 if (b
< 2 || b
> 16)
2318 xsignal1 (Qargs_out_of_range
, base
);
2321 /* Skip any whitespace at the front of the number. Some versions of
2322 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2324 while (*p
== ' ' || *p
== '\t')
2335 if (isfloat_string (p
) && b
== 10)
2336 val
= make_float (sign
* atof (p
));
2343 int digit
= digit_to_number (*p
++, b
);
2349 val
= make_fixnum_or_float (sign
* v
);
2369 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2370 int, Lisp_Object
*));
2371 extern Lisp_Object
fmod_float ();
2374 arith_driver (code
, nargs
, args
)
2377 register Lisp_Object
*args
;
2379 register Lisp_Object val
;
2380 register int argnum
;
2381 register EMACS_INT accum
= 0;
2382 register EMACS_INT next
;
2384 switch (SWITCH_ENUM_CAST (code
))
2402 for (argnum
= 0; argnum
< nargs
; argnum
++)
2404 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2406 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2409 return float_arith_driver ((double) accum
, argnum
, code
,
2412 next
= XINT (args
[argnum
]);
2413 switch (SWITCH_ENUM_CAST (code
))
2419 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2430 xsignal0 (Qarith_error
);
2444 if (!argnum
|| next
> accum
)
2448 if (!argnum
|| next
< accum
)
2454 XSETINT (val
, accum
);
2459 #define isnan(x) ((x) != (x))
2462 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2464 register int argnum
;
2467 register Lisp_Object
*args
;
2469 register Lisp_Object val
;
2472 for (; argnum
< nargs
; argnum
++)
2474 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2475 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2479 next
= XFLOAT_DATA (val
);
2483 args
[argnum
] = val
; /* runs into a compiler bug. */
2484 next
= XINT (args
[argnum
]);
2486 switch (SWITCH_ENUM_CAST (code
))
2492 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2502 if (! IEEE_FLOATING_POINT
&& next
== 0)
2503 xsignal0 (Qarith_error
);
2510 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2512 if (!argnum
|| isnan (next
) || next
> accum
)
2516 if (!argnum
|| isnan (next
) || next
< accum
)
2522 return make_float (accum
);
2526 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2527 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2528 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2533 return arith_driver (Aadd
, nargs
, args
);
2536 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2537 doc
: /* Negate number or subtract numbers or markers and return the result.
2538 With one arg, negates it. With more than one arg,
2539 subtracts all but the first from the first.
2540 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2545 return arith_driver (Asub
, nargs
, args
);
2548 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2549 doc
: /* Return product of any number of arguments, which are numbers or markers.
2550 usage: (* &rest NUMBERS-OR-MARKERS) */)
2555 return arith_driver (Amult
, nargs
, args
);
2558 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2559 doc
: /* Return first argument divided by all the remaining arguments.
2560 The arguments must be numbers or markers.
2561 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2567 for (argnum
= 2; argnum
< nargs
; argnum
++)
2568 if (FLOATP (args
[argnum
]))
2569 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2570 return arith_driver (Adiv
, nargs
, args
);
2573 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2574 doc
: /* Return remainder of X divided by Y.
2575 Both must be integers or markers. */)
2577 register Lisp_Object x
, y
;
2581 CHECK_NUMBER_COERCE_MARKER (x
);
2582 CHECK_NUMBER_COERCE_MARKER (y
);
2584 if (XFASTINT (y
) == 0)
2585 xsignal0 (Qarith_error
);
2587 XSETINT (val
, XINT (x
) % XINT (y
));
2601 /* If the magnitude of the result exceeds that of the divisor, or
2602 the sign of the result does not agree with that of the dividend,
2603 iterate with the reduced value. This does not yield a
2604 particularly accurate result, but at least it will be in the
2605 range promised by fmod. */
2607 r
-= f2
* floor (r
/ f2
);
2608 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2612 #endif /* ! HAVE_FMOD */
2614 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2615 doc
: /* Return X modulo Y.
2616 The result falls between zero (inclusive) and Y (exclusive).
2617 Both X and Y must be numbers or markers. */)
2619 register Lisp_Object x
, y
;
2624 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2625 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2627 if (FLOATP (x
) || FLOATP (y
))
2628 return fmod_float (x
, y
);
2634 xsignal0 (Qarith_error
);
2638 /* If the "remainder" comes out with the wrong sign, fix it. */
2639 if (i2
< 0 ? i1
> 0 : i1
< 0)
2646 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2647 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2648 The value is always a number; markers are converted to numbers.
2649 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2654 return arith_driver (Amax
, nargs
, args
);
2657 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2658 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2659 The value is always a number; markers are converted to numbers.
2660 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2665 return arith_driver (Amin
, nargs
, args
);
2668 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2669 doc
: /* Return bitwise-and of all the arguments.
2670 Arguments may be integers, or markers converted to integers.
2671 usage: (logand &rest INTS-OR-MARKERS) */)
2676 return arith_driver (Alogand
, nargs
, args
);
2679 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2680 doc
: /* Return bitwise-or of all the arguments.
2681 Arguments may be integers, or markers converted to integers.
2682 usage: (logior &rest INTS-OR-MARKERS) */)
2687 return arith_driver (Alogior
, nargs
, args
);
2690 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2691 doc
: /* Return bitwise-exclusive-or of all the arguments.
2692 Arguments may be integers, or markers converted to integers.
2693 usage: (logxor &rest INTS-OR-MARKERS) */)
2698 return arith_driver (Alogxor
, nargs
, args
);
2701 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2702 doc
: /* Return VALUE with its bits shifted left by COUNT.
2703 If COUNT is negative, shifting is actually to the right.
2704 In this case, the sign bit is duplicated. */)
2706 register Lisp_Object value
, count
;
2708 register Lisp_Object val
;
2710 CHECK_NUMBER (value
);
2711 CHECK_NUMBER (count
);
2713 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2715 else if (XINT (count
) > 0)
2716 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2717 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2718 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2720 XSETINT (val
, XINT (value
) >> -XINT (count
));
2724 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2725 doc
: /* Return VALUE with its bits shifted left by COUNT.
2726 If COUNT is negative, shifting is actually to the right.
2727 In this case, zeros are shifted in on the left. */)
2729 register Lisp_Object value
, count
;
2731 register Lisp_Object val
;
2733 CHECK_NUMBER (value
);
2734 CHECK_NUMBER (count
);
2736 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2738 else if (XINT (count
) > 0)
2739 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2740 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2743 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2747 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2748 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2749 Markers are converted to integers. */)
2751 register Lisp_Object number
;
2753 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2755 if (FLOATP (number
))
2756 return (make_float (1.0 + XFLOAT_DATA (number
)));
2758 XSETINT (number
, XINT (number
) + 1);
2762 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2763 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2764 Markers are converted to integers. */)
2766 register Lisp_Object number
;
2768 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2770 if (FLOATP (number
))
2771 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2773 XSETINT (number
, XINT (number
) - 1);
2777 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2778 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2780 register Lisp_Object number
;
2782 CHECK_NUMBER (number
);
2783 XSETINT (number
, ~XINT (number
));
2787 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2788 doc
: /* Return the byteorder for the machine.
2789 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2790 lowercase l) for small endian machines. */)
2793 unsigned i
= 0x04030201;
2794 int order
= *(char *)&i
== 1 ? 108 : 66;
2796 return make_number (order
);
2804 Lisp_Object error_tail
, arith_tail
;
2806 Qquote
= intern ("quote");
2807 Qlambda
= intern ("lambda");
2808 Qsubr
= intern ("subr");
2809 Qerror_conditions
= intern ("error-conditions");
2810 Qerror_message
= intern ("error-message");
2811 Qtop_level
= intern ("top-level");
2813 Qerror
= intern ("error");
2814 Qquit
= intern ("quit");
2815 Qwrong_type_argument
= intern ("wrong-type-argument");
2816 Qargs_out_of_range
= intern ("args-out-of-range");
2817 Qvoid_function
= intern ("void-function");
2818 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2819 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2820 Qvoid_variable
= intern ("void-variable");
2821 Qsetting_constant
= intern ("setting-constant");
2822 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2824 Qinvalid_function
= intern ("invalid-function");
2825 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2826 Qno_catch
= intern ("no-catch");
2827 Qend_of_file
= intern ("end-of-file");
2828 Qarith_error
= intern ("arith-error");
2829 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2830 Qend_of_buffer
= intern ("end-of-buffer");
2831 Qbuffer_read_only
= intern ("buffer-read-only");
2832 Qtext_read_only
= intern ("text-read-only");
2833 Qmark_inactive
= intern ("mark-inactive");
2835 Qlistp
= intern ("listp");
2836 Qconsp
= intern ("consp");
2837 Qsymbolp
= intern ("symbolp");
2838 Qkeywordp
= intern ("keywordp");
2839 Qintegerp
= intern ("integerp");
2840 Qnatnump
= intern ("natnump");
2841 Qwholenump
= intern ("wholenump");
2842 Qstringp
= intern ("stringp");
2843 Qarrayp
= intern ("arrayp");
2844 Qsequencep
= intern ("sequencep");
2845 Qbufferp
= intern ("bufferp");
2846 Qvectorp
= intern ("vectorp");
2847 Qchar_or_string_p
= intern ("char-or-string-p");
2848 Qmarkerp
= intern ("markerp");
2849 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2850 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2851 Qboundp
= intern ("boundp");
2852 Qfboundp
= intern ("fboundp");
2854 Qfloatp
= intern ("floatp");
2855 Qnumberp
= intern ("numberp");
2856 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2858 Qchar_table_p
= intern ("char-table-p");
2859 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2861 Qsubrp
= intern ("subrp");
2862 Qunevalled
= intern ("unevalled");
2863 Qmany
= intern ("many");
2865 Qcdr
= intern ("cdr");
2867 /* Handle automatic advice activation */
2868 Qad_advice_info
= intern ("ad-advice-info");
2869 Qad_activate_internal
= intern ("ad-activate-internal");
2871 error_tail
= Fcons (Qerror
, Qnil
);
2873 /* ERROR is used as a signaler for random errors for which nothing else is right */
2875 Fput (Qerror
, Qerror_conditions
,
2877 Fput (Qerror
, Qerror_message
,
2878 build_string ("error"));
2880 Fput (Qquit
, Qerror_conditions
,
2881 Fcons (Qquit
, Qnil
));
2882 Fput (Qquit
, Qerror_message
,
2883 build_string ("Quit"));
2885 Fput (Qwrong_type_argument
, Qerror_conditions
,
2886 Fcons (Qwrong_type_argument
, error_tail
));
2887 Fput (Qwrong_type_argument
, Qerror_message
,
2888 build_string ("Wrong type argument"));
2890 Fput (Qargs_out_of_range
, Qerror_conditions
,
2891 Fcons (Qargs_out_of_range
, error_tail
));
2892 Fput (Qargs_out_of_range
, Qerror_message
,
2893 build_string ("Args out of range"));
2895 Fput (Qvoid_function
, Qerror_conditions
,
2896 Fcons (Qvoid_function
, error_tail
));
2897 Fput (Qvoid_function
, Qerror_message
,
2898 build_string ("Symbol's function definition is void"));
2900 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2901 Fcons (Qcyclic_function_indirection
, error_tail
));
2902 Fput (Qcyclic_function_indirection
, Qerror_message
,
2903 build_string ("Symbol's chain of function indirections contains a loop"));
2905 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2906 Fcons (Qcyclic_variable_indirection
, error_tail
));
2907 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2908 build_string ("Symbol's chain of variable indirections contains a loop"));
2910 Qcircular_list
= intern ("circular-list");
2911 staticpro (&Qcircular_list
);
2912 Fput (Qcircular_list
, Qerror_conditions
,
2913 Fcons (Qcircular_list
, error_tail
));
2914 Fput (Qcircular_list
, Qerror_message
,
2915 build_string ("List contains a loop"));
2917 Fput (Qvoid_variable
, Qerror_conditions
,
2918 Fcons (Qvoid_variable
, error_tail
));
2919 Fput (Qvoid_variable
, Qerror_message
,
2920 build_string ("Symbol's value as variable is void"));
2922 Fput (Qsetting_constant
, Qerror_conditions
,
2923 Fcons (Qsetting_constant
, error_tail
));
2924 Fput (Qsetting_constant
, Qerror_message
,
2925 build_string ("Attempt to set a constant symbol"));
2927 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2928 Fcons (Qinvalid_read_syntax
, error_tail
));
2929 Fput (Qinvalid_read_syntax
, Qerror_message
,
2930 build_string ("Invalid read syntax"));
2932 Fput (Qinvalid_function
, Qerror_conditions
,
2933 Fcons (Qinvalid_function
, error_tail
));
2934 Fput (Qinvalid_function
, Qerror_message
,
2935 build_string ("Invalid function"));
2937 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2938 Fcons (Qwrong_number_of_arguments
, error_tail
));
2939 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2940 build_string ("Wrong number of arguments"));
2942 Fput (Qno_catch
, Qerror_conditions
,
2943 Fcons (Qno_catch
, error_tail
));
2944 Fput (Qno_catch
, Qerror_message
,
2945 build_string ("No catch for tag"));
2947 Fput (Qend_of_file
, Qerror_conditions
,
2948 Fcons (Qend_of_file
, error_tail
));
2949 Fput (Qend_of_file
, Qerror_message
,
2950 build_string ("End of file during parsing"));
2952 arith_tail
= Fcons (Qarith_error
, error_tail
);
2953 Fput (Qarith_error
, Qerror_conditions
,
2955 Fput (Qarith_error
, Qerror_message
,
2956 build_string ("Arithmetic error"));
2958 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2959 Fcons (Qbeginning_of_buffer
, error_tail
));
2960 Fput (Qbeginning_of_buffer
, Qerror_message
,
2961 build_string ("Beginning of buffer"));
2963 Fput (Qend_of_buffer
, Qerror_conditions
,
2964 Fcons (Qend_of_buffer
, error_tail
));
2965 Fput (Qend_of_buffer
, Qerror_message
,
2966 build_string ("End of buffer"));
2968 Fput (Qbuffer_read_only
, Qerror_conditions
,
2969 Fcons (Qbuffer_read_only
, error_tail
));
2970 Fput (Qbuffer_read_only
, Qerror_message
,
2971 build_string ("Buffer is read-only"));
2973 Fput (Qtext_read_only
, Qerror_conditions
,
2974 Fcons (Qtext_read_only
, error_tail
));
2975 Fput (Qtext_read_only
, Qerror_message
,
2976 build_string ("Text is read-only"));
2978 Qrange_error
= intern ("range-error");
2979 Qdomain_error
= intern ("domain-error");
2980 Qsingularity_error
= intern ("singularity-error");
2981 Qoverflow_error
= intern ("overflow-error");
2982 Qunderflow_error
= intern ("underflow-error");
2984 Fput (Qdomain_error
, Qerror_conditions
,
2985 Fcons (Qdomain_error
, arith_tail
));
2986 Fput (Qdomain_error
, Qerror_message
,
2987 build_string ("Arithmetic domain error"));
2989 Fput (Qrange_error
, Qerror_conditions
,
2990 Fcons (Qrange_error
, arith_tail
));
2991 Fput (Qrange_error
, Qerror_message
,
2992 build_string ("Arithmetic range error"));
2994 Fput (Qsingularity_error
, Qerror_conditions
,
2995 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2996 Fput (Qsingularity_error
, Qerror_message
,
2997 build_string ("Arithmetic singularity error"));
2999 Fput (Qoverflow_error
, Qerror_conditions
,
3000 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3001 Fput (Qoverflow_error
, Qerror_message
,
3002 build_string ("Arithmetic overflow error"));
3004 Fput (Qunderflow_error
, Qerror_conditions
,
3005 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3006 Fput (Qunderflow_error
, Qerror_message
,
3007 build_string ("Arithmetic underflow error"));
3009 staticpro (&Qrange_error
);
3010 staticpro (&Qdomain_error
);
3011 staticpro (&Qsingularity_error
);
3012 staticpro (&Qoverflow_error
);
3013 staticpro (&Qunderflow_error
);
3017 staticpro (&Qquote
);
3018 staticpro (&Qlambda
);
3020 staticpro (&Qunbound
);
3021 staticpro (&Qerror_conditions
);
3022 staticpro (&Qerror_message
);
3023 staticpro (&Qtop_level
);
3025 staticpro (&Qerror
);
3027 staticpro (&Qwrong_type_argument
);
3028 staticpro (&Qargs_out_of_range
);
3029 staticpro (&Qvoid_function
);
3030 staticpro (&Qcyclic_function_indirection
);
3031 staticpro (&Qcyclic_variable_indirection
);
3032 staticpro (&Qvoid_variable
);
3033 staticpro (&Qsetting_constant
);
3034 staticpro (&Qinvalid_read_syntax
);
3035 staticpro (&Qwrong_number_of_arguments
);
3036 staticpro (&Qinvalid_function
);
3037 staticpro (&Qno_catch
);
3038 staticpro (&Qend_of_file
);
3039 staticpro (&Qarith_error
);
3040 staticpro (&Qbeginning_of_buffer
);
3041 staticpro (&Qend_of_buffer
);
3042 staticpro (&Qbuffer_read_only
);
3043 staticpro (&Qtext_read_only
);
3044 staticpro (&Qmark_inactive
);
3046 staticpro (&Qlistp
);
3047 staticpro (&Qconsp
);
3048 staticpro (&Qsymbolp
);
3049 staticpro (&Qkeywordp
);
3050 staticpro (&Qintegerp
);
3051 staticpro (&Qnatnump
);
3052 staticpro (&Qwholenump
);
3053 staticpro (&Qstringp
);
3054 staticpro (&Qarrayp
);
3055 staticpro (&Qsequencep
);
3056 staticpro (&Qbufferp
);
3057 staticpro (&Qvectorp
);
3058 staticpro (&Qchar_or_string_p
);
3059 staticpro (&Qmarkerp
);
3060 staticpro (&Qbuffer_or_string_p
);
3061 staticpro (&Qinteger_or_marker_p
);
3062 staticpro (&Qfloatp
);
3063 staticpro (&Qnumberp
);
3064 staticpro (&Qnumber_or_marker_p
);
3065 staticpro (&Qchar_table_p
);
3066 staticpro (&Qvector_or_char_table_p
);
3067 staticpro (&Qsubrp
);
3069 staticpro (&Qunevalled
);
3071 staticpro (&Qboundp
);
3072 staticpro (&Qfboundp
);
3074 staticpro (&Qad_advice_info
);
3075 staticpro (&Qad_activate_internal
);
3077 /* Types that type-of returns. */
3078 Qinteger
= intern ("integer");
3079 Qsymbol
= intern ("symbol");
3080 Qstring
= intern ("string");
3081 Qcons
= intern ("cons");
3082 Qmarker
= intern ("marker");
3083 Qoverlay
= intern ("overlay");
3084 Qfloat
= intern ("float");
3085 Qwindow_configuration
= intern ("window-configuration");
3086 Qprocess
= intern ("process");
3087 Qwindow
= intern ("window");
3088 /* Qsubr = intern ("subr"); */
3089 Qcompiled_function
= intern ("compiled-function");
3090 Qbuffer
= intern ("buffer");
3091 Qframe
= intern ("frame");
3092 Qvector
= intern ("vector");
3093 Qchar_table
= intern ("char-table");
3094 Qbool_vector
= intern ("bool-vector");
3095 Qhash_table
= intern ("hash-table");
3097 staticpro (&Qinteger
);
3098 staticpro (&Qsymbol
);
3099 staticpro (&Qstring
);
3101 staticpro (&Qmarker
);
3102 staticpro (&Qoverlay
);
3103 staticpro (&Qfloat
);
3104 staticpro (&Qwindow_configuration
);
3105 staticpro (&Qprocess
);
3106 staticpro (&Qwindow
);
3107 /* staticpro (&Qsubr); */
3108 staticpro (&Qcompiled_function
);
3109 staticpro (&Qbuffer
);
3110 staticpro (&Qframe
);
3111 staticpro (&Qvector
);
3112 staticpro (&Qchar_table
);
3113 staticpro (&Qbool_vector
);
3114 staticpro (&Qhash_table
);
3116 defsubr (&Sindirect_variable
);
3117 defsubr (&Sinteractive_form
);
3120 defsubr (&Stype_of
);
3125 defsubr (&Sintegerp
);
3126 defsubr (&Sinteger_or_marker_p
);
3127 defsubr (&Snumberp
);
3128 defsubr (&Snumber_or_marker_p
);
3130 defsubr (&Snatnump
);
3131 defsubr (&Ssymbolp
);
3132 defsubr (&Skeywordp
);
3133 defsubr (&Sstringp
);
3134 defsubr (&Smultibyte_string_p
);
3135 defsubr (&Svectorp
);
3136 defsubr (&Schar_table_p
);
3137 defsubr (&Svector_or_char_table_p
);
3138 defsubr (&Sbool_vector_p
);
3140 defsubr (&Ssequencep
);
3141 defsubr (&Sbufferp
);
3142 defsubr (&Smarkerp
);
3144 defsubr (&Sbyte_code_function_p
);
3145 defsubr (&Schar_or_string_p
);
3148 defsubr (&Scar_safe
);
3149 defsubr (&Scdr_safe
);
3152 defsubr (&Ssymbol_function
);
3153 defsubr (&Sindirect_function
);
3154 defsubr (&Ssymbol_plist
);
3155 defsubr (&Ssymbol_name
);
3156 defsubr (&Smakunbound
);
3157 defsubr (&Sfmakunbound
);
3159 defsubr (&Sfboundp
);
3161 defsubr (&Sdefalias
);
3162 defsubr (&Ssetplist
);
3163 defsubr (&Ssymbol_value
);
3165 defsubr (&Sdefault_boundp
);
3166 defsubr (&Sdefault_value
);
3167 defsubr (&Sset_default
);
3168 defsubr (&Ssetq_default
);
3169 defsubr (&Smake_variable_buffer_local
);
3170 defsubr (&Smake_local_variable
);
3171 defsubr (&Skill_local_variable
);
3172 defsubr (&Smake_variable_frame_local
);
3173 defsubr (&Slocal_variable_p
);
3174 defsubr (&Slocal_variable_if_set_p
);
3175 defsubr (&Svariable_binding_locus
);
3178 defsubr (&Snumber_to_string
);
3179 defsubr (&Sstring_to_number
);
3180 defsubr (&Seqlsign
);
3203 defsubr (&Sbyteorder
);
3204 defsubr (&Ssubr_arity
);
3205 defsubr (&Ssubr_name
);
3207 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3209 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3210 doc
: /* The largest value that is representable in a Lisp integer. */);
3211 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3213 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3214 doc
: /* The smallest value that is representable in a Lisp integer. */);
3215 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3222 #if defined(USG) && !defined(POSIX_SIGNALS)
3223 /* USG systems forget handlers when they are used;
3224 must reestablish each time */
3225 signal (signo
, arith_error
);
3228 /* VMS systems are like USG. */
3229 signal (signo
, arith_error
);
3233 #else /* not BSD4_1 */
3234 sigsetmask (SIGEMPTYMASK
);
3235 #endif /* not BSD4_1 */
3237 SIGNAL_THREAD_CHECK (signo
);
3238 xsignal0 (Qarith_error
);
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
);
3259 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3260 (do not change this comment) */