1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005 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., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
32 #include "syssignal.h"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
69 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
70 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
71 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
72 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
73 Lisp_Object Qtext_read_only
;
75 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
76 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
77 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
78 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
79 Lisp_Object Qboundp
, Qfboundp
;
80 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
83 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
85 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
86 Lisp_Object Qoverflow_error
, Qunderflow_error
;
89 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
92 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
93 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
95 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
96 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
97 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
99 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
101 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
105 circular_list_error (list
)
108 Fsignal (Qcircular_list
, list
);
113 wrong_type_argument (predicate
, value
)
114 register Lisp_Object predicate
, value
;
116 register Lisp_Object tem
;
119 /* If VALUE is not even a valid Lisp object, abort here
120 where we can get a backtrace showing where it came from. */
121 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
124 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
125 tem
= call1 (predicate
, value
);
134 error ("Attempt to modify read-only object");
138 args_out_of_range (a1
, a2
)
142 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
146 args_out_of_range_3 (a1
, a2
, a3
)
147 Lisp_Object a1
, a2
, a3
;
150 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
153 /* On some machines, XINT needs a temporary location.
154 Here it is, in case it is needed. */
156 int sign_extend_temp
;
158 /* On a few machines, XINT can only be done by calling this. */
161 sign_extend_lisp_int (num
)
164 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
165 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
167 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
170 /* Data type predicates */
172 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
173 doc
: /* Return t if the two args are the same Lisp object. */)
175 Lisp_Object obj1
, obj2
;
182 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
183 doc
: /* Return t if OBJECT is nil. */)
192 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
193 doc
: /* Return a symbol representing the type of OBJECT.
194 The symbol returned names the object's basic type;
195 for example, (type-of 1) returns `integer'. */)
199 switch (XGCTYPE (object
))
214 switch (XMISCTYPE (object
))
216 case Lisp_Misc_Marker
:
218 case Lisp_Misc_Overlay
:
220 case Lisp_Misc_Float
:
225 case Lisp_Vectorlike
:
226 if (GC_WINDOW_CONFIGURATIONP (object
))
227 return Qwindow_configuration
;
228 if (GC_PROCESSP (object
))
230 if (GC_WINDOWP (object
))
232 if (GC_SUBRP (object
))
234 if (GC_COMPILEDP (object
))
235 return Qcompiled_function
;
236 if (GC_BUFFERP (object
))
238 if (GC_CHAR_TABLE_P (object
))
240 if (GC_BOOL_VECTOR_P (object
))
242 if (GC_FRAMEP (object
))
244 if (GC_HASH_TABLE_P (object
))
256 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
257 doc
: /* Return t if OBJECT is a cons cell. */)
266 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
267 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
276 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
277 doc
: /* Return t if OBJECT is a list. This includes nil. */)
281 if (CONSP (object
) || NILP (object
))
286 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
287 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
291 if (CONSP (object
) || NILP (object
))
296 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
297 doc
: /* Return t if OBJECT is a symbol. */)
301 if (SYMBOLP (object
))
306 /* Define this in C to avoid unnecessarily consing up the symbol
308 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
309 doc
: /* Return t if OBJECT is a keyword.
310 This means that it is a symbol with a print name beginning with `:'
311 interned in the initial obarray. */)
316 && SREF (SYMBOL_NAME (object
), 0) == ':'
317 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
322 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
323 doc
: /* Return t if OBJECT is a vector. */)
327 if (VECTORP (object
))
332 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
333 doc
: /* Return t if OBJECT is a string. */)
337 if (STRINGP (object
))
342 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
344 doc
: /* Return t if OBJECT is a multibyte string. */)
348 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
353 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
354 doc
: /* Return t if OBJECT is a char-table. */)
358 if (CHAR_TABLE_P (object
))
363 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
364 Svector_or_char_table_p
, 1, 1, 0,
365 doc
: /* Return t if OBJECT is a char-table or vector. */)
369 if (VECTORP (object
) || CHAR_TABLE_P (object
))
374 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
375 doc
: /* Return t if OBJECT is a bool-vector. */)
379 if (BOOL_VECTOR_P (object
))
384 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
385 doc
: /* Return t if OBJECT is an array (string or vector). */)
389 if (VECTORP (object
) || STRINGP (object
)
390 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
395 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
396 doc
: /* Return t if OBJECT is a sequence (list or array). */)
398 register Lisp_Object object
;
400 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
401 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
406 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is an editor buffer. */)
411 if (BUFFERP (object
))
416 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
417 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
421 if (MARKERP (object
))
426 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
427 doc
: /* Return t if OBJECT is a built-in function. */)
436 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
438 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
442 if (COMPILEDP (object
))
447 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
448 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
450 register Lisp_Object object
;
452 if (INTEGERP (object
) || STRINGP (object
))
457 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
458 doc
: /* Return t if OBJECT is an integer. */)
462 if (INTEGERP (object
))
467 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
468 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
470 register Lisp_Object object
;
472 if (MARKERP (object
) || INTEGERP (object
))
477 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
478 doc
: /* Return t if OBJECT is a nonnegative integer. */)
482 if (NATNUMP (object
))
487 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
488 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
492 if (NUMBERP (object
))
498 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
499 Snumber_or_marker_p
, 1, 1, 0,
500 doc
: /* Return t if OBJECT is a number or a marker. */)
504 if (NUMBERP (object
) || MARKERP (object
))
509 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
510 doc
: /* Return t if OBJECT is a floating point number. */)
520 /* Extract and set components of lists */
522 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
523 doc
: /* Return the car of LIST. If arg is nil, return nil.
524 Error if arg is not nil and not a cons cell. See also `car-safe'. */)
526 register Lisp_Object list
;
532 else if (EQ (list
, Qnil
))
535 list
= wrong_type_argument (Qlistp
, list
);
539 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
540 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
545 return XCAR (object
);
550 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
551 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
552 Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
554 register Lisp_Object list
;
560 else if (EQ (list
, Qnil
))
563 list
= wrong_type_argument (Qlistp
, list
);
567 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
568 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
573 return XCDR (object
);
578 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
579 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
581 register Lisp_Object cell
, newcar
;
584 cell
= wrong_type_argument (Qconsp
, cell
);
587 XSETCAR (cell
, newcar
);
591 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
592 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
594 register Lisp_Object cell
, newcdr
;
597 cell
= wrong_type_argument (Qconsp
, cell
);
600 XSETCDR (cell
, newcdr
);
604 /* Extract and set components of symbols */
606 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
607 doc
: /* Return t if SYMBOL's value is not void. */)
609 register Lisp_Object symbol
;
611 Lisp_Object valcontents
;
612 CHECK_SYMBOL (symbol
);
614 valcontents
= SYMBOL_VALUE (symbol
);
616 if (BUFFER_LOCAL_VALUEP (valcontents
)
617 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
618 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
620 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
623 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
624 doc
: /* Return t if SYMBOL's function definition is not void. */)
626 register Lisp_Object symbol
;
628 CHECK_SYMBOL (symbol
);
629 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
632 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
633 doc
: /* Make SYMBOL's value be void.
636 register Lisp_Object symbol
;
638 CHECK_SYMBOL (symbol
);
639 if (XSYMBOL (symbol
)->constant
)
640 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
641 Fset (symbol
, Qunbound
);
645 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
646 doc
: /* Make SYMBOL's function definition be void.
649 register Lisp_Object symbol
;
651 CHECK_SYMBOL (symbol
);
652 if (NILP (symbol
) || EQ (symbol
, Qt
))
653 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
654 XSYMBOL (symbol
)->function
= Qunbound
;
658 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
659 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
661 register Lisp_Object symbol
;
663 CHECK_SYMBOL (symbol
);
664 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
665 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
666 return XSYMBOL (symbol
)->function
;
669 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
670 doc
: /* Return SYMBOL's property list. */)
672 register Lisp_Object symbol
;
674 CHECK_SYMBOL (symbol
);
675 return XSYMBOL (symbol
)->plist
;
678 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
679 doc
: /* Return SYMBOL's name, a string. */)
681 register Lisp_Object symbol
;
683 register Lisp_Object name
;
685 CHECK_SYMBOL (symbol
);
686 name
= SYMBOL_NAME (symbol
);
690 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
691 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
693 register Lisp_Object symbol
, definition
;
695 CHECK_SYMBOL (symbol
);
696 if (NILP (symbol
) || EQ (symbol
, Qt
))
697 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
698 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
699 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
701 XSYMBOL (symbol
)->function
= definition
;
702 /* Handle automatic advice activation */
703 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
705 call2 (Qad_activate_internal
, symbol
, Qnil
);
706 definition
= XSYMBOL (symbol
)->function
;
711 extern Lisp_Object Qfunction_documentation
;
713 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
714 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
715 Associates the function with the current load file, if any.
716 The optional third argument DOCSTRING specifies the documentation string
717 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
718 determined by DEFINITION. */)
719 (symbol
, definition
, docstring
)
720 register Lisp_Object symbol
, definition
, docstring
;
722 CHECK_SYMBOL (symbol
);
723 if (CONSP (XSYMBOL (symbol
)->function
)
724 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
725 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
726 definition
= Ffset (symbol
, definition
);
727 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
728 if (!NILP (docstring
))
729 Fput (symbol
, Qfunction_documentation
, docstring
);
733 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
734 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
736 register Lisp_Object symbol
, newplist
;
738 CHECK_SYMBOL (symbol
);
739 XSYMBOL (symbol
)->plist
= newplist
;
743 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
744 doc
: /* Return minimum and maximum number of args allowed for SUBR.
745 SUBR must be a built-in function.
746 The returned value is a pair (MIN . MAX). MIN is the minimum number
747 of args. MAX is the maximum number or the symbol `many', for a
748 function with `&rest' args, or `unevalled' for a special form. */)
752 short minargs
, maxargs
;
754 wrong_type_argument (Qsubrp
, subr
);
755 minargs
= XSUBR (subr
)->min_args
;
756 maxargs
= XSUBR (subr
)->max_args
;
758 return Fcons (make_number (minargs
), Qmany
);
759 else if (maxargs
== UNEVALLED
)
760 return Fcons (make_number (minargs
), Qunevalled
);
762 return Fcons (make_number (minargs
), make_number (maxargs
));
765 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
766 doc
: /* Return name of subroutine SUBR.
767 SUBR must be a built-in function. */)
773 wrong_type_argument (Qsubrp
, subr
);
774 name
= XSUBR (subr
)->symbol_name
;
775 return make_string (name
, strlen (name
));
778 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
779 doc
: /* Return the interactive form of CMD or nil if none.
780 If CMD is not a command, the return value is nil.
781 Value, if non-nil, is a list \(interactive SPEC). */)
785 Lisp_Object fun
= indirect_function (cmd
);
789 if (XSUBR (fun
)->prompt
)
790 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
792 else if (COMPILEDP (fun
))
794 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
795 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
797 else if (CONSP (fun
))
799 Lisp_Object funcar
= XCAR (fun
);
800 if (EQ (funcar
, Qlambda
))
801 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
802 else if (EQ (funcar
, Qautoload
))
806 do_autoload (fun
, cmd
);
808 return Finteractive_form (cmd
);
815 /***********************************************************************
816 Getting and Setting Values of Symbols
817 ***********************************************************************/
819 /* Return the symbol holding SYMBOL's value. Signal
820 `cyclic-variable-indirection' if SYMBOL's chain of variable
821 indirections contains a loop. */
824 indirect_variable (symbol
)
827 Lisp_Object tortoise
, hare
;
829 hare
= tortoise
= symbol
;
831 while (XSYMBOL (hare
)->indirect_variable
)
833 hare
= XSYMBOL (hare
)->value
;
834 if (!XSYMBOL (hare
)->indirect_variable
)
837 hare
= XSYMBOL (hare
)->value
;
838 tortoise
= XSYMBOL (tortoise
)->value
;
840 if (EQ (hare
, tortoise
))
841 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
848 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
849 doc
: /* Return the variable at the end of OBJECT's variable chain.
850 If OBJECT is a symbol, follow all variable indirections and return the final
851 variable. If OBJECT is not a symbol, just return it.
852 Signal a cyclic-variable-indirection error if there is a loop in the
853 variable chain of symbols. */)
857 if (SYMBOLP (object
))
858 object
= indirect_variable (object
);
863 /* Given the raw contents of a symbol value cell,
864 return the Lisp value of the symbol.
865 This does not handle buffer-local variables; use
866 swap_in_symval_forwarding for that. */
869 do_symval_forwarding (valcontents
)
870 register Lisp_Object valcontents
;
872 register Lisp_Object val
;
874 if (MISCP (valcontents
))
875 switch (XMISCTYPE (valcontents
))
877 case Lisp_Misc_Intfwd
:
878 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
881 case Lisp_Misc_Boolfwd
:
882 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
884 case Lisp_Misc_Objfwd
:
885 return *XOBJFWD (valcontents
)->objvar
;
887 case Lisp_Misc_Buffer_Objfwd
:
888 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
889 return PER_BUFFER_VALUE (current_buffer
, offset
);
891 case Lisp_Misc_Kboard_Objfwd
:
892 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
893 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
898 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
899 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
900 buffer-independent contents of the value cell: forwarded just one
901 step past the buffer-localness.
903 BUF non-zero means set the value in buffer BUF instead of the
904 current buffer. This only plays a role for per-buffer variables. */
907 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
909 register Lisp_Object valcontents
, newval
;
912 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
915 switch (XMISCTYPE (valcontents
))
917 case Lisp_Misc_Intfwd
:
918 CHECK_NUMBER (newval
);
919 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
920 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
921 error ("Value out of range for variable `%s'",
922 SDATA (SYMBOL_NAME (symbol
)));
925 case Lisp_Misc_Boolfwd
:
926 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
929 case Lisp_Misc_Objfwd
:
930 *XOBJFWD (valcontents
)->objvar
= newval
;
932 /* If this variable is a default for something stored
933 in the buffer itself, such as default-fill-column,
934 find the buffers that don't have local values for it
936 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
937 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
939 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
940 - (char *) &buffer_defaults
);
941 int idx
= PER_BUFFER_IDX (offset
);
948 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
953 buf
= Fcdr (XCAR (tail
));
954 if (!BUFFERP (buf
)) continue;
957 if (! PER_BUFFER_VALUE_P (b
, idx
))
958 PER_BUFFER_VALUE (b
, offset
) = newval
;
963 case Lisp_Misc_Buffer_Objfwd
:
965 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
968 type
= PER_BUFFER_TYPE (offset
);
969 if (! NILP (type
) && ! NILP (newval
)
970 && XTYPE (newval
) != XINT (type
))
971 buffer_slot_type_mismatch (offset
);
974 buf
= current_buffer
;
975 PER_BUFFER_VALUE (buf
, offset
) = newval
;
979 case Lisp_Misc_Kboard_Objfwd
:
981 char *base
= (char *) current_kboard
;
982 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
983 *(Lisp_Object
*) p
= newval
;
994 valcontents
= SYMBOL_VALUE (symbol
);
995 if (BUFFER_LOCAL_VALUEP (valcontents
)
996 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
997 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
999 SET_SYMBOL_VALUE (symbol
, newval
);
1003 /* Set up SYMBOL to refer to its global binding.
1004 This makes it safe to alter the status of other bindings. */
1007 swap_in_global_binding (symbol
)
1010 Lisp_Object valcontents
, cdr
;
1012 valcontents
= SYMBOL_VALUE (symbol
);
1013 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1014 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1016 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1018 /* Unload the previously loaded binding. */
1019 Fsetcdr (XCAR (cdr
),
1020 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1022 /* Select the global binding in the symbol. */
1024 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1026 /* Indicate that the global binding is set up now. */
1027 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1028 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1029 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1030 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1033 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1034 VALCONTENTS is the contents of its value cell,
1035 which points to a struct Lisp_Buffer_Local_Value.
1037 Return the value forwarded one step past the buffer-local stage.
1038 This could be another forwarding pointer. */
1041 swap_in_symval_forwarding (symbol
, valcontents
)
1042 Lisp_Object symbol
, valcontents
;
1044 register Lisp_Object tem1
;
1046 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1049 || current_buffer
!= XBUFFER (tem1
)
1050 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1051 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1053 if (XSYMBOL (symbol
)->indirect_variable
)
1054 symbol
= indirect_variable (symbol
);
1056 /* Unload the previously loaded binding. */
1057 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1059 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1060 /* Choose the new binding. */
1061 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1062 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1063 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1066 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1067 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1069 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1071 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1074 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1076 /* Load the new binding. */
1077 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1078 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1079 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1080 store_symval_forwarding (symbol
,
1081 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1084 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1087 /* Find the value of a symbol, returning Qunbound if it's not bound.
1088 This is helpful for code which just wants to get a variable's value
1089 if it has one, without signaling an error.
1090 Note that it must not be possible to quit
1091 within this function. Great care is required for this. */
1094 find_symbol_value (symbol
)
1097 register Lisp_Object valcontents
;
1098 register Lisp_Object val
;
1100 CHECK_SYMBOL (symbol
);
1101 valcontents
= SYMBOL_VALUE (symbol
);
1103 if (BUFFER_LOCAL_VALUEP (valcontents
)
1104 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1105 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1107 if (MISCP (valcontents
))
1109 switch (XMISCTYPE (valcontents
))
1111 case Lisp_Misc_Intfwd
:
1112 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1115 case Lisp_Misc_Boolfwd
:
1116 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1118 case Lisp_Misc_Objfwd
:
1119 return *XOBJFWD (valcontents
)->objvar
;
1121 case Lisp_Misc_Buffer_Objfwd
:
1122 return PER_BUFFER_VALUE (current_buffer
,
1123 XBUFFER_OBJFWD (valcontents
)->offset
);
1125 case Lisp_Misc_Kboard_Objfwd
:
1126 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1127 + (char *)current_kboard
);
1134 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1135 doc
: /* Return SYMBOL's value. Error if that is void. */)
1141 val
= find_symbol_value (symbol
);
1142 if (EQ (val
, Qunbound
))
1143 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1148 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1149 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1151 register Lisp_Object symbol
, newval
;
1153 return set_internal (symbol
, newval
, current_buffer
, 0);
1156 /* Return 1 if SYMBOL currently has a let-binding
1157 which was made in the buffer that is now current. */
1160 let_shadows_buffer_binding_p (symbol
)
1163 volatile struct specbinding
*p
;
1165 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1167 && CONSP (p
->symbol
))
1169 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1170 if ((EQ (symbol
, let_bound_symbol
)
1171 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1172 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1173 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1177 return p
>= specpdl
;
1180 /* Store the value NEWVAL into SYMBOL.
1181 If buffer-locality is an issue, BUF specifies which buffer to use.
1182 (0 stands for the current buffer.)
1184 If BINDFLAG is zero, then if this symbol is supposed to become
1185 local in every buffer where it is set, then we make it local.
1186 If BINDFLAG is nonzero, we don't do that. */
1189 set_internal (symbol
, newval
, buf
, bindflag
)
1190 register Lisp_Object symbol
, newval
;
1194 int voide
= EQ (newval
, Qunbound
);
1196 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1199 buf
= current_buffer
;
1201 /* If restoring in a dead buffer, do nothing. */
1202 if (NILP (buf
->name
))
1205 CHECK_SYMBOL (symbol
);
1206 if (SYMBOL_CONSTANT_P (symbol
)
1207 && (NILP (Fkeywordp (symbol
))
1208 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1209 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1211 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1213 if (BUFFER_OBJFWDP (valcontents
))
1215 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1216 int idx
= PER_BUFFER_IDX (offset
);
1219 && !let_shadows_buffer_binding_p (symbol
))
1220 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1222 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1223 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1225 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1226 if (XSYMBOL (symbol
)->indirect_variable
)
1227 symbol
= indirect_variable (symbol
);
1229 /* What binding is loaded right now? */
1230 current_alist_element
1231 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1233 /* If the current buffer is not the buffer whose binding is
1234 loaded, or if there may be frame-local bindings and the frame
1235 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1236 the default binding is loaded, the loaded binding may be the
1238 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1239 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1240 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1241 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1242 || (BUFFER_LOCAL_VALUEP (valcontents
)
1243 && EQ (XCAR (current_alist_element
),
1244 current_alist_element
)))
1246 /* The currently loaded binding is not necessarily valid.
1247 We need to unload it, and choose a new binding. */
1249 /* Write out `realvalue' to the old loaded binding. */
1250 Fsetcdr (current_alist_element
,
1251 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1253 /* Find the new binding. */
1254 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1255 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1256 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1260 /* This buffer still sees the default value. */
1262 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1263 or if this is `let' rather than `set',
1264 make CURRENT-ALIST-ELEMENT point to itself,
1265 indicating that we're seeing the default value.
1266 Likewise if the variable has been let-bound
1267 in the current buffer. */
1268 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1269 || let_shadows_buffer_binding_p (symbol
))
1271 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1273 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1274 tem1
= Fassq (symbol
,
1275 XFRAME (selected_frame
)->param_alist
);
1278 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1280 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1282 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1283 and we're not within a let that was made for this buffer,
1284 create a new buffer-local binding for the variable.
1285 That means, give this buffer a new assoc for a local value
1286 and load that binding. */
1289 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1290 buf
->local_var_alist
1291 = Fcons (tem1
, buf
->local_var_alist
);
1295 /* Record which binding is now loaded. */
1296 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1299 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1300 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1301 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1303 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1306 /* If storing void (making the symbol void), forward only through
1307 buffer-local indicator, not through Lisp_Objfwd, etc. */
1309 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1311 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1313 /* If we just set a variable whose current binding is frame-local,
1314 store the new value in the frame parameter too. */
1316 if (BUFFER_LOCAL_VALUEP (valcontents
)
1317 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1319 /* What binding is loaded right now? */
1320 current_alist_element
1321 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1323 /* If the current buffer is not the buffer whose binding is
1324 loaded, or if there may be frame-local bindings and the frame
1325 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1326 the default binding is loaded, the loaded binding may be the
1328 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1329 XSETCDR (current_alist_element
, newval
);
1335 /* Access or set a buffer-local symbol's default value. */
1337 /* Return the default value of SYMBOL, but don't check for voidness.
1338 Return Qunbound if it is void. */
1341 default_value (symbol
)
1344 register Lisp_Object valcontents
;
1346 CHECK_SYMBOL (symbol
);
1347 valcontents
= SYMBOL_VALUE (symbol
);
1349 /* For a built-in buffer-local variable, get the default value
1350 rather than letting do_symval_forwarding get the current value. */
1351 if (BUFFER_OBJFWDP (valcontents
))
1353 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1354 if (PER_BUFFER_IDX (offset
) != 0)
1355 return PER_BUFFER_DEFAULT (offset
);
1358 /* Handle user-created local variables. */
1359 if (BUFFER_LOCAL_VALUEP (valcontents
)
1360 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1362 /* If var is set up for a buffer that lacks a local value for it,
1363 the current value is nominally the default value.
1364 But the `realvalue' slot may be more up to date, since
1365 ordinary setq stores just that slot. So use that. */
1366 Lisp_Object current_alist_element
, alist_element_car
;
1367 current_alist_element
1368 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1369 alist_element_car
= XCAR (current_alist_element
);
1370 if (EQ (alist_element_car
, current_alist_element
))
1371 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1373 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1375 /* For other variables, get the current value. */
1376 return do_symval_forwarding (valcontents
);
1379 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1380 doc
: /* Return t if SYMBOL has a non-void default value.
1381 This is the value that is seen in buffers that do not have their own values
1382 for this variable. */)
1386 register Lisp_Object value
;
1388 value
= default_value (symbol
);
1389 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1392 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1393 doc
: /* Return SYMBOL's default value.
1394 This is the value that is seen in buffers that do not have their own values
1395 for this variable. The default value is meaningful for variables with
1396 local bindings in certain buffers. */)
1400 register Lisp_Object value
;
1402 value
= default_value (symbol
);
1403 if (EQ (value
, Qunbound
))
1404 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1408 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1409 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1410 The default value is seen in buffers that do not have their own values
1411 for this variable. */)
1413 Lisp_Object symbol
, value
;
1415 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1417 CHECK_SYMBOL (symbol
);
1418 valcontents
= SYMBOL_VALUE (symbol
);
1420 /* Handle variables like case-fold-search that have special slots
1421 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1423 if (BUFFER_OBJFWDP (valcontents
))
1425 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1426 int idx
= PER_BUFFER_IDX (offset
);
1428 PER_BUFFER_DEFAULT (offset
) = value
;
1430 /* If this variable is not always local in all buffers,
1431 set it in the buffers that don't nominally have a local value. */
1436 for (b
= all_buffers
; b
; b
= b
->next
)
1437 if (!PER_BUFFER_VALUE_P (b
, idx
))
1438 PER_BUFFER_VALUE (b
, offset
) = value
;
1443 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1444 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1445 return Fset (symbol
, value
);
1447 /* Store new value into the DEFAULT-VALUE slot. */
1448 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1450 /* If the default binding is now loaded, set the REALVALUE slot too. */
1451 current_alist_element
1452 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1453 alist_element_buffer
= Fcar (current_alist_element
);
1454 if (EQ (alist_element_buffer
, current_alist_element
))
1455 store_symval_forwarding (symbol
,
1456 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1462 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1463 doc
: /* Set the default value of variable VAR to VALUE.
1464 VAR, the variable name, is literal (not evaluated);
1465 VALUE is an expression: it is evaluated and its value returned.
1466 The default value of a variable is seen in buffers
1467 that do not have their own values for the variable.
1469 More generally, you can use multiple variables and values, as in
1470 (setq-default VAR VALUE VAR VALUE...)
1471 This sets each VAR's default value to the corresponding VALUE.
1472 The VALUE for the Nth VAR can refer to the new default values
1474 usage: (setq-default [VAR VALUE...]) */)
1478 register Lisp_Object args_left
;
1479 register Lisp_Object val
, symbol
;
1480 struct gcpro gcpro1
;
1490 val
= Feval (Fcar (Fcdr (args_left
)));
1491 symbol
= XCAR (args_left
);
1492 Fset_default (symbol
, val
);
1493 args_left
= Fcdr (XCDR (args_left
));
1495 while (!NILP (args_left
));
1501 /* Lisp functions for creating and removing buffer-local variables. */
1503 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1504 1, 1, "vMake Variable Buffer Local: ",
1505 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1506 At any time, the value for the current buffer is in effect,
1507 unless the variable has never been set in this buffer,
1508 in which case the default value is in effect.
1509 Note that binding the variable with `let', or setting it while
1510 a `let'-style binding made in this buffer is in effect,
1511 does not make the variable buffer-local. Return VARIABLE.
1513 In most cases it is better to use `make-local-variable',
1514 which makes a variable local in just one buffer.
1516 The function `default-value' gets the default value and `set-default' sets it. */)
1518 register Lisp_Object variable
;
1520 register Lisp_Object tem
, valcontents
, newval
;
1522 CHECK_SYMBOL (variable
);
1523 variable
= indirect_variable (variable
);
1525 valcontents
= SYMBOL_VALUE (variable
);
1526 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1527 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1529 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1531 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1533 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1536 if (EQ (valcontents
, Qunbound
))
1537 SET_SYMBOL_VALUE (variable
, Qnil
);
1538 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1540 newval
= allocate_misc ();
1541 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1542 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1543 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1544 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1545 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1546 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1547 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1548 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1549 SET_SYMBOL_VALUE (variable
, newval
);
1553 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1554 1, 1, "vMake Local Variable: ",
1555 doc
: /* Make VARIABLE have a separate value in the current buffer.
1556 Other buffers will continue to share a common default value.
1557 \(The buffer-local value of VARIABLE starts out as the same value
1558 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1561 If the variable is already arranged to become local when set,
1562 this function causes a local value to exist for this buffer,
1563 just as setting the variable would do.
1565 This function returns VARIABLE, and therefore
1566 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1569 See also `make-variable-buffer-local'.
1571 Do not use `make-local-variable' to make a hook variable buffer-local.
1572 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1574 register Lisp_Object variable
;
1576 register Lisp_Object tem
, valcontents
;
1578 CHECK_SYMBOL (variable
);
1579 variable
= indirect_variable (variable
);
1581 valcontents
= SYMBOL_VALUE (variable
);
1582 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1583 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1585 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1587 tem
= Fboundp (variable
);
1589 /* Make sure the symbol has a local value in this particular buffer,
1590 by setting it to the same value it already has. */
1591 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1594 /* Make sure symbol is set up to hold per-buffer values. */
1595 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1598 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1600 newval
= allocate_misc ();
1601 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1602 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1603 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1604 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1605 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1606 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1607 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1608 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1609 SET_SYMBOL_VALUE (variable
, newval
);;
1611 /* Make sure this buffer has its own value of symbol. */
1612 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1615 /* Swap out any local binding for some other buffer, and make
1616 sure the current value is permanently recorded, if it's the
1618 find_symbol_value (variable
);
1620 current_buffer
->local_var_alist
1621 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1622 current_buffer
->local_var_alist
);
1624 /* Make sure symbol does not think it is set up for this buffer;
1625 force it to look once again for this buffer's value. */
1627 Lisp_Object
*pvalbuf
;
1629 valcontents
= SYMBOL_VALUE (variable
);
1631 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1632 if (current_buffer
== XBUFFER (*pvalbuf
))
1634 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1638 /* If the symbol forwards into a C variable, then load the binding
1639 for this buffer now. If C code modifies the variable before we
1640 load the binding in, then that new value will clobber the default
1641 binding the next time we unload it. */
1642 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1643 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1644 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1649 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1650 1, 1, "vKill Local Variable: ",
1651 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1652 From now on the default value will apply in this buffer. Return VARIABLE. */)
1654 register Lisp_Object variable
;
1656 register Lisp_Object tem
, valcontents
;
1658 CHECK_SYMBOL (variable
);
1659 variable
= indirect_variable (variable
);
1661 valcontents
= SYMBOL_VALUE (variable
);
1663 if (BUFFER_OBJFWDP (valcontents
))
1665 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1666 int idx
= PER_BUFFER_IDX (offset
);
1670 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1671 PER_BUFFER_VALUE (current_buffer
, offset
)
1672 = PER_BUFFER_DEFAULT (offset
);
1677 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1678 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1681 /* Get rid of this buffer's alist element, if any. */
1683 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1685 current_buffer
->local_var_alist
1686 = Fdelq (tem
, current_buffer
->local_var_alist
);
1688 /* If the symbol is set up with the current buffer's binding
1689 loaded, recompute its value. We have to do it now, or else
1690 forwarded objects won't work right. */
1692 Lisp_Object
*pvalbuf
, buf
;
1693 valcontents
= SYMBOL_VALUE (variable
);
1694 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1695 XSETBUFFER (buf
, current_buffer
);
1696 if (EQ (buf
, *pvalbuf
))
1699 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1700 find_symbol_value (variable
);
1707 /* Lisp functions for creating and removing buffer-local variables. */
1709 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1710 1, 1, "vMake Variable Frame Local: ",
1711 doc
: /* Enable VARIABLE to have frame-local bindings.
1712 When a frame-local binding exists in the current frame,
1713 it is in effect whenever the current buffer has no buffer-local binding.
1714 A frame-local binding is actually a frame parameter value;
1715 thus, any given frame has a local binding for VARIABLE if it has
1716 a value for the frame parameter named VARIABLE. Return VARIABLE.
1718 This function does not in itself create any frame-local bindings for
1719 VARIABLE. See `modify-frame-parameters' for how to set frame parameters. */)
1721 register Lisp_Object variable
;
1723 register Lisp_Object tem
, valcontents
, newval
;
1725 CHECK_SYMBOL (variable
);
1726 variable
= indirect_variable (variable
);
1728 valcontents
= SYMBOL_VALUE (variable
);
1729 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1730 || BUFFER_OBJFWDP (valcontents
))
1731 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1733 if (BUFFER_LOCAL_VALUEP (valcontents
)
1734 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1736 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1740 if (EQ (valcontents
, Qunbound
))
1741 SET_SYMBOL_VALUE (variable
, Qnil
);
1742 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1744 newval
= allocate_misc ();
1745 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1746 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1747 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1748 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1749 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1750 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1751 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1752 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1753 SET_SYMBOL_VALUE (variable
, newval
);
1757 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1759 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1760 BUFFER defaults to the current buffer. */)
1762 register Lisp_Object variable
, buffer
;
1764 Lisp_Object valcontents
;
1765 register struct buffer
*buf
;
1768 buf
= current_buffer
;
1771 CHECK_BUFFER (buffer
);
1772 buf
= XBUFFER (buffer
);
1775 CHECK_SYMBOL (variable
);
1776 variable
= indirect_variable (variable
);
1778 valcontents
= SYMBOL_VALUE (variable
);
1779 if (BUFFER_LOCAL_VALUEP (valcontents
)
1780 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1782 Lisp_Object tail
, elt
;
1784 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1787 if (EQ (variable
, XCAR (elt
)))
1791 if (BUFFER_OBJFWDP (valcontents
))
1793 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1794 int idx
= PER_BUFFER_IDX (offset
);
1795 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1801 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1803 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1804 More precisely, this means that setting the variable \(with `set' or`setq'),
1805 while it does not have a `let'-style binding that was made in BUFFER,
1806 will produce a buffer local binding. See Info node
1807 `(elisp)Creating Buffer-Local'.
1808 BUFFER defaults to the current buffer. */)
1810 register Lisp_Object variable
, buffer
;
1812 Lisp_Object valcontents
;
1813 register struct buffer
*buf
;
1816 buf
= current_buffer
;
1819 CHECK_BUFFER (buffer
);
1820 buf
= XBUFFER (buffer
);
1823 CHECK_SYMBOL (variable
);
1824 variable
= indirect_variable (variable
);
1826 valcontents
= SYMBOL_VALUE (variable
);
1828 /* This means that make-variable-buffer-local was done. */
1829 if (BUFFER_LOCAL_VALUEP (valcontents
))
1831 /* All these slots become local if they are set. */
1832 if (BUFFER_OBJFWDP (valcontents
))
1834 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1836 Lisp_Object tail
, elt
;
1837 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1840 if (EQ (variable
, XCAR (elt
)))
1847 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1849 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1850 If the current binding is buffer-local, the value is the current buffer.
1851 If the current binding is frame-local, the value is the selected frame.
1852 If the current binding is global (the default), the value is nil. */)
1854 register Lisp_Object variable
;
1856 Lisp_Object valcontents
;
1858 CHECK_SYMBOL (variable
);
1859 variable
= indirect_variable (variable
);
1861 /* Make sure the current binding is actually swapped in. */
1862 find_symbol_value (variable
);
1864 valcontents
= XSYMBOL (variable
)->value
;
1866 if (BUFFER_LOCAL_VALUEP (valcontents
)
1867 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1868 || BUFFER_OBJFWDP (valcontents
))
1870 /* For a local variable, record both the symbol and which
1871 buffer's or frame's value we are saving. */
1872 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1873 return Fcurrent_buffer ();
1874 else if (!BUFFER_OBJFWDP (valcontents
)
1875 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1876 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1882 /* Find the function at the end of a chain of symbol function indirections. */
1884 /* If OBJECT is a symbol, find the end of its function chain and
1885 return the value found there. If OBJECT is not a symbol, just
1886 return it. If there is a cycle in the function chain, signal a
1887 cyclic-function-indirection error.
1889 This is like Findirect_function, except that it doesn't signal an
1890 error if the chain ends up unbound. */
1892 indirect_function (object
)
1893 register Lisp_Object object
;
1895 Lisp_Object tortoise
, hare
;
1897 hare
= tortoise
= object
;
1901 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1903 hare
= XSYMBOL (hare
)->function
;
1904 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1906 hare
= XSYMBOL (hare
)->function
;
1908 tortoise
= XSYMBOL (tortoise
)->function
;
1910 if (EQ (hare
, tortoise
))
1911 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1917 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1918 doc
: /* Return the function at the end of OBJECT's function chain.
1919 If OBJECT is a symbol, follow all function indirections and return the final
1921 If OBJECT is not a symbol, just return it.
1922 Signal a void-function error if the final symbol is unbound.
1923 Signal a cyclic-function-indirection error if there is a loop in the
1924 function chain of symbols. */)
1926 register Lisp_Object object
;
1930 result
= indirect_function (object
);
1932 if (EQ (result
, Qunbound
))
1933 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1937 /* Extract and set vector and string elements */
1939 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1940 doc
: /* Return the element of ARRAY at index IDX.
1941 ARRAY may be a vector, a string, a char-table, a bool-vector,
1942 or a byte-code object. IDX starts at 0. */)
1944 register Lisp_Object array
;
1947 register int idxval
;
1950 idxval
= XINT (idx
);
1951 if (STRINGP (array
))
1955 if (idxval
< 0 || idxval
>= SCHARS (array
))
1956 args_out_of_range (array
, idx
);
1957 if (! STRING_MULTIBYTE (array
))
1958 return make_number ((unsigned char) SREF (array
, idxval
));
1959 idxval_byte
= string_char_to_byte (array
, idxval
);
1961 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1962 SBYTES (array
) - idxval_byte
);
1963 return make_number (c
);
1965 else if (BOOL_VECTOR_P (array
))
1969 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1970 args_out_of_range (array
, idx
);
1972 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1973 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1975 else if (CHAR_TABLE_P (array
))
1982 args_out_of_range (array
, idx
);
1983 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1985 if (! SINGLE_BYTE_CHAR_P (idxval
))
1986 args_out_of_range (array
, idx
);
1987 /* For ASCII and 8-bit European characters, the element is
1988 stored in the top table. */
1989 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1993 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
1994 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
1995 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
1996 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
1999 val
= XCHAR_TABLE (array
)->defalt
;
2000 while (NILP (val
)) /* Follow parents until we find some value. */
2002 array
= XCHAR_TABLE (array
)->parent
;
2005 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2007 val
= XCHAR_TABLE (array
)->defalt
;
2014 Lisp_Object sub_table
;
2015 Lisp_Object current_default
;
2017 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2018 if (code
[1] < 32) code
[1] = -1;
2019 else if (code
[2] < 32) code
[2] = -1;
2021 /* Here, the possible range of CODE[0] (== charset ID) is
2022 128..MAX_CHARSET. Since the top level char table contains
2023 data for multibyte characters after 256th element, we must
2024 increment CODE[0] by 128 to get a correct index. */
2026 code
[3] = -1; /* anchor */
2028 try_parent_char_table
:
2029 current_default
= XCHAR_TABLE (array
)->defalt
;
2031 for (i
= 0; code
[i
] >= 0; i
++)
2033 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2034 if (SUB_CHAR_TABLE_P (val
))
2037 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2038 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2043 val
= current_default
;
2046 array
= XCHAR_TABLE (array
)->parent
;
2048 goto try_parent_char_table
;
2053 /* Reaching here means IDXVAL is a generic character in
2054 which each character or a group has independent value.
2055 Essentially it's nonsense to get a value for such a
2056 generic character, but for backward compatibility, we try
2057 the default value and parent. */
2058 val
= current_default
;
2061 array
= XCHAR_TABLE (array
)->parent
;
2063 goto try_parent_char_table
;
2071 if (VECTORP (array
))
2072 size
= XVECTOR (array
)->size
;
2073 else if (COMPILEDP (array
))
2074 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2076 wrong_type_argument (Qarrayp
, array
);
2078 if (idxval
< 0 || idxval
>= size
)
2079 args_out_of_range (array
, idx
);
2080 return XVECTOR (array
)->contents
[idxval
];
2084 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2085 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2086 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2087 bool-vector. IDX starts at 0. */)
2088 (array
, idx
, newelt
)
2089 register Lisp_Object array
;
2090 Lisp_Object idx
, newelt
;
2092 register int idxval
;
2095 idxval
= XINT (idx
);
2096 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2097 && ! CHAR_TABLE_P (array
))
2098 array
= wrong_type_argument (Qarrayp
, array
);
2099 CHECK_IMPURE (array
);
2101 if (VECTORP (array
))
2103 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2104 args_out_of_range (array
, idx
);
2105 XVECTOR (array
)->contents
[idxval
] = newelt
;
2107 else if (BOOL_VECTOR_P (array
))
2111 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2112 args_out_of_range (array
, idx
);
2114 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2116 if (! NILP (newelt
))
2117 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2119 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2120 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2122 else if (CHAR_TABLE_P (array
))
2125 args_out_of_range (array
, idx
);
2126 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2128 if (! SINGLE_BYTE_CHAR_P (idxval
))
2129 args_out_of_range (array
, idx
);
2130 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2137 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2138 if (code
[1] < 32) code
[1] = -1;
2139 else if (code
[2] < 32) code
[2] = -1;
2141 /* See the comment of the corresponding part in Faref. */
2143 code
[3] = -1; /* anchor */
2144 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2146 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2147 if (SUB_CHAR_TABLE_P (val
))
2153 /* VAL is a leaf. Create a sub char table with the
2154 initial value VAL and look into it. */
2156 temp
= make_sub_char_table (val
);
2157 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2161 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2164 else if (STRING_MULTIBYTE (array
))
2166 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2167 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2169 if (idxval
< 0 || idxval
>= SCHARS (array
))
2170 args_out_of_range (array
, idx
);
2171 CHECK_NUMBER (newelt
);
2173 nbytes
= SBYTES (array
);
2175 idxval_byte
= string_char_to_byte (array
, idxval
);
2176 p1
= SDATA (array
) + idxval_byte
;
2177 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2178 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2179 if (prev_bytes
!= new_bytes
)
2181 /* We must relocate the string data. */
2182 int nchars
= SCHARS (array
);
2186 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2187 bcopy (SDATA (array
), str
, nbytes
);
2188 allocate_string_data (XSTRING (array
), nchars
,
2189 nbytes
+ new_bytes
- prev_bytes
);
2190 bcopy (str
, SDATA (array
), idxval_byte
);
2191 p1
= SDATA (array
) + idxval_byte
;
2192 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2193 nbytes
- (idxval_byte
+ prev_bytes
));
2195 clear_string_char_byte_cache ();
2202 if (idxval
< 0 || idxval
>= SCHARS (array
))
2203 args_out_of_range (array
, idx
);
2204 CHECK_NUMBER (newelt
);
2206 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2207 SSET (array
, idxval
, XINT (newelt
));
2210 /* We must relocate the string data while converting it to
2212 int idxval_byte
, prev_bytes
, new_bytes
;
2213 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2214 unsigned char *origstr
= SDATA (array
), *str
;
2218 nchars
= SCHARS (array
);
2219 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2220 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2222 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2223 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2224 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2226 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2227 allocate_string_data (XSTRING (array
), nchars
,
2228 nbytes
+ new_bytes
- prev_bytes
);
2229 bcopy (str
, SDATA (array
), idxval_byte
);
2230 p1
= SDATA (array
) + idxval_byte
;
2233 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2234 nbytes
- (idxval_byte
+ prev_bytes
));
2236 clear_string_char_byte_cache ();
2243 /* Arithmetic functions */
2245 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2248 arithcompare (num1
, num2
, comparison
)
2249 Lisp_Object num1
, num2
;
2250 enum comparison comparison
;
2252 double f1
= 0, f2
= 0;
2255 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2256 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2258 if (FLOATP (num1
) || FLOATP (num2
))
2261 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2262 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2268 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2273 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2278 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2283 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2288 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2293 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2302 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2303 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2305 register Lisp_Object num1
, num2
;
2307 return arithcompare (num1
, num2
, equal
);
2310 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2311 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2313 register Lisp_Object num1
, num2
;
2315 return arithcompare (num1
, num2
, less
);
2318 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2319 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2321 register Lisp_Object num1
, num2
;
2323 return arithcompare (num1
, num2
, grtr
);
2326 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2327 doc
: /* Return t if first arg is less than or equal to second arg.
2328 Both must be numbers or markers. */)
2330 register Lisp_Object num1
, num2
;
2332 return arithcompare (num1
, num2
, less_or_equal
);
2335 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2336 doc
: /* Return t if first arg is greater than or equal to second arg.
2337 Both must be numbers or markers. */)
2339 register Lisp_Object num1
, num2
;
2341 return arithcompare (num1
, num2
, grtr_or_equal
);
2344 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2345 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2347 register Lisp_Object num1
, num2
;
2349 return arithcompare (num1
, num2
, notequal
);
2352 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2353 doc
: /* Return t if NUMBER is zero. */)
2355 register Lisp_Object number
;
2357 CHECK_NUMBER_OR_FLOAT (number
);
2359 if (FLOATP (number
))
2361 if (XFLOAT_DATA (number
) == 0.0)
2371 /* Convert between long values and pairs of Lisp integers. */
2377 unsigned long top
= i
>> 16;
2378 unsigned int bot
= i
& 0xFFFF;
2380 return make_number (bot
);
2381 if (top
== (unsigned long)-1 >> 16)
2382 return Fcons (make_number (-1), make_number (bot
));
2383 return Fcons (make_number (top
), make_number (bot
));
2390 Lisp_Object top
, bot
;
2397 return ((XINT (top
) << 16) | XINT (bot
));
2400 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2401 doc
: /* Return the decimal representation of NUMBER as a string.
2402 Uses a minus sign if negative.
2403 NUMBER may be an integer or a floating point number. */)
2407 char buffer
[VALBITS
];
2409 CHECK_NUMBER_OR_FLOAT (number
);
2411 if (FLOATP (number
))
2413 char pigbuf
[350]; /* see comments in float_to_string */
2415 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2416 return build_string (pigbuf
);
2419 if (sizeof (int) == sizeof (EMACS_INT
))
2420 sprintf (buffer
, "%d", XINT (number
));
2421 else if (sizeof (long) == sizeof (EMACS_INT
))
2422 sprintf (buffer
, "%ld", (long) XINT (number
));
2425 return build_string (buffer
);
2429 digit_to_number (character
, base
)
2430 int character
, base
;
2434 if (character
>= '0' && character
<= '9')
2435 digit
= character
- '0';
2436 else if (character
>= 'a' && character
<= 'z')
2437 digit
= character
- 'a' + 10;
2438 else if (character
>= 'A' && character
<= 'Z')
2439 digit
= character
- 'A' + 10;
2449 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2450 doc
: /* Parse STRING as a decimal number and return the number.
2451 This parses both integers and floating point numbers.
2452 It ignores leading spaces and tabs.
2454 If BASE, interpret STRING as a number in that base. If BASE isn't
2455 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2456 If the base used is not 10, floating point is not recognized. */)
2458 register Lisp_Object string
, base
;
2460 register unsigned char *p
;
2465 CHECK_STRING (string
);
2471 CHECK_NUMBER (base
);
2473 if (b
< 2 || b
> 16)
2474 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2477 /* Skip any whitespace at the front of the number. Some versions of
2478 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2480 while (*p
== ' ' || *p
== '\t')
2491 if (isfloat_string (p
) && b
== 10)
2492 val
= make_float (sign
* atof (p
));
2499 int digit
= digit_to_number (*p
++, b
);
2505 val
= make_fixnum_or_float (sign
* v
);
2525 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2526 int, Lisp_Object
*));
2527 extern Lisp_Object
fmod_float ();
2530 arith_driver (code
, nargs
, args
)
2533 register Lisp_Object
*args
;
2535 register Lisp_Object val
;
2536 register int argnum
;
2537 register EMACS_INT accum
= 0;
2538 register EMACS_INT next
;
2540 switch (SWITCH_ENUM_CAST (code
))
2558 for (argnum
= 0; argnum
< nargs
; argnum
++)
2560 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2562 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2565 return float_arith_driver ((double) accum
, argnum
, code
,
2568 next
= XINT (args
[argnum
]);
2569 switch (SWITCH_ENUM_CAST (code
))
2575 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2586 Fsignal (Qarith_error
, Qnil
);
2600 if (!argnum
|| next
> accum
)
2604 if (!argnum
|| next
< accum
)
2610 XSETINT (val
, accum
);
2615 #define isnan(x) ((x) != (x))
2618 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2620 register int argnum
;
2623 register Lisp_Object
*args
;
2625 register Lisp_Object val
;
2628 for (; argnum
< nargs
; argnum
++)
2630 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2631 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2635 next
= XFLOAT_DATA (val
);
2639 args
[argnum
] = val
; /* runs into a compiler bug. */
2640 next
= XINT (args
[argnum
]);
2642 switch (SWITCH_ENUM_CAST (code
))
2648 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2658 if (! IEEE_FLOATING_POINT
&& next
== 0)
2659 Fsignal (Qarith_error
, Qnil
);
2666 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2668 if (!argnum
|| isnan (next
) || next
> accum
)
2672 if (!argnum
|| isnan (next
) || next
< accum
)
2678 return make_float (accum
);
2682 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2683 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2684 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2689 return arith_driver (Aadd
, nargs
, args
);
2692 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2693 doc
: /* Negate number or subtract numbers or markers and return the result.
2694 With one arg, negates it. With more than one arg,
2695 subtracts all but the first from the first.
2696 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2701 return arith_driver (Asub
, nargs
, args
);
2704 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2705 doc
: /* Return product of any number of arguments, which are numbers or markers.
2706 usage: (* &rest NUMBERS-OR-MARKERS) */)
2711 return arith_driver (Amult
, nargs
, args
);
2714 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2715 doc
: /* Return first argument divided by all the remaining arguments.
2716 The arguments must be numbers or markers.
2717 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2723 for (argnum
= 2; argnum
< nargs
; argnum
++)
2724 if (FLOATP (args
[argnum
]))
2725 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2726 return arith_driver (Adiv
, nargs
, args
);
2729 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2730 doc
: /* Return remainder of X divided by Y.
2731 Both must be integers or markers. */)
2733 register Lisp_Object x
, y
;
2737 CHECK_NUMBER_COERCE_MARKER (x
);
2738 CHECK_NUMBER_COERCE_MARKER (y
);
2740 if (XFASTINT (y
) == 0)
2741 Fsignal (Qarith_error
, Qnil
);
2743 XSETINT (val
, XINT (x
) % XINT (y
));
2757 /* If the magnitude of the result exceeds that of the divisor, or
2758 the sign of the result does not agree with that of the dividend,
2759 iterate with the reduced value. This does not yield a
2760 particularly accurate result, but at least it will be in the
2761 range promised by fmod. */
2763 r
-= f2
* floor (r
/ f2
);
2764 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2768 #endif /* ! HAVE_FMOD */
2770 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2771 doc
: /* Return X modulo Y.
2772 The result falls between zero (inclusive) and Y (exclusive).
2773 Both X and Y must be numbers or markers. */)
2775 register Lisp_Object x
, y
;
2780 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2781 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2783 if (FLOATP (x
) || FLOATP (y
))
2784 return fmod_float (x
, y
);
2790 Fsignal (Qarith_error
, Qnil
);
2794 /* If the "remainder" comes out with the wrong sign, fix it. */
2795 if (i2
< 0 ? i1
> 0 : i1
< 0)
2802 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2803 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2804 The value is always a number; markers are converted to numbers.
2805 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2810 return arith_driver (Amax
, nargs
, args
);
2813 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2814 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2815 The value is always a number; markers are converted to numbers.
2816 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2821 return arith_driver (Amin
, nargs
, args
);
2824 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2825 doc
: /* Return bitwise-and of all the arguments.
2826 Arguments may be integers, or markers converted to integers.
2827 usage: (logand &rest INTS-OR-MARKERS) */)
2832 return arith_driver (Alogand
, nargs
, args
);
2835 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2836 doc
: /* Return bitwise-or of all the arguments.
2837 Arguments may be integers, or markers converted to integers.
2838 usage: (logior &rest INTS-OR-MARKERS) */)
2843 return arith_driver (Alogior
, nargs
, args
);
2846 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2847 doc
: /* Return bitwise-exclusive-or of all the arguments.
2848 Arguments may be integers, or markers converted to integers.
2849 usage: (logxor &rest INTS-OR-MARKERS) */)
2854 return arith_driver (Alogxor
, nargs
, args
);
2857 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2858 doc
: /* Return VALUE with its bits shifted left by COUNT.
2859 If COUNT is negative, shifting is actually to the right.
2860 In this case, the sign bit is duplicated. */)
2862 register Lisp_Object value
, count
;
2864 register Lisp_Object val
;
2866 CHECK_NUMBER (value
);
2867 CHECK_NUMBER (count
);
2869 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2871 else if (XINT (count
) > 0)
2872 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2873 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2874 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2876 XSETINT (val
, XINT (value
) >> -XINT (count
));
2880 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2881 doc
: /* Return VALUE with its bits shifted left by COUNT.
2882 If COUNT is negative, shifting is actually to the right.
2883 In this case, zeros are shifted in on the left. */)
2885 register Lisp_Object value
, count
;
2887 register Lisp_Object val
;
2889 CHECK_NUMBER (value
);
2890 CHECK_NUMBER (count
);
2892 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2894 else if (XINT (count
) > 0)
2895 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2896 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2899 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2903 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2904 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2905 Markers are converted to integers. */)
2907 register Lisp_Object number
;
2909 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2911 if (FLOATP (number
))
2912 return (make_float (1.0 + XFLOAT_DATA (number
)));
2914 XSETINT (number
, XINT (number
) + 1);
2918 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2919 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2920 Markers are converted to integers. */)
2922 register Lisp_Object number
;
2924 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2926 if (FLOATP (number
))
2927 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2929 XSETINT (number
, XINT (number
) - 1);
2933 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2934 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2936 register Lisp_Object number
;
2938 CHECK_NUMBER (number
);
2939 XSETINT (number
, ~XINT (number
));
2943 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2944 doc
: /* Return the byteorder for the machine.
2945 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2946 lowercase l) for small endian machines. */)
2949 unsigned i
= 0x04030201;
2950 int order
= *(char *)&i
== 1 ? 108 : 66;
2952 return make_number (order
);
2960 Lisp_Object error_tail
, arith_tail
;
2962 Qquote
= intern ("quote");
2963 Qlambda
= intern ("lambda");
2964 Qsubr
= intern ("subr");
2965 Qerror_conditions
= intern ("error-conditions");
2966 Qerror_message
= intern ("error-message");
2967 Qtop_level
= intern ("top-level");
2969 Qerror
= intern ("error");
2970 Qquit
= intern ("quit");
2971 Qwrong_type_argument
= intern ("wrong-type-argument");
2972 Qargs_out_of_range
= intern ("args-out-of-range");
2973 Qvoid_function
= intern ("void-function");
2974 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2975 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2976 Qvoid_variable
= intern ("void-variable");
2977 Qsetting_constant
= intern ("setting-constant");
2978 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2980 Qinvalid_function
= intern ("invalid-function");
2981 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2982 Qno_catch
= intern ("no-catch");
2983 Qend_of_file
= intern ("end-of-file");
2984 Qarith_error
= intern ("arith-error");
2985 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2986 Qend_of_buffer
= intern ("end-of-buffer");
2987 Qbuffer_read_only
= intern ("buffer-read-only");
2988 Qtext_read_only
= intern ("text-read-only");
2989 Qmark_inactive
= intern ("mark-inactive");
2991 Qlistp
= intern ("listp");
2992 Qconsp
= intern ("consp");
2993 Qsymbolp
= intern ("symbolp");
2994 Qkeywordp
= intern ("keywordp");
2995 Qintegerp
= intern ("integerp");
2996 Qnatnump
= intern ("natnump");
2997 Qwholenump
= intern ("wholenump");
2998 Qstringp
= intern ("stringp");
2999 Qarrayp
= intern ("arrayp");
3000 Qsequencep
= intern ("sequencep");
3001 Qbufferp
= intern ("bufferp");
3002 Qvectorp
= intern ("vectorp");
3003 Qchar_or_string_p
= intern ("char-or-string-p");
3004 Qmarkerp
= intern ("markerp");
3005 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3006 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3007 Qboundp
= intern ("boundp");
3008 Qfboundp
= intern ("fboundp");
3010 Qfloatp
= intern ("floatp");
3011 Qnumberp
= intern ("numberp");
3012 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3014 Qchar_table_p
= intern ("char-table-p");
3015 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3017 Qsubrp
= intern ("subrp");
3018 Qunevalled
= intern ("unevalled");
3019 Qmany
= intern ("many");
3021 Qcdr
= intern ("cdr");
3023 /* Handle automatic advice activation */
3024 Qad_advice_info
= intern ("ad-advice-info");
3025 Qad_activate_internal
= intern ("ad-activate-internal");
3027 error_tail
= Fcons (Qerror
, Qnil
);
3029 /* ERROR is used as a signaler for random errors for which nothing else is right */
3031 Fput (Qerror
, Qerror_conditions
,
3033 Fput (Qerror
, Qerror_message
,
3034 build_string ("error"));
3036 Fput (Qquit
, Qerror_conditions
,
3037 Fcons (Qquit
, Qnil
));
3038 Fput (Qquit
, Qerror_message
,
3039 build_string ("Quit"));
3041 Fput (Qwrong_type_argument
, Qerror_conditions
,
3042 Fcons (Qwrong_type_argument
, error_tail
));
3043 Fput (Qwrong_type_argument
, Qerror_message
,
3044 build_string ("Wrong type argument"));
3046 Fput (Qargs_out_of_range
, Qerror_conditions
,
3047 Fcons (Qargs_out_of_range
, error_tail
));
3048 Fput (Qargs_out_of_range
, Qerror_message
,
3049 build_string ("Args out of range"));
3051 Fput (Qvoid_function
, Qerror_conditions
,
3052 Fcons (Qvoid_function
, error_tail
));
3053 Fput (Qvoid_function
, Qerror_message
,
3054 build_string ("Symbol's function definition is void"));
3056 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3057 Fcons (Qcyclic_function_indirection
, error_tail
));
3058 Fput (Qcyclic_function_indirection
, Qerror_message
,
3059 build_string ("Symbol's chain of function indirections contains a loop"));
3061 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3062 Fcons (Qcyclic_variable_indirection
, error_tail
));
3063 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3064 build_string ("Symbol's chain of variable indirections contains a loop"));
3066 Qcircular_list
= intern ("circular-list");
3067 staticpro (&Qcircular_list
);
3068 Fput (Qcircular_list
, Qerror_conditions
,
3069 Fcons (Qcircular_list
, error_tail
));
3070 Fput (Qcircular_list
, Qerror_message
,
3071 build_string ("List contains a loop"));
3073 Fput (Qvoid_variable
, Qerror_conditions
,
3074 Fcons (Qvoid_variable
, error_tail
));
3075 Fput (Qvoid_variable
, Qerror_message
,
3076 build_string ("Symbol's value as variable is void"));
3078 Fput (Qsetting_constant
, Qerror_conditions
,
3079 Fcons (Qsetting_constant
, error_tail
));
3080 Fput (Qsetting_constant
, Qerror_message
,
3081 build_string ("Attempt to set a constant symbol"));
3083 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3084 Fcons (Qinvalid_read_syntax
, error_tail
));
3085 Fput (Qinvalid_read_syntax
, Qerror_message
,
3086 build_string ("Invalid read syntax"));
3088 Fput (Qinvalid_function
, Qerror_conditions
,
3089 Fcons (Qinvalid_function
, error_tail
));
3090 Fput (Qinvalid_function
, Qerror_message
,
3091 build_string ("Invalid function"));
3093 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3094 Fcons (Qwrong_number_of_arguments
, error_tail
));
3095 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3096 build_string ("Wrong number of arguments"));
3098 Fput (Qno_catch
, Qerror_conditions
,
3099 Fcons (Qno_catch
, error_tail
));
3100 Fput (Qno_catch
, Qerror_message
,
3101 build_string ("No catch for tag"));
3103 Fput (Qend_of_file
, Qerror_conditions
,
3104 Fcons (Qend_of_file
, error_tail
));
3105 Fput (Qend_of_file
, Qerror_message
,
3106 build_string ("End of file during parsing"));
3108 arith_tail
= Fcons (Qarith_error
, error_tail
);
3109 Fput (Qarith_error
, Qerror_conditions
,
3111 Fput (Qarith_error
, Qerror_message
,
3112 build_string ("Arithmetic error"));
3114 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3115 Fcons (Qbeginning_of_buffer
, error_tail
));
3116 Fput (Qbeginning_of_buffer
, Qerror_message
,
3117 build_string ("Beginning of buffer"));
3119 Fput (Qend_of_buffer
, Qerror_conditions
,
3120 Fcons (Qend_of_buffer
, error_tail
));
3121 Fput (Qend_of_buffer
, Qerror_message
,
3122 build_string ("End of buffer"));
3124 Fput (Qbuffer_read_only
, Qerror_conditions
,
3125 Fcons (Qbuffer_read_only
, error_tail
));
3126 Fput (Qbuffer_read_only
, Qerror_message
,
3127 build_string ("Buffer is read-only"));
3129 Fput (Qtext_read_only
, Qerror_conditions
,
3130 Fcons (Qtext_read_only
, error_tail
));
3131 Fput (Qtext_read_only
, Qerror_message
,
3132 build_string ("Text is read-only"));
3134 Qrange_error
= intern ("range-error");
3135 Qdomain_error
= intern ("domain-error");
3136 Qsingularity_error
= intern ("singularity-error");
3137 Qoverflow_error
= intern ("overflow-error");
3138 Qunderflow_error
= intern ("underflow-error");
3140 Fput (Qdomain_error
, Qerror_conditions
,
3141 Fcons (Qdomain_error
, arith_tail
));
3142 Fput (Qdomain_error
, Qerror_message
,
3143 build_string ("Arithmetic domain error"));
3145 Fput (Qrange_error
, Qerror_conditions
,
3146 Fcons (Qrange_error
, arith_tail
));
3147 Fput (Qrange_error
, Qerror_message
,
3148 build_string ("Arithmetic range error"));
3150 Fput (Qsingularity_error
, Qerror_conditions
,
3151 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3152 Fput (Qsingularity_error
, Qerror_message
,
3153 build_string ("Arithmetic singularity error"));
3155 Fput (Qoverflow_error
, Qerror_conditions
,
3156 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3157 Fput (Qoverflow_error
, Qerror_message
,
3158 build_string ("Arithmetic overflow error"));
3160 Fput (Qunderflow_error
, Qerror_conditions
,
3161 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3162 Fput (Qunderflow_error
, Qerror_message
,
3163 build_string ("Arithmetic underflow error"));
3165 staticpro (&Qrange_error
);
3166 staticpro (&Qdomain_error
);
3167 staticpro (&Qsingularity_error
);
3168 staticpro (&Qoverflow_error
);
3169 staticpro (&Qunderflow_error
);
3173 staticpro (&Qquote
);
3174 staticpro (&Qlambda
);
3176 staticpro (&Qunbound
);
3177 staticpro (&Qerror_conditions
);
3178 staticpro (&Qerror_message
);
3179 staticpro (&Qtop_level
);
3181 staticpro (&Qerror
);
3183 staticpro (&Qwrong_type_argument
);
3184 staticpro (&Qargs_out_of_range
);
3185 staticpro (&Qvoid_function
);
3186 staticpro (&Qcyclic_function_indirection
);
3187 staticpro (&Qcyclic_variable_indirection
);
3188 staticpro (&Qvoid_variable
);
3189 staticpro (&Qsetting_constant
);
3190 staticpro (&Qinvalid_read_syntax
);
3191 staticpro (&Qwrong_number_of_arguments
);
3192 staticpro (&Qinvalid_function
);
3193 staticpro (&Qno_catch
);
3194 staticpro (&Qend_of_file
);
3195 staticpro (&Qarith_error
);
3196 staticpro (&Qbeginning_of_buffer
);
3197 staticpro (&Qend_of_buffer
);
3198 staticpro (&Qbuffer_read_only
);
3199 staticpro (&Qtext_read_only
);
3200 staticpro (&Qmark_inactive
);
3202 staticpro (&Qlistp
);
3203 staticpro (&Qconsp
);
3204 staticpro (&Qsymbolp
);
3205 staticpro (&Qkeywordp
);
3206 staticpro (&Qintegerp
);
3207 staticpro (&Qnatnump
);
3208 staticpro (&Qwholenump
);
3209 staticpro (&Qstringp
);
3210 staticpro (&Qarrayp
);
3211 staticpro (&Qsequencep
);
3212 staticpro (&Qbufferp
);
3213 staticpro (&Qvectorp
);
3214 staticpro (&Qchar_or_string_p
);
3215 staticpro (&Qmarkerp
);
3216 staticpro (&Qbuffer_or_string_p
);
3217 staticpro (&Qinteger_or_marker_p
);
3218 staticpro (&Qfloatp
);
3219 staticpro (&Qnumberp
);
3220 staticpro (&Qnumber_or_marker_p
);
3221 staticpro (&Qchar_table_p
);
3222 staticpro (&Qvector_or_char_table_p
);
3223 staticpro (&Qsubrp
);
3225 staticpro (&Qunevalled
);
3227 staticpro (&Qboundp
);
3228 staticpro (&Qfboundp
);
3230 staticpro (&Qad_advice_info
);
3231 staticpro (&Qad_activate_internal
);
3233 /* Types that type-of returns. */
3234 Qinteger
= intern ("integer");
3235 Qsymbol
= intern ("symbol");
3236 Qstring
= intern ("string");
3237 Qcons
= intern ("cons");
3238 Qmarker
= intern ("marker");
3239 Qoverlay
= intern ("overlay");
3240 Qfloat
= intern ("float");
3241 Qwindow_configuration
= intern ("window-configuration");
3242 Qprocess
= intern ("process");
3243 Qwindow
= intern ("window");
3244 /* Qsubr = intern ("subr"); */
3245 Qcompiled_function
= intern ("compiled-function");
3246 Qbuffer
= intern ("buffer");
3247 Qframe
= intern ("frame");
3248 Qvector
= intern ("vector");
3249 Qchar_table
= intern ("char-table");
3250 Qbool_vector
= intern ("bool-vector");
3251 Qhash_table
= intern ("hash-table");
3253 staticpro (&Qinteger
);
3254 staticpro (&Qsymbol
);
3255 staticpro (&Qstring
);
3257 staticpro (&Qmarker
);
3258 staticpro (&Qoverlay
);
3259 staticpro (&Qfloat
);
3260 staticpro (&Qwindow_configuration
);
3261 staticpro (&Qprocess
);
3262 staticpro (&Qwindow
);
3263 /* staticpro (&Qsubr); */
3264 staticpro (&Qcompiled_function
);
3265 staticpro (&Qbuffer
);
3266 staticpro (&Qframe
);
3267 staticpro (&Qvector
);
3268 staticpro (&Qchar_table
);
3269 staticpro (&Qbool_vector
);
3270 staticpro (&Qhash_table
);
3272 defsubr (&Sindirect_variable
);
3273 defsubr (&Sinteractive_form
);
3276 defsubr (&Stype_of
);
3281 defsubr (&Sintegerp
);
3282 defsubr (&Sinteger_or_marker_p
);
3283 defsubr (&Snumberp
);
3284 defsubr (&Snumber_or_marker_p
);
3286 defsubr (&Snatnump
);
3287 defsubr (&Ssymbolp
);
3288 defsubr (&Skeywordp
);
3289 defsubr (&Sstringp
);
3290 defsubr (&Smultibyte_string_p
);
3291 defsubr (&Svectorp
);
3292 defsubr (&Schar_table_p
);
3293 defsubr (&Svector_or_char_table_p
);
3294 defsubr (&Sbool_vector_p
);
3296 defsubr (&Ssequencep
);
3297 defsubr (&Sbufferp
);
3298 defsubr (&Smarkerp
);
3300 defsubr (&Sbyte_code_function_p
);
3301 defsubr (&Schar_or_string_p
);
3304 defsubr (&Scar_safe
);
3305 defsubr (&Scdr_safe
);
3308 defsubr (&Ssymbol_function
);
3309 defsubr (&Sindirect_function
);
3310 defsubr (&Ssymbol_plist
);
3311 defsubr (&Ssymbol_name
);
3312 defsubr (&Smakunbound
);
3313 defsubr (&Sfmakunbound
);
3315 defsubr (&Sfboundp
);
3317 defsubr (&Sdefalias
);
3318 defsubr (&Ssetplist
);
3319 defsubr (&Ssymbol_value
);
3321 defsubr (&Sdefault_boundp
);
3322 defsubr (&Sdefault_value
);
3323 defsubr (&Sset_default
);
3324 defsubr (&Ssetq_default
);
3325 defsubr (&Smake_variable_buffer_local
);
3326 defsubr (&Smake_local_variable
);
3327 defsubr (&Skill_local_variable
);
3328 defsubr (&Smake_variable_frame_local
);
3329 defsubr (&Slocal_variable_p
);
3330 defsubr (&Slocal_variable_if_set_p
);
3331 defsubr (&Svariable_binding_locus
);
3334 defsubr (&Snumber_to_string
);
3335 defsubr (&Sstring_to_number
);
3336 defsubr (&Seqlsign
);
3359 defsubr (&Sbyteorder
);
3360 defsubr (&Ssubr_arity
);
3361 defsubr (&Ssubr_name
);
3363 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3365 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3366 doc
: /* The largest value that is representable in a Lisp integer. */);
3367 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3369 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3370 doc
: /* The smallest value that is representable in a Lisp integer. */);
3371 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3378 #if defined(USG) && !defined(POSIX_SIGNALS)
3379 /* USG systems forget handlers when they are used;
3380 must reestablish each time */
3381 signal (signo
, arith_error
);
3384 /* VMS systems are like USG. */
3385 signal (signo
, arith_error
);
3389 #else /* not BSD4_1 */
3390 sigsetmask (SIGEMPTYMASK
);
3391 #endif /* not BSD4_1 */
3393 SIGNAL_THREAD_CHECK (signo
);
3394 Fsignal (Qarith_error
, Qnil
);
3400 /* Don't do this if just dumping out.
3401 We don't want to call `signal' in this case
3402 so that we don't have trouble with dumping
3403 signal-delivering routines in an inconsistent state. */
3407 #endif /* CANNOT_DUMP */
3408 signal (SIGFPE
, arith_error
);
3411 signal (SIGEMT
, arith_error
);
3415 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3416 (do not change this comment) */