1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 2003
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
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
;
74 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
75 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
76 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
77 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
78 Lisp_Object Qboundp
, Qfboundp
;
79 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
82 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
84 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
85 Lisp_Object Qoverflow_error
, Qunderflow_error
;
88 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
90 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
91 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
93 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
94 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
95 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
97 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
99 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
103 circular_list_error (list
)
106 Fsignal (Qcircular_list
, list
);
111 wrong_type_argument (predicate
, value
)
112 register Lisp_Object predicate
, value
;
114 register Lisp_Object tem
;
117 /* If VALUE is not even a valid Lisp object, abort here
118 where we can get a backtrace showing where it came from. */
119 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
122 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
123 tem
= call1 (predicate
, value
);
132 error ("Attempt to modify read-only object");
136 args_out_of_range (a1
, a2
)
140 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
144 args_out_of_range_3 (a1
, a2
, a3
)
145 Lisp_Object a1
, a2
, a3
;
148 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
151 /* On some machines, XINT needs a temporary location.
152 Here it is, in case it is needed. */
154 int sign_extend_temp
;
156 /* On a few machines, XINT can only be done by calling this. */
159 sign_extend_lisp_int (num
)
162 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
163 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
165 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
168 /* Data type predicates */
170 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
171 doc
: /* Return t if the two args are the same Lisp object. */)
173 Lisp_Object obj1
, obj2
;
180 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
181 doc
: /* Return t if OBJECT is nil. */)
190 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
191 doc
: /* Return a symbol representing the type of OBJECT.
192 The symbol returned names the object's basic type;
193 for example, (type-of 1) returns `integer'. */)
197 switch (XGCTYPE (object
))
212 switch (XMISCTYPE (object
))
214 case Lisp_Misc_Marker
:
216 case Lisp_Misc_Overlay
:
218 case Lisp_Misc_Float
:
223 case Lisp_Vectorlike
:
224 if (GC_WINDOW_CONFIGURATIONP (object
))
225 return Qwindow_configuration
;
226 if (GC_PROCESSP (object
))
228 if (GC_WINDOWP (object
))
230 if (GC_SUBRP (object
))
232 if (GC_COMPILEDP (object
))
233 return Qcompiled_function
;
234 if (GC_BUFFERP (object
))
236 if (GC_CHAR_TABLE_P (object
))
238 if (GC_BOOL_VECTOR_P (object
))
240 if (GC_FRAMEP (object
))
242 if (GC_HASH_TABLE_P (object
))
254 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
255 doc
: /* Return t if OBJECT is a cons cell. */)
264 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
265 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
274 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
275 doc
: /* Return t if OBJECT is a list. This includes nil. */)
279 if (CONSP (object
) || NILP (object
))
284 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
285 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
289 if (CONSP (object
) || NILP (object
))
294 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
295 doc
: /* Return t if OBJECT is a symbol. */)
299 if (SYMBOLP (object
))
304 /* Define this in C to avoid unnecessarily consing up the symbol
306 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is a keyword.
308 This means that it is a symbol with a print name beginning with `:'
309 interned in the initial obarray. */)
314 && SREF (SYMBOL_NAME (object
), 0) == ':'
315 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
320 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a vector. */)
325 if (VECTORP (object
))
330 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
331 doc
: /* Return t if OBJECT is a string. */)
335 if (STRINGP (object
))
340 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
342 doc
: /* Return t if OBJECT is a multibyte string. */)
346 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
351 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a char-table. */)
356 if (CHAR_TABLE_P (object
))
361 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
362 Svector_or_char_table_p
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a char-table or vector. */)
367 if (VECTORP (object
) || CHAR_TABLE_P (object
))
372 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
373 doc
: /* Return t if OBJECT is a bool-vector. */)
377 if (BOOL_VECTOR_P (object
))
382 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 if (VECTORP (object
) || STRINGP (object
)
388 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
393 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
394 doc
: /* Return t if OBJECT is a sequence (list or array). */)
396 register Lisp_Object object
;
398 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
399 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
404 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is an editor buffer. */)
409 if (BUFFERP (object
))
414 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
419 if (MARKERP (object
))
424 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a built-in function. */)
434 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
436 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
440 if (COMPILEDP (object
))
445 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
446 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
448 register Lisp_Object object
;
450 if (CHARACTERP (object
) || STRINGP (object
))
455 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
456 doc
: /* Return t if OBJECT is an integer. */)
460 if (INTEGERP (object
))
465 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
466 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
468 register Lisp_Object object
;
470 if (MARKERP (object
) || INTEGERP (object
))
475 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
476 doc
: /* Return t if OBJECT is a nonnegative integer. */)
480 if (NATNUMP (object
))
485 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
486 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
490 if (NUMBERP (object
))
496 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
497 Snumber_or_marker_p
, 1, 1, 0,
498 doc
: /* Return t if OBJECT is a number or a marker. */)
502 if (NUMBERP (object
) || MARKERP (object
))
507 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
508 doc
: /* Return t if OBJECT is a floating point number. */)
518 /* Extract and set components of lists */
520 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
521 doc
: /* Return the car of LIST. If arg is nil, return nil.
522 Error if arg is not nil and not a cons cell. See also `car-safe'. */)
524 register Lisp_Object list
;
530 else if (EQ (list
, Qnil
))
533 list
= wrong_type_argument (Qlistp
, list
);
537 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
538 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
543 return XCAR (object
);
548 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
549 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
550 Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
552 register Lisp_Object list
;
558 else if (EQ (list
, Qnil
))
561 list
= wrong_type_argument (Qlistp
, list
);
565 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
566 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
571 return XCDR (object
);
576 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
577 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
579 register Lisp_Object cell
, newcar
;
582 cell
= wrong_type_argument (Qconsp
, cell
);
585 XSETCAR (cell
, newcar
);
589 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
590 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
592 register Lisp_Object cell
, newcdr
;
595 cell
= wrong_type_argument (Qconsp
, cell
);
598 XSETCDR (cell
, newcdr
);
602 /* Extract and set components of symbols */
604 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
605 doc
: /* Return t if SYMBOL's value is not void. */)
607 register Lisp_Object symbol
;
609 Lisp_Object valcontents
;
610 CHECK_SYMBOL (symbol
);
612 valcontents
= SYMBOL_VALUE (symbol
);
614 if (BUFFER_LOCAL_VALUEP (valcontents
)
615 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
616 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
618 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
621 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
622 doc
: /* Return t if SYMBOL's function definition is not void. */)
624 register Lisp_Object symbol
;
626 CHECK_SYMBOL (symbol
);
627 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
630 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
631 doc
: /* Make SYMBOL's value be void.
634 register Lisp_Object symbol
;
636 CHECK_SYMBOL (symbol
);
637 if (XSYMBOL (symbol
)->constant
)
638 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
639 Fset (symbol
, Qunbound
);
643 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
644 doc
: /* Make SYMBOL's function definition be void.
647 register Lisp_Object symbol
;
649 CHECK_SYMBOL (symbol
);
650 if (NILP (symbol
) || EQ (symbol
, Qt
))
651 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
652 XSYMBOL (symbol
)->function
= Qunbound
;
656 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
657 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
659 register Lisp_Object symbol
;
661 CHECK_SYMBOL (symbol
);
662 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
663 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
664 return XSYMBOL (symbol
)->function
;
667 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
668 doc
: /* Return SYMBOL's property list. */)
670 register Lisp_Object symbol
;
672 CHECK_SYMBOL (symbol
);
673 return XSYMBOL (symbol
)->plist
;
676 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
677 doc
: /* Return SYMBOL's name, a string. */)
679 register Lisp_Object symbol
;
681 register Lisp_Object name
;
683 CHECK_SYMBOL (symbol
);
684 name
= SYMBOL_NAME (symbol
);
688 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
689 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
691 register Lisp_Object symbol
, definition
;
693 CHECK_SYMBOL (symbol
);
694 if (NILP (symbol
) || EQ (symbol
, Qt
))
695 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
696 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
697 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
699 XSYMBOL (symbol
)->function
= definition
;
700 /* Handle automatic advice activation */
701 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
703 call2 (Qad_activate_internal
, symbol
, Qnil
);
704 definition
= XSYMBOL (symbol
)->function
;
709 extern Lisp_Object Qfunction_documentation
;
711 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
712 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
713 Associates the function with the current load file, if any.
714 The optional third argument DOCSTRING specifies the documentation string
715 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
716 determined by DEFINITION. */)
717 (symbol
, definition
, docstring
)
718 register Lisp_Object symbol
, definition
, docstring
;
720 if (CONSP (XSYMBOL (symbol
)->function
)
721 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
722 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
723 definition
= Ffset (symbol
, definition
);
724 LOADHIST_ATTACH (symbol
);
725 if (!NILP (docstring
))
726 Fput (symbol
, Qfunction_documentation
, docstring
);
730 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
731 doc
: /* Set SYMBOL's property list to NEWVAL, and return NEWVAL. */)
733 register Lisp_Object symbol
, newplist
;
735 CHECK_SYMBOL (symbol
);
736 XSYMBOL (symbol
)->plist
= newplist
;
740 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
741 doc
: /* Return minimum and maximum number of args allowed for SUBR.
742 SUBR must be a built-in function.
743 The returned value is a pair (MIN . MAX). MIN is the minimum number
744 of args. MAX is the maximum number or the symbol `many', for a
745 function with `&rest' args, or `unevalled' for a special form. */)
749 short minargs
, maxargs
;
751 wrong_type_argument (Qsubrp
, subr
);
752 minargs
= XSUBR (subr
)->min_args
;
753 maxargs
= XSUBR (subr
)->max_args
;
755 return Fcons (make_number (minargs
), Qmany
);
756 else if (maxargs
== UNEVALLED
)
757 return Fcons (make_number (minargs
), Qunevalled
);
759 return Fcons (make_number (minargs
), make_number (maxargs
));
762 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
763 doc
: /* Return the interactive form of SUBR or nil if none.
764 SUBR must be a built-in function. Value, if non-nil, is a list
765 \(interactive SPEC). */)
770 wrong_type_argument (Qsubrp
, subr
);
771 if (XSUBR (subr
)->prompt
)
772 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
777 /***********************************************************************
778 Getting and Setting Values of Symbols
779 ***********************************************************************/
781 /* Return the symbol holding SYMBOL's value. Signal
782 `cyclic-variable-indirection' if SYMBOL's chain of variable
783 indirections contains a loop. */
786 indirect_variable (symbol
)
789 Lisp_Object tortoise
, hare
;
791 hare
= tortoise
= symbol
;
793 while (XSYMBOL (hare
)->indirect_variable
)
795 hare
= XSYMBOL (hare
)->value
;
796 if (!XSYMBOL (hare
)->indirect_variable
)
799 hare
= XSYMBOL (hare
)->value
;
800 tortoise
= XSYMBOL (tortoise
)->value
;
802 if (EQ (hare
, tortoise
))
803 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
810 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
811 doc
: /* Return the variable at the end of OBJECT's variable chain.
812 If OBJECT is a symbol, follow all variable indirections and return the final
813 variable. If OBJECT is not a symbol, just return it.
814 Signal a cyclic-variable-indirection error if there is a loop in the
815 variable chain of symbols. */)
819 if (SYMBOLP (object
))
820 object
= indirect_variable (object
);
825 /* Given the raw contents of a symbol value cell,
826 return the Lisp value of the symbol.
827 This does not handle buffer-local variables; use
828 swap_in_symval_forwarding for that. */
831 do_symval_forwarding (valcontents
)
832 register Lisp_Object valcontents
;
834 register Lisp_Object val
;
836 if (MISCP (valcontents
))
837 switch (XMISCTYPE (valcontents
))
839 case Lisp_Misc_Intfwd
:
840 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
843 case Lisp_Misc_Boolfwd
:
844 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
846 case Lisp_Misc_Objfwd
:
847 return *XOBJFWD (valcontents
)->objvar
;
849 case Lisp_Misc_Buffer_Objfwd
:
850 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
851 return PER_BUFFER_VALUE (current_buffer
, offset
);
853 case Lisp_Misc_Kboard_Objfwd
:
854 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
855 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
860 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
861 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
862 buffer-independent contents of the value cell: forwarded just one
863 step past the buffer-localness.
865 BUF non-zero means set the value in buffer BUF instead of the
866 current buffer. This only plays a role for per-buffer variables. */
869 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
871 register Lisp_Object valcontents
, newval
;
874 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
877 switch (XMISCTYPE (valcontents
))
879 case Lisp_Misc_Intfwd
:
880 CHECK_NUMBER (newval
);
881 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
882 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
883 error ("Value out of range for variable `%s'",
884 SDATA (SYMBOL_NAME (symbol
)));
887 case Lisp_Misc_Boolfwd
:
888 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
891 case Lisp_Misc_Objfwd
:
892 *XOBJFWD (valcontents
)->objvar
= newval
;
895 case Lisp_Misc_Buffer_Objfwd
:
897 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
900 type
= PER_BUFFER_TYPE (offset
);
901 if (! NILP (type
) && ! NILP (newval
)
902 && XTYPE (newval
) != XINT (type
))
903 buffer_slot_type_mismatch (offset
);
906 buf
= current_buffer
;
907 PER_BUFFER_VALUE (buf
, offset
) = newval
;
911 case Lisp_Misc_Kboard_Objfwd
:
913 char *base
= (char *) current_kboard
;
914 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
915 *(Lisp_Object
*) p
= newval
;
926 valcontents
= SYMBOL_VALUE (symbol
);
927 if (BUFFER_LOCAL_VALUEP (valcontents
)
928 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
929 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
931 SET_SYMBOL_VALUE (symbol
, newval
);
935 /* Set up SYMBOL to refer to its global binding.
936 This makes it safe to alter the status of other bindings. */
939 swap_in_global_binding (symbol
)
942 Lisp_Object valcontents
, cdr
;
944 valcontents
= SYMBOL_VALUE (symbol
);
945 if (!BUFFER_LOCAL_VALUEP (valcontents
)
946 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
948 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
950 /* Unload the previously loaded binding. */
952 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
954 /* Select the global binding in the symbol. */
956 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
958 /* Indicate that the global binding is set up now. */
959 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
960 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
961 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
962 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
965 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
966 VALCONTENTS is the contents of its value cell,
967 which points to a struct Lisp_Buffer_Local_Value.
969 Return the value forwarded one step past the buffer-local stage.
970 This could be another forwarding pointer. */
973 swap_in_symval_forwarding (symbol
, valcontents
)
974 Lisp_Object symbol
, valcontents
;
976 register Lisp_Object tem1
;
978 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
981 || current_buffer
!= XBUFFER (tem1
)
982 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
983 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
985 if (XSYMBOL (symbol
)->indirect_variable
)
986 symbol
= indirect_variable (symbol
);
988 /* Unload the previously loaded binding. */
989 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
991 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
992 /* Choose the new binding. */
993 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
994 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
995 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
998 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
999 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1001 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1003 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1006 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1008 /* Load the new binding. */
1009 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1010 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1011 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1012 store_symval_forwarding (symbol
,
1013 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1016 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1019 /* Find the value of a symbol, returning Qunbound if it's not bound.
1020 This is helpful for code which just wants to get a variable's value
1021 if it has one, without signaling an error.
1022 Note that it must not be possible to quit
1023 within this function. Great care is required for this. */
1026 find_symbol_value (symbol
)
1029 register Lisp_Object valcontents
;
1030 register Lisp_Object val
;
1032 CHECK_SYMBOL (symbol
);
1033 valcontents
= SYMBOL_VALUE (symbol
);
1035 if (BUFFER_LOCAL_VALUEP (valcontents
)
1036 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1037 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1039 if (MISCP (valcontents
))
1041 switch (XMISCTYPE (valcontents
))
1043 case Lisp_Misc_Intfwd
:
1044 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1047 case Lisp_Misc_Boolfwd
:
1048 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1050 case Lisp_Misc_Objfwd
:
1051 return *XOBJFWD (valcontents
)->objvar
;
1053 case Lisp_Misc_Buffer_Objfwd
:
1054 return PER_BUFFER_VALUE (current_buffer
,
1055 XBUFFER_OBJFWD (valcontents
)->offset
);
1057 case Lisp_Misc_Kboard_Objfwd
:
1058 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1059 + (char *)current_kboard
);
1066 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1067 doc
: /* Return SYMBOL's value. Error if that is void. */)
1073 val
= find_symbol_value (symbol
);
1074 if (EQ (val
, Qunbound
))
1075 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1080 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1081 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1083 register Lisp_Object symbol
, newval
;
1085 return set_internal (symbol
, newval
, current_buffer
, 0);
1088 /* Return 1 if SYMBOL currently has a let-binding
1089 which was made in the buffer that is now current. */
1092 let_shadows_buffer_binding_p (symbol
)
1095 volatile struct specbinding
*p
;
1097 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1099 && CONSP (p
->symbol
))
1101 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1102 if ((EQ (symbol
, let_bound_symbol
)
1103 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1104 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1105 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1109 return p
>= specpdl
;
1112 /* Store the value NEWVAL into SYMBOL.
1113 If buffer-locality is an issue, BUF specifies which buffer to use.
1114 (0 stands for the current buffer.)
1116 If BINDFLAG is zero, then if this symbol is supposed to become
1117 local in every buffer where it is set, then we make it local.
1118 If BINDFLAG is nonzero, we don't do that. */
1121 set_internal (symbol
, newval
, buf
, bindflag
)
1122 register Lisp_Object symbol
, newval
;
1126 int voide
= EQ (newval
, Qunbound
);
1128 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1131 buf
= current_buffer
;
1133 /* If restoring in a dead buffer, do nothing. */
1134 if (NILP (buf
->name
))
1137 CHECK_SYMBOL (symbol
);
1138 if (SYMBOL_CONSTANT_P (symbol
)
1139 && (NILP (Fkeywordp (symbol
))
1140 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1141 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1143 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1145 if (BUFFER_OBJFWDP (valcontents
))
1147 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1148 int idx
= PER_BUFFER_IDX (offset
);
1151 && !let_shadows_buffer_binding_p (symbol
))
1152 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1154 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1155 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1157 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1158 if (XSYMBOL (symbol
)->indirect_variable
)
1159 symbol
= indirect_variable (symbol
);
1161 /* What binding is loaded right now? */
1162 current_alist_element
1163 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1165 /* If the current buffer is not the buffer whose binding is
1166 loaded, or if there may be frame-local bindings and the frame
1167 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1168 the default binding is loaded, the loaded binding may be the
1170 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1171 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1172 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1173 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1174 || (BUFFER_LOCAL_VALUEP (valcontents
)
1175 && EQ (XCAR (current_alist_element
),
1176 current_alist_element
)))
1178 /* The currently loaded binding is not necessarily valid.
1179 We need to unload it, and choose a new binding. */
1181 /* Write out `realvalue' to the old loaded binding. */
1182 Fsetcdr (current_alist_element
,
1183 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1185 /* Find the new binding. */
1186 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1187 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1188 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1192 /* This buffer still sees the default value. */
1194 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1195 or if this is `let' rather than `set',
1196 make CURRENT-ALIST-ELEMENT point to itself,
1197 indicating that we're seeing the default value.
1198 Likewise if the variable has been let-bound
1199 in the current buffer. */
1200 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1201 || let_shadows_buffer_binding_p (symbol
))
1203 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1205 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1206 tem1
= Fassq (symbol
,
1207 XFRAME (selected_frame
)->param_alist
);
1210 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1212 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1214 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1215 and we're not within a let that was made for this buffer,
1216 create a new buffer-local binding for the variable.
1217 That means, give this buffer a new assoc for a local value
1218 and load that binding. */
1221 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1222 buf
->local_var_alist
1223 = Fcons (tem1
, buf
->local_var_alist
);
1227 /* Record which binding is now loaded. */
1228 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1231 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1232 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1233 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1235 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1238 /* If storing void (making the symbol void), forward only through
1239 buffer-local indicator, not through Lisp_Objfwd, etc. */
1241 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1243 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1245 /* If we just set a variable whose current binding is frame-local,
1246 store the new value in the frame parameter too. */
1248 if (BUFFER_LOCAL_VALUEP (valcontents
)
1249 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1251 /* What binding is loaded right now? */
1252 current_alist_element
1253 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1255 /* If the current buffer is not the buffer whose binding is
1256 loaded, or if there may be frame-local bindings and the frame
1257 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1258 the default binding is loaded, the loaded binding may be the
1260 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1261 XSETCDR (current_alist_element
, newval
);
1267 /* Access or set a buffer-local symbol's default value. */
1269 /* Return the default value of SYMBOL, but don't check for voidness.
1270 Return Qunbound if it is void. */
1273 default_value (symbol
)
1276 register Lisp_Object valcontents
;
1278 CHECK_SYMBOL (symbol
);
1279 valcontents
= SYMBOL_VALUE (symbol
);
1281 /* For a built-in buffer-local variable, get the default value
1282 rather than letting do_symval_forwarding get the current value. */
1283 if (BUFFER_OBJFWDP (valcontents
))
1285 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1286 if (PER_BUFFER_IDX (offset
) != 0)
1287 return PER_BUFFER_DEFAULT (offset
);
1290 /* Handle user-created local variables. */
1291 if (BUFFER_LOCAL_VALUEP (valcontents
)
1292 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1294 /* If var is set up for a buffer that lacks a local value for it,
1295 the current value is nominally the default value.
1296 But the `realvalue' slot may be more up to date, since
1297 ordinary setq stores just that slot. So use that. */
1298 Lisp_Object current_alist_element
, alist_element_car
;
1299 current_alist_element
1300 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1301 alist_element_car
= XCAR (current_alist_element
);
1302 if (EQ (alist_element_car
, current_alist_element
))
1303 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1305 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1307 /* For other variables, get the current value. */
1308 return do_symval_forwarding (valcontents
);
1311 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1312 doc
: /* Return t if SYMBOL has a non-void default value.
1313 This is the value that is seen in buffers that do not have their own values
1314 for this variable. */)
1318 register Lisp_Object value
;
1320 value
= default_value (symbol
);
1321 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1324 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1325 doc
: /* Return SYMBOL's default value.
1326 This is the value that is seen in buffers that do not have their own values
1327 for this variable. The default value is meaningful for variables with
1328 local bindings in certain buffers. */)
1332 register Lisp_Object value
;
1334 value
= default_value (symbol
);
1335 if (EQ (value
, Qunbound
))
1336 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1340 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1341 doc
: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1342 The default value is seen in buffers that do not have their own values
1343 for this variable. */)
1345 Lisp_Object symbol
, value
;
1347 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1349 CHECK_SYMBOL (symbol
);
1350 valcontents
= SYMBOL_VALUE (symbol
);
1352 /* Handle variables like case-fold-search that have special slots
1353 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1355 if (BUFFER_OBJFWDP (valcontents
))
1357 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1358 int idx
= PER_BUFFER_IDX (offset
);
1360 PER_BUFFER_DEFAULT (offset
) = value
;
1362 /* If this variable is not always local in all buffers,
1363 set it in the buffers that don't nominally have a local value. */
1368 for (b
= all_buffers
; b
; b
= b
->next
)
1369 if (!PER_BUFFER_VALUE_P (b
, idx
))
1370 PER_BUFFER_VALUE (b
, offset
) = value
;
1375 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1376 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1377 return Fset (symbol
, value
);
1379 /* Store new value into the DEFAULT-VALUE slot. */
1380 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1382 /* If the default binding is now loaded, set the REALVALUE slot too. */
1383 current_alist_element
1384 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1385 alist_element_buffer
= Fcar (current_alist_element
);
1386 if (EQ (alist_element_buffer
, current_alist_element
))
1387 store_symval_forwarding (symbol
,
1388 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1394 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1395 doc
: /* Set the default value of variable VAR to VALUE.
1396 VAR, the variable name, is literal (not evaluated);
1397 VALUE is an expression: it is evaluated and its value returned.
1398 The default value of a variable is seen in buffers
1399 that do not have their own values for the variable.
1401 More generally, you can use multiple variables and values, as in
1402 (setq-default SYMBOL VALUE SYMBOL VALUE...)
1403 This sets each SYMBOL's default value to the corresponding VALUE.
1404 The VALUE for the Nth SYMBOL can refer to the new default values
1406 usage: (setq-default SYMBOL VALUE [SYMBOL VALUE...]) */)
1410 register Lisp_Object args_left
;
1411 register Lisp_Object val
, symbol
;
1412 struct gcpro gcpro1
;
1422 val
= Feval (Fcar (Fcdr (args_left
)));
1423 symbol
= XCAR (args_left
);
1424 Fset_default (symbol
, val
);
1425 args_left
= Fcdr (XCDR (args_left
));
1427 while (!NILP (args_left
));
1433 /* Lisp functions for creating and removing buffer-local variables. */
1435 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1436 1, 1, "vMake Variable Buffer Local: ",
1437 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1438 At any time, the value for the current buffer is in effect,
1439 unless the variable has never been set in this buffer,
1440 in which case the default value is in effect.
1441 Note that binding the variable with `let', or setting it while
1442 a `let'-style binding made in this buffer is in effect,
1443 does not make the variable buffer-local. Return VARIABLE.
1445 The function `default-value' gets the default value and `set-default' sets it. */)
1447 register Lisp_Object variable
;
1449 register Lisp_Object tem
, valcontents
, newval
;
1451 CHECK_SYMBOL (variable
);
1453 valcontents
= SYMBOL_VALUE (variable
);
1454 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1455 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1457 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1459 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1461 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1464 if (EQ (valcontents
, Qunbound
))
1465 SET_SYMBOL_VALUE (variable
, Qnil
);
1466 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1468 newval
= allocate_misc ();
1469 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1470 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1471 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1472 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1473 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1474 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1475 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1476 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1477 SET_SYMBOL_VALUE (variable
, newval
);
1481 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1482 1, 1, "vMake Local Variable: ",
1483 doc
: /* Make VARIABLE have a separate value in the current buffer.
1484 Other buffers will continue to share a common default value.
1485 \(The buffer-local value of VARIABLE starts out as the same value
1486 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1487 See also `make-variable-buffer-local'. Return VARIABLE.
1489 If the variable is already arranged to become local when set,
1490 this function causes a local value to exist for this buffer,
1491 just as setting the variable would do.
1493 This function returns VARIABLE, and therefore
1494 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1497 Do not use `make-local-variable' to make a hook variable buffer-local.
1498 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1500 register Lisp_Object variable
;
1502 register Lisp_Object tem
, valcontents
;
1504 CHECK_SYMBOL (variable
);
1506 valcontents
= SYMBOL_VALUE (variable
);
1507 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1508 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1510 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1512 tem
= Fboundp (variable
);
1514 /* Make sure the symbol has a local value in this particular buffer,
1515 by setting it to the same value it already has. */
1516 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1519 /* Make sure symbol is set up to hold per-buffer values. */
1520 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1523 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1525 newval
= allocate_misc ();
1526 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1527 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1528 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1529 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1530 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1531 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1532 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1533 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1534 SET_SYMBOL_VALUE (variable
, newval
);;
1536 /* Make sure this buffer has its own value of symbol. */
1537 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1540 /* Swap out any local binding for some other buffer, and make
1541 sure the current value is permanently recorded, if it's the
1543 find_symbol_value (variable
);
1545 current_buffer
->local_var_alist
1546 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1547 current_buffer
->local_var_alist
);
1549 /* Make sure symbol does not think it is set up for this buffer;
1550 force it to look once again for this buffer's value. */
1552 Lisp_Object
*pvalbuf
;
1554 valcontents
= SYMBOL_VALUE (variable
);
1556 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1557 if (current_buffer
== XBUFFER (*pvalbuf
))
1559 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1563 /* If the symbol forwards into a C variable, then load the binding
1564 for this buffer now. If C code modifies the variable before we
1565 load the binding in, then that new value will clobber the default
1566 binding the next time we unload it. */
1567 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1568 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1569 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1574 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1575 1, 1, "vKill Local Variable: ",
1576 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1577 From now on the default value will apply in this buffer. Return VARIABLE. */)
1579 register Lisp_Object variable
;
1581 register Lisp_Object tem
, valcontents
;
1583 CHECK_SYMBOL (variable
);
1585 valcontents
= SYMBOL_VALUE (variable
);
1587 if (BUFFER_OBJFWDP (valcontents
))
1589 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1590 int idx
= PER_BUFFER_IDX (offset
);
1594 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1595 PER_BUFFER_VALUE (current_buffer
, offset
)
1596 = PER_BUFFER_DEFAULT (offset
);
1601 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1602 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1605 /* Get rid of this buffer's alist element, if any. */
1607 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1609 current_buffer
->local_var_alist
1610 = Fdelq (tem
, current_buffer
->local_var_alist
);
1612 /* If the symbol is set up with the current buffer's binding
1613 loaded, recompute its value. We have to do it now, or else
1614 forwarded objects won't work right. */
1616 Lisp_Object
*pvalbuf
, buf
;
1617 valcontents
= SYMBOL_VALUE (variable
);
1618 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1619 XSETBUFFER (buf
, current_buffer
);
1620 if (EQ (buf
, *pvalbuf
))
1623 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1624 find_symbol_value (variable
);
1631 /* Lisp functions for creating and removing buffer-local variables. */
1633 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1634 1, 1, "vMake Variable Frame Local: ",
1635 doc
: /* Enable VARIABLE to have frame-local bindings.
1636 When a frame-local binding exists in the current frame,
1637 it is in effect whenever the current buffer has no buffer-local binding.
1638 A frame-local binding is actually a frame parameter value;
1639 thus, any given frame has a local binding for VARIABLE if it has
1640 a value for the frame parameter named VARIABLE. Return VARIABLE.
1641 See `modify-frame-parameters' for how to set frame parameters. */)
1643 register Lisp_Object variable
;
1645 register Lisp_Object tem
, valcontents
, newval
;
1647 CHECK_SYMBOL (variable
);
1649 valcontents
= SYMBOL_VALUE (variable
);
1650 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1651 || BUFFER_OBJFWDP (valcontents
))
1652 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1654 if (BUFFER_LOCAL_VALUEP (valcontents
)
1655 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1657 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1661 if (EQ (valcontents
, Qunbound
))
1662 SET_SYMBOL_VALUE (variable
, Qnil
);
1663 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1665 newval
= allocate_misc ();
1666 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1667 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1668 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1669 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1670 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1671 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1672 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1673 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1674 SET_SYMBOL_VALUE (variable
, newval
);
1678 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1680 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1681 BUFFER defaults to the current buffer. */)
1683 register Lisp_Object variable
, buffer
;
1685 Lisp_Object valcontents
;
1686 register struct buffer
*buf
;
1689 buf
= current_buffer
;
1692 CHECK_BUFFER (buffer
);
1693 buf
= XBUFFER (buffer
);
1696 CHECK_SYMBOL (variable
);
1698 valcontents
= SYMBOL_VALUE (variable
);
1699 if (BUFFER_LOCAL_VALUEP (valcontents
)
1700 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1702 Lisp_Object tail
, elt
;
1704 variable
= indirect_variable (variable
);
1705 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1708 if (EQ (variable
, XCAR (elt
)))
1712 if (BUFFER_OBJFWDP (valcontents
))
1714 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1715 int idx
= PER_BUFFER_IDX (offset
);
1716 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1722 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1724 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
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
);
1742 valcontents
= SYMBOL_VALUE (variable
);
1744 /* This means that make-variable-buffer-local was done. */
1745 if (BUFFER_LOCAL_VALUEP (valcontents
))
1747 /* All these slots become local if they are set. */
1748 if (BUFFER_OBJFWDP (valcontents
))
1750 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1752 Lisp_Object tail
, elt
;
1753 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1756 if (EQ (variable
, XCAR (elt
)))
1763 /* Find the function at the end of a chain of symbol function indirections. */
1765 /* If OBJECT is a symbol, find the end of its function chain and
1766 return the value found there. If OBJECT is not a symbol, just
1767 return it. If there is a cycle in the function chain, signal a
1768 cyclic-function-indirection error.
1770 This is like Findirect_function, except that it doesn't signal an
1771 error if the chain ends up unbound. */
1773 indirect_function (object
)
1774 register Lisp_Object object
;
1776 Lisp_Object tortoise
, hare
;
1778 hare
= tortoise
= object
;
1782 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1784 hare
= XSYMBOL (hare
)->function
;
1785 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1787 hare
= XSYMBOL (hare
)->function
;
1789 tortoise
= XSYMBOL (tortoise
)->function
;
1791 if (EQ (hare
, tortoise
))
1792 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1798 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1799 doc
: /* Return the function at the end of OBJECT's function chain.
1800 If OBJECT is a symbol, follow all function indirections and return the final
1802 If OBJECT is not a symbol, just return it.
1803 Signal a void-function error if the final symbol is unbound.
1804 Signal a cyclic-function-indirection error if there is a loop in the
1805 function chain of symbols. */)
1807 register Lisp_Object object
;
1811 result
= indirect_function (object
);
1813 if (EQ (result
, Qunbound
))
1814 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1818 /* Extract and set vector and string elements */
1820 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1821 doc
: /* Return the element of ARRAY at index IDX.
1822 ARRAY may be a vector, a string, a char-table, a bool-vector,
1823 or a byte-code object. IDX starts at 0. */)
1825 register Lisp_Object array
;
1828 register int idxval
;
1831 idxval
= XINT (idx
);
1832 if (STRINGP (array
))
1836 if (idxval
< 0 || idxval
>= SCHARS (array
))
1837 args_out_of_range (array
, idx
);
1838 if (! STRING_MULTIBYTE (array
))
1839 return make_number ((unsigned char) SREF (array
, idxval
));
1840 idxval_byte
= string_char_to_byte (array
, idxval
);
1842 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1843 SBYTES (array
) - idxval_byte
);
1844 return make_number (c
);
1846 else if (BOOL_VECTOR_P (array
))
1850 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1851 args_out_of_range (array
, idx
);
1853 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1854 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1856 else if (CHAR_TABLE_P (array
))
1858 CHECK_CHARACTER (idx
);
1859 return CHAR_TABLE_REF (array
, idxval
);
1864 if (VECTORP (array
))
1865 size
= XVECTOR (array
)->size
;
1866 else if (COMPILEDP (array
))
1867 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1869 wrong_type_argument (Qarrayp
, array
);
1871 if (idxval
< 0 || idxval
>= size
)
1872 args_out_of_range (array
, idx
);
1873 return XVECTOR (array
)->contents
[idxval
];
1877 /* Don't use alloca for relocating string data larger than this, lest
1878 we overflow their stack. The value is the same as what used in
1879 fns.c for base64 handling. */
1880 #define MAX_ALLOCA 16*1024
1882 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1883 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1884 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
1885 bool-vector. IDX starts at 0. */)
1886 (array
, idx
, newelt
)
1887 register Lisp_Object array
;
1888 Lisp_Object idx
, newelt
;
1890 register int idxval
;
1893 idxval
= XINT (idx
);
1894 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1895 && ! CHAR_TABLE_P (array
))
1896 array
= wrong_type_argument (Qarrayp
, array
);
1897 CHECK_IMPURE (array
);
1899 if (VECTORP (array
))
1901 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1902 args_out_of_range (array
, idx
);
1903 XVECTOR (array
)->contents
[idxval
] = newelt
;
1905 else if (BOOL_VECTOR_P (array
))
1909 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1910 args_out_of_range (array
, idx
);
1912 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1914 if (! NILP (newelt
))
1915 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1917 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1918 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1920 else if (CHAR_TABLE_P (array
))
1922 CHECK_CHARACTER (idx
);
1923 CHAR_TABLE_SET (array
, idxval
, newelt
);
1925 else if (STRING_MULTIBYTE (array
))
1927 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
1928 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
1930 if (idxval
< 0 || idxval
>= SCHARS (array
))
1931 args_out_of_range (array
, idx
);
1932 CHECK_CHARACTER (newelt
);
1934 nbytes
= SBYTES (array
);
1936 idxval_byte
= string_char_to_byte (array
, idxval
);
1937 p1
= SDATA (array
) + idxval_byte
;
1938 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
1939 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
1940 if (prev_bytes
!= new_bytes
)
1942 /* We must relocate the string data. */
1943 int nchars
= SCHARS (array
);
1946 str
= (nbytes
<= MAX_ALLOCA
1947 ? (unsigned char *) alloca (nbytes
)
1948 : (unsigned char *) xmalloc (nbytes
));
1949 bcopy (SDATA (array
), str
, nbytes
);
1950 allocate_string_data (XSTRING (array
), nchars
,
1951 nbytes
+ new_bytes
- prev_bytes
);
1952 bcopy (str
, SDATA (array
), idxval_byte
);
1953 p1
= SDATA (array
) + idxval_byte
;
1954 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
1955 nbytes
- (idxval_byte
+ prev_bytes
));
1956 if (nbytes
> MAX_ALLOCA
)
1958 clear_string_char_byte_cache ();
1965 if (idxval
< 0 || idxval
>= SCHARS (array
))
1966 args_out_of_range (array
, idx
);
1967 CHECK_NUMBER (newelt
);
1969 if (XINT (newelt
) < 0 || ASCII_CHAR_P (XINT (newelt
))
1970 || CHAR_BYTE8_P (XINT (newelt
)))
1971 SSET (array
, idxval
, XINT (newelt
));
1974 /* We must relocate the string data while converting it to
1976 int idxval_byte
, prev_bytes
, new_bytes
;
1977 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
1978 unsigned char *origstr
= SDATA (array
), *str
;
1981 nchars
= SCHARS (array
);
1982 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
1983 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
1985 str
= (nbytes
<= MAX_ALLOCA
1986 ? (unsigned char *) alloca (nbytes
)
1987 : (unsigned char *) xmalloc (nbytes
));
1988 copy_text (SDATA (array
), str
, nchars
, 0, 1);
1989 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
1991 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
1992 allocate_string_data (XSTRING (array
), nchars
,
1993 nbytes
+ new_bytes
- prev_bytes
);
1994 bcopy (str
, SDATA (array
), idxval_byte
);
1995 p1
= SDATA (array
) + idxval_byte
;
1998 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
1999 nbytes
- (idxval_byte
+ prev_bytes
));
2000 if (nbytes
> MAX_ALLOCA
)
2002 clear_string_char_byte_cache ();
2009 /* Arithmetic functions */
2011 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2014 arithcompare (num1
, num2
, comparison
)
2015 Lisp_Object num1
, num2
;
2016 enum comparison comparison
;
2018 double f1
= 0, f2
= 0;
2021 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2022 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2024 if (FLOATP (num1
) || FLOATP (num2
))
2027 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2028 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2034 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2039 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2044 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2049 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2054 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2059 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2068 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2069 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2071 register Lisp_Object num1
, num2
;
2073 return arithcompare (num1
, num2
, equal
);
2076 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2077 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2079 register Lisp_Object num1
, num2
;
2081 return arithcompare (num1
, num2
, less
);
2084 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2085 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2087 register Lisp_Object num1
, num2
;
2089 return arithcompare (num1
, num2
, grtr
);
2092 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2093 doc
: /* Return t if first arg is less than or equal to second arg.
2094 Both must be numbers or markers. */)
2096 register Lisp_Object num1
, num2
;
2098 return arithcompare (num1
, num2
, less_or_equal
);
2101 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2102 doc
: /* Return t if first arg is greater than or equal to second arg.
2103 Both must be numbers or markers. */)
2105 register Lisp_Object num1
, num2
;
2107 return arithcompare (num1
, num2
, grtr_or_equal
);
2110 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2111 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2113 register Lisp_Object num1
, num2
;
2115 return arithcompare (num1
, num2
, notequal
);
2118 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2119 doc
: /* Return t if NUMBER is zero. */)
2121 register Lisp_Object number
;
2123 CHECK_NUMBER_OR_FLOAT (number
);
2125 if (FLOATP (number
))
2127 if (XFLOAT_DATA (number
) == 0.0)
2137 /* Convert between long values and pairs of Lisp integers. */
2143 unsigned long top
= i
>> 16;
2144 unsigned int bot
= i
& 0xFFFF;
2146 return make_number (bot
);
2147 if (top
== (unsigned long)-1 >> 16)
2148 return Fcons (make_number (-1), make_number (bot
));
2149 return Fcons (make_number (top
), make_number (bot
));
2156 Lisp_Object top
, bot
;
2163 return ((XINT (top
) << 16) | XINT (bot
));
2166 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2167 doc
: /* Return the decimal representation of NUMBER as a string.
2168 Uses a minus sign if negative.
2169 NUMBER may be an integer or a floating point number. */)
2173 char buffer
[VALBITS
];
2175 CHECK_NUMBER_OR_FLOAT (number
);
2177 if (FLOATP (number
))
2179 char pigbuf
[350]; /* see comments in float_to_string */
2181 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2182 return build_string (pigbuf
);
2185 if (sizeof (int) == sizeof (EMACS_INT
))
2186 sprintf (buffer
, "%d", XINT (number
));
2187 else if (sizeof (long) == sizeof (EMACS_INT
))
2188 sprintf (buffer
, "%ld", (long) XINT (number
));
2191 return build_string (buffer
);
2195 digit_to_number (character
, base
)
2196 int character
, base
;
2200 if (character
>= '0' && character
<= '9')
2201 digit
= character
- '0';
2202 else if (character
>= 'a' && character
<= 'z')
2203 digit
= character
- 'a' + 10;
2204 else if (character
>= 'A' && character
<= 'Z')
2205 digit
= character
- 'A' + 10;
2215 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2216 doc
: /* Parse STRING as a decimal number and return the number.
2217 This parses both integers and floating point numbers.
2218 It ignores leading spaces and tabs.
2220 If BASE, interpret STRING as a number in that base. If BASE isn't
2221 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2222 If the base used is not 10, floating point is not recognized. */)
2224 register Lisp_Object string
, base
;
2226 register unsigned char *p
;
2231 CHECK_STRING (string
);
2237 CHECK_NUMBER (base
);
2239 if (b
< 2 || b
> 16)
2240 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2243 /* Skip any whitespace at the front of the number. Some versions of
2244 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2246 while (*p
== ' ' || *p
== '\t')
2257 if (isfloat_string (p
) && b
== 10)
2258 val
= make_float (sign
* atof (p
));
2265 int digit
= digit_to_number (*p
++, b
);
2271 val
= make_fixnum_or_float (sign
* v
);
2291 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2292 int, Lisp_Object
*));
2293 extern Lisp_Object
fmod_float ();
2296 arith_driver (code
, nargs
, args
)
2299 register Lisp_Object
*args
;
2301 register Lisp_Object val
;
2302 register int argnum
;
2303 register EMACS_INT accum
= 0;
2304 register EMACS_INT next
;
2306 switch (SWITCH_ENUM_CAST (code
))
2324 for (argnum
= 0; argnum
< nargs
; argnum
++)
2326 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2328 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2331 return float_arith_driver ((double) accum
, argnum
, code
,
2334 next
= XINT (args
[argnum
]);
2335 switch (SWITCH_ENUM_CAST (code
))
2341 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2352 Fsignal (Qarith_error
, Qnil
);
2366 if (!argnum
|| next
> accum
)
2370 if (!argnum
|| next
< accum
)
2376 XSETINT (val
, accum
);
2381 #define isnan(x) ((x) != (x))
2384 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2386 register int argnum
;
2389 register Lisp_Object
*args
;
2391 register Lisp_Object val
;
2394 for (; argnum
< nargs
; argnum
++)
2396 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2397 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2401 next
= XFLOAT_DATA (val
);
2405 args
[argnum
] = val
; /* runs into a compiler bug. */
2406 next
= XINT (args
[argnum
]);
2408 switch (SWITCH_ENUM_CAST (code
))
2414 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2424 if (! IEEE_FLOATING_POINT
&& next
== 0)
2425 Fsignal (Qarith_error
, Qnil
);
2432 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2434 if (!argnum
|| isnan (next
) || next
> accum
)
2438 if (!argnum
|| isnan (next
) || next
< accum
)
2444 return make_float (accum
);
2448 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2449 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2450 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2455 return arith_driver (Aadd
, nargs
, args
);
2458 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2459 doc
: /* Negate number or subtract numbers or markers and return the result.
2460 With one arg, negates it. With more than one arg,
2461 subtracts all but the first from the first.
2462 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2467 return arith_driver (Asub
, nargs
, args
);
2470 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2471 doc
: /* Return product of any number of arguments, which are numbers or markers.
2472 usage: (* &rest NUMBERS-OR-MARKERS) */)
2477 return arith_driver (Amult
, nargs
, args
);
2480 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2481 doc
: /* Return first argument divided by all the remaining arguments.
2482 The arguments must be numbers or markers.
2483 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2488 return arith_driver (Adiv
, nargs
, args
);
2491 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2492 doc
: /* Return remainder of X divided by Y.
2493 Both must be integers or markers. */)
2495 register Lisp_Object x
, y
;
2499 CHECK_NUMBER_COERCE_MARKER (x
);
2500 CHECK_NUMBER_COERCE_MARKER (y
);
2502 if (XFASTINT (y
) == 0)
2503 Fsignal (Qarith_error
, Qnil
);
2505 XSETINT (val
, XINT (x
) % XINT (y
));
2519 /* If the magnitude of the result exceeds that of the divisor, or
2520 the sign of the result does not agree with that of the dividend,
2521 iterate with the reduced value. This does not yield a
2522 particularly accurate result, but at least it will be in the
2523 range promised by fmod. */
2525 r
-= f2
* floor (r
/ f2
);
2526 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2530 #endif /* ! HAVE_FMOD */
2532 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2533 doc
: /* Return X modulo Y.
2534 The result falls between zero (inclusive) and Y (exclusive).
2535 Both X and Y must be numbers or markers. */)
2537 register Lisp_Object x
, y
;
2542 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2543 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2545 if (FLOATP (x
) || FLOATP (y
))
2546 return fmod_float (x
, y
);
2552 Fsignal (Qarith_error
, Qnil
);
2556 /* If the "remainder" comes out with the wrong sign, fix it. */
2557 if (i2
< 0 ? i1
> 0 : i1
< 0)
2564 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2565 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2566 The value is always a number; markers are converted to numbers.
2567 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2572 return arith_driver (Amax
, nargs
, args
);
2575 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2576 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2577 The value is always a number; markers are converted to numbers.
2578 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2583 return arith_driver (Amin
, nargs
, args
);
2586 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2587 doc
: /* Return bitwise-and of all the arguments.
2588 Arguments may be integers, or markers converted to integers.
2589 usage: (logand &rest INTS-OR-MARKERS) */)
2594 return arith_driver (Alogand
, nargs
, args
);
2597 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2598 doc
: /* Return bitwise-or of all the arguments.
2599 Arguments may be integers, or markers converted to integers.
2600 usage: (logior &rest INTS-OR-MARKERS) */)
2605 return arith_driver (Alogior
, nargs
, args
);
2608 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2609 doc
: /* Return bitwise-exclusive-or of all the arguments.
2610 Arguments may be integers, or markers converted to integers.
2611 usage: (logxor &rest INTS-OR-MARKERS) */)
2616 return arith_driver (Alogxor
, nargs
, args
);
2619 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2620 doc
: /* Return VALUE with its bits shifted left by COUNT.
2621 If COUNT is negative, shifting is actually to the right.
2622 In this case, the sign bit is duplicated. */)
2624 register Lisp_Object value
, count
;
2626 register Lisp_Object val
;
2628 CHECK_NUMBER (value
);
2629 CHECK_NUMBER (count
);
2631 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2633 else if (XINT (count
) > 0)
2634 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2635 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2636 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2638 XSETINT (val
, XINT (value
) >> -XINT (count
));
2642 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2643 doc
: /* Return VALUE with its bits shifted left by COUNT.
2644 If COUNT is negative, shifting is actually to the right.
2645 In this case, zeros are shifted in on the left. */)
2647 register Lisp_Object value
, count
;
2649 register Lisp_Object val
;
2651 CHECK_NUMBER (value
);
2652 CHECK_NUMBER (count
);
2654 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2656 else if (XINT (count
) > 0)
2657 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2658 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2661 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2665 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2666 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2667 Markers are converted to integers. */)
2669 register Lisp_Object number
;
2671 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2673 if (FLOATP (number
))
2674 return (make_float (1.0 + XFLOAT_DATA (number
)));
2676 XSETINT (number
, XINT (number
) + 1);
2680 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2681 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2682 Markers are converted to integers. */)
2684 register Lisp_Object number
;
2686 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2688 if (FLOATP (number
))
2689 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2691 XSETINT (number
, XINT (number
) - 1);
2695 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2696 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2698 register Lisp_Object number
;
2700 CHECK_NUMBER (number
);
2701 XSETINT (number
, ~XINT (number
));
2708 Lisp_Object error_tail
, arith_tail
;
2710 Qquote
= intern ("quote");
2711 Qlambda
= intern ("lambda");
2712 Qsubr
= intern ("subr");
2713 Qerror_conditions
= intern ("error-conditions");
2714 Qerror_message
= intern ("error-message");
2715 Qtop_level
= intern ("top-level");
2717 Qerror
= intern ("error");
2718 Qquit
= intern ("quit");
2719 Qwrong_type_argument
= intern ("wrong-type-argument");
2720 Qargs_out_of_range
= intern ("args-out-of-range");
2721 Qvoid_function
= intern ("void-function");
2722 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2723 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2724 Qvoid_variable
= intern ("void-variable");
2725 Qsetting_constant
= intern ("setting-constant");
2726 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2728 Qinvalid_function
= intern ("invalid-function");
2729 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2730 Qno_catch
= intern ("no-catch");
2731 Qend_of_file
= intern ("end-of-file");
2732 Qarith_error
= intern ("arith-error");
2733 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2734 Qend_of_buffer
= intern ("end-of-buffer");
2735 Qbuffer_read_only
= intern ("buffer-read-only");
2736 Qtext_read_only
= intern ("text-read-only");
2737 Qmark_inactive
= intern ("mark-inactive");
2739 Qlistp
= intern ("listp");
2740 Qconsp
= intern ("consp");
2741 Qsymbolp
= intern ("symbolp");
2742 Qkeywordp
= intern ("keywordp");
2743 Qintegerp
= intern ("integerp");
2744 Qnatnump
= intern ("natnump");
2745 Qwholenump
= intern ("wholenump");
2746 Qstringp
= intern ("stringp");
2747 Qarrayp
= intern ("arrayp");
2748 Qsequencep
= intern ("sequencep");
2749 Qbufferp
= intern ("bufferp");
2750 Qvectorp
= intern ("vectorp");
2751 Qchar_or_string_p
= intern ("char-or-string-p");
2752 Qmarkerp
= intern ("markerp");
2753 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2754 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2755 Qboundp
= intern ("boundp");
2756 Qfboundp
= intern ("fboundp");
2758 Qfloatp
= intern ("floatp");
2759 Qnumberp
= intern ("numberp");
2760 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2762 Qchar_table_p
= intern ("char-table-p");
2763 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2765 Qsubrp
= intern ("subrp");
2766 Qunevalled
= intern ("unevalled");
2767 Qmany
= intern ("many");
2769 Qcdr
= intern ("cdr");
2771 /* Handle automatic advice activation */
2772 Qad_advice_info
= intern ("ad-advice-info");
2773 Qad_activate_internal
= intern ("ad-activate-internal");
2775 error_tail
= Fcons (Qerror
, Qnil
);
2777 /* ERROR is used as a signaler for random errors for which nothing else is right */
2779 Fput (Qerror
, Qerror_conditions
,
2781 Fput (Qerror
, Qerror_message
,
2782 build_string ("error"));
2784 Fput (Qquit
, Qerror_conditions
,
2785 Fcons (Qquit
, Qnil
));
2786 Fput (Qquit
, Qerror_message
,
2787 build_string ("Quit"));
2789 Fput (Qwrong_type_argument
, Qerror_conditions
,
2790 Fcons (Qwrong_type_argument
, error_tail
));
2791 Fput (Qwrong_type_argument
, Qerror_message
,
2792 build_string ("Wrong type argument"));
2794 Fput (Qargs_out_of_range
, Qerror_conditions
,
2795 Fcons (Qargs_out_of_range
, error_tail
));
2796 Fput (Qargs_out_of_range
, Qerror_message
,
2797 build_string ("Args out of range"));
2799 Fput (Qvoid_function
, Qerror_conditions
,
2800 Fcons (Qvoid_function
, error_tail
));
2801 Fput (Qvoid_function
, Qerror_message
,
2802 build_string ("Symbol's function definition is void"));
2804 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2805 Fcons (Qcyclic_function_indirection
, error_tail
));
2806 Fput (Qcyclic_function_indirection
, Qerror_message
,
2807 build_string ("Symbol's chain of function indirections contains a loop"));
2809 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2810 Fcons (Qcyclic_variable_indirection
, error_tail
));
2811 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2812 build_string ("Symbol's chain of variable indirections contains a loop"));
2814 Qcircular_list
= intern ("circular-list");
2815 staticpro (&Qcircular_list
);
2816 Fput (Qcircular_list
, Qerror_conditions
,
2817 Fcons (Qcircular_list
, error_tail
));
2818 Fput (Qcircular_list
, Qerror_message
,
2819 build_string ("List contains a loop"));
2821 Fput (Qvoid_variable
, Qerror_conditions
,
2822 Fcons (Qvoid_variable
, error_tail
));
2823 Fput (Qvoid_variable
, Qerror_message
,
2824 build_string ("Symbol's value as variable is void"));
2826 Fput (Qsetting_constant
, Qerror_conditions
,
2827 Fcons (Qsetting_constant
, error_tail
));
2828 Fput (Qsetting_constant
, Qerror_message
,
2829 build_string ("Attempt to set a constant symbol"));
2831 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2832 Fcons (Qinvalid_read_syntax
, error_tail
));
2833 Fput (Qinvalid_read_syntax
, Qerror_message
,
2834 build_string ("Invalid read syntax"));
2836 Fput (Qinvalid_function
, Qerror_conditions
,
2837 Fcons (Qinvalid_function
, error_tail
));
2838 Fput (Qinvalid_function
, Qerror_message
,
2839 build_string ("Invalid function"));
2841 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2842 Fcons (Qwrong_number_of_arguments
, error_tail
));
2843 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2844 build_string ("Wrong number of arguments"));
2846 Fput (Qno_catch
, Qerror_conditions
,
2847 Fcons (Qno_catch
, error_tail
));
2848 Fput (Qno_catch
, Qerror_message
,
2849 build_string ("No catch for tag"));
2851 Fput (Qend_of_file
, Qerror_conditions
,
2852 Fcons (Qend_of_file
, error_tail
));
2853 Fput (Qend_of_file
, Qerror_message
,
2854 build_string ("End of file during parsing"));
2856 arith_tail
= Fcons (Qarith_error
, error_tail
);
2857 Fput (Qarith_error
, Qerror_conditions
,
2859 Fput (Qarith_error
, Qerror_message
,
2860 build_string ("Arithmetic error"));
2862 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2863 Fcons (Qbeginning_of_buffer
, error_tail
));
2864 Fput (Qbeginning_of_buffer
, Qerror_message
,
2865 build_string ("Beginning of buffer"));
2867 Fput (Qend_of_buffer
, Qerror_conditions
,
2868 Fcons (Qend_of_buffer
, error_tail
));
2869 Fput (Qend_of_buffer
, Qerror_message
,
2870 build_string ("End of buffer"));
2872 Fput (Qbuffer_read_only
, Qerror_conditions
,
2873 Fcons (Qbuffer_read_only
, error_tail
));
2874 Fput (Qbuffer_read_only
, Qerror_message
,
2875 build_string ("Buffer is read-only"));
2877 Fput (Qtext_read_only
, Qerror_conditions
,
2878 Fcons (Qtext_read_only
, error_tail
));
2879 Fput (Qtext_read_only
, Qerror_message
,
2880 build_string ("Text is read-only"));
2882 Qrange_error
= intern ("range-error");
2883 Qdomain_error
= intern ("domain-error");
2884 Qsingularity_error
= intern ("singularity-error");
2885 Qoverflow_error
= intern ("overflow-error");
2886 Qunderflow_error
= intern ("underflow-error");
2888 Fput (Qdomain_error
, Qerror_conditions
,
2889 Fcons (Qdomain_error
, arith_tail
));
2890 Fput (Qdomain_error
, Qerror_message
,
2891 build_string ("Arithmetic domain error"));
2893 Fput (Qrange_error
, Qerror_conditions
,
2894 Fcons (Qrange_error
, arith_tail
));
2895 Fput (Qrange_error
, Qerror_message
,
2896 build_string ("Arithmetic range error"));
2898 Fput (Qsingularity_error
, Qerror_conditions
,
2899 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2900 Fput (Qsingularity_error
, Qerror_message
,
2901 build_string ("Arithmetic singularity error"));
2903 Fput (Qoverflow_error
, Qerror_conditions
,
2904 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2905 Fput (Qoverflow_error
, Qerror_message
,
2906 build_string ("Arithmetic overflow error"));
2908 Fput (Qunderflow_error
, Qerror_conditions
,
2909 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2910 Fput (Qunderflow_error
, Qerror_message
,
2911 build_string ("Arithmetic underflow error"));
2913 staticpro (&Qrange_error
);
2914 staticpro (&Qdomain_error
);
2915 staticpro (&Qsingularity_error
);
2916 staticpro (&Qoverflow_error
);
2917 staticpro (&Qunderflow_error
);
2921 staticpro (&Qquote
);
2922 staticpro (&Qlambda
);
2924 staticpro (&Qunbound
);
2925 staticpro (&Qerror_conditions
);
2926 staticpro (&Qerror_message
);
2927 staticpro (&Qtop_level
);
2929 staticpro (&Qerror
);
2931 staticpro (&Qwrong_type_argument
);
2932 staticpro (&Qargs_out_of_range
);
2933 staticpro (&Qvoid_function
);
2934 staticpro (&Qcyclic_function_indirection
);
2935 staticpro (&Qvoid_variable
);
2936 staticpro (&Qsetting_constant
);
2937 staticpro (&Qinvalid_read_syntax
);
2938 staticpro (&Qwrong_number_of_arguments
);
2939 staticpro (&Qinvalid_function
);
2940 staticpro (&Qno_catch
);
2941 staticpro (&Qend_of_file
);
2942 staticpro (&Qarith_error
);
2943 staticpro (&Qbeginning_of_buffer
);
2944 staticpro (&Qend_of_buffer
);
2945 staticpro (&Qbuffer_read_only
);
2946 staticpro (&Qtext_read_only
);
2947 staticpro (&Qmark_inactive
);
2949 staticpro (&Qlistp
);
2950 staticpro (&Qconsp
);
2951 staticpro (&Qsymbolp
);
2952 staticpro (&Qkeywordp
);
2953 staticpro (&Qintegerp
);
2954 staticpro (&Qnatnump
);
2955 staticpro (&Qwholenump
);
2956 staticpro (&Qstringp
);
2957 staticpro (&Qarrayp
);
2958 staticpro (&Qsequencep
);
2959 staticpro (&Qbufferp
);
2960 staticpro (&Qvectorp
);
2961 staticpro (&Qchar_or_string_p
);
2962 staticpro (&Qmarkerp
);
2963 staticpro (&Qbuffer_or_string_p
);
2964 staticpro (&Qinteger_or_marker_p
);
2965 staticpro (&Qfloatp
);
2966 staticpro (&Qnumberp
);
2967 staticpro (&Qnumber_or_marker_p
);
2968 staticpro (&Qchar_table_p
);
2969 staticpro (&Qvector_or_char_table_p
);
2970 staticpro (&Qsubrp
);
2972 staticpro (&Qunevalled
);
2974 staticpro (&Qboundp
);
2975 staticpro (&Qfboundp
);
2977 staticpro (&Qad_advice_info
);
2978 staticpro (&Qad_activate_internal
);
2980 /* Types that type-of returns. */
2981 Qinteger
= intern ("integer");
2982 Qsymbol
= intern ("symbol");
2983 Qstring
= intern ("string");
2984 Qcons
= intern ("cons");
2985 Qmarker
= intern ("marker");
2986 Qoverlay
= intern ("overlay");
2987 Qfloat
= intern ("float");
2988 Qwindow_configuration
= intern ("window-configuration");
2989 Qprocess
= intern ("process");
2990 Qwindow
= intern ("window");
2991 /* Qsubr = intern ("subr"); */
2992 Qcompiled_function
= intern ("compiled-function");
2993 Qbuffer
= intern ("buffer");
2994 Qframe
= intern ("frame");
2995 Qvector
= intern ("vector");
2996 Qchar_table
= intern ("char-table");
2997 Qbool_vector
= intern ("bool-vector");
2998 Qhash_table
= intern ("hash-table");
3000 staticpro (&Qinteger
);
3001 staticpro (&Qsymbol
);
3002 staticpro (&Qstring
);
3004 staticpro (&Qmarker
);
3005 staticpro (&Qoverlay
);
3006 staticpro (&Qfloat
);
3007 staticpro (&Qwindow_configuration
);
3008 staticpro (&Qprocess
);
3009 staticpro (&Qwindow
);
3010 /* staticpro (&Qsubr); */
3011 staticpro (&Qcompiled_function
);
3012 staticpro (&Qbuffer
);
3013 staticpro (&Qframe
);
3014 staticpro (&Qvector
);
3015 staticpro (&Qchar_table
);
3016 staticpro (&Qbool_vector
);
3017 staticpro (&Qhash_table
);
3019 defsubr (&Sindirect_variable
);
3020 defsubr (&Ssubr_interactive_form
);
3023 defsubr (&Stype_of
);
3028 defsubr (&Sintegerp
);
3029 defsubr (&Sinteger_or_marker_p
);
3030 defsubr (&Snumberp
);
3031 defsubr (&Snumber_or_marker_p
);
3033 defsubr (&Snatnump
);
3034 defsubr (&Ssymbolp
);
3035 defsubr (&Skeywordp
);
3036 defsubr (&Sstringp
);
3037 defsubr (&Smultibyte_string_p
);
3038 defsubr (&Svectorp
);
3039 defsubr (&Schar_table_p
);
3040 defsubr (&Svector_or_char_table_p
);
3041 defsubr (&Sbool_vector_p
);
3043 defsubr (&Ssequencep
);
3044 defsubr (&Sbufferp
);
3045 defsubr (&Smarkerp
);
3047 defsubr (&Sbyte_code_function_p
);
3048 defsubr (&Schar_or_string_p
);
3051 defsubr (&Scar_safe
);
3052 defsubr (&Scdr_safe
);
3055 defsubr (&Ssymbol_function
);
3056 defsubr (&Sindirect_function
);
3057 defsubr (&Ssymbol_plist
);
3058 defsubr (&Ssymbol_name
);
3059 defsubr (&Smakunbound
);
3060 defsubr (&Sfmakunbound
);
3062 defsubr (&Sfboundp
);
3064 defsubr (&Sdefalias
);
3065 defsubr (&Ssetplist
);
3066 defsubr (&Ssymbol_value
);
3068 defsubr (&Sdefault_boundp
);
3069 defsubr (&Sdefault_value
);
3070 defsubr (&Sset_default
);
3071 defsubr (&Ssetq_default
);
3072 defsubr (&Smake_variable_buffer_local
);
3073 defsubr (&Smake_local_variable
);
3074 defsubr (&Skill_local_variable
);
3075 defsubr (&Smake_variable_frame_local
);
3076 defsubr (&Slocal_variable_p
);
3077 defsubr (&Slocal_variable_if_set_p
);
3080 defsubr (&Snumber_to_string
);
3081 defsubr (&Sstring_to_number
);
3082 defsubr (&Seqlsign
);
3105 defsubr (&Ssubr_arity
);
3107 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3109 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3110 doc
: /* The largest value that is representable in a Lisp integer. */);
3111 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3113 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3114 doc
: /* The smallest value that is representable in a Lisp integer. */);
3115 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3122 #if defined(USG) && !defined(POSIX_SIGNALS)
3123 /* USG systems forget handlers when they are used;
3124 must reestablish each time */
3125 signal (signo
, arith_error
);
3128 /* VMS systems are like USG. */
3129 signal (signo
, arith_error
);
3133 #else /* not BSD4_1 */
3134 sigsetmask (SIGEMPTYMASK
);
3135 #endif /* not BSD4_1 */
3137 Fsignal (Qarith_error
, Qnil
);
3143 /* Don't do this if just dumping out.
3144 We don't want to call `signal' in this case
3145 so that we don't have trouble with dumping
3146 signal-delivering routines in an inconsistent state. */
3150 #endif /* CANNOT_DUMP */
3151 signal (SIGFPE
, arith_error
);
3154 signal (SIGEMT
, arith_error
);