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"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
49 /* Work around a problem that happens because math.h on hpux 7
50 defines two static variables--which, in Emacs, are not really static,
51 because `static' is defined as nothing. The problem is that they are
52 here, in floatfns.c, and in lread.c.
53 These macros prevent the name conflict. */
54 #if defined (HPUX) && !defined (HPUX8)
55 #define _MAXLDBL data_c_maxldbl
56 #define _NMAXLDBL data_c_nmaxldbl
62 extern double atof ();
65 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
66 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
67 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
68 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
69 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
70 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
71 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
72 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
73 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
74 Lisp_Object Qtext_read_only
;
76 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
77 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
78 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
79 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
80 Lisp_Object Qboundp
, Qfboundp
;
81 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
84 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
86 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
87 Lisp_Object Qoverflow_error
, Qunderflow_error
;
90 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
93 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
94 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
96 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
97 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
98 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
100 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
102 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
106 circular_list_error (list
)
109 xsignal (Qcircular_list
, list
);
114 wrong_type_argument (predicate
, value
)
115 register Lisp_Object predicate
, value
;
117 /* If VALUE is not even a valid Lisp object, abort here
118 where we can get a backtrace showing where it came from. */
119 if ((unsigned int) XTYPE (value
) >= Lisp_Type_Limit
)
122 xsignal2 (Qwrong_type_argument
, predicate
, value
);
128 error ("Attempt to modify read-only object");
132 args_out_of_range (a1
, a2
)
135 xsignal2 (Qargs_out_of_range
, a1
, a2
);
139 args_out_of_range_3 (a1
, a2
, a3
)
140 Lisp_Object a1
, a2
, a3
;
142 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
145 /* On some machines, XINT needs a temporary location.
146 Here it is, in case it is needed. */
148 int sign_extend_temp
;
150 /* On a few machines, XINT can only be done by calling this. */
153 sign_extend_lisp_int (num
)
156 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
157 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
159 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
162 /* Data type predicates */
164 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
165 doc
: /* Return t if the two args are the same Lisp object. */)
167 Lisp_Object obj1
, obj2
;
174 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
175 doc
: /* Return t if OBJECT is nil. */)
184 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
185 doc
: /* Return a symbol representing the type of OBJECT.
186 The symbol returned names the object's basic type;
187 for example, (type-of 1) returns `integer'. */)
191 switch (XTYPE (object
))
206 switch (XMISCTYPE (object
))
208 case Lisp_Misc_Marker
:
210 case Lisp_Misc_Overlay
:
212 case Lisp_Misc_Float
:
217 case Lisp_Vectorlike
:
218 if (WINDOW_CONFIGURATIONP (object
))
219 return Qwindow_configuration
;
220 if (PROCESSP (object
))
222 if (WINDOWP (object
))
226 if (COMPILEDP (object
))
227 return Qcompiled_function
;
228 if (BUFFERP (object
))
230 if (CHAR_TABLE_P (object
))
232 if (BOOL_VECTOR_P (object
))
236 if (HASH_TABLE_P (object
))
248 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
249 doc
: /* Return t if OBJECT is a cons cell. */)
258 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
259 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
268 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
269 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
270 Otherwise, return nil. */)
274 if (CONSP (object
) || NILP (object
))
279 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
290 doc
: /* Return t if OBJECT is a symbol. */)
294 if (SYMBOLP (object
))
299 /* Define this in C to avoid unnecessarily consing up the symbol
301 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
302 doc
: /* Return t if OBJECT is a keyword.
303 This means that it is a symbol with a print name beginning with `:'
304 interned in the initial obarray. */)
309 && SREF (SYMBOL_NAME (object
), 0) == ':'
310 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
315 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is a vector. */)
320 if (VECTORP (object
))
325 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
326 doc
: /* Return t if OBJECT is a string. */)
330 if (STRINGP (object
))
335 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
337 doc
: /* Return t if OBJECT is a multibyte string. */)
341 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
346 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
347 doc
: /* Return t if OBJECT is a char-table. */)
351 if (CHAR_TABLE_P (object
))
356 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
357 Svector_or_char_table_p
, 1, 1, 0,
358 doc
: /* Return t if OBJECT is a char-table or vector. */)
362 if (VECTORP (object
) || CHAR_TABLE_P (object
))
367 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a bool-vector. */)
372 if (BOOL_VECTOR_P (object
))
377 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
388 doc
: /* Return t if OBJECT is a sequence (list or array). */)
390 register Lisp_Object object
;
392 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
397 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is an editor buffer. */)
402 if (BUFFERP (object
))
407 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
412 if (MARKERP (object
))
417 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a built-in function. */)
427 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
429 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
433 if (COMPILEDP (object
))
438 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
439 doc
: /* Return t if OBJECT is a character or a string. */)
441 register Lisp_Object object
;
443 if (CHARACTERP (object
) || STRINGP (object
))
448 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is an integer. */)
453 if (INTEGERP (object
))
458 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
461 register Lisp_Object object
;
463 if (MARKERP (object
) || INTEGERP (object
))
468 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is a nonnegative integer. */)
473 if (NATNUMP (object
))
478 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
479 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
483 if (NUMBERP (object
))
489 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
490 Snumber_or_marker_p
, 1, 1, 0,
491 doc
: /* Return t if OBJECT is a number or a marker. */)
495 if (NUMBERP (object
) || MARKERP (object
))
500 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a floating point number. */)
511 /* Extract and set components of lists */
513 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
514 doc
: /* Return the car of LIST. If arg is nil, return nil.
515 Error if arg is not nil and not a cons cell. See also `car-safe'.
517 See Info node `(elisp)Cons Cells' for a discussion of related basic
518 Lisp concepts such as car, cdr, cons cell and list. */)
520 register Lisp_Object list
;
525 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
526 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
530 return CAR_SAFE (object
);
533 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
534 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
535 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
537 See Info node `(elisp)Cons Cells' for a discussion of related basic
538 Lisp concepts such as cdr, car, cons cell and list. */)
540 register Lisp_Object list
;
545 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
546 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
550 return CDR_SAFE (object
);
553 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
554 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
556 register Lisp_Object cell
, newcar
;
560 XSETCAR (cell
, newcar
);
564 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
565 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
567 register Lisp_Object cell
, newcdr
;
571 XSETCDR (cell
, newcdr
);
575 /* Extract and set components of symbols */
577 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
578 doc
: /* Return t if SYMBOL's value is not void. */)
580 register Lisp_Object symbol
;
582 Lisp_Object valcontents
;
583 CHECK_SYMBOL (symbol
);
585 valcontents
= SYMBOL_VALUE (symbol
);
587 if (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 register Lisp_Object function
;
667 CHECK_SYMBOL (symbol
);
668 if (NILP (symbol
) || EQ (symbol
, Qt
))
669 xsignal1 (Qsetting_constant
, symbol
);
671 function
= XSYMBOL (symbol
)->function
;
673 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
674 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
676 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
677 Fput (symbol
, Qautoload
, XCDR (function
));
679 XSYMBOL (symbol
)->function
= definition
;
680 /* Handle automatic advice activation */
681 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
683 call2 (Qad_activate_internal
, symbol
, Qnil
);
684 definition
= XSYMBOL (symbol
)->function
;
689 extern Lisp_Object Qfunction_documentation
;
691 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
692 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
693 Associates the function with the current load file, if any.
694 The optional third argument DOCSTRING specifies the documentation string
695 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
696 determined by DEFINITION. */)
697 (symbol
, definition
, docstring
)
698 register Lisp_Object symbol
, definition
, docstring
;
700 CHECK_SYMBOL (symbol
);
701 if (CONSP (XSYMBOL (symbol
)->function
)
702 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
703 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
704 definition
= Ffset (symbol
, definition
);
705 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
706 if (!NILP (docstring
))
707 Fput (symbol
, Qfunction_documentation
, docstring
);
711 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
712 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
714 register Lisp_Object symbol
, newplist
;
716 CHECK_SYMBOL (symbol
);
717 XSYMBOL (symbol
)->plist
= newplist
;
721 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
722 doc
: /* Return minimum and maximum number of args allowed for SUBR.
723 SUBR must be a built-in function.
724 The returned value is a pair (MIN . MAX). MIN is the minimum number
725 of args. MAX is the maximum number or the symbol `many', for a
726 function with `&rest' args, or `unevalled' for a special form. */)
730 short minargs
, maxargs
;
732 minargs
= XSUBR (subr
)->min_args
;
733 maxargs
= XSUBR (subr
)->max_args
;
735 return Fcons (make_number (minargs
), Qmany
);
736 else if (maxargs
== UNEVALLED
)
737 return Fcons (make_number (minargs
), Qunevalled
);
739 return Fcons (make_number (minargs
), make_number (maxargs
));
742 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
743 doc
: /* Return name of subroutine SUBR.
744 SUBR must be a built-in function. */)
750 name
= XSUBR (subr
)->symbol_name
;
751 return make_string (name
, strlen (name
));
754 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
755 doc
: /* Return the interactive form of CMD or nil if none.
756 If CMD is not a command, the return value is nil.
757 Value, if non-nil, is a list \(interactive SPEC). */)
761 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
763 if (NILP (fun
) || EQ (fun
, Qunbound
))
766 /* Use an `interactive-form' property if present, analogous to the
767 function-documentation property. */
769 while (SYMBOLP (fun
))
771 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
775 fun
= Fsymbol_function (fun
);
780 char *spec
= XSUBR (fun
)->intspec
;
782 return list2 (Qinteractive
,
783 (*spec
!= '(') ? build_string (spec
) :
784 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
786 else if (COMPILEDP (fun
))
788 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
789 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
791 else if (CONSP (fun
))
793 Lisp_Object funcar
= XCAR (fun
);
794 if (EQ (funcar
, Qlambda
))
795 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
796 else if (EQ (funcar
, Qautoload
))
800 do_autoload (fun
, cmd
);
802 return Finteractive_form (cmd
);
809 /***********************************************************************
810 Getting and Setting Values of Symbols
811 ***********************************************************************/
813 /* Return the symbol holding SYMBOL's value. Signal
814 `cyclic-variable-indirection' if SYMBOL's chain of variable
815 indirections contains a loop. */
818 indirect_variable (symbol
)
821 Lisp_Object tortoise
, hare
;
823 hare
= tortoise
= symbol
;
825 while (XSYMBOL (hare
)->indirect_variable
)
827 hare
= XSYMBOL (hare
)->value
;
828 if (!XSYMBOL (hare
)->indirect_variable
)
831 hare
= XSYMBOL (hare
)->value
;
832 tortoise
= XSYMBOL (tortoise
)->value
;
834 if (EQ (hare
, tortoise
))
835 xsignal1 (Qcyclic_variable_indirection
, symbol
);
842 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
843 doc
: /* Return the variable at the end of OBJECT's variable chain.
844 If OBJECT is a symbol, follow all variable indirections and return the final
845 variable. If OBJECT is not a symbol, just return it.
846 Signal a cyclic-variable-indirection error if there is a loop in the
847 variable chain of symbols. */)
851 if (SYMBOLP (object
))
852 object
= indirect_variable (object
);
857 /* Given the raw contents of a symbol value cell,
858 return the Lisp value of the symbol.
859 This does not handle buffer-local variables; use
860 swap_in_symval_forwarding for that. */
863 do_symval_forwarding (valcontents
)
864 register Lisp_Object valcontents
;
866 register Lisp_Object val
;
867 if (MISCP (valcontents
))
868 switch (XMISCTYPE (valcontents
))
870 case Lisp_Misc_Intfwd
:
871 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
874 case Lisp_Misc_Boolfwd
:
875 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
877 case Lisp_Misc_Objfwd
:
878 return *XOBJFWD (valcontents
)->objvar
;
880 case Lisp_Misc_Buffer_Objfwd
:
881 return PER_BUFFER_VALUE (current_buffer
,
882 XBUFFER_OBJFWD (valcontents
)->offset
);
884 case Lisp_Misc_Kboard_Objfwd
:
885 /* We used to simply use current_kboard here, but from Lisp
886 code, it's value is often unexpected. It seems nicer to
887 allow constructions like this to work as intuitively expected:
889 (with-selected-frame frame
890 (define-key local-function-map "\eOP" [f1]))
892 On the other hand, this affects the semantics of
893 last-command and real-last-command, and people may rely on
894 that. I took a quick look at the Lisp codebase, and I
895 don't think anything will break. --lorentey */
896 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
897 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
902 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
903 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
904 buffer-independent contents of the value cell: forwarded just one
905 step past the buffer-localness.
907 BUF non-zero means set the value in buffer BUF instead of the
908 current buffer. This only plays a role for per-buffer variables. */
911 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
913 register Lisp_Object valcontents
, newval
;
916 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
919 switch (XMISCTYPE (valcontents
))
921 case Lisp_Misc_Intfwd
:
922 CHECK_NUMBER (newval
);
923 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
924 /* This can never happen since intvar points to an EMACS_INT
925 which is at least large enough to hold a Lisp_Object.
926 if (*XINTFWD (valcontents)->intvar != XINT (newval))
927 error ("Value out of range for variable `%s'",
928 SDATA (SYMBOL_NAME (symbol))); */
931 case Lisp_Misc_Boolfwd
:
932 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
935 case Lisp_Misc_Objfwd
:
936 *XOBJFWD (valcontents
)->objvar
= newval
;
938 /* If this variable is a default for something stored
939 in the buffer itself, such as default-fill-column,
940 find the buffers that don't have local values for it
942 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
943 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
945 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
946 - (char *) &buffer_defaults
);
947 int idx
= PER_BUFFER_IDX (offset
);
954 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
959 buf
= Fcdr (XCAR (tail
));
960 if (!BUFFERP (buf
)) continue;
963 if (! PER_BUFFER_VALUE_P (b
, idx
))
964 PER_BUFFER_VALUE (b
, offset
) = newval
;
969 case Lisp_Misc_Buffer_Objfwd
:
971 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
972 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
974 if (! NILP (type
) && ! NILP (newval
)
975 && XTYPE (newval
) != XINT (type
))
976 buffer_slot_type_mismatch (symbol
, XINT (type
));
979 buf
= current_buffer
;
980 PER_BUFFER_VALUE (buf
, offset
) = newval
;
984 case Lisp_Misc_Kboard_Objfwd
:
986 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
987 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
988 *(Lisp_Object
*) p
= newval
;
999 valcontents
= SYMBOL_VALUE (symbol
);
1000 if (BUFFER_LOCAL_VALUEP (valcontents
))
1001 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1003 SET_SYMBOL_VALUE (symbol
, newval
);
1007 /* Set up SYMBOL to refer to its global binding.
1008 This makes it safe to alter the status of other bindings. */
1011 swap_in_global_binding (symbol
)
1014 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1015 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1016 Lisp_Object cdr
= blv
->cdr
;
1018 /* Unload the previously loaded binding. */
1019 Fsetcdr (XCAR (cdr
),
1020 do_symval_forwarding (blv
->realvalue
));
1022 /* Select the global binding in the symbol. */
1024 store_symval_forwarding (symbol
, blv
->realvalue
, XCDR (cdr
), NULL
);
1026 /* Indicate that the global binding is set up now. */
1029 blv
->found_for_frame
= 0;
1030 blv
->found_for_buffer
= 0;
1033 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1034 VALCONTENTS is the contents of its value cell,
1035 which points to a struct Lisp_Buffer_Local_Value.
1037 Return the value forwarded one step past the buffer-local stage.
1038 This could be another forwarding pointer. */
1041 swap_in_symval_forwarding (symbol
, valcontents
)
1042 Lisp_Object symbol
, valcontents
;
1044 register Lisp_Object tem1
;
1046 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1049 || current_buffer
!= XBUFFER (tem1
)
1050 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1051 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1053 if (XSYMBOL (symbol
)->indirect_variable
)
1054 symbol
= indirect_variable (symbol
);
1056 /* Unload the previously loaded binding. */
1057 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1059 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1060 /* Choose the new binding. */
1061 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1062 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1063 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1066 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1067 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1069 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1071 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1074 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1076 /* Load the new binding. */
1077 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1078 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1079 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1080 store_symval_forwarding (symbol
,
1081 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1084 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1087 /* Find the value of a symbol, returning Qunbound if it's not bound.
1088 This is helpful for code which just wants to get a variable's value
1089 if it has one, without signaling an error.
1090 Note that it must not be possible to quit
1091 within this function. Great care is required for this. */
1094 find_symbol_value (symbol
)
1097 register Lisp_Object valcontents
;
1098 register Lisp_Object val
;
1100 CHECK_SYMBOL (symbol
);
1101 valcontents
= SYMBOL_VALUE (symbol
);
1103 if (BUFFER_LOCAL_VALUEP (valcontents
))
1104 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1106 return do_symval_forwarding (valcontents
);
1109 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1110 doc
: /* Return SYMBOL's value. Error if that is void. */)
1116 val
= find_symbol_value (symbol
);
1117 if (!EQ (val
, Qunbound
))
1120 xsignal1 (Qvoid_variable
, symbol
);
1123 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1124 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1126 register Lisp_Object symbol
, newval
;
1128 return set_internal (symbol
, newval
, current_buffer
, 0);
1131 /* Return 1 if SYMBOL currently has a let-binding
1132 which was made in the buffer that is now current. */
1135 let_shadows_buffer_binding_p (symbol
)
1138 volatile struct specbinding
*p
;
1140 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1142 && CONSP (p
->symbol
))
1144 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1145 if ((EQ (symbol
, let_bound_symbol
)
1146 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1147 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1148 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1152 return p
>= specpdl
;
1155 /* Store the value NEWVAL into SYMBOL.
1156 If buffer-locality is an issue, BUF specifies which buffer to use.
1157 (0 stands for the current buffer.)
1159 If BINDFLAG is zero, then if this symbol is supposed to become
1160 local in every buffer where it is set, then we make it local.
1161 If BINDFLAG is nonzero, we don't do that. */
1164 set_internal (symbol
, newval
, buf
, bindflag
)
1165 register Lisp_Object symbol
, newval
;
1169 int voide
= EQ (newval
, Qunbound
);
1171 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1174 buf
= current_buffer
;
1176 /* If restoring in a dead buffer, do nothing. */
1177 if (NILP (buf
->name
))
1180 CHECK_SYMBOL (symbol
);
1181 if (SYMBOL_CONSTANT_P (symbol
)
1182 && (NILP (Fkeywordp (symbol
))
1183 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1184 xsignal1 (Qsetting_constant
, symbol
);
1186 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1188 if (BUFFER_OBJFWDP (valcontents
))
1190 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1191 int idx
= PER_BUFFER_IDX (offset
);
1194 && !let_shadows_buffer_binding_p (symbol
))
1195 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1197 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1199 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1200 if (XSYMBOL (symbol
)->indirect_variable
)
1201 symbol
= indirect_variable (symbol
);
1203 /* What binding is loaded right now? */
1204 current_alist_element
1205 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1207 /* If the current buffer is not the buffer whose binding is
1208 loaded, or if there may be frame-local bindings and the frame
1209 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1210 the default binding is loaded, the loaded binding may be the
1212 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1213 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1214 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1215 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1216 /* Also unload a global binding (if the var is local_if_set). */
1217 || (EQ (XCAR (current_alist_element
),
1218 current_alist_element
)))
1220 /* The currently loaded binding is not necessarily valid.
1221 We need to unload it, and choose a new binding. */
1223 /* Write out `realvalue' to the old loaded binding. */
1224 Fsetcdr (current_alist_element
,
1225 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1227 /* Find the new binding. */
1228 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1229 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1230 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1234 /* This buffer still sees the default value. */
1236 /* If the variable is not local_if_set,
1237 or if this is `let' rather than `set',
1238 make CURRENT-ALIST-ELEMENT point to itself,
1239 indicating that we're seeing the default value.
1240 Likewise if the variable has been let-bound
1241 in the current buffer. */
1242 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1243 || let_shadows_buffer_binding_p (symbol
))
1245 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1247 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1248 tem1
= Fassq (symbol
,
1249 XFRAME (selected_frame
)->param_alist
);
1252 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1254 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1256 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1257 and we're not within a let that was made for this buffer,
1258 create a new buffer-local binding for the variable.
1259 That means, give this buffer a new assoc for a local value
1260 and load that binding. */
1263 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1264 buf
->local_var_alist
1265 = Fcons (tem1
, buf
->local_var_alist
);
1269 /* Record which binding is now loaded. */
1270 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1272 /* Set `buffer' and `frame' slots for the binding now loaded. */
1273 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1274 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1276 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1278 /* Store the new value in the cons-cell. */
1279 XSETCDR (XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
), newval
);
1282 /* If storing void (making the symbol void), forward only through
1283 buffer-local indicator, not through Lisp_Objfwd, etc. */
1285 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1287 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1292 /* Access or set a buffer-local symbol's default value. */
1294 /* Return the default value of SYMBOL, but don't check for voidness.
1295 Return Qunbound if it is void. */
1298 default_value (symbol
)
1301 register Lisp_Object valcontents
;
1303 CHECK_SYMBOL (symbol
);
1304 valcontents
= SYMBOL_VALUE (symbol
);
1306 /* For a built-in buffer-local variable, get the default value
1307 rather than letting do_symval_forwarding get the current value. */
1308 if (BUFFER_OBJFWDP (valcontents
))
1310 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1311 if (PER_BUFFER_IDX (offset
) != 0)
1312 return PER_BUFFER_DEFAULT (offset
);
1315 /* Handle user-created local variables. */
1316 if (BUFFER_LOCAL_VALUEP (valcontents
))
1318 /* If var is set up for a buffer that lacks a local value for it,
1319 the current value is nominally the default value.
1320 But the `realvalue' slot may be more up to date, since
1321 ordinary setq stores just that slot. So use that. */
1322 Lisp_Object current_alist_element
, alist_element_car
;
1323 current_alist_element
1324 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1325 alist_element_car
= XCAR (current_alist_element
);
1326 if (EQ (alist_element_car
, current_alist_element
))
1327 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1329 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1331 /* For other variables, get the current value. */
1332 return do_symval_forwarding (valcontents
);
1335 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1336 doc
: /* Return t if SYMBOL has a non-void default value.
1337 This is the value that is seen in buffers that do not have their own values
1338 for this variable. */)
1342 register Lisp_Object value
;
1344 value
= default_value (symbol
);
1345 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1348 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1349 doc
: /* Return SYMBOL's default value.
1350 This is the value that is seen in buffers that do not have their own values
1351 for this variable. The default value is meaningful for variables with
1352 local bindings in certain buffers. */)
1356 register Lisp_Object value
;
1358 value
= default_value (symbol
);
1359 if (!EQ (value
, Qunbound
))
1362 xsignal1 (Qvoid_variable
, symbol
);
1365 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1366 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1367 The default value is seen in buffers that do not have their own values
1368 for this variable. */)
1370 Lisp_Object symbol
, value
;
1372 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1374 CHECK_SYMBOL (symbol
);
1375 valcontents
= SYMBOL_VALUE (symbol
);
1377 /* Handle variables like case-fold-search that have special slots
1378 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1380 if (BUFFER_OBJFWDP (valcontents
))
1382 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1383 int idx
= PER_BUFFER_IDX (offset
);
1385 PER_BUFFER_DEFAULT (offset
) = value
;
1387 /* If this variable is not always local in all buffers,
1388 set it in the buffers that don't nominally have a local value. */
1393 for (b
= all_buffers
; b
; b
= b
->next
)
1394 if (!PER_BUFFER_VALUE_P (b
, idx
))
1395 PER_BUFFER_VALUE (b
, offset
) = value
;
1400 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1401 return Fset (symbol
, value
);
1403 /* Store new value into the DEFAULT-VALUE slot. */
1404 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1406 /* If the default binding is now loaded, set the REALVALUE slot too. */
1407 current_alist_element
1408 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1409 alist_element_buffer
= Fcar (current_alist_element
);
1410 if (EQ (alist_element_buffer
, current_alist_element
))
1411 store_symval_forwarding (symbol
,
1412 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1418 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1419 doc
: /* Set the default value of variable VAR to VALUE.
1420 VAR, the variable name, is literal (not evaluated);
1421 VALUE is an expression: it is evaluated and its value returned.
1422 The default value of a variable is seen in buffers
1423 that do not have their own values for the variable.
1425 More generally, you can use multiple variables and values, as in
1426 (setq-default VAR VALUE VAR VALUE...)
1427 This sets each VAR's default value to the corresponding VALUE.
1428 The VALUE for the Nth VAR can refer to the new default values
1430 usage: (setq-default [VAR VALUE]...) */)
1434 register Lisp_Object args_left
;
1435 register Lisp_Object val
, symbol
;
1436 struct gcpro gcpro1
;
1446 val
= Feval (Fcar (Fcdr (args_left
)));
1447 symbol
= XCAR (args_left
);
1448 Fset_default (symbol
, val
);
1449 args_left
= Fcdr (XCDR (args_left
));
1451 while (!NILP (args_left
));
1457 /* Lisp functions for creating and removing buffer-local variables. */
1459 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1460 1, 1, "vMake Variable Buffer Local: ",
1461 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1462 At any time, the value for the current buffer is in effect,
1463 unless the variable has never been set in this buffer,
1464 in which case the default value is in effect.
1465 Note that binding the variable with `let', or setting it while
1466 a `let'-style binding made in this buffer is in effect,
1467 does not make the variable buffer-local. Return VARIABLE.
1469 In most cases it is better to use `make-local-variable',
1470 which makes a variable local in just one buffer.
1472 The function `default-value' gets the default value and `set-default' sets it. */)
1474 register Lisp_Object variable
;
1476 register Lisp_Object tem
, valcontents
, newval
;
1478 CHECK_SYMBOL (variable
);
1479 variable
= indirect_variable (variable
);
1481 valcontents
= SYMBOL_VALUE (variable
);
1482 if (XSYMBOL (variable
)->constant
|| KBOARD_OBJFWDP (valcontents
))
1483 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1485 if (BUFFER_OBJFWDP (valcontents
))
1487 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1488 newval
= valcontents
;
1491 if (EQ (valcontents
, Qunbound
))
1492 SET_SYMBOL_VALUE (variable
, Qnil
);
1493 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1495 newval
= allocate_misc ();
1496 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1497 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1498 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1499 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1500 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1501 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1502 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1503 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1504 SET_SYMBOL_VALUE (variable
, newval
);
1506 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1510 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1511 1, 1, "vMake Local Variable: ",
1512 doc
: /* Make VARIABLE have a separate value in the current buffer.
1513 Other buffers will continue to share a common default value.
1514 \(The buffer-local value of VARIABLE starts out as the same value
1515 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1518 If the variable is already arranged to become local when set,
1519 this function causes a local value to exist for this buffer,
1520 just as setting the variable would do.
1522 This function returns VARIABLE, and therefore
1523 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1526 See also `make-variable-buffer-local'.
1528 Do not use `make-local-variable' to make a hook variable buffer-local.
1529 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1531 register Lisp_Object variable
;
1533 register Lisp_Object tem
, valcontents
;
1535 CHECK_SYMBOL (variable
);
1536 variable
= indirect_variable (variable
);
1538 valcontents
= SYMBOL_VALUE (variable
);
1539 if (XSYMBOL (variable
)->constant
|| KBOARD_OBJFWDP (valcontents
))
1540 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1542 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1543 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1544 || BUFFER_OBJFWDP (valcontents
))
1546 tem
= Fboundp (variable
);
1548 /* Make sure the symbol has a local value in this particular buffer,
1549 by setting it to the same value it already has. */
1550 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1553 /* Make sure symbol is set up to hold per-buffer values. */
1554 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1557 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1559 newval
= allocate_misc ();
1560 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1561 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1562 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1563 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1564 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1565 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1566 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1567 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1568 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1569 SET_SYMBOL_VALUE (variable
, newval
);
1571 /* Make sure this buffer has its own value of symbol. */
1572 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1575 /* Swap out any local binding for some other buffer, and make
1576 sure the current value is permanently recorded, if it's the
1578 find_symbol_value (variable
);
1580 current_buffer
->local_var_alist
1581 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1582 current_buffer
->local_var_alist
);
1584 /* Make sure symbol does not think it is set up for this buffer;
1585 force it to look once again for this buffer's value. */
1587 Lisp_Object
*pvalbuf
;
1589 valcontents
= SYMBOL_VALUE (variable
);
1591 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1592 if (current_buffer
== XBUFFER (*pvalbuf
))
1594 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1598 /* If the symbol forwards into a C variable, then load the binding
1599 for this buffer now. If C code modifies the variable before we
1600 load the binding in, then that new value will clobber the default
1601 binding the next time we unload it. */
1602 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1603 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1604 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1609 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1610 1, 1, "vKill Local Variable: ",
1611 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1612 From now on the default value will apply in this buffer. Return VARIABLE. */)
1614 register Lisp_Object variable
;
1616 register Lisp_Object tem
, valcontents
;
1618 CHECK_SYMBOL (variable
);
1619 variable
= indirect_variable (variable
);
1621 valcontents
= SYMBOL_VALUE (variable
);
1623 if (BUFFER_OBJFWDP (valcontents
))
1625 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1626 int idx
= PER_BUFFER_IDX (offset
);
1630 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1631 PER_BUFFER_VALUE (current_buffer
, offset
)
1632 = PER_BUFFER_DEFAULT (offset
);
1637 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1640 /* Get rid of this buffer's alist element, if any. */
1642 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1644 current_buffer
->local_var_alist
1645 = Fdelq (tem
, current_buffer
->local_var_alist
);
1647 /* If the symbol is set up with the current buffer's binding
1648 loaded, recompute its value. We have to do it now, or else
1649 forwarded objects won't work right. */
1651 Lisp_Object
*pvalbuf
, buf
;
1652 valcontents
= SYMBOL_VALUE (variable
);
1653 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1654 XSETBUFFER (buf
, current_buffer
);
1655 if (EQ (buf
, *pvalbuf
))
1658 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1659 find_symbol_value (variable
);
1666 /* Lisp functions for creating and removing buffer-local variables. */
1668 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1669 1, 1, "vMake Variable Frame Local: ",
1670 doc
: /* Enable VARIABLE to have frame-local bindings.
1671 This does not create any frame-local bindings for VARIABLE,
1672 it just makes them possible.
1674 A frame-local binding is actually a frame parameter value.
1675 If a frame F has a value for the frame parameter named VARIABLE,
1676 that also acts as a frame-local binding for VARIABLE in F--
1677 provided this function has been called to enable VARIABLE
1678 to have frame-local bindings at all.
1680 The only way to create a frame-local binding for VARIABLE in a frame
1681 is to set the VARIABLE frame parameter of that frame. See
1682 `modify-frame-parameters' for how to set frame parameters.
1684 Buffer-local bindings take precedence over frame-local bindings. */)
1686 register Lisp_Object variable
;
1688 register Lisp_Object tem
, valcontents
, newval
;
1690 CHECK_SYMBOL (variable
);
1691 variable
= indirect_variable (variable
);
1693 valcontents
= SYMBOL_VALUE (variable
);
1694 if (XSYMBOL (variable
)->constant
|| KBOARD_OBJFWDP (valcontents
)
1695 || BUFFER_OBJFWDP (valcontents
))
1696 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1698 if (BUFFER_LOCAL_VALUEP (valcontents
))
1700 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1704 if (EQ (valcontents
, Qunbound
))
1705 SET_SYMBOL_VALUE (variable
, Qnil
);
1706 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1708 newval
= allocate_misc ();
1709 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1710 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1711 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1712 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1713 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1714 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1715 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1716 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1717 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1718 SET_SYMBOL_VALUE (variable
, newval
);
1722 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1724 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1725 BUFFER defaults to the current buffer. */)
1727 register Lisp_Object variable
, buffer
;
1729 Lisp_Object valcontents
;
1730 register struct buffer
*buf
;
1733 buf
= current_buffer
;
1736 CHECK_BUFFER (buffer
);
1737 buf
= XBUFFER (buffer
);
1740 CHECK_SYMBOL (variable
);
1741 variable
= indirect_variable (variable
);
1743 valcontents
= SYMBOL_VALUE (variable
);
1744 if (BUFFER_LOCAL_VALUEP (valcontents
))
1746 Lisp_Object tail
, elt
;
1748 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1751 if (EQ (variable
, XCAR (elt
)))
1755 if (BUFFER_OBJFWDP (valcontents
))
1757 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1758 int idx
= PER_BUFFER_IDX (offset
);
1759 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1765 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1767 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1768 More precisely, this means that setting the variable \(with `set' or`setq'),
1769 while it does not have a `let'-style binding that was made in BUFFER,
1770 will produce a buffer local binding. See Info node
1771 `(elisp)Creating Buffer-Local'.
1772 BUFFER defaults to the current buffer. */)
1774 register Lisp_Object variable
, buffer
;
1776 Lisp_Object valcontents
;
1777 register struct buffer
*buf
;
1780 buf
= current_buffer
;
1783 CHECK_BUFFER (buffer
);
1784 buf
= XBUFFER (buffer
);
1787 CHECK_SYMBOL (variable
);
1788 variable
= indirect_variable (variable
);
1790 valcontents
= SYMBOL_VALUE (variable
);
1792 if (BUFFER_OBJFWDP (valcontents
))
1793 /* All these slots become local if they are set. */
1795 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1797 Lisp_Object tail
, elt
;
1798 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1800 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1803 if (EQ (variable
, XCAR (elt
)))
1810 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1812 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1813 If the current binding is buffer-local, the value is the current buffer.
1814 If the current binding is frame-local, the value is the selected frame.
1815 If the current binding is global (the default), the value is nil. */)
1817 register Lisp_Object variable
;
1819 Lisp_Object valcontents
;
1821 CHECK_SYMBOL (variable
);
1822 variable
= indirect_variable (variable
);
1824 /* Make sure the current binding is actually swapped in. */
1825 find_symbol_value (variable
);
1827 valcontents
= XSYMBOL (variable
)->value
;
1829 if (BUFFER_LOCAL_VALUEP (valcontents
)
1830 || BUFFER_OBJFWDP (valcontents
))
1832 /* For a local variable, record both the symbol and which
1833 buffer's or frame's value we are saving. */
1834 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1835 return Fcurrent_buffer ();
1836 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1837 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1838 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1844 /* This code is disabled now that we use the selected frame to return
1845 keyboard-local-values. */
1847 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1849 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1850 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1851 If SYMBOL is not a terminal-local variable, then return its normal
1852 value, like `symbol-value'.
1854 TERMINAL may be a terminal id, a frame, or nil (meaning the
1855 selected frame's terminal device). */)
1858 Lisp_Object terminal
;
1861 struct terminal
*t
= get_terminal (terminal
, 1);
1862 push_kboard (t
->kboard
);
1863 result
= Fsymbol_value (symbol
);
1868 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1869 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1870 If VARIABLE is not a terminal-local variable, then set its normal
1871 binding, like `set'.
1873 TERMINAL may be a terminal id, a frame, or nil (meaning the
1874 selected frame's terminal device). */)
1875 (symbol
, terminal
, value
)
1877 Lisp_Object terminal
;
1881 struct terminal
*t
= get_terminal (terminal
, 1);
1882 push_kboard (d
->kboard
);
1883 result
= Fset (symbol
, value
);
1889 /* Find the function at the end of a chain of symbol function indirections. */
1891 /* If OBJECT is a symbol, find the end of its function chain and
1892 return the value found there. If OBJECT is not a symbol, just
1893 return it. If there is a cycle in the function chain, signal a
1894 cyclic-function-indirection error.
1896 This is like Findirect_function, except that it doesn't signal an
1897 error if the chain ends up unbound. */
1899 indirect_function (object
)
1900 register Lisp_Object object
;
1902 Lisp_Object tortoise
, hare
;
1904 hare
= tortoise
= object
;
1908 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1910 hare
= XSYMBOL (hare
)->function
;
1911 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1913 hare
= XSYMBOL (hare
)->function
;
1915 tortoise
= XSYMBOL (tortoise
)->function
;
1917 if (EQ (hare
, tortoise
))
1918 xsignal1 (Qcyclic_function_indirection
, object
);
1924 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1925 doc
: /* Return the function at the end of OBJECT's function chain.
1926 If OBJECT is not a symbol, just return it. Otherwise, follow all
1927 function indirections to find the final function binding and return it.
1928 If the final symbol in the chain is unbound, signal a void-function error.
1929 Optional arg NOERROR non-nil means to return nil instead of signalling.
1930 Signal a cyclic-function-indirection error if there is a loop in the
1931 function chain of symbols. */)
1933 register Lisp_Object object
;
1934 Lisp_Object noerror
;
1938 /* Optimize for no indirection. */
1940 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1941 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1942 result
= indirect_function (result
);
1943 if (!EQ (result
, Qunbound
))
1947 xsignal1 (Qvoid_function
, object
);
1952 /* Extract and set vector and string elements */
1954 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1955 doc
: /* Return the element of ARRAY at index IDX.
1956 ARRAY may be a vector, a string, a char-table, a bool-vector,
1957 or a byte-code object. IDX starts at 0. */)
1959 register Lisp_Object array
;
1962 register int idxval
;
1965 idxval
= XINT (idx
);
1966 if (STRINGP (array
))
1970 if (idxval
< 0 || idxval
>= SCHARS (array
))
1971 args_out_of_range (array
, idx
);
1972 if (! STRING_MULTIBYTE (array
))
1973 return make_number ((unsigned char) SREF (array
, idxval
));
1974 idxval_byte
= string_char_to_byte (array
, idxval
);
1976 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1977 SBYTES (array
) - idxval_byte
);
1978 return make_number (c
);
1980 else if (BOOL_VECTOR_P (array
))
1984 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1985 args_out_of_range (array
, idx
);
1987 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1988 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1990 else if (CHAR_TABLE_P (array
))
1992 CHECK_CHARACTER (idx
);
1993 return CHAR_TABLE_REF (array
, idxval
);
1998 if (VECTORP (array
))
1999 size
= XVECTOR (array
)->size
;
2000 else if (COMPILEDP (array
))
2001 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2003 wrong_type_argument (Qarrayp
, array
);
2005 if (idxval
< 0 || idxval
>= size
)
2006 args_out_of_range (array
, idx
);
2007 return XVECTOR (array
)->contents
[idxval
];
2011 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2012 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2013 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2014 bool-vector. IDX starts at 0. */)
2015 (array
, idx
, newelt
)
2016 register Lisp_Object array
;
2017 Lisp_Object idx
, newelt
;
2019 register int idxval
;
2022 idxval
= XINT (idx
);
2023 CHECK_ARRAY (array
, Qarrayp
);
2024 CHECK_IMPURE (array
);
2026 if (VECTORP (array
))
2028 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2029 args_out_of_range (array
, idx
);
2030 XVECTOR (array
)->contents
[idxval
] = newelt
;
2032 else if (BOOL_VECTOR_P (array
))
2036 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2037 args_out_of_range (array
, idx
);
2039 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2041 if (! NILP (newelt
))
2042 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2044 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2045 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2047 else if (CHAR_TABLE_P (array
))
2049 CHECK_CHARACTER (idx
);
2050 CHAR_TABLE_SET (array
, idxval
, newelt
);
2052 else if (STRING_MULTIBYTE (array
))
2054 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2055 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2057 if (idxval
< 0 || idxval
>= SCHARS (array
))
2058 args_out_of_range (array
, idx
);
2059 CHECK_CHARACTER (newelt
);
2061 nbytes
= SBYTES (array
);
2063 idxval_byte
= string_char_to_byte (array
, idxval
);
2064 p1
= SDATA (array
) + idxval_byte
;
2065 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2066 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2067 if (prev_bytes
!= new_bytes
)
2069 /* We must relocate the string data. */
2070 int nchars
= SCHARS (array
);
2074 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2075 bcopy (SDATA (array
), str
, nbytes
);
2076 allocate_string_data (XSTRING (array
), nchars
,
2077 nbytes
+ new_bytes
- prev_bytes
);
2078 bcopy (str
, SDATA (array
), idxval_byte
);
2079 p1
= SDATA (array
) + idxval_byte
;
2080 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2081 nbytes
- (idxval_byte
+ prev_bytes
));
2083 clear_string_char_byte_cache ();
2090 if (idxval
< 0 || idxval
>= SCHARS (array
))
2091 args_out_of_range (array
, idx
);
2092 CHECK_NUMBER (newelt
);
2094 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2095 args_out_of_range (array
, newelt
);
2096 SSET (array
, idxval
, XINT (newelt
));
2102 /* Arithmetic functions */
2104 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2107 arithcompare (num1
, num2
, comparison
)
2108 Lisp_Object num1
, num2
;
2109 enum comparison comparison
;
2111 double f1
= 0, f2
= 0;
2114 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2115 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2117 if (FLOATP (num1
) || FLOATP (num2
))
2120 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2121 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2127 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2132 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2137 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2142 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2147 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2152 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2161 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2162 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2164 register Lisp_Object num1
, num2
;
2166 return arithcompare (num1
, num2
, equal
);
2169 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2170 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2172 register Lisp_Object num1
, num2
;
2174 return arithcompare (num1
, num2
, less
);
2177 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2178 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2180 register Lisp_Object num1
, num2
;
2182 return arithcompare (num1
, num2
, grtr
);
2185 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2186 doc
: /* Return t if first arg is less than or equal to second arg.
2187 Both must be numbers or markers. */)
2189 register Lisp_Object num1
, num2
;
2191 return arithcompare (num1
, num2
, less_or_equal
);
2194 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2195 doc
: /* Return t if first arg is greater than or equal to second arg.
2196 Both must be numbers or markers. */)
2198 register Lisp_Object num1
, num2
;
2200 return arithcompare (num1
, num2
, grtr_or_equal
);
2203 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2204 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2206 register Lisp_Object num1
, num2
;
2208 return arithcompare (num1
, num2
, notequal
);
2211 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2212 doc
: /* Return t if NUMBER is zero. */)
2214 register Lisp_Object number
;
2216 CHECK_NUMBER_OR_FLOAT (number
);
2218 if (FLOATP (number
))
2220 if (XFLOAT_DATA (number
) == 0.0)
2230 /* Convert between long values and pairs of Lisp integers.
2231 Note that long_to_cons returns a single Lisp integer
2232 when the value fits in one. */
2238 unsigned long top
= i
>> 16;
2239 unsigned int bot
= i
& 0xFFFF;
2241 return make_number (bot
);
2242 if (top
== (unsigned long)-1 >> 16)
2243 return Fcons (make_number (-1), make_number (bot
));
2244 return Fcons (make_number (top
), make_number (bot
));
2251 Lisp_Object top
, bot
;
2258 return ((XINT (top
) << 16) | XINT (bot
));
2261 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2262 doc
: /* Return the decimal representation of NUMBER as a string.
2263 Uses a minus sign if negative.
2264 NUMBER may be an integer or a floating point number. */)
2268 char buffer
[VALBITS
];
2270 CHECK_NUMBER_OR_FLOAT (number
);
2272 if (FLOATP (number
))
2274 char pigbuf
[350]; /* see comments in float_to_string */
2276 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2277 return build_string (pigbuf
);
2280 if (sizeof (int) == sizeof (EMACS_INT
))
2281 sprintf (buffer
, "%d", (int) XINT (number
));
2282 else if (sizeof (long) == sizeof (EMACS_INT
))
2283 sprintf (buffer
, "%ld", (long) XINT (number
));
2286 return build_string (buffer
);
2290 digit_to_number (character
, base
)
2291 int character
, base
;
2295 if (character
>= '0' && character
<= '9')
2296 digit
= character
- '0';
2297 else if (character
>= 'a' && character
<= 'z')
2298 digit
= character
- 'a' + 10;
2299 else if (character
>= 'A' && character
<= 'Z')
2300 digit
= character
- 'A' + 10;
2310 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2311 doc
: /* Parse STRING as a decimal number and return the number.
2312 This parses both integers and floating point numbers.
2313 It ignores leading spaces and tabs.
2315 If BASE, interpret STRING as a number in that base. If BASE isn't
2316 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2317 If the base used is not 10, floating point is not recognized. */)
2319 register Lisp_Object string
, base
;
2321 register unsigned char *p
;
2326 CHECK_STRING (string
);
2332 CHECK_NUMBER (base
);
2334 if (b
< 2 || b
> 16)
2335 xsignal1 (Qargs_out_of_range
, base
);
2338 /* Skip any whitespace at the front of the number. Some versions of
2339 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2341 while (*p
== ' ' || *p
== '\t')
2352 if (isfloat_string (p
) && b
== 10)
2353 val
= make_float (sign
* atof (p
));
2360 int digit
= digit_to_number (*p
++, b
);
2366 val
= make_fixnum_or_float (sign
* v
);
2386 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2387 int, Lisp_Object
*));
2388 extern Lisp_Object
fmod_float ();
2391 arith_driver (code
, nargs
, args
)
2394 register Lisp_Object
*args
;
2396 register Lisp_Object val
;
2397 register int argnum
;
2398 register EMACS_INT accum
= 0;
2399 register EMACS_INT next
;
2401 switch (SWITCH_ENUM_CAST (code
))
2419 for (argnum
= 0; argnum
< nargs
; argnum
++)
2421 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2423 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2426 return float_arith_driver ((double) accum
, argnum
, code
,
2429 next
= XINT (args
[argnum
]);
2430 switch (SWITCH_ENUM_CAST (code
))
2436 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2447 xsignal0 (Qarith_error
);
2461 if (!argnum
|| next
> accum
)
2465 if (!argnum
|| next
< accum
)
2471 XSETINT (val
, accum
);
2476 #define isnan(x) ((x) != (x))
2479 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2481 register int argnum
;
2484 register Lisp_Object
*args
;
2486 register Lisp_Object val
;
2489 for (; argnum
< nargs
; argnum
++)
2491 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2492 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2496 next
= XFLOAT_DATA (val
);
2500 args
[argnum
] = val
; /* runs into a compiler bug. */
2501 next
= XINT (args
[argnum
]);
2503 switch (SWITCH_ENUM_CAST (code
))
2509 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2519 if (! IEEE_FLOATING_POINT
&& next
== 0)
2520 xsignal0 (Qarith_error
);
2527 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2529 if (!argnum
|| isnan (next
) || next
> accum
)
2533 if (!argnum
|| isnan (next
) || next
< accum
)
2539 return make_float (accum
);
2543 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2544 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2545 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2550 return arith_driver (Aadd
, nargs
, args
);
2553 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2554 doc
: /* Negate number or subtract numbers or markers and return the result.
2555 With one arg, negates it. With more than one arg,
2556 subtracts all but the first from the first.
2557 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2562 return arith_driver (Asub
, nargs
, args
);
2565 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2566 doc
: /* Return product of any number of arguments, which are numbers or markers.
2567 usage: (* &rest NUMBERS-OR-MARKERS) */)
2572 return arith_driver (Amult
, nargs
, args
);
2575 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2576 doc
: /* Return first argument divided by all the remaining arguments.
2577 The arguments must be numbers or markers.
2578 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2584 for (argnum
= 2; argnum
< nargs
; argnum
++)
2585 if (FLOATP (args
[argnum
]))
2586 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2587 return arith_driver (Adiv
, nargs
, args
);
2590 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2591 doc
: /* Return remainder of X divided by Y.
2592 Both must be integers or markers. */)
2594 register Lisp_Object x
, y
;
2598 CHECK_NUMBER_COERCE_MARKER (x
);
2599 CHECK_NUMBER_COERCE_MARKER (y
);
2601 if (XFASTINT (y
) == 0)
2602 xsignal0 (Qarith_error
);
2604 XSETINT (val
, XINT (x
) % XINT (y
));
2618 /* If the magnitude of the result exceeds that of the divisor, or
2619 the sign of the result does not agree with that of the dividend,
2620 iterate with the reduced value. This does not yield a
2621 particularly accurate result, but at least it will be in the
2622 range promised by fmod. */
2624 r
-= f2
* floor (r
/ f2
);
2625 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2629 #endif /* ! HAVE_FMOD */
2631 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2632 doc
: /* Return X modulo Y.
2633 The result falls between zero (inclusive) and Y (exclusive).
2634 Both X and Y must be numbers or markers. */)
2636 register Lisp_Object x
, y
;
2641 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2642 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2644 if (FLOATP (x
) || FLOATP (y
))
2645 return fmod_float (x
, y
);
2651 xsignal0 (Qarith_error
);
2655 /* If the "remainder" comes out with the wrong sign, fix it. */
2656 if (i2
< 0 ? i1
> 0 : i1
< 0)
2663 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2664 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2665 The value is always a number; markers are converted to numbers.
2666 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2671 return arith_driver (Amax
, nargs
, args
);
2674 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2675 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2676 The value is always a number; markers are converted to numbers.
2677 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2682 return arith_driver (Amin
, nargs
, args
);
2685 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2686 doc
: /* Return bitwise-and of all the arguments.
2687 Arguments may be integers, or markers converted to integers.
2688 usage: (logand &rest INTS-OR-MARKERS) */)
2693 return arith_driver (Alogand
, nargs
, args
);
2696 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2697 doc
: /* Return bitwise-or of all the arguments.
2698 Arguments may be integers, or markers converted to integers.
2699 usage: (logior &rest INTS-OR-MARKERS) */)
2704 return arith_driver (Alogior
, nargs
, args
);
2707 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2708 doc
: /* Return bitwise-exclusive-or of all the arguments.
2709 Arguments may be integers, or markers converted to integers.
2710 usage: (logxor &rest INTS-OR-MARKERS) */)
2715 return arith_driver (Alogxor
, nargs
, args
);
2718 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2719 doc
: /* Return VALUE with its bits shifted left by COUNT.
2720 If COUNT is negative, shifting is actually to the right.
2721 In this case, the sign bit is duplicated. */)
2723 register Lisp_Object value
, count
;
2725 register Lisp_Object val
;
2727 CHECK_NUMBER (value
);
2728 CHECK_NUMBER (count
);
2730 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2732 else if (XINT (count
) > 0)
2733 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2734 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2735 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2737 XSETINT (val
, XINT (value
) >> -XINT (count
));
2741 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2742 doc
: /* Return VALUE with its bits shifted left by COUNT.
2743 If COUNT is negative, shifting is actually to the right.
2744 In this case, zeros are shifted in on the left. */)
2746 register Lisp_Object value
, count
;
2748 register Lisp_Object val
;
2750 CHECK_NUMBER (value
);
2751 CHECK_NUMBER (count
);
2753 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2755 else if (XINT (count
) > 0)
2756 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2757 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2760 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2764 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2765 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2766 Markers are converted to integers. */)
2768 register Lisp_Object number
;
2770 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2772 if (FLOATP (number
))
2773 return (make_float (1.0 + XFLOAT_DATA (number
)));
2775 XSETINT (number
, XINT (number
) + 1);
2779 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2780 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2781 Markers are converted to integers. */)
2783 register Lisp_Object number
;
2785 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2787 if (FLOATP (number
))
2788 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2790 XSETINT (number
, XINT (number
) - 1);
2794 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2795 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2797 register Lisp_Object number
;
2799 CHECK_NUMBER (number
);
2800 XSETINT (number
, ~XINT (number
));
2804 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2805 doc
: /* Return the byteorder for the machine.
2806 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2807 lowercase l) for small endian machines. */)
2810 unsigned i
= 0x04030201;
2811 int order
= *(char *)&i
== 1 ? 108 : 66;
2813 return make_number (order
);
2821 Lisp_Object error_tail
, arith_tail
;
2823 Qquote
= intern ("quote");
2824 Qlambda
= intern ("lambda");
2825 Qsubr
= intern ("subr");
2826 Qerror_conditions
= intern ("error-conditions");
2827 Qerror_message
= intern ("error-message");
2828 Qtop_level
= intern ("top-level");
2830 Qerror
= intern ("error");
2831 Qquit
= intern ("quit");
2832 Qwrong_type_argument
= intern ("wrong-type-argument");
2833 Qargs_out_of_range
= intern ("args-out-of-range");
2834 Qvoid_function
= intern ("void-function");
2835 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2836 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2837 Qvoid_variable
= intern ("void-variable");
2838 Qsetting_constant
= intern ("setting-constant");
2839 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2841 Qinvalid_function
= intern ("invalid-function");
2842 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2843 Qno_catch
= intern ("no-catch");
2844 Qend_of_file
= intern ("end-of-file");
2845 Qarith_error
= intern ("arith-error");
2846 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2847 Qend_of_buffer
= intern ("end-of-buffer");
2848 Qbuffer_read_only
= intern ("buffer-read-only");
2849 Qtext_read_only
= intern ("text-read-only");
2850 Qmark_inactive
= intern ("mark-inactive");
2852 Qlistp
= intern ("listp");
2853 Qconsp
= intern ("consp");
2854 Qsymbolp
= intern ("symbolp");
2855 Qkeywordp
= intern ("keywordp");
2856 Qintegerp
= intern ("integerp");
2857 Qnatnump
= intern ("natnump");
2858 Qwholenump
= intern ("wholenump");
2859 Qstringp
= intern ("stringp");
2860 Qarrayp
= intern ("arrayp");
2861 Qsequencep
= intern ("sequencep");
2862 Qbufferp
= intern ("bufferp");
2863 Qvectorp
= intern ("vectorp");
2864 Qchar_or_string_p
= intern ("char-or-string-p");
2865 Qmarkerp
= intern ("markerp");
2866 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2867 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2868 Qboundp
= intern ("boundp");
2869 Qfboundp
= intern ("fboundp");
2871 Qfloatp
= intern ("floatp");
2872 Qnumberp
= intern ("numberp");
2873 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2875 Qchar_table_p
= intern ("char-table-p");
2876 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2878 Qsubrp
= intern ("subrp");
2879 Qunevalled
= intern ("unevalled");
2880 Qmany
= intern ("many");
2882 Qcdr
= intern ("cdr");
2884 /* Handle automatic advice activation */
2885 Qad_advice_info
= intern ("ad-advice-info");
2886 Qad_activate_internal
= intern ("ad-activate-internal");
2888 error_tail
= Fcons (Qerror
, Qnil
);
2890 /* ERROR is used as a signaler for random errors for which nothing else is right */
2892 Fput (Qerror
, Qerror_conditions
,
2894 Fput (Qerror
, Qerror_message
,
2895 build_string ("error"));
2897 Fput (Qquit
, Qerror_conditions
,
2898 Fcons (Qquit
, Qnil
));
2899 Fput (Qquit
, Qerror_message
,
2900 build_string ("Quit"));
2902 Fput (Qwrong_type_argument
, Qerror_conditions
,
2903 Fcons (Qwrong_type_argument
, error_tail
));
2904 Fput (Qwrong_type_argument
, Qerror_message
,
2905 build_string ("Wrong type argument"));
2907 Fput (Qargs_out_of_range
, Qerror_conditions
,
2908 Fcons (Qargs_out_of_range
, error_tail
));
2909 Fput (Qargs_out_of_range
, Qerror_message
,
2910 build_string ("Args out of range"));
2912 Fput (Qvoid_function
, Qerror_conditions
,
2913 Fcons (Qvoid_function
, error_tail
));
2914 Fput (Qvoid_function
, Qerror_message
,
2915 build_string ("Symbol's function definition is void"));
2917 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2918 Fcons (Qcyclic_function_indirection
, error_tail
));
2919 Fput (Qcyclic_function_indirection
, Qerror_message
,
2920 build_string ("Symbol's chain of function indirections contains a loop"));
2922 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2923 Fcons (Qcyclic_variable_indirection
, error_tail
));
2924 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2925 build_string ("Symbol's chain of variable indirections contains a loop"));
2927 Qcircular_list
= intern ("circular-list");
2928 staticpro (&Qcircular_list
);
2929 Fput (Qcircular_list
, Qerror_conditions
,
2930 Fcons (Qcircular_list
, error_tail
));
2931 Fput (Qcircular_list
, Qerror_message
,
2932 build_string ("List contains a loop"));
2934 Fput (Qvoid_variable
, Qerror_conditions
,
2935 Fcons (Qvoid_variable
, error_tail
));
2936 Fput (Qvoid_variable
, Qerror_message
,
2937 build_string ("Symbol's value as variable is void"));
2939 Fput (Qsetting_constant
, Qerror_conditions
,
2940 Fcons (Qsetting_constant
, error_tail
));
2941 Fput (Qsetting_constant
, Qerror_message
,
2942 build_string ("Attempt to set a constant symbol"));
2944 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2945 Fcons (Qinvalid_read_syntax
, error_tail
));
2946 Fput (Qinvalid_read_syntax
, Qerror_message
,
2947 build_string ("Invalid read syntax"));
2949 Fput (Qinvalid_function
, Qerror_conditions
,
2950 Fcons (Qinvalid_function
, error_tail
));
2951 Fput (Qinvalid_function
, Qerror_message
,
2952 build_string ("Invalid function"));
2954 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2955 Fcons (Qwrong_number_of_arguments
, error_tail
));
2956 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2957 build_string ("Wrong number of arguments"));
2959 Fput (Qno_catch
, Qerror_conditions
,
2960 Fcons (Qno_catch
, error_tail
));
2961 Fput (Qno_catch
, Qerror_message
,
2962 build_string ("No catch for tag"));
2964 Fput (Qend_of_file
, Qerror_conditions
,
2965 Fcons (Qend_of_file
, error_tail
));
2966 Fput (Qend_of_file
, Qerror_message
,
2967 build_string ("End of file during parsing"));
2969 arith_tail
= Fcons (Qarith_error
, error_tail
);
2970 Fput (Qarith_error
, Qerror_conditions
,
2972 Fput (Qarith_error
, Qerror_message
,
2973 build_string ("Arithmetic error"));
2975 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2976 Fcons (Qbeginning_of_buffer
, error_tail
));
2977 Fput (Qbeginning_of_buffer
, Qerror_message
,
2978 build_string ("Beginning of buffer"));
2980 Fput (Qend_of_buffer
, Qerror_conditions
,
2981 Fcons (Qend_of_buffer
, error_tail
));
2982 Fput (Qend_of_buffer
, Qerror_message
,
2983 build_string ("End of buffer"));
2985 Fput (Qbuffer_read_only
, Qerror_conditions
,
2986 Fcons (Qbuffer_read_only
, error_tail
));
2987 Fput (Qbuffer_read_only
, Qerror_message
,
2988 build_string ("Buffer is read-only"));
2990 Fput (Qtext_read_only
, Qerror_conditions
,
2991 Fcons (Qtext_read_only
, error_tail
));
2992 Fput (Qtext_read_only
, Qerror_message
,
2993 build_string ("Text is read-only"));
2995 Qrange_error
= intern ("range-error");
2996 Qdomain_error
= intern ("domain-error");
2997 Qsingularity_error
= intern ("singularity-error");
2998 Qoverflow_error
= intern ("overflow-error");
2999 Qunderflow_error
= intern ("underflow-error");
3001 Fput (Qdomain_error
, Qerror_conditions
,
3002 Fcons (Qdomain_error
, arith_tail
));
3003 Fput (Qdomain_error
, Qerror_message
,
3004 build_string ("Arithmetic domain error"));
3006 Fput (Qrange_error
, Qerror_conditions
,
3007 Fcons (Qrange_error
, arith_tail
));
3008 Fput (Qrange_error
, Qerror_message
,
3009 build_string ("Arithmetic range error"));
3011 Fput (Qsingularity_error
, Qerror_conditions
,
3012 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3013 Fput (Qsingularity_error
, Qerror_message
,
3014 build_string ("Arithmetic singularity error"));
3016 Fput (Qoverflow_error
, Qerror_conditions
,
3017 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3018 Fput (Qoverflow_error
, Qerror_message
,
3019 build_string ("Arithmetic overflow error"));
3021 Fput (Qunderflow_error
, Qerror_conditions
,
3022 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3023 Fput (Qunderflow_error
, Qerror_message
,
3024 build_string ("Arithmetic underflow error"));
3026 staticpro (&Qrange_error
);
3027 staticpro (&Qdomain_error
);
3028 staticpro (&Qsingularity_error
);
3029 staticpro (&Qoverflow_error
);
3030 staticpro (&Qunderflow_error
);
3034 staticpro (&Qquote
);
3035 staticpro (&Qlambda
);
3037 staticpro (&Qunbound
);
3038 staticpro (&Qerror_conditions
);
3039 staticpro (&Qerror_message
);
3040 staticpro (&Qtop_level
);
3042 staticpro (&Qerror
);
3044 staticpro (&Qwrong_type_argument
);
3045 staticpro (&Qargs_out_of_range
);
3046 staticpro (&Qvoid_function
);
3047 staticpro (&Qcyclic_function_indirection
);
3048 staticpro (&Qcyclic_variable_indirection
);
3049 staticpro (&Qvoid_variable
);
3050 staticpro (&Qsetting_constant
);
3051 staticpro (&Qinvalid_read_syntax
);
3052 staticpro (&Qwrong_number_of_arguments
);
3053 staticpro (&Qinvalid_function
);
3054 staticpro (&Qno_catch
);
3055 staticpro (&Qend_of_file
);
3056 staticpro (&Qarith_error
);
3057 staticpro (&Qbeginning_of_buffer
);
3058 staticpro (&Qend_of_buffer
);
3059 staticpro (&Qbuffer_read_only
);
3060 staticpro (&Qtext_read_only
);
3061 staticpro (&Qmark_inactive
);
3063 staticpro (&Qlistp
);
3064 staticpro (&Qconsp
);
3065 staticpro (&Qsymbolp
);
3066 staticpro (&Qkeywordp
);
3067 staticpro (&Qintegerp
);
3068 staticpro (&Qnatnump
);
3069 staticpro (&Qwholenump
);
3070 staticpro (&Qstringp
);
3071 staticpro (&Qarrayp
);
3072 staticpro (&Qsequencep
);
3073 staticpro (&Qbufferp
);
3074 staticpro (&Qvectorp
);
3075 staticpro (&Qchar_or_string_p
);
3076 staticpro (&Qmarkerp
);
3077 staticpro (&Qbuffer_or_string_p
);
3078 staticpro (&Qinteger_or_marker_p
);
3079 staticpro (&Qfloatp
);
3080 staticpro (&Qnumberp
);
3081 staticpro (&Qnumber_or_marker_p
);
3082 staticpro (&Qchar_table_p
);
3083 staticpro (&Qvector_or_char_table_p
);
3084 staticpro (&Qsubrp
);
3086 staticpro (&Qunevalled
);
3088 staticpro (&Qboundp
);
3089 staticpro (&Qfboundp
);
3091 staticpro (&Qad_advice_info
);
3092 staticpro (&Qad_activate_internal
);
3094 /* Types that type-of returns. */
3095 Qinteger
= intern ("integer");
3096 Qsymbol
= intern ("symbol");
3097 Qstring
= intern ("string");
3098 Qcons
= intern ("cons");
3099 Qmarker
= intern ("marker");
3100 Qoverlay
= intern ("overlay");
3101 Qfloat
= intern ("float");
3102 Qwindow_configuration
= intern ("window-configuration");
3103 Qprocess
= intern ("process");
3104 Qwindow
= intern ("window");
3105 /* Qsubr = intern ("subr"); */
3106 Qcompiled_function
= intern ("compiled-function");
3107 Qbuffer
= intern ("buffer");
3108 Qframe
= intern ("frame");
3109 Qvector
= intern ("vector");
3110 Qchar_table
= intern ("char-table");
3111 Qbool_vector
= intern ("bool-vector");
3112 Qhash_table
= intern ("hash-table");
3114 staticpro (&Qinteger
);
3115 staticpro (&Qsymbol
);
3116 staticpro (&Qstring
);
3118 staticpro (&Qmarker
);
3119 staticpro (&Qoverlay
);
3120 staticpro (&Qfloat
);
3121 staticpro (&Qwindow_configuration
);
3122 staticpro (&Qprocess
);
3123 staticpro (&Qwindow
);
3124 /* staticpro (&Qsubr); */
3125 staticpro (&Qcompiled_function
);
3126 staticpro (&Qbuffer
);
3127 staticpro (&Qframe
);
3128 staticpro (&Qvector
);
3129 staticpro (&Qchar_table
);
3130 staticpro (&Qbool_vector
);
3131 staticpro (&Qhash_table
);
3133 defsubr (&Sindirect_variable
);
3134 defsubr (&Sinteractive_form
);
3137 defsubr (&Stype_of
);
3142 defsubr (&Sintegerp
);
3143 defsubr (&Sinteger_or_marker_p
);
3144 defsubr (&Snumberp
);
3145 defsubr (&Snumber_or_marker_p
);
3147 defsubr (&Snatnump
);
3148 defsubr (&Ssymbolp
);
3149 defsubr (&Skeywordp
);
3150 defsubr (&Sstringp
);
3151 defsubr (&Smultibyte_string_p
);
3152 defsubr (&Svectorp
);
3153 defsubr (&Schar_table_p
);
3154 defsubr (&Svector_or_char_table_p
);
3155 defsubr (&Sbool_vector_p
);
3157 defsubr (&Ssequencep
);
3158 defsubr (&Sbufferp
);
3159 defsubr (&Smarkerp
);
3161 defsubr (&Sbyte_code_function_p
);
3162 defsubr (&Schar_or_string_p
);
3165 defsubr (&Scar_safe
);
3166 defsubr (&Scdr_safe
);
3169 defsubr (&Ssymbol_function
);
3170 defsubr (&Sindirect_function
);
3171 defsubr (&Ssymbol_plist
);
3172 defsubr (&Ssymbol_name
);
3173 defsubr (&Smakunbound
);
3174 defsubr (&Sfmakunbound
);
3176 defsubr (&Sfboundp
);
3178 defsubr (&Sdefalias
);
3179 defsubr (&Ssetplist
);
3180 defsubr (&Ssymbol_value
);
3182 defsubr (&Sdefault_boundp
);
3183 defsubr (&Sdefault_value
);
3184 defsubr (&Sset_default
);
3185 defsubr (&Ssetq_default
);
3186 defsubr (&Smake_variable_buffer_local
);
3187 defsubr (&Smake_local_variable
);
3188 defsubr (&Skill_local_variable
);
3189 defsubr (&Smake_variable_frame_local
);
3190 defsubr (&Slocal_variable_p
);
3191 defsubr (&Slocal_variable_if_set_p
);
3192 defsubr (&Svariable_binding_locus
);
3193 #if 0 /* XXX Remove this. --lorentey */
3194 defsubr (&Sterminal_local_value
);
3195 defsubr (&Sset_terminal_local_value
);
3199 defsubr (&Snumber_to_string
);
3200 defsubr (&Sstring_to_number
);
3201 defsubr (&Seqlsign
);
3224 defsubr (&Sbyteorder
);
3225 defsubr (&Ssubr_arity
);
3226 defsubr (&Ssubr_name
);
3228 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3230 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3231 doc
: /* The largest value that is representable in a Lisp integer. */);
3232 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3234 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3235 doc
: /* The smallest value that is representable in a Lisp integer. */);
3236 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3243 #if defined(USG) && !defined(POSIX_SIGNALS)
3244 /* USG systems forget handlers when they are used;
3245 must reestablish each time */
3246 signal (signo
, arith_error
);
3249 /* VMS systems are like USG. */
3250 signal (signo
, arith_error
);
3254 #else /* not BSD4_1 */
3255 sigsetmask (SIGEMPTYMASK
);
3256 #endif /* not BSD4_1 */
3258 SIGNAL_THREAD_CHECK (signo
);
3259 xsignal0 (Qarith_error
);
3265 /* Don't do this if just dumping out.
3266 We don't want to call `signal' in this case
3267 so that we don't have trouble with dumping
3268 signal-delivering routines in an inconsistent state. */
3272 #endif /* CANNOT_DUMP */
3273 signal (SIGFPE
, arith_error
);
3276 signal (SIGEMT
, arith_error
);
3280 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3281 (do not change this comment) */