1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
32 #include "syssignal.h"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
;
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
));
100 wrong_type_argument (predicate
, value
)
101 register Lisp_Object predicate
, value
;
103 register Lisp_Object tem
;
106 if (!EQ (Vmocklisp_arguments
, Qt
))
108 if (STRINGP (value
) &&
109 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
110 return Fstring_to_number (value
, Qnil
);
111 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
112 return Fnumber_to_string (value
);
115 /* If VALUE is not even a valid Lisp object, abort here
116 where we can get a backtrace showing where it came from. */
117 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
120 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
121 tem
= call1 (predicate
, value
);
130 error ("Attempt to modify read-only object");
134 args_out_of_range (a1
, a2
)
138 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
142 args_out_of_range_3 (a1
, a2
, a3
)
143 Lisp_Object a1
, a2
, a3
;
146 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
149 /* On some machines, XINT needs a temporary location.
150 Here it is, in case it is needed. */
152 int sign_extend_temp
;
154 /* On a few machines, XINT can only be done by calling this. */
157 sign_extend_lisp_int (num
)
160 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
161 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
163 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
166 /* Data type predicates */
168 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
169 "Return t if the two args are the same Lisp object.")
171 Lisp_Object obj1
, obj2
;
178 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
187 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
188 "Return a symbol representing the type of OBJECT.\n\
189 The symbol returned names the object's basic type;\n\
190 for example, (type-of 1) returns `integer'.")
194 switch (XGCTYPE (object
))
209 switch (XMISCTYPE (object
))
211 case Lisp_Misc_Marker
:
213 case Lisp_Misc_Overlay
:
215 case Lisp_Misc_Float
:
220 case Lisp_Vectorlike
:
221 if (GC_WINDOW_CONFIGURATIONP (object
))
222 return Qwindow_configuration
;
223 if (GC_PROCESSP (object
))
225 if (GC_WINDOWP (object
))
227 if (GC_SUBRP (object
))
229 if (GC_COMPILEDP (object
))
230 return Qcompiled_function
;
231 if (GC_BUFFERP (object
))
233 if (GC_CHAR_TABLE_P (object
))
235 if (GC_BOOL_VECTOR_P (object
))
237 if (GC_FRAMEP (object
))
239 if (GC_HASH_TABLE_P (object
))
251 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
260 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
261 "Return t if OBJECT is not a cons cell. This includes nil.")
270 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
271 "Return t if OBJECT is a list. This includes nil.")
275 if (CONSP (object
) || NILP (object
))
280 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
281 "Return t if OBJECT is not a list. Lists include nil.")
285 if (CONSP (object
) || NILP (object
))
290 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
291 "Return t if OBJECT is a symbol.")
295 if (SYMBOLP (object
))
300 /* Define this in C to avoid unnecessarily consing up the symbol
302 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
303 "Return t if OBJECT is a keyword.\n\
304 This means that it is a symbol with a print name beginning with `:'\n\
305 interned in the initial obarray.")
310 && XSYMBOL (object
)->name
->data
[0] == ':'
311 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
316 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
317 "Return t if OBJECT is a vector.")
321 if (VECTORP (object
))
326 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
327 "Return t if OBJECT is a string.")
331 if (STRINGP (object
))
336 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
337 1, 1, 0, "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 "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 "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, "Return t if OBJECT is a bool-vector.")
371 if (BOOL_VECTOR_P (object
))
376 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
380 if (VECTORP (object
) || STRINGP (object
)
381 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
386 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
387 "Return t if OBJECT is a sequence (list or array).")
389 register Lisp_Object object
;
391 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
392 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
397 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
401 if (BUFFERP (object
))
406 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
410 if (MARKERP (object
))
415 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
424 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
425 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
429 if (COMPILEDP (object
))
434 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
435 "Return t if OBJECT is a character (an integer) or a string.")
437 register Lisp_Object object
;
439 if (INTEGERP (object
) || STRINGP (object
))
444 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
448 if (INTEGERP (object
))
453 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
454 "Return t if OBJECT is an integer or a marker (editor pointer).")
456 register Lisp_Object object
;
458 if (MARKERP (object
) || INTEGERP (object
))
463 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
464 "Return t if OBJECT is a nonnegative integer.")
468 if (NATNUMP (object
))
473 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
474 "Return t if OBJECT is a number (floating point or integer).")
478 if (NUMBERP (object
))
484 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
485 Snumber_or_marker_p
, 1, 1, 0,
486 "Return t if OBJECT is a number or a marker.")
490 if (NUMBERP (object
) || MARKERP (object
))
495 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
496 "Return t if OBJECT is a floating point number.")
506 /* Extract and set components of lists */
508 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
509 "Return the car of LIST. If arg is nil, return nil.\n\
510 Error if arg is not nil and not a cons cell. See also `car-safe'.")
512 register Lisp_Object list
;
518 else if (EQ (list
, Qnil
))
521 list
= wrong_type_argument (Qlistp
, list
);
525 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
526 "Return the car of OBJECT if it is a cons cell, or else nil.")
531 return XCAR (object
);
536 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
537 "Return the cdr of LIST. If arg is nil, return nil.\n\
538 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
541 register Lisp_Object list
;
547 else if (EQ (list
, Qnil
))
550 list
= wrong_type_argument (Qlistp
, list
);
554 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
555 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
560 return XCDR (object
);
565 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
566 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
568 register Lisp_Object cell
, newcar
;
571 cell
= wrong_type_argument (Qconsp
, cell
);
574 XCAR (cell
) = newcar
;
578 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
579 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
581 register Lisp_Object cell
, newcdr
;
584 cell
= wrong_type_argument (Qconsp
, cell
);
587 XCDR (cell
) = newcdr
;
591 /* Extract and set components of symbols */
593 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
595 register Lisp_Object symbol
;
597 Lisp_Object valcontents
;
598 CHECK_SYMBOL (symbol
, 0);
600 valcontents
= SYMBOL_VALUE (symbol
);
602 if (BUFFER_LOCAL_VALUEP (valcontents
)
603 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
604 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
606 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
609 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
611 register Lisp_Object symbol
;
613 CHECK_SYMBOL (symbol
, 0);
614 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
617 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
619 register Lisp_Object symbol
;
621 CHECK_SYMBOL (symbol
, 0);
622 if (XSYMBOL (symbol
)->constant
)
623 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
624 Fset (symbol
, Qunbound
);
628 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
630 register Lisp_Object symbol
;
632 CHECK_SYMBOL (symbol
, 0);
633 if (NILP (symbol
) || EQ (symbol
, Qt
))
634 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
635 XSYMBOL (symbol
)->function
= Qunbound
;
639 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
640 "Return SYMBOL's function definition. Error if that is void.")
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
, 0);
645 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
646 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
647 return XSYMBOL (symbol
)->function
;
650 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
652 register Lisp_Object symbol
;
654 CHECK_SYMBOL (symbol
, 0);
655 return XSYMBOL (symbol
)->plist
;
658 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
660 register Lisp_Object symbol
;
662 register Lisp_Object name
;
664 CHECK_SYMBOL (symbol
, 0);
665 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
669 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
670 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
672 register Lisp_Object symbol
, definition
;
674 CHECK_SYMBOL (symbol
, 0);
675 if (NILP (symbol
) || EQ (symbol
, Qt
))
676 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
677 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
678 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
680 XSYMBOL (symbol
)->function
= definition
;
681 /* Handle automatic advice activation */
682 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
684 call2 (Qad_activate_internal
, symbol
, Qnil
);
685 definition
= XSYMBOL (symbol
)->function
;
690 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
691 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
692 Associates the function with the current load file, if any.")
694 register Lisp_Object symbol
, definition
;
696 definition
= Ffset (symbol
, definition
);
697 LOADHIST_ATTACH (symbol
);
701 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
702 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
704 register Lisp_Object symbol
, newplist
;
706 CHECK_SYMBOL (symbol
, 0);
707 XSYMBOL (symbol
)->plist
= newplist
;
711 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
712 "Return minimum and maximum number of args allowed for SUBR.\n\
713 SUBR must be a built-in function.\n\
714 The returned value is a pair (MIN . MAX). MIN is the minimum number\n\
715 of args. MAX is the maximum number or the symbol `many', for a\n\
716 function with `&rest' args, or `unevalled' for a special form.")
720 short minargs
, maxargs
;
722 wrong_type_argument (Qsubrp
, subr
);
723 minargs
= XSUBR (subr
)->min_args
;
724 maxargs
= XSUBR (subr
)->max_args
;
726 return Fcons (make_number (minargs
), Qmany
);
727 else if (maxargs
== UNEVALLED
)
728 return Fcons (make_number (minargs
), Qunevalled
);
730 return Fcons (make_number (minargs
), make_number (maxargs
));
733 DEFUN ("subr-interactive-form", Fsubr_interactive_form
, Ssubr_interactive_form
, 1, 1, 0,
734 "Return the interactive form of SUBR or nil if none.\n\
735 SUBR must be a built-in function. Value, if non-nil, is a list\n\
736 \(interactive SPEC).")
741 wrong_type_argument (Qsubrp
, subr
);
742 if (XSUBR (subr
)->prompt
)
743 return list2 (Qinteractive
, build_string (XSUBR (subr
)->prompt
));
748 /***********************************************************************
749 Getting and Setting Values of Symbols
750 ***********************************************************************/
752 /* Return the symbol holding SYMBOL's value. Signal
753 `cyclic-variable-indirection' if SYMBOL's chain of variable
754 indirections contains a loop. */
757 indirect_variable (symbol
)
760 Lisp_Object tortoise
, hare
;
762 hare
= tortoise
= symbol
;
764 while (XSYMBOL (hare
)->indirect_variable
)
766 hare
= XSYMBOL (hare
)->value
;
767 if (!XSYMBOL (hare
)->indirect_variable
)
770 hare
= XSYMBOL (hare
)->value
;
771 tortoise
= XSYMBOL (tortoise
)->value
;
773 if (EQ (hare
, tortoise
))
774 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
781 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
782 "Return the variable at the end of OBJECT's variable chain.\n\
783 If OBJECT is a symbol, follow all variable indirections and return the final\n\
784 variable. If OBJECT is not a symbol, just return it.\n\
785 Signal a cyclic-variable-indirection error if there is a loop in the\n\
786 variable chain of symbols.")
790 if (SYMBOLP (object
))
791 object
= indirect_variable (object
);
796 /* Given the raw contents of a symbol value cell,
797 return the Lisp value of the symbol.
798 This does not handle buffer-local variables; use
799 swap_in_symval_forwarding for that. */
802 do_symval_forwarding (valcontents
)
803 register Lisp_Object valcontents
;
805 register Lisp_Object val
;
807 if (MISCP (valcontents
))
808 switch (XMISCTYPE (valcontents
))
810 case Lisp_Misc_Intfwd
:
811 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
814 case Lisp_Misc_Boolfwd
:
815 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
817 case Lisp_Misc_Objfwd
:
818 return *XOBJFWD (valcontents
)->objvar
;
820 case Lisp_Misc_Buffer_Objfwd
:
821 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
822 return PER_BUFFER_VALUE (current_buffer
, offset
);
824 case Lisp_Misc_Kboard_Objfwd
:
825 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
826 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
831 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
832 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
833 buffer-independent contents of the value cell: forwarded just one
834 step past the buffer-localness.
836 BUF non-zero means set the value in buffer BUF instead of the
837 current buffer. This only plays a role for per-buffer variables. */
840 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
842 register Lisp_Object valcontents
, newval
;
845 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
848 switch (XMISCTYPE (valcontents
))
850 case Lisp_Misc_Intfwd
:
851 CHECK_NUMBER (newval
, 1);
852 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
853 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
854 error ("Value out of range for variable `%s'",
855 XSYMBOL (symbol
)->name
->data
);
858 case Lisp_Misc_Boolfwd
:
859 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
862 case Lisp_Misc_Objfwd
:
863 *XOBJFWD (valcontents
)->objvar
= newval
;
866 case Lisp_Misc_Buffer_Objfwd
:
868 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
871 type
= PER_BUFFER_TYPE (offset
);
872 if (XINT (type
) == -1)
873 error ("Variable %s is read-only", XSYMBOL (symbol
)->name
->data
);
875 if (! NILP (type
) && ! NILP (newval
)
876 && XTYPE (newval
) != XINT (type
))
877 buffer_slot_type_mismatch (offset
);
880 buf
= current_buffer
;
881 PER_BUFFER_VALUE (buf
, offset
) = newval
;
885 case Lisp_Misc_Kboard_Objfwd
:
887 char *base
= (char *) current_kboard
;
888 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
889 *(Lisp_Object
*) p
= newval
;
900 valcontents
= SYMBOL_VALUE (symbol
);
901 if (BUFFER_LOCAL_VALUEP (valcontents
)
902 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
903 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
905 SET_SYMBOL_VALUE (symbol
, newval
);
909 /* Set up SYMBOL to refer to its global binding.
910 This makes it safe to alter the status of other bindings. */
913 swap_in_global_binding (symbol
)
916 Lisp_Object valcontents
, cdr
;
918 valcontents
= SYMBOL_VALUE (symbol
);
919 if (!BUFFER_LOCAL_VALUEP (valcontents
)
920 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
922 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
924 /* Unload the previously loaded binding. */
926 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
928 /* Select the global binding in the symbol. */
930 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
932 /* Indicate that the global binding is set up now. */
933 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
934 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
935 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
936 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
939 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
940 VALCONTENTS is the contents of its value cell,
941 which points to a struct Lisp_Buffer_Local_Value.
943 Return the value forwarded one step past the buffer-local stage.
944 This could be another forwarding pointer. */
947 swap_in_symval_forwarding (symbol
, valcontents
)
948 Lisp_Object symbol
, valcontents
;
950 register Lisp_Object tem1
;
952 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
955 || current_buffer
!= XBUFFER (tem1
)
956 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
957 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
959 if (XSYMBOL (symbol
)->indirect_variable
)
960 symbol
= indirect_variable (symbol
);
962 /* Unload the previously loaded binding. */
963 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
965 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
966 /* Choose the new binding. */
967 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
968 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
969 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
972 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
973 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
975 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
977 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
980 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
982 /* Load the new binding. */
983 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = tem1
;
984 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
985 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
986 store_symval_forwarding (symbol
,
987 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
990 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
993 /* Find the value of a symbol, returning Qunbound if it's not bound.
994 This is helpful for code which just wants to get a variable's value
995 if it has one, without signaling an error.
996 Note that it must not be possible to quit
997 within this function. Great care is required for this. */
1000 find_symbol_value (symbol
)
1003 register Lisp_Object valcontents
;
1004 register Lisp_Object val
;
1006 CHECK_SYMBOL (symbol
, 0);
1007 valcontents
= SYMBOL_VALUE (symbol
);
1009 if (BUFFER_LOCAL_VALUEP (valcontents
)
1010 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1011 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1013 if (MISCP (valcontents
))
1015 switch (XMISCTYPE (valcontents
))
1017 case Lisp_Misc_Intfwd
:
1018 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1021 case Lisp_Misc_Boolfwd
:
1022 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1024 case Lisp_Misc_Objfwd
:
1025 return *XOBJFWD (valcontents
)->objvar
;
1027 case Lisp_Misc_Buffer_Objfwd
:
1028 return PER_BUFFER_VALUE (current_buffer
,
1029 XBUFFER_OBJFWD (valcontents
)->offset
);
1031 case Lisp_Misc_Kboard_Objfwd
:
1032 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1033 + (char *)current_kboard
);
1040 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1041 "Return SYMBOL's value. Error if that is void.")
1047 val
= find_symbol_value (symbol
);
1048 if (EQ (val
, Qunbound
))
1049 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1054 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1055 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
1057 register Lisp_Object symbol
, newval
;
1059 return set_internal (symbol
, newval
, current_buffer
, 0);
1062 /* Return 1 if SYMBOL currently has a let-binding
1063 which was made in the buffer that is now current. */
1066 let_shadows_buffer_binding_p (symbol
)
1069 struct specbinding
*p
;
1071 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1073 && CONSP (p
->symbol
))
1075 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1076 if ((EQ (symbol
, let_bound_symbol
)
1077 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1078 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1079 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1083 return p
>= specpdl
;
1086 /* Store the value NEWVAL into SYMBOL.
1087 If buffer-locality is an issue, BUF specifies which buffer to use.
1088 (0 stands for the current buffer.)
1090 If BINDFLAG is zero, then if this symbol is supposed to become
1091 local in every buffer where it is set, then we make it local.
1092 If BINDFLAG is nonzero, we don't do that. */
1095 set_internal (symbol
, newval
, buf
, bindflag
)
1096 register Lisp_Object symbol
, newval
;
1100 int voide
= EQ (newval
, Qunbound
);
1102 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1105 buf
= current_buffer
;
1107 /* If restoring in a dead buffer, do nothing. */
1108 if (NILP (buf
->name
))
1111 CHECK_SYMBOL (symbol
, 0);
1112 if (SYMBOL_CONSTANT_P (symbol
)
1113 && (NILP (Fkeywordp (symbol
))
1114 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1115 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1117 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1119 if (BUFFER_OBJFWDP (valcontents
))
1121 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1122 int idx
= PER_BUFFER_IDX (offset
);
1125 && !let_shadows_buffer_binding_p (symbol
))
1126 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1128 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1129 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1131 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1132 if (XSYMBOL (symbol
)->indirect_variable
)
1133 symbol
= indirect_variable (symbol
);
1135 /* What binding is loaded right now? */
1136 current_alist_element
1137 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1139 /* If the current buffer is not the buffer whose binding is
1140 loaded, or if there may be frame-local bindings and the frame
1141 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1142 the default binding is loaded, the loaded binding may be the
1144 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1145 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1146 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1147 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1148 || (BUFFER_LOCAL_VALUEP (valcontents
)
1149 && EQ (XCAR (current_alist_element
),
1150 current_alist_element
)))
1152 /* The currently loaded binding is not necessarily valid.
1153 We need to unload it, and choose a new binding. */
1155 /* Write out `realvalue' to the old loaded binding. */
1156 Fsetcdr (current_alist_element
,
1157 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1159 /* Find the new binding. */
1160 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1161 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1162 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1166 /* This buffer still sees the default value. */
1168 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1169 or if this is `let' rather than `set',
1170 make CURRENT-ALIST-ELEMENT point to itself,
1171 indicating that we're seeing the default value.
1172 Likewise if the variable has been let-bound
1173 in the current buffer. */
1174 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1175 || let_shadows_buffer_binding_p (symbol
))
1177 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1179 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1180 tem1
= Fassq (symbol
,
1181 XFRAME (selected_frame
)->param_alist
);
1184 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1186 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1188 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1189 and we're not within a let that was made for this buffer,
1190 create a new buffer-local binding for the variable.
1191 That means, give this buffer a new assoc for a local value
1192 and load that binding. */
1195 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1196 buf
->local_var_alist
1197 = Fcons (tem1
, buf
->local_var_alist
);
1201 /* Record which binding is now loaded. */
1202 XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)
1205 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1206 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1207 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1209 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1212 /* If storing void (making the symbol void), forward only through
1213 buffer-local indicator, not through Lisp_Objfwd, etc. */
1215 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1217 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1219 /* If we just set a variable whose current binding is frame-local,
1220 store the new value in the frame parameter too. */
1222 if (BUFFER_LOCAL_VALUEP (valcontents
)
1223 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1225 /* What binding is loaded right now? */
1226 current_alist_element
1227 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1229 /* If the current buffer is not the buffer whose binding is
1230 loaded, or if there may be frame-local bindings and the frame
1231 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1232 the default binding is loaded, the loaded binding may be the
1234 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1235 XCDR (current_alist_element
) = newval
;
1241 /* Access or set a buffer-local symbol's default value. */
1243 /* Return the default value of SYMBOL, but don't check for voidness.
1244 Return Qunbound if it is void. */
1247 default_value (symbol
)
1250 register Lisp_Object valcontents
;
1252 CHECK_SYMBOL (symbol
, 0);
1253 valcontents
= SYMBOL_VALUE (symbol
);
1255 /* For a built-in buffer-local variable, get the default value
1256 rather than letting do_symval_forwarding get the current value. */
1257 if (BUFFER_OBJFWDP (valcontents
))
1259 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1260 if (PER_BUFFER_IDX (offset
) != 0)
1261 return PER_BUFFER_DEFAULT (offset
);
1264 /* Handle user-created local variables. */
1265 if (BUFFER_LOCAL_VALUEP (valcontents
)
1266 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1268 /* If var is set up for a buffer that lacks a local value for it,
1269 the current value is nominally the default value.
1270 But the `realvalue' slot may be more up to date, since
1271 ordinary setq stores just that slot. So use that. */
1272 Lisp_Object current_alist_element
, alist_element_car
;
1273 current_alist_element
1274 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1275 alist_element_car
= XCAR (current_alist_element
);
1276 if (EQ (alist_element_car
, current_alist_element
))
1277 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1279 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1281 /* For other variables, get the current value. */
1282 return do_symval_forwarding (valcontents
);
1285 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1286 "Return t if SYMBOL has a non-void default value.\n\
1287 This is the value that is seen in buffers that do not have their own values\n\
1288 for this variable.")
1292 register Lisp_Object value
;
1294 value
= default_value (symbol
);
1295 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1298 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1299 "Return SYMBOL's default value.\n\
1300 This is the value that is seen in buffers that do not have their own values\n\
1301 for this variable. The default value is meaningful for variables with\n\
1302 local bindings in certain buffers.")
1306 register Lisp_Object value
;
1308 value
= default_value (symbol
);
1309 if (EQ (value
, Qunbound
))
1310 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1314 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1315 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1316 The default value is seen in buffers that do not have their own values\n\
1317 for this variable.")
1319 Lisp_Object symbol
, value
;
1321 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1323 CHECK_SYMBOL (symbol
, 0);
1324 valcontents
= SYMBOL_VALUE (symbol
);
1326 /* Handle variables like case-fold-search that have special slots
1327 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1329 if (BUFFER_OBJFWDP (valcontents
))
1331 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1332 int idx
= PER_BUFFER_IDX (offset
);
1334 PER_BUFFER_DEFAULT (offset
) = value
;
1336 /* If this variable is not always local in all buffers,
1337 set it in the buffers that don't nominally have a local value. */
1342 for (b
= all_buffers
; b
; b
= b
->next
)
1343 if (!PER_BUFFER_VALUE_P (b
, idx
))
1344 PER_BUFFER_VALUE (b
, offset
) = value
;
1349 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1350 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1351 return Fset (symbol
, value
);
1353 /* Store new value into the DEFAULT-VALUE slot. */
1354 XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
) = value
;
1356 /* If the default binding is now loaded, set the REALVALUE slot too. */
1357 current_alist_element
1358 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1359 alist_element_buffer
= Fcar (current_alist_element
);
1360 if (EQ (alist_element_buffer
, current_alist_element
))
1361 store_symval_forwarding (symbol
,
1362 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1368 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1369 "Set the default value of variable VAR to VALUE.\n\
1370 VAR, the variable name, is literal (not evaluated);\n\
1371 VALUE is an expression and it is evaluated.\n\
1372 The default value of a variable is seen in buffers\n\
1373 that do not have their own values for the variable.\n\
1375 More generally, you can use multiple variables and values, as in\n\
1376 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1377 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1378 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1383 register Lisp_Object args_left
;
1384 register Lisp_Object val
, symbol
;
1385 struct gcpro gcpro1
;
1395 val
= Feval (Fcar (Fcdr (args_left
)));
1396 symbol
= Fcar (args_left
);
1397 Fset_default (symbol
, val
);
1398 args_left
= Fcdr (Fcdr (args_left
));
1400 while (!NILP (args_left
));
1406 /* Lisp functions for creating and removing buffer-local variables. */
1408 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1409 1, 1, "vMake Variable Buffer Local: ",
1410 "Make VARIABLE become buffer-local whenever it is set.\n\
1411 At any time, the value for the current buffer is in effect,\n\
1412 unless the variable has never been set in this buffer,\n\
1413 in which case the default value is in effect.\n\
1414 Note that binding the variable with `let', or setting it while\n\
1415 a `let'-style binding made in this buffer is in effect,\n\
1416 does not make the variable buffer-local.\n\
1418 The function `default-value' gets the default value and `set-default' sets it.")
1420 register Lisp_Object variable
;
1422 register Lisp_Object tem
, valcontents
, newval
;
1424 CHECK_SYMBOL (variable
, 0);
1426 valcontents
= SYMBOL_VALUE (variable
);
1427 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1428 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1430 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1432 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1434 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1437 if (EQ (valcontents
, Qunbound
))
1438 SET_SYMBOL_VALUE (variable
, Qnil
);
1439 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1441 newval
= allocate_misc ();
1442 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1443 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1444 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1445 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1446 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1447 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1448 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1449 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1450 SET_SYMBOL_VALUE (variable
, newval
);
1454 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1455 1, 1, "vMake Local Variable: ",
1456 "Make VARIABLE have a separate value in the current buffer.\n\
1457 Other buffers will continue to share a common default value.\n\
1458 \(The buffer-local value of VARIABLE starts out as the same value\n\
1459 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1460 See also `make-variable-buffer-local'.\n\
1462 If the variable is already arranged to become local when set,\n\
1463 this function causes a local value to exist for this buffer,\n\
1464 just as setting the variable would do.\n\
1466 This function returns VARIABLE, and therefore\n\
1467 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1470 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1471 Use `make-local-hook' instead.")
1473 register Lisp_Object variable
;
1475 register Lisp_Object tem
, valcontents
;
1477 CHECK_SYMBOL (variable
, 0);
1479 valcontents
= SYMBOL_VALUE (variable
);
1480 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1481 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1483 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1485 tem
= Fboundp (variable
);
1487 /* Make sure the symbol has a local value in this particular buffer,
1488 by setting it to the same value it already has. */
1489 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1492 /* Make sure symbol is set up to hold per-buffer values. */
1493 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1496 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1498 newval
= allocate_misc ();
1499 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1500 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1501 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1502 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1503 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1504 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1505 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1506 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1507 SET_SYMBOL_VALUE (variable
, newval
);;
1509 /* Make sure this buffer has its own value of symbol. */
1510 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1513 /* Swap out any local binding for some other buffer, and make
1514 sure the current value is permanently recorded, if it's the
1516 find_symbol_value (variable
);
1518 current_buffer
->local_var_alist
1519 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1520 current_buffer
->local_var_alist
);
1522 /* Make sure symbol does not think it is set up for this buffer;
1523 force it to look once again for this buffer's value. */
1525 Lisp_Object
*pvalbuf
;
1527 valcontents
= SYMBOL_VALUE (variable
);
1529 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1530 if (current_buffer
== XBUFFER (*pvalbuf
))
1532 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1536 /* If the symbol forwards into a C variable, then load the binding
1537 for this buffer now. If C code modifies the variable before we
1538 load the binding in, then that new value will clobber the default
1539 binding the next time we unload it. */
1540 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1541 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1542 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1547 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1548 1, 1, "vKill Local Variable: ",
1549 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1550 From now on the default value will apply in this buffer.")
1552 register Lisp_Object variable
;
1554 register Lisp_Object tem
, valcontents
;
1556 CHECK_SYMBOL (variable
, 0);
1558 valcontents
= SYMBOL_VALUE (variable
);
1560 if (BUFFER_OBJFWDP (valcontents
))
1562 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1563 int idx
= PER_BUFFER_IDX (offset
);
1567 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1568 PER_BUFFER_VALUE (current_buffer
, offset
)
1569 = PER_BUFFER_DEFAULT (offset
);
1574 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1575 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1578 /* Get rid of this buffer's alist element, if any. */
1580 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1582 current_buffer
->local_var_alist
1583 = Fdelq (tem
, current_buffer
->local_var_alist
);
1585 /* If the symbol is set up with the current buffer's binding
1586 loaded, recompute its value. We have to do it now, or else
1587 forwarded objects won't work right. */
1589 Lisp_Object
*pvalbuf
;
1590 valcontents
= SYMBOL_VALUE (variable
);
1591 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1592 if (current_buffer
== XBUFFER (*pvalbuf
))
1595 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1596 find_symbol_value (variable
);
1603 /* Lisp functions for creating and removing buffer-local variables. */
1605 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1606 1, 1, "vMake Variable Frame Local: ",
1607 "Enable VARIABLE to have frame-local bindings.\n\
1608 When a frame-local binding exists in the current frame,\n\
1609 it is in effect whenever the current buffer has no buffer-local binding.\n\
1610 A frame-local binding is actual a frame parameter value;\n\
1611 thus, any given frame has a local binding for VARIABLE\n\
1612 if it has a value for the frame parameter named VARIABLE.\n\
1613 See `modify-frame-parameters'.")
1615 register Lisp_Object variable
;
1617 register Lisp_Object tem
, valcontents
, newval
;
1619 CHECK_SYMBOL (variable
, 0);
1621 valcontents
= SYMBOL_VALUE (variable
);
1622 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1623 || BUFFER_OBJFWDP (valcontents
))
1624 error ("Symbol %s may not be frame-local", XSYMBOL (variable
)->name
->data
);
1626 if (BUFFER_LOCAL_VALUEP (valcontents
)
1627 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1629 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1633 if (EQ (valcontents
, Qunbound
))
1634 SET_SYMBOL_VALUE (variable
, Qnil
);
1635 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1637 newval
= allocate_misc ();
1638 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1639 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1640 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1641 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1642 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1643 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1644 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1645 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1646 SET_SYMBOL_VALUE (variable
, newval
);
1650 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1652 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1653 BUFFER defaults to the current buffer.")
1655 register Lisp_Object variable
, buffer
;
1657 Lisp_Object valcontents
;
1658 register struct buffer
*buf
;
1661 buf
= current_buffer
;
1664 CHECK_BUFFER (buffer
, 0);
1665 buf
= XBUFFER (buffer
);
1668 CHECK_SYMBOL (variable
, 0);
1670 valcontents
= SYMBOL_VALUE (variable
);
1671 if (BUFFER_LOCAL_VALUEP (valcontents
)
1672 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1674 Lisp_Object tail
, elt
;
1676 variable
= indirect_variable (variable
);
1677 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1680 if (EQ (variable
, XCAR (elt
)))
1684 if (BUFFER_OBJFWDP (valcontents
))
1686 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1687 int idx
= PER_BUFFER_IDX (offset
);
1688 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1694 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1696 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1697 BUFFER defaults to the current buffer.")
1699 register Lisp_Object variable
, buffer
;
1701 Lisp_Object valcontents
;
1702 register struct buffer
*buf
;
1705 buf
= current_buffer
;
1708 CHECK_BUFFER (buffer
, 0);
1709 buf
= XBUFFER (buffer
);
1712 CHECK_SYMBOL (variable
, 0);
1714 valcontents
= SYMBOL_VALUE (variable
);
1716 /* This means that make-variable-buffer-local was done. */
1717 if (BUFFER_LOCAL_VALUEP (valcontents
))
1719 /* All these slots become local if they are set. */
1720 if (BUFFER_OBJFWDP (valcontents
))
1722 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1724 Lisp_Object tail
, elt
;
1725 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1728 if (EQ (variable
, XCAR (elt
)))
1735 /* Find the function at the end of a chain of symbol function indirections. */
1737 /* If OBJECT is a symbol, find the end of its function chain and
1738 return the value found there. If OBJECT is not a symbol, just
1739 return it. If there is a cycle in the function chain, signal a
1740 cyclic-function-indirection error.
1742 This is like Findirect_function, except that it doesn't signal an
1743 error if the chain ends up unbound. */
1745 indirect_function (object
)
1746 register Lisp_Object object
;
1748 Lisp_Object tortoise
, hare
;
1750 hare
= tortoise
= object
;
1754 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1756 hare
= XSYMBOL (hare
)->function
;
1757 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1759 hare
= XSYMBOL (hare
)->function
;
1761 tortoise
= XSYMBOL (tortoise
)->function
;
1763 if (EQ (hare
, tortoise
))
1764 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1770 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1771 "Return the function at the end of OBJECT's function chain.\n\
1772 If OBJECT is a symbol, follow all function indirections and return the final\n\
1773 function binding.\n\
1774 If OBJECT is not a symbol, just return it.\n\
1775 Signal a void-function error if the final symbol is unbound.\n\
1776 Signal a cyclic-function-indirection error if there is a loop in the\n\
1777 function chain of symbols.")
1779 register Lisp_Object object
;
1783 result
= indirect_function (object
);
1785 if (EQ (result
, Qunbound
))
1786 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1790 /* Extract and set vector and string elements */
1792 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1793 "Return the element of ARRAY at index IDX.\n\
1794 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1795 or a byte-code object. IDX starts at 0.")
1797 register Lisp_Object array
;
1800 register int idxval
;
1802 CHECK_NUMBER (idx
, 1);
1803 idxval
= XINT (idx
);
1804 if (STRINGP (array
))
1808 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1809 args_out_of_range (array
, idx
);
1810 if (! STRING_MULTIBYTE (array
))
1811 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1812 idxval_byte
= string_char_to_byte (array
, idxval
);
1814 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1815 STRING_BYTES (XSTRING (array
)) - idxval_byte
);
1816 return make_number (c
);
1818 else if (BOOL_VECTOR_P (array
))
1822 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1823 args_out_of_range (array
, idx
);
1825 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1826 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1828 else if (CHAR_TABLE_P (array
))
1835 args_out_of_range (array
, idx
);
1836 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1838 /* For ASCII and 8-bit European characters, the element is
1839 stored in the top table. */
1840 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1842 val
= XCHAR_TABLE (array
)->defalt
;
1843 while (NILP (val
)) /* Follow parents until we find some value. */
1845 array
= XCHAR_TABLE (array
)->parent
;
1848 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1850 val
= XCHAR_TABLE (array
)->defalt
;
1857 Lisp_Object sub_table
;
1859 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1860 if (code
[1] < 32) code
[1] = -1;
1861 else if (code
[2] < 32) code
[2] = -1;
1863 /* Here, the possible range of CODE[0] (== charset ID) is
1864 128..MAX_CHARSET. Since the top level char table contains
1865 data for multibyte characters after 256th element, we must
1866 increment CODE[0] by 128 to get a correct index. */
1868 code
[3] = -1; /* anchor */
1870 try_parent_char_table
:
1872 for (i
= 0; code
[i
] >= 0; i
++)
1874 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1875 if (SUB_CHAR_TABLE_P (val
))
1880 val
= XCHAR_TABLE (sub_table
)->defalt
;
1883 array
= XCHAR_TABLE (array
)->parent
;
1885 goto try_parent_char_table
;
1890 /* Here, VAL is a sub char table. We try the default value
1892 val
= XCHAR_TABLE (val
)->defalt
;
1895 array
= XCHAR_TABLE (array
)->parent
;
1897 goto try_parent_char_table
;
1905 if (VECTORP (array
))
1906 size
= XVECTOR (array
)->size
;
1907 else if (COMPILEDP (array
))
1908 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1910 wrong_type_argument (Qarrayp
, array
);
1912 if (idxval
< 0 || idxval
>= size
)
1913 args_out_of_range (array
, idx
);
1914 return XVECTOR (array
)->contents
[idxval
];
1918 /* Don't use alloca for relocating string data larger than this, lest
1919 we overflow their stack. The value is the same as what used in
1920 fns.c for base64 handling. */
1921 #define MAX_ALLOCA 16*1024
1923 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1924 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1925 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1927 (array
, idx
, newelt
)
1928 register Lisp_Object array
;
1929 Lisp_Object idx
, newelt
;
1931 register int idxval
;
1933 CHECK_NUMBER (idx
, 1);
1934 idxval
= XINT (idx
);
1935 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1936 && ! CHAR_TABLE_P (array
))
1937 array
= wrong_type_argument (Qarrayp
, array
);
1938 CHECK_IMPURE (array
);
1940 if (VECTORP (array
))
1942 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1943 args_out_of_range (array
, idx
);
1944 XVECTOR (array
)->contents
[idxval
] = newelt
;
1946 else if (BOOL_VECTOR_P (array
))
1950 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1951 args_out_of_range (array
, idx
);
1953 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1955 if (! NILP (newelt
))
1956 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1958 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1959 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1961 else if (CHAR_TABLE_P (array
))
1964 args_out_of_range (array
, idx
);
1965 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1966 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1972 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1973 if (code
[1] < 32) code
[1] = -1;
1974 else if (code
[2] < 32) code
[2] = -1;
1976 /* See the comment of the corresponding part in Faref. */
1978 code
[3] = -1; /* anchor */
1979 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1981 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1982 if (SUB_CHAR_TABLE_P (val
))
1988 /* VAL is a leaf. Create a sub char table with the
1989 default value VAL or XCHAR_TABLE (array)->defalt
1990 and look into it. */
1992 temp
= make_sub_char_table (NILP (val
)
1993 ? XCHAR_TABLE (array
)->defalt
1995 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1999 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2002 else if (STRING_MULTIBYTE (array
))
2004 int idxval_byte
, prev_bytes
, new_bytes
;
2005 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2007 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2008 args_out_of_range (array
, idx
);
2009 CHECK_NUMBER (newelt
, 2);
2011 idxval_byte
= string_char_to_byte (array
, idxval
);
2012 p1
= &XSTRING (array
)->data
[idxval_byte
];
2013 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2014 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2015 if (prev_bytes
!= new_bytes
)
2017 /* We must relocate the string data. */
2018 int nchars
= XSTRING (array
)->size
;
2019 int nbytes
= STRING_BYTES (XSTRING (array
));
2022 str
= (nbytes
<= MAX_ALLOCA
2023 ? (unsigned char *) alloca (nbytes
)
2024 : (unsigned char *) xmalloc (nbytes
));
2025 bcopy (XSTRING (array
)->data
, str
, nbytes
);
2026 allocate_string_data (XSTRING (array
), nchars
,
2027 nbytes
+ new_bytes
- prev_bytes
);
2028 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2029 p1
= XSTRING (array
)->data
+ idxval_byte
;
2030 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2031 nbytes
- (idxval_byte
+ prev_bytes
));
2032 if (nbytes
> MAX_ALLOCA
)
2034 clear_string_char_byte_cache ();
2041 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
2042 args_out_of_range (array
, idx
);
2043 CHECK_NUMBER (newelt
, 2);
2045 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2046 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
2049 /* We must relocate the string data while converting it to
2051 int idxval_byte
, prev_bytes
, new_bytes
;
2052 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2053 unsigned char *origstr
= XSTRING (array
)->data
, *str
;
2056 nchars
= XSTRING (array
)->size
;
2057 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2058 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2060 str
= (nbytes
<= MAX_ALLOCA
2061 ? (unsigned char *) alloca (nbytes
)
2062 : (unsigned char *) xmalloc (nbytes
));
2063 copy_text (XSTRING (array
)->data
, str
, nchars
, 0, 1);
2064 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2066 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2067 allocate_string_data (XSTRING (array
), nchars
,
2068 nbytes
+ new_bytes
- prev_bytes
);
2069 bcopy (str
, XSTRING (array
)->data
, idxval_byte
);
2070 p1
= XSTRING (array
)->data
+ idxval_byte
;
2073 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2074 nbytes
- (idxval_byte
+ prev_bytes
));
2075 if (nbytes
> MAX_ALLOCA
)
2077 clear_string_char_byte_cache ();
2084 /* Arithmetic functions */
2086 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2089 arithcompare (num1
, num2
, comparison
)
2090 Lisp_Object num1
, num2
;
2091 enum comparison comparison
;
2093 double f1
= 0, f2
= 0;
2096 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
2097 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
2099 if (FLOATP (num1
) || FLOATP (num2
))
2102 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2103 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2109 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2114 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2119 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2124 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2129 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2134 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2143 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2144 "Return t if two args, both numbers or markers, are equal.")
2146 register Lisp_Object num1
, num2
;
2148 return arithcompare (num1
, num2
, equal
);
2151 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2152 "Return t if first arg is less than second arg. Both must be numbers or markers.")
2154 register Lisp_Object num1
, num2
;
2156 return arithcompare (num1
, num2
, less
);
2159 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2160 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
2162 register Lisp_Object num1
, num2
;
2164 return arithcompare (num1
, num2
, grtr
);
2167 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2168 "Return t if first arg is less than or equal to second arg.\n\
2169 Both must be numbers or markers.")
2171 register Lisp_Object num1
, num2
;
2173 return arithcompare (num1
, num2
, less_or_equal
);
2176 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2177 "Return t if first arg is greater than or equal to second arg.\n\
2178 Both must be numbers or markers.")
2180 register Lisp_Object num1
, num2
;
2182 return arithcompare (num1
, num2
, grtr_or_equal
);
2185 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2186 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
2188 register Lisp_Object num1
, num2
;
2190 return arithcompare (num1
, num2
, notequal
);
2193 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
2195 register Lisp_Object number
;
2197 CHECK_NUMBER_OR_FLOAT (number
, 0);
2199 if (FLOATP (number
))
2201 if (XFLOAT_DATA (number
) == 0.0)
2211 /* Convert between long values and pairs of Lisp integers. */
2217 unsigned int top
= i
>> 16;
2218 unsigned int bot
= i
& 0xFFFF;
2220 return make_number (bot
);
2221 if (top
== (unsigned long)-1 >> 16)
2222 return Fcons (make_number (-1), make_number (bot
));
2223 return Fcons (make_number (top
), make_number (bot
));
2230 Lisp_Object top
, bot
;
2237 return ((XINT (top
) << 16) | XINT (bot
));
2240 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2241 "Convert NUMBER to a string by printing it in decimal.\n\
2242 Uses a minus sign if negative.\n\
2243 NUMBER may be an integer or a floating point number.")
2247 char buffer
[VALBITS
];
2249 CHECK_NUMBER_OR_FLOAT (number
, 0);
2251 if (FLOATP (number
))
2253 char pigbuf
[350]; /* see comments in float_to_string */
2255 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2256 return build_string (pigbuf
);
2259 if (sizeof (int) == sizeof (EMACS_INT
))
2260 sprintf (buffer
, "%d", XINT (number
));
2261 else if (sizeof (long) == sizeof (EMACS_INT
))
2262 sprintf (buffer
, "%ld", (long) XINT (number
));
2265 return build_string (buffer
);
2269 digit_to_number (character
, base
)
2270 int character
, base
;
2274 if (character
>= '0' && character
<= '9')
2275 digit
= character
- '0';
2276 else if (character
>= 'a' && character
<= 'z')
2277 digit
= character
- 'a' + 10;
2278 else if (character
>= 'A' && character
<= 'Z')
2279 digit
= character
- 'A' + 10;
2289 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2290 "Convert STRING to a number by parsing it as a decimal number.\n\
2291 This parses both integers and floating point numbers.\n\
2292 It ignores leading spaces and tabs.\n\
2294 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2295 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2296 If the base used is not 10, floating point is not recognized.")
2298 register Lisp_Object string
, base
;
2300 register unsigned char *p
;
2305 CHECK_STRING (string
, 0);
2311 CHECK_NUMBER (base
, 1);
2313 if (b
< 2 || b
> 16)
2314 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2317 /* Skip any whitespace at the front of the number. Some versions of
2318 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2319 p
= XSTRING (string
)->data
;
2320 while (*p
== ' ' || *p
== '\t')
2331 if (isfloat_string (p
) && b
== 10)
2332 val
= make_float (sign
* atof (p
));
2339 int digit
= digit_to_number (*p
++, b
);
2345 if (v
> (EMACS_UINT
) (VALMASK
>> 1))
2346 val
= make_float (sign
* v
);
2348 val
= make_number (sign
* (int) v
);
2368 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2369 int, Lisp_Object
*));
2370 extern Lisp_Object
fmod_float ();
2373 arith_driver (code
, nargs
, args
)
2376 register Lisp_Object
*args
;
2378 register Lisp_Object val
;
2379 register int argnum
;
2380 register EMACS_INT accum
= 0;
2381 register EMACS_INT next
;
2383 switch (SWITCH_ENUM_CAST (code
))
2401 for (argnum
= 0; argnum
< nargs
; argnum
++)
2403 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2405 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2408 return float_arith_driver ((double) accum
, argnum
, code
,
2411 next
= XINT (args
[argnum
]);
2412 switch (SWITCH_ENUM_CAST (code
))
2418 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2429 Fsignal (Qarith_error
, Qnil
);
2443 if (!argnum
|| next
> accum
)
2447 if (!argnum
|| next
< accum
)
2453 XSETINT (val
, accum
);
2458 #define isnan(x) ((x) != (x))
2461 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2463 register int argnum
;
2466 register Lisp_Object
*args
;
2468 register Lisp_Object val
;
2471 for (; argnum
< nargs
; argnum
++)
2473 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2474 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2478 next
= XFLOAT_DATA (val
);
2482 args
[argnum
] = val
; /* runs into a compiler bug. */
2483 next
= XINT (args
[argnum
]);
2485 switch (SWITCH_ENUM_CAST (code
))
2491 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2501 if (! IEEE_FLOATING_POINT
&& next
== 0)
2502 Fsignal (Qarith_error
, Qnil
);
2509 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2511 if (!argnum
|| isnan (next
) || next
> accum
)
2515 if (!argnum
|| isnan (next
) || next
< accum
)
2521 return make_float (accum
);
2525 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2526 "Return sum of any number of arguments, which are numbers or markers.")
2531 return arith_driver (Aadd
, nargs
, args
);
2534 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2535 "Negate number or subtract numbers or markers.\n\
2536 With one arg, negates it. With more than one arg,\n\
2537 subtracts all but the first from the first.")
2542 return arith_driver (Asub
, nargs
, args
);
2545 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2546 "Returns product of any number of arguments, which are numbers or markers.")
2551 return arith_driver (Amult
, nargs
, args
);
2554 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2555 "Returns first argument divided by all the remaining arguments.\n\
2556 The arguments must be numbers or markers.")
2561 return arith_driver (Adiv
, nargs
, args
);
2564 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2565 "Returns remainder of X divided by Y.\n\
2566 Both must be integers or markers.")
2568 register Lisp_Object x
, y
;
2572 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2573 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2575 if (XFASTINT (y
) == 0)
2576 Fsignal (Qarith_error
, Qnil
);
2578 XSETINT (val
, XINT (x
) % XINT (y
));
2592 /* If the magnitude of the result exceeds that of the divisor, or
2593 the sign of the result does not agree with that of the dividend,
2594 iterate with the reduced value. This does not yield a
2595 particularly accurate result, but at least it will be in the
2596 range promised by fmod. */
2598 r
-= f2
* floor (r
/ f2
);
2599 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2603 #endif /* ! HAVE_FMOD */
2605 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2606 "Returns X modulo Y.\n\
2607 The result falls between zero (inclusive) and Y (exclusive).\n\
2608 Both X and Y must be numbers or markers.")
2610 register Lisp_Object x
, y
;
2615 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2616 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2618 if (FLOATP (x
) || FLOATP (y
))
2619 return fmod_float (x
, y
);
2625 Fsignal (Qarith_error
, Qnil
);
2629 /* If the "remainder" comes out with the wrong sign, fix it. */
2630 if (i2
< 0 ? i1
> 0 : i1
< 0)
2637 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2638 "Return largest of all the arguments (which must be numbers or markers).\n\
2639 The value is always a number; markers are converted to numbers.")
2644 return arith_driver (Amax
, nargs
, args
);
2647 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2648 "Return smallest of all the arguments (which must be numbers or markers).\n\
2649 The value is always a number; markers are converted to numbers.")
2654 return arith_driver (Amin
, nargs
, args
);
2657 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2658 "Return bitwise-and of all the arguments.\n\
2659 Arguments may be integers, or markers converted to integers.")
2664 return arith_driver (Alogand
, nargs
, args
);
2667 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2668 "Return bitwise-or of all the arguments.\n\
2669 Arguments may be integers, or markers converted to integers.")
2674 return arith_driver (Alogior
, nargs
, args
);
2677 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2678 "Return bitwise-exclusive-or of all the arguments.\n\
2679 Arguments may be integers, or markers converted to integers.")
2684 return arith_driver (Alogxor
, nargs
, args
);
2687 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2688 "Return VALUE with its bits shifted left by COUNT.\n\
2689 If COUNT is negative, shifting is actually to the right.\n\
2690 In this case, the sign bit is duplicated.")
2692 register Lisp_Object value
, count
;
2694 register Lisp_Object val
;
2696 CHECK_NUMBER (value
, 0);
2697 CHECK_NUMBER (count
, 1);
2699 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2701 else if (XINT (count
) > 0)
2702 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2703 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2704 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2706 XSETINT (val
, XINT (value
) >> -XINT (count
));
2710 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2711 "Return VALUE with its bits shifted left by COUNT.\n\
2712 If COUNT is negative, shifting is actually to the right.\n\
2713 In this case, zeros are shifted in on the left.")
2715 register Lisp_Object value
, count
;
2717 register Lisp_Object val
;
2719 CHECK_NUMBER (value
, 0);
2720 CHECK_NUMBER (count
, 1);
2722 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2724 else if (XINT (count
) > 0)
2725 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2726 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2729 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2733 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2734 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2735 Markers are converted to integers.")
2737 register Lisp_Object number
;
2739 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2741 if (FLOATP (number
))
2742 return (make_float (1.0 + XFLOAT_DATA (number
)));
2744 XSETINT (number
, XINT (number
) + 1);
2748 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2749 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2750 Markers are converted to integers.")
2752 register Lisp_Object number
;
2754 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2756 if (FLOATP (number
))
2757 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2759 XSETINT (number
, XINT (number
) - 1);
2763 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2764 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2766 register Lisp_Object number
;
2768 CHECK_NUMBER (number
, 0);
2769 XSETINT (number
, ~XINT (number
));
2776 Lisp_Object error_tail
, arith_tail
;
2778 Qquote
= intern ("quote");
2779 Qlambda
= intern ("lambda");
2780 Qsubr
= intern ("subr");
2781 Qerror_conditions
= intern ("error-conditions");
2782 Qerror_message
= intern ("error-message");
2783 Qtop_level
= intern ("top-level");
2785 Qerror
= intern ("error");
2786 Qquit
= intern ("quit");
2787 Qwrong_type_argument
= intern ("wrong-type-argument");
2788 Qargs_out_of_range
= intern ("args-out-of-range");
2789 Qvoid_function
= intern ("void-function");
2790 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2791 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2792 Qvoid_variable
= intern ("void-variable");
2793 Qsetting_constant
= intern ("setting-constant");
2794 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2796 Qinvalid_function
= intern ("invalid-function");
2797 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2798 Qno_catch
= intern ("no-catch");
2799 Qend_of_file
= intern ("end-of-file");
2800 Qarith_error
= intern ("arith-error");
2801 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2802 Qend_of_buffer
= intern ("end-of-buffer");
2803 Qbuffer_read_only
= intern ("buffer-read-only");
2804 Qtext_read_only
= intern ("text-read-only");
2805 Qmark_inactive
= intern ("mark-inactive");
2807 Qlistp
= intern ("listp");
2808 Qconsp
= intern ("consp");
2809 Qsymbolp
= intern ("symbolp");
2810 Qkeywordp
= intern ("keywordp");
2811 Qintegerp
= intern ("integerp");
2812 Qnatnump
= intern ("natnump");
2813 Qwholenump
= intern ("wholenump");
2814 Qstringp
= intern ("stringp");
2815 Qarrayp
= intern ("arrayp");
2816 Qsequencep
= intern ("sequencep");
2817 Qbufferp
= intern ("bufferp");
2818 Qvectorp
= intern ("vectorp");
2819 Qchar_or_string_p
= intern ("char-or-string-p");
2820 Qmarkerp
= intern ("markerp");
2821 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2822 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2823 Qboundp
= intern ("boundp");
2824 Qfboundp
= intern ("fboundp");
2826 Qfloatp
= intern ("floatp");
2827 Qnumberp
= intern ("numberp");
2828 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2830 Qchar_table_p
= intern ("char-table-p");
2831 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2833 Qsubrp
= intern ("subrp");
2834 Qunevalled
= intern ("unevalled");
2835 Qmany
= intern ("many");
2837 Qcdr
= intern ("cdr");
2839 /* Handle automatic advice activation */
2840 Qad_advice_info
= intern ("ad-advice-info");
2841 Qad_activate_internal
= intern ("ad-activate-internal");
2843 error_tail
= Fcons (Qerror
, Qnil
);
2845 /* ERROR is used as a signaler for random errors for which nothing else is right */
2847 Fput (Qerror
, Qerror_conditions
,
2849 Fput (Qerror
, Qerror_message
,
2850 build_string ("error"));
2852 Fput (Qquit
, Qerror_conditions
,
2853 Fcons (Qquit
, Qnil
));
2854 Fput (Qquit
, Qerror_message
,
2855 build_string ("Quit"));
2857 Fput (Qwrong_type_argument
, Qerror_conditions
,
2858 Fcons (Qwrong_type_argument
, error_tail
));
2859 Fput (Qwrong_type_argument
, Qerror_message
,
2860 build_string ("Wrong type argument"));
2862 Fput (Qargs_out_of_range
, Qerror_conditions
,
2863 Fcons (Qargs_out_of_range
, error_tail
));
2864 Fput (Qargs_out_of_range
, Qerror_message
,
2865 build_string ("Args out of range"));
2867 Fput (Qvoid_function
, Qerror_conditions
,
2868 Fcons (Qvoid_function
, error_tail
));
2869 Fput (Qvoid_function
, Qerror_message
,
2870 build_string ("Symbol's function definition is void"));
2872 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2873 Fcons (Qcyclic_function_indirection
, error_tail
));
2874 Fput (Qcyclic_function_indirection
, Qerror_message
,
2875 build_string ("Symbol's chain of function indirections contains a loop"));
2877 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2878 Fcons (Qcyclic_variable_indirection
, error_tail
));
2879 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2880 build_string ("Symbol's chain of variable indirections contains a loop"));
2882 Fput (Qvoid_variable
, Qerror_conditions
,
2883 Fcons (Qvoid_variable
, error_tail
));
2884 Fput (Qvoid_variable
, Qerror_message
,
2885 build_string ("Symbol's value as variable is void"));
2887 Fput (Qsetting_constant
, Qerror_conditions
,
2888 Fcons (Qsetting_constant
, error_tail
));
2889 Fput (Qsetting_constant
, Qerror_message
,
2890 build_string ("Attempt to set a constant symbol"));
2892 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2893 Fcons (Qinvalid_read_syntax
, error_tail
));
2894 Fput (Qinvalid_read_syntax
, Qerror_message
,
2895 build_string ("Invalid read syntax"));
2897 Fput (Qinvalid_function
, Qerror_conditions
,
2898 Fcons (Qinvalid_function
, error_tail
));
2899 Fput (Qinvalid_function
, Qerror_message
,
2900 build_string ("Invalid function"));
2902 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2903 Fcons (Qwrong_number_of_arguments
, error_tail
));
2904 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2905 build_string ("Wrong number of arguments"));
2907 Fput (Qno_catch
, Qerror_conditions
,
2908 Fcons (Qno_catch
, error_tail
));
2909 Fput (Qno_catch
, Qerror_message
,
2910 build_string ("No catch for tag"));
2912 Fput (Qend_of_file
, Qerror_conditions
,
2913 Fcons (Qend_of_file
, error_tail
));
2914 Fput (Qend_of_file
, Qerror_message
,
2915 build_string ("End of file during parsing"));
2917 arith_tail
= Fcons (Qarith_error
, error_tail
);
2918 Fput (Qarith_error
, Qerror_conditions
,
2920 Fput (Qarith_error
, Qerror_message
,
2921 build_string ("Arithmetic error"));
2923 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2924 Fcons (Qbeginning_of_buffer
, error_tail
));
2925 Fput (Qbeginning_of_buffer
, Qerror_message
,
2926 build_string ("Beginning of buffer"));
2928 Fput (Qend_of_buffer
, Qerror_conditions
,
2929 Fcons (Qend_of_buffer
, error_tail
));
2930 Fput (Qend_of_buffer
, Qerror_message
,
2931 build_string ("End of buffer"));
2933 Fput (Qbuffer_read_only
, Qerror_conditions
,
2934 Fcons (Qbuffer_read_only
, error_tail
));
2935 Fput (Qbuffer_read_only
, Qerror_message
,
2936 build_string ("Buffer is read-only"));
2938 Fput (Qtext_read_only
, Qerror_conditions
,
2939 Fcons (Qtext_read_only
, error_tail
));
2940 Fput (Qtext_read_only
, Qerror_message
,
2941 build_string ("Text is read-only"));
2943 Qrange_error
= intern ("range-error");
2944 Qdomain_error
= intern ("domain-error");
2945 Qsingularity_error
= intern ("singularity-error");
2946 Qoverflow_error
= intern ("overflow-error");
2947 Qunderflow_error
= intern ("underflow-error");
2949 Fput (Qdomain_error
, Qerror_conditions
,
2950 Fcons (Qdomain_error
, arith_tail
));
2951 Fput (Qdomain_error
, Qerror_message
,
2952 build_string ("Arithmetic domain error"));
2954 Fput (Qrange_error
, Qerror_conditions
,
2955 Fcons (Qrange_error
, arith_tail
));
2956 Fput (Qrange_error
, Qerror_message
,
2957 build_string ("Arithmetic range error"));
2959 Fput (Qsingularity_error
, Qerror_conditions
,
2960 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2961 Fput (Qsingularity_error
, Qerror_message
,
2962 build_string ("Arithmetic singularity error"));
2964 Fput (Qoverflow_error
, Qerror_conditions
,
2965 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2966 Fput (Qoverflow_error
, Qerror_message
,
2967 build_string ("Arithmetic overflow error"));
2969 Fput (Qunderflow_error
, Qerror_conditions
,
2970 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2971 Fput (Qunderflow_error
, Qerror_message
,
2972 build_string ("Arithmetic underflow error"));
2974 staticpro (&Qrange_error
);
2975 staticpro (&Qdomain_error
);
2976 staticpro (&Qsingularity_error
);
2977 staticpro (&Qoverflow_error
);
2978 staticpro (&Qunderflow_error
);
2982 staticpro (&Qquote
);
2983 staticpro (&Qlambda
);
2985 staticpro (&Qunbound
);
2986 staticpro (&Qerror_conditions
);
2987 staticpro (&Qerror_message
);
2988 staticpro (&Qtop_level
);
2990 staticpro (&Qerror
);
2992 staticpro (&Qwrong_type_argument
);
2993 staticpro (&Qargs_out_of_range
);
2994 staticpro (&Qvoid_function
);
2995 staticpro (&Qcyclic_function_indirection
);
2996 staticpro (&Qvoid_variable
);
2997 staticpro (&Qsetting_constant
);
2998 staticpro (&Qinvalid_read_syntax
);
2999 staticpro (&Qwrong_number_of_arguments
);
3000 staticpro (&Qinvalid_function
);
3001 staticpro (&Qno_catch
);
3002 staticpro (&Qend_of_file
);
3003 staticpro (&Qarith_error
);
3004 staticpro (&Qbeginning_of_buffer
);
3005 staticpro (&Qend_of_buffer
);
3006 staticpro (&Qbuffer_read_only
);
3007 staticpro (&Qtext_read_only
);
3008 staticpro (&Qmark_inactive
);
3010 staticpro (&Qlistp
);
3011 staticpro (&Qconsp
);
3012 staticpro (&Qsymbolp
);
3013 staticpro (&Qkeywordp
);
3014 staticpro (&Qintegerp
);
3015 staticpro (&Qnatnump
);
3016 staticpro (&Qwholenump
);
3017 staticpro (&Qstringp
);
3018 staticpro (&Qarrayp
);
3019 staticpro (&Qsequencep
);
3020 staticpro (&Qbufferp
);
3021 staticpro (&Qvectorp
);
3022 staticpro (&Qchar_or_string_p
);
3023 staticpro (&Qmarkerp
);
3024 staticpro (&Qbuffer_or_string_p
);
3025 staticpro (&Qinteger_or_marker_p
);
3026 staticpro (&Qfloatp
);
3027 staticpro (&Qnumberp
);
3028 staticpro (&Qnumber_or_marker_p
);
3029 staticpro (&Qchar_table_p
);
3030 staticpro (&Qvector_or_char_table_p
);
3031 staticpro (&Qsubrp
);
3033 staticpro (&Qunevalled
);
3035 staticpro (&Qboundp
);
3036 staticpro (&Qfboundp
);
3038 staticpro (&Qad_advice_info
);
3039 staticpro (&Qad_activate_internal
);
3041 /* Types that type-of returns. */
3042 Qinteger
= intern ("integer");
3043 Qsymbol
= intern ("symbol");
3044 Qstring
= intern ("string");
3045 Qcons
= intern ("cons");
3046 Qmarker
= intern ("marker");
3047 Qoverlay
= intern ("overlay");
3048 Qfloat
= intern ("float");
3049 Qwindow_configuration
= intern ("window-configuration");
3050 Qprocess
= intern ("process");
3051 Qwindow
= intern ("window");
3052 /* Qsubr = intern ("subr"); */
3053 Qcompiled_function
= intern ("compiled-function");
3054 Qbuffer
= intern ("buffer");
3055 Qframe
= intern ("frame");
3056 Qvector
= intern ("vector");
3057 Qchar_table
= intern ("char-table");
3058 Qbool_vector
= intern ("bool-vector");
3059 Qhash_table
= intern ("hash-table");
3061 staticpro (&Qinteger
);
3062 staticpro (&Qsymbol
);
3063 staticpro (&Qstring
);
3065 staticpro (&Qmarker
);
3066 staticpro (&Qoverlay
);
3067 staticpro (&Qfloat
);
3068 staticpro (&Qwindow_configuration
);
3069 staticpro (&Qprocess
);
3070 staticpro (&Qwindow
);
3071 /* staticpro (&Qsubr); */
3072 staticpro (&Qcompiled_function
);
3073 staticpro (&Qbuffer
);
3074 staticpro (&Qframe
);
3075 staticpro (&Qvector
);
3076 staticpro (&Qchar_table
);
3077 staticpro (&Qbool_vector
);
3078 staticpro (&Qhash_table
);
3080 defsubr (&Sindirect_variable
);
3081 defsubr (&Ssubr_interactive_form
);
3084 defsubr (&Stype_of
);
3089 defsubr (&Sintegerp
);
3090 defsubr (&Sinteger_or_marker_p
);
3091 defsubr (&Snumberp
);
3092 defsubr (&Snumber_or_marker_p
);
3094 defsubr (&Snatnump
);
3095 defsubr (&Ssymbolp
);
3096 defsubr (&Skeywordp
);
3097 defsubr (&Sstringp
);
3098 defsubr (&Smultibyte_string_p
);
3099 defsubr (&Svectorp
);
3100 defsubr (&Schar_table_p
);
3101 defsubr (&Svector_or_char_table_p
);
3102 defsubr (&Sbool_vector_p
);
3104 defsubr (&Ssequencep
);
3105 defsubr (&Sbufferp
);
3106 defsubr (&Smarkerp
);
3108 defsubr (&Sbyte_code_function_p
);
3109 defsubr (&Schar_or_string_p
);
3112 defsubr (&Scar_safe
);
3113 defsubr (&Scdr_safe
);
3116 defsubr (&Ssymbol_function
);
3117 defsubr (&Sindirect_function
);
3118 defsubr (&Ssymbol_plist
);
3119 defsubr (&Ssymbol_name
);
3120 defsubr (&Smakunbound
);
3121 defsubr (&Sfmakunbound
);
3123 defsubr (&Sfboundp
);
3125 defsubr (&Sdefalias
);
3126 defsubr (&Ssetplist
);
3127 defsubr (&Ssymbol_value
);
3129 defsubr (&Sdefault_boundp
);
3130 defsubr (&Sdefault_value
);
3131 defsubr (&Sset_default
);
3132 defsubr (&Ssetq_default
);
3133 defsubr (&Smake_variable_buffer_local
);
3134 defsubr (&Smake_local_variable
);
3135 defsubr (&Skill_local_variable
);
3136 defsubr (&Smake_variable_frame_local
);
3137 defsubr (&Slocal_variable_p
);
3138 defsubr (&Slocal_variable_if_set_p
);
3141 defsubr (&Snumber_to_string
);
3142 defsubr (&Sstring_to_number
);
3143 defsubr (&Seqlsign
);
3166 defsubr (&Ssubr_arity
);
3168 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3175 #if defined(USG) && !defined(POSIX_SIGNALS)
3176 /* USG systems forget handlers when they are used;
3177 must reestablish each time */
3178 signal (signo
, arith_error
);
3181 /* VMS systems are like USG. */
3182 signal (signo
, arith_error
);
3186 #else /* not BSD4_1 */
3187 sigsetmask (SIGEMPTYMASK
);
3188 #endif /* not BSD4_1 */
3190 Fsignal (Qarith_error
, Qnil
);
3196 /* Don't do this if just dumping out.
3197 We don't want to call `signal' in this case
3198 so that we don't have trouble with dumping
3199 signal-delivering routines in an inconsistent state. */
3203 #endif /* CANNOT_DUMP */
3204 signal (SIGFPE
, arith_error
);
3207 signal (SIGEMT
, arith_error
);