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 See Info node `(elisp)Cons Cells' for a discussion of basic Lisp
527 concepts such as car, cdr, cons cell and list. */)
529 register Lisp_Object list
;
535 else if (EQ (list
, Qnil
))
538 list
= wrong_type_argument (Qlistp
, list
);
542 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
543 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
548 return XCAR (object
);
553 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
554 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
555 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
557 See Info node `(elisp)Cons Cells' for a discussion of basic Lisp
558 concepts such as cdr, car, cons cell and list. */)
560 register Lisp_Object list
;
566 else if (EQ (list
, Qnil
))
569 list
= wrong_type_argument (Qlistp
, list
);
573 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
574 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
579 return XCDR (object
);
584 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
585 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
587 register Lisp_Object cell
, newcar
;
590 cell
= wrong_type_argument (Qconsp
, cell
);
593 XSETCAR (cell
, newcar
);
597 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
598 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
600 register Lisp_Object cell
, newcdr
;
603 cell
= wrong_type_argument (Qconsp
, cell
);
606 XSETCDR (cell
, newcdr
);
610 /* Extract and set components of symbols */
612 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
613 doc
: /* Return t if SYMBOL's value is not void. */)
615 register Lisp_Object symbol
;
617 Lisp_Object valcontents
;
618 CHECK_SYMBOL (symbol
);
620 valcontents
= SYMBOL_VALUE (symbol
);
622 if (BUFFER_LOCAL_VALUEP (valcontents
)
623 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
624 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
626 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
629 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
630 doc
: /* Return t if SYMBOL's function definition is not void. */)
632 register Lisp_Object symbol
;
634 CHECK_SYMBOL (symbol
);
635 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
638 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
639 doc
: /* Make SYMBOL's value be void.
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
);
645 if (XSYMBOL (symbol
)->constant
)
646 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
647 Fset (symbol
, Qunbound
);
651 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
652 doc
: /* Make SYMBOL's function definition be void.
655 register Lisp_Object symbol
;
657 CHECK_SYMBOL (symbol
);
658 if (NILP (symbol
) || EQ (symbol
, Qt
))
659 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
660 XSYMBOL (symbol
)->function
= Qunbound
;
664 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
665 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
667 register Lisp_Object symbol
;
669 CHECK_SYMBOL (symbol
);
670 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
671 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
672 return XSYMBOL (symbol
)->function
;
675 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
676 doc
: /* Return SYMBOL's property list. */)
678 register Lisp_Object symbol
;
680 CHECK_SYMBOL (symbol
);
681 return XSYMBOL (symbol
)->plist
;
684 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
685 doc
: /* Return SYMBOL's name, a string. */)
687 register Lisp_Object symbol
;
689 register Lisp_Object name
;
691 CHECK_SYMBOL (symbol
);
692 name
= SYMBOL_NAME (symbol
);
696 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
697 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
699 register Lisp_Object symbol
, definition
;
701 CHECK_SYMBOL (symbol
);
702 if (NILP (symbol
) || EQ (symbol
, Qt
))
703 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
704 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
705 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
707 XSYMBOL (symbol
)->function
= definition
;
708 /* Handle automatic advice activation */
709 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
711 call2 (Qad_activate_internal
, symbol
, Qnil
);
712 definition
= XSYMBOL (symbol
)->function
;
717 extern Lisp_Object Qfunction_documentation
;
719 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
720 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
721 Associates the function with the current load file, if any.
722 The optional third argument DOCSTRING specifies the documentation string
723 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
724 determined by DEFINITION. */)
725 (symbol
, definition
, docstring
)
726 register Lisp_Object symbol
, definition
, docstring
;
728 CHECK_SYMBOL (symbol
);
729 if (CONSP (XSYMBOL (symbol
)->function
)
730 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
731 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
732 definition
= Ffset (symbol
, definition
);
733 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
734 if (!NILP (docstring
))
735 Fput (symbol
, Qfunction_documentation
, docstring
);
739 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
740 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
742 register Lisp_Object symbol
, newplist
;
744 CHECK_SYMBOL (symbol
);
745 XSYMBOL (symbol
)->plist
= newplist
;
749 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
750 doc
: /* Return minimum and maximum number of args allowed for SUBR.
751 SUBR must be a built-in function.
752 The returned value is a pair (MIN . MAX). MIN is the minimum number
753 of args. MAX is the maximum number or the symbol `many', for a
754 function with `&rest' args, or `unevalled' for a special form. */)
758 short minargs
, maxargs
;
760 wrong_type_argument (Qsubrp
, subr
);
761 minargs
= XSUBR (subr
)->min_args
;
762 maxargs
= XSUBR (subr
)->max_args
;
764 return Fcons (make_number (minargs
), Qmany
);
765 else if (maxargs
== UNEVALLED
)
766 return Fcons (make_number (minargs
), Qunevalled
);
768 return Fcons (make_number (minargs
), make_number (maxargs
));
771 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
772 doc
: /* Return name of subroutine SUBR.
773 SUBR must be a built-in function. */)
779 wrong_type_argument (Qsubrp
, subr
);
780 name
= XSUBR (subr
)->symbol_name
;
781 return make_string (name
, strlen (name
));
784 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
785 doc
: /* Return the interactive form of CMD or nil if none.
786 If CMD is not a command, the return value is nil.
787 Value, if non-nil, is a list \(interactive SPEC). */)
791 Lisp_Object fun
= indirect_function (cmd
);
795 if (XSUBR (fun
)->prompt
)
796 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
798 else if (COMPILEDP (fun
))
800 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
801 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
803 else if (CONSP (fun
))
805 Lisp_Object funcar
= XCAR (fun
);
806 if (EQ (funcar
, Qlambda
))
807 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
808 else if (EQ (funcar
, Qautoload
))
812 do_autoload (fun
, cmd
);
814 return Finteractive_form (cmd
);
821 /***********************************************************************
822 Getting and Setting Values of Symbols
823 ***********************************************************************/
825 /* Return the symbol holding SYMBOL's value. Signal
826 `cyclic-variable-indirection' if SYMBOL's chain of variable
827 indirections contains a loop. */
830 indirect_variable (symbol
)
833 Lisp_Object tortoise
, hare
;
835 hare
= tortoise
= symbol
;
837 while (XSYMBOL (hare
)->indirect_variable
)
839 hare
= XSYMBOL (hare
)->value
;
840 if (!XSYMBOL (hare
)->indirect_variable
)
843 hare
= XSYMBOL (hare
)->value
;
844 tortoise
= XSYMBOL (tortoise
)->value
;
846 if (EQ (hare
, tortoise
))
847 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
854 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
855 doc
: /* Return the variable at the end of OBJECT's variable chain.
856 If OBJECT is a symbol, follow all variable indirections and return the final
857 variable. If OBJECT is not a symbol, just return it.
858 Signal a cyclic-variable-indirection error if there is a loop in the
859 variable chain of symbols. */)
863 if (SYMBOLP (object
))
864 object
= indirect_variable (object
);
869 /* Given the raw contents of a symbol value cell,
870 return the Lisp value of the symbol.
871 This does not handle buffer-local variables; use
872 swap_in_symval_forwarding for that. */
875 do_symval_forwarding (valcontents
)
876 register Lisp_Object valcontents
;
878 register Lisp_Object val
;
880 if (MISCP (valcontents
))
881 switch (XMISCTYPE (valcontents
))
883 case Lisp_Misc_Intfwd
:
884 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
887 case Lisp_Misc_Boolfwd
:
888 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
890 case Lisp_Misc_Objfwd
:
891 return *XOBJFWD (valcontents
)->objvar
;
893 case Lisp_Misc_Buffer_Objfwd
:
894 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
895 return PER_BUFFER_VALUE (current_buffer
, offset
);
897 case Lisp_Misc_Kboard_Objfwd
:
898 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
899 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
904 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
905 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
906 buffer-independent contents of the value cell: forwarded just one
907 step past the buffer-localness.
909 BUF non-zero means set the value in buffer BUF instead of the
910 current buffer. This only plays a role for per-buffer variables. */
913 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
915 register Lisp_Object valcontents
, newval
;
918 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
921 switch (XMISCTYPE (valcontents
))
923 case Lisp_Misc_Intfwd
:
924 CHECK_NUMBER (newval
);
925 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
926 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
927 error ("Value out of range for variable `%s'",
928 SDATA (SYMBOL_NAME (symbol
)));
931 case Lisp_Misc_Boolfwd
:
932 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
935 case Lisp_Misc_Objfwd
:
936 *XOBJFWD (valcontents
)->objvar
= newval
;
938 /* If this variable is a default for something stored
939 in the buffer itself, such as default-fill-column,
940 find the buffers that don't have local values for it
942 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
943 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
945 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
946 - (char *) &buffer_defaults
);
947 int idx
= PER_BUFFER_IDX (offset
);
954 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
959 buf
= Fcdr (XCAR (tail
));
960 if (!BUFFERP (buf
)) continue;
963 if (! PER_BUFFER_VALUE_P (b
, idx
))
964 PER_BUFFER_VALUE (b
, offset
) = newval
;
969 case Lisp_Misc_Buffer_Objfwd
:
971 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
974 type
= PER_BUFFER_TYPE (offset
);
975 if (! NILP (type
) && ! NILP (newval
)
976 && XTYPE (newval
) != XINT (type
))
977 buffer_slot_type_mismatch (offset
);
980 buf
= current_buffer
;
981 PER_BUFFER_VALUE (buf
, offset
) = newval
;
985 case Lisp_Misc_Kboard_Objfwd
:
987 char *base
= (char *) current_kboard
;
988 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
989 *(Lisp_Object
*) p
= newval
;
1000 valcontents
= SYMBOL_VALUE (symbol
);
1001 if (BUFFER_LOCAL_VALUEP (valcontents
)
1002 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1003 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1005 SET_SYMBOL_VALUE (symbol
, newval
);
1009 /* Set up SYMBOL to refer to its global binding.
1010 This makes it safe to alter the status of other bindings. */
1013 swap_in_global_binding (symbol
)
1016 Lisp_Object valcontents
, cdr
;
1018 valcontents
= SYMBOL_VALUE (symbol
);
1019 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1020 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1022 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1024 /* Unload the previously loaded binding. */
1025 Fsetcdr (XCAR (cdr
),
1026 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1028 /* Select the global binding in the symbol. */
1030 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1032 /* Indicate that the global binding is set up now. */
1033 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1034 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1035 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1036 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1039 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1040 VALCONTENTS is the contents of its value cell,
1041 which points to a struct Lisp_Buffer_Local_Value.
1043 Return the value forwarded one step past the buffer-local stage.
1044 This could be another forwarding pointer. */
1047 swap_in_symval_forwarding (symbol
, valcontents
)
1048 Lisp_Object symbol
, valcontents
;
1050 register Lisp_Object tem1
;
1052 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1055 || current_buffer
!= XBUFFER (tem1
)
1056 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1057 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1059 if (XSYMBOL (symbol
)->indirect_variable
)
1060 symbol
= indirect_variable (symbol
);
1062 /* Unload the previously loaded binding. */
1063 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1065 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1066 /* Choose the new binding. */
1067 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1068 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1069 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1072 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1073 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1075 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1077 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1080 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1082 /* Load the new binding. */
1083 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1084 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1085 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1086 store_symval_forwarding (symbol
,
1087 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1090 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1093 /* Find the value of a symbol, returning Qunbound if it's not bound.
1094 This is helpful for code which just wants to get a variable's value
1095 if it has one, without signaling an error.
1096 Note that it must not be possible to quit
1097 within this function. Great care is required for this. */
1100 find_symbol_value (symbol
)
1103 register Lisp_Object valcontents
;
1104 register Lisp_Object val
;
1106 CHECK_SYMBOL (symbol
);
1107 valcontents
= SYMBOL_VALUE (symbol
);
1109 if (BUFFER_LOCAL_VALUEP (valcontents
)
1110 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1111 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1113 if (MISCP (valcontents
))
1115 switch (XMISCTYPE (valcontents
))
1117 case Lisp_Misc_Intfwd
:
1118 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1121 case Lisp_Misc_Boolfwd
:
1122 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1124 case Lisp_Misc_Objfwd
:
1125 return *XOBJFWD (valcontents
)->objvar
;
1127 case Lisp_Misc_Buffer_Objfwd
:
1128 return PER_BUFFER_VALUE (current_buffer
,
1129 XBUFFER_OBJFWD (valcontents
)->offset
);
1131 case Lisp_Misc_Kboard_Objfwd
:
1132 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1133 + (char *)current_kboard
);
1140 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1141 doc
: /* Return SYMBOL's value. Error if that is void. */)
1147 val
= find_symbol_value (symbol
);
1148 if (EQ (val
, Qunbound
))
1149 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1154 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1155 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1157 register Lisp_Object symbol
, newval
;
1159 return set_internal (symbol
, newval
, current_buffer
, 0);
1162 /* Return 1 if SYMBOL currently has a let-binding
1163 which was made in the buffer that is now current. */
1166 let_shadows_buffer_binding_p (symbol
)
1169 volatile struct specbinding
*p
;
1171 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1173 && CONSP (p
->symbol
))
1175 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1176 if ((EQ (symbol
, let_bound_symbol
)
1177 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1178 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1179 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1183 return p
>= specpdl
;
1186 /* Store the value NEWVAL into SYMBOL.
1187 If buffer-locality is an issue, BUF specifies which buffer to use.
1188 (0 stands for the current buffer.)
1190 If BINDFLAG is zero, then if this symbol is supposed to become
1191 local in every buffer where it is set, then we make it local.
1192 If BINDFLAG is nonzero, we don't do that. */
1195 set_internal (symbol
, newval
, buf
, bindflag
)
1196 register Lisp_Object symbol
, newval
;
1200 int voide
= EQ (newval
, Qunbound
);
1202 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1205 buf
= current_buffer
;
1207 /* If restoring in a dead buffer, do nothing. */
1208 if (NILP (buf
->name
))
1211 CHECK_SYMBOL (symbol
);
1212 if (SYMBOL_CONSTANT_P (symbol
)
1213 && (NILP (Fkeywordp (symbol
))
1214 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1215 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1217 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1219 if (BUFFER_OBJFWDP (valcontents
))
1221 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1222 int idx
= PER_BUFFER_IDX (offset
);
1225 && !let_shadows_buffer_binding_p (symbol
))
1226 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1228 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1229 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1231 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1232 if (XSYMBOL (symbol
)->indirect_variable
)
1233 symbol
= indirect_variable (symbol
);
1235 /* What binding is loaded right now? */
1236 current_alist_element
1237 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1239 /* If the current buffer is not the buffer whose binding is
1240 loaded, or if there may be frame-local bindings and the frame
1241 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1242 the default binding is loaded, the loaded binding may be the
1244 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1245 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1246 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1247 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1248 || (BUFFER_LOCAL_VALUEP (valcontents
)
1249 && EQ (XCAR (current_alist_element
),
1250 current_alist_element
)))
1252 /* The currently loaded binding is not necessarily valid.
1253 We need to unload it, and choose a new binding. */
1255 /* Write out `realvalue' to the old loaded binding. */
1256 Fsetcdr (current_alist_element
,
1257 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1259 /* Find the new binding. */
1260 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1261 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1262 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1266 /* This buffer still sees the default value. */
1268 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1269 or if this is `let' rather than `set',
1270 make CURRENT-ALIST-ELEMENT point to itself,
1271 indicating that we're seeing the default value.
1272 Likewise if the variable has been let-bound
1273 in the current buffer. */
1274 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1275 || let_shadows_buffer_binding_p (symbol
))
1277 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1279 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1280 tem1
= Fassq (symbol
,
1281 XFRAME (selected_frame
)->param_alist
);
1284 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1286 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1288 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1289 and we're not within a let that was made for this buffer,
1290 create a new buffer-local binding for the variable.
1291 That means, give this buffer a new assoc for a local value
1292 and load that binding. */
1295 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1296 buf
->local_var_alist
1297 = Fcons (tem1
, buf
->local_var_alist
);
1301 /* Record which binding is now loaded. */
1302 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1305 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1306 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1307 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1309 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1312 /* If storing void (making the symbol void), forward only through
1313 buffer-local indicator, not through Lisp_Objfwd, etc. */
1315 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1317 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1319 /* If we just set a variable whose current binding is frame-local,
1320 store the new value in the frame parameter too. */
1322 if (BUFFER_LOCAL_VALUEP (valcontents
)
1323 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1325 /* What binding is loaded right now? */
1326 current_alist_element
1327 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1329 /* If the current buffer is not the buffer whose binding is
1330 loaded, or if there may be frame-local bindings and the frame
1331 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1332 the default binding is loaded, the loaded binding may be the
1334 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1335 XSETCDR (current_alist_element
, newval
);
1341 /* Access or set a buffer-local symbol's default value. */
1343 /* Return the default value of SYMBOL, but don't check for voidness.
1344 Return Qunbound if it is void. */
1347 default_value (symbol
)
1350 register Lisp_Object valcontents
;
1352 CHECK_SYMBOL (symbol
);
1353 valcontents
= SYMBOL_VALUE (symbol
);
1355 /* For a built-in buffer-local variable, get the default value
1356 rather than letting do_symval_forwarding get the current value. */
1357 if (BUFFER_OBJFWDP (valcontents
))
1359 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1360 if (PER_BUFFER_IDX (offset
) != 0)
1361 return PER_BUFFER_DEFAULT (offset
);
1364 /* Handle user-created local variables. */
1365 if (BUFFER_LOCAL_VALUEP (valcontents
)
1366 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1368 /* If var is set up for a buffer that lacks a local value for it,
1369 the current value is nominally the default value.
1370 But the `realvalue' slot may be more up to date, since
1371 ordinary setq stores just that slot. So use that. */
1372 Lisp_Object current_alist_element
, alist_element_car
;
1373 current_alist_element
1374 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1375 alist_element_car
= XCAR (current_alist_element
);
1376 if (EQ (alist_element_car
, current_alist_element
))
1377 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1379 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1381 /* For other variables, get the current value. */
1382 return do_symval_forwarding (valcontents
);
1385 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1386 doc
: /* Return t if SYMBOL has a non-void default value.
1387 This is the value that is seen in buffers that do not have their own values
1388 for this variable. */)
1392 register Lisp_Object value
;
1394 value
= default_value (symbol
);
1395 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1398 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1399 doc
: /* Return SYMBOL's default value.
1400 This is the value that is seen in buffers that do not have their own values
1401 for this variable. The default value is meaningful for variables with
1402 local bindings in certain buffers. */)
1406 register Lisp_Object value
;
1408 value
= default_value (symbol
);
1409 if (EQ (value
, Qunbound
))
1410 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1414 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1415 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1416 The default value is seen in buffers that do not have their own values
1417 for this variable. */)
1419 Lisp_Object symbol
, value
;
1421 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1423 CHECK_SYMBOL (symbol
);
1424 valcontents
= SYMBOL_VALUE (symbol
);
1426 /* Handle variables like case-fold-search that have special slots
1427 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1429 if (BUFFER_OBJFWDP (valcontents
))
1431 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1432 int idx
= PER_BUFFER_IDX (offset
);
1434 PER_BUFFER_DEFAULT (offset
) = value
;
1436 /* If this variable is not always local in all buffers,
1437 set it in the buffers that don't nominally have a local value. */
1442 for (b
= all_buffers
; b
; b
= b
->next
)
1443 if (!PER_BUFFER_VALUE_P (b
, idx
))
1444 PER_BUFFER_VALUE (b
, offset
) = value
;
1449 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1450 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1451 return Fset (symbol
, value
);
1453 /* Store new value into the DEFAULT-VALUE slot. */
1454 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1456 /* If the default binding is now loaded, set the REALVALUE slot too. */
1457 current_alist_element
1458 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1459 alist_element_buffer
= Fcar (current_alist_element
);
1460 if (EQ (alist_element_buffer
, current_alist_element
))
1461 store_symval_forwarding (symbol
,
1462 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1468 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1469 doc
: /* Set the default value of variable VAR to VALUE.
1470 VAR, the variable name, is literal (not evaluated);
1471 VALUE is an expression: it is evaluated and its value returned.
1472 The default value of a variable is seen in buffers
1473 that do not have their own values for the variable.
1475 More generally, you can use multiple variables and values, as in
1476 (setq-default VAR VALUE VAR VALUE...)
1477 This sets each VAR's default value to the corresponding VALUE.
1478 The VALUE for the Nth VAR can refer to the new default values
1480 usage: (setq-default [VAR VALUE...]) */)
1484 register Lisp_Object args_left
;
1485 register Lisp_Object val
, symbol
;
1486 struct gcpro gcpro1
;
1496 val
= Feval (Fcar (Fcdr (args_left
)));
1497 symbol
= XCAR (args_left
);
1498 Fset_default (symbol
, val
);
1499 args_left
= Fcdr (XCDR (args_left
));
1501 while (!NILP (args_left
));
1507 /* Lisp functions for creating and removing buffer-local variables. */
1509 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1510 1, 1, "vMake Variable Buffer Local: ",
1511 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1512 At any time, the value for the current buffer is in effect,
1513 unless the variable has never been set in this buffer,
1514 in which case the default value is in effect.
1515 Note that binding the variable with `let', or setting it while
1516 a `let'-style binding made in this buffer is in effect,
1517 does not make the variable buffer-local. Return VARIABLE.
1519 In most cases it is better to use `make-local-variable',
1520 which makes a variable local in just one buffer.
1522 The function `default-value' gets the default value and `set-default' sets it. */)
1524 register Lisp_Object variable
;
1526 register Lisp_Object tem
, valcontents
, newval
;
1528 CHECK_SYMBOL (variable
);
1529 variable
= indirect_variable (variable
);
1531 valcontents
= SYMBOL_VALUE (variable
);
1532 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1533 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1535 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1537 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1539 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1542 if (EQ (valcontents
, Qunbound
))
1543 SET_SYMBOL_VALUE (variable
, Qnil
);
1544 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1546 newval
= allocate_misc ();
1547 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1548 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1549 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1550 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1551 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1552 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1553 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1554 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1555 SET_SYMBOL_VALUE (variable
, newval
);
1559 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1560 1, 1, "vMake Local Variable: ",
1561 doc
: /* Make VARIABLE have a separate value in the current buffer.
1562 Other buffers will continue to share a common default value.
1563 \(The buffer-local value of VARIABLE starts out as the same value
1564 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1567 If the variable is already arranged to become local when set,
1568 this function causes a local value to exist for this buffer,
1569 just as setting the variable would do.
1571 This function returns VARIABLE, and therefore
1572 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1575 See also `make-variable-buffer-local'.
1577 Do not use `make-local-variable' to make a hook variable buffer-local.
1578 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1580 register Lisp_Object variable
;
1582 register Lisp_Object tem
, valcontents
;
1584 CHECK_SYMBOL (variable
);
1585 variable
= indirect_variable (variable
);
1587 valcontents
= SYMBOL_VALUE (variable
);
1588 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1589 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1591 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1593 tem
= Fboundp (variable
);
1595 /* Make sure the symbol has a local value in this particular buffer,
1596 by setting it to the same value it already has. */
1597 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1600 /* Make sure symbol is set up to hold per-buffer values. */
1601 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1604 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1606 newval
= allocate_misc ();
1607 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1608 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1609 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1610 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1611 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1612 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1613 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1614 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1615 SET_SYMBOL_VALUE (variable
, newval
);;
1617 /* Make sure this buffer has its own value of symbol. */
1618 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1621 /* Swap out any local binding for some other buffer, and make
1622 sure the current value is permanently recorded, if it's the
1624 find_symbol_value (variable
);
1626 current_buffer
->local_var_alist
1627 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1628 current_buffer
->local_var_alist
);
1630 /* Make sure symbol does not think it is set up for this buffer;
1631 force it to look once again for this buffer's value. */
1633 Lisp_Object
*pvalbuf
;
1635 valcontents
= SYMBOL_VALUE (variable
);
1637 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1638 if (current_buffer
== XBUFFER (*pvalbuf
))
1640 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1644 /* If the symbol forwards into a C variable, then load the binding
1645 for this buffer now. If C code modifies the variable before we
1646 load the binding in, then that new value will clobber the default
1647 binding the next time we unload it. */
1648 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1649 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1650 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1655 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1656 1, 1, "vKill Local Variable: ",
1657 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1658 From now on the default value will apply in this buffer. Return VARIABLE. */)
1660 register Lisp_Object variable
;
1662 register Lisp_Object tem
, valcontents
;
1664 CHECK_SYMBOL (variable
);
1665 variable
= indirect_variable (variable
);
1667 valcontents
= SYMBOL_VALUE (variable
);
1669 if (BUFFER_OBJFWDP (valcontents
))
1671 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1672 int idx
= PER_BUFFER_IDX (offset
);
1676 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1677 PER_BUFFER_VALUE (current_buffer
, offset
)
1678 = PER_BUFFER_DEFAULT (offset
);
1683 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1684 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1687 /* Get rid of this buffer's alist element, if any. */
1689 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1691 current_buffer
->local_var_alist
1692 = Fdelq (tem
, current_buffer
->local_var_alist
);
1694 /* If the symbol is set up with the current buffer's binding
1695 loaded, recompute its value. We have to do it now, or else
1696 forwarded objects won't work right. */
1698 Lisp_Object
*pvalbuf
, buf
;
1699 valcontents
= SYMBOL_VALUE (variable
);
1700 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1701 XSETBUFFER (buf
, current_buffer
);
1702 if (EQ (buf
, *pvalbuf
))
1705 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1706 find_symbol_value (variable
);
1713 /* Lisp functions for creating and removing buffer-local variables. */
1715 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1716 1, 1, "vMake Variable Frame Local: ",
1717 doc
: /* Enable VARIABLE to have frame-local bindings.
1718 This does not create any frame-local bindings for VARIABLE,
1719 it just makes them possible.
1721 A frame-local binding is actually a frame parameter value.
1722 If a frame F has a value for the frame parameter named VARIABLE,
1723 that also acts as a frame-local binding for VARIABLE in F--
1724 provided this function has been called to enable VARIABLE
1725 to have frame-local bindings at all.
1727 The only way to create a frame-local binding for VARIABLE in a frame
1728 is to set the VARIABLE frame parameter of that frame. See
1729 `modify-frame-parameters' for how to set frame parameters.
1731 Buffer-local bindings take precedence over frame-local bindings. */)
1733 register Lisp_Object variable
;
1735 register Lisp_Object tem
, valcontents
, newval
;
1737 CHECK_SYMBOL (variable
);
1738 variable
= indirect_variable (variable
);
1740 valcontents
= SYMBOL_VALUE (variable
);
1741 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1742 || BUFFER_OBJFWDP (valcontents
))
1743 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1745 if (BUFFER_LOCAL_VALUEP (valcontents
)
1746 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1748 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1752 if (EQ (valcontents
, Qunbound
))
1753 SET_SYMBOL_VALUE (variable
, Qnil
);
1754 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1756 newval
= allocate_misc ();
1757 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1758 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1759 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1760 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1761 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1762 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1763 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1764 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1765 SET_SYMBOL_VALUE (variable
, newval
);
1769 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1771 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1772 BUFFER defaults to the current buffer. */)
1774 register Lisp_Object variable
, buffer
;
1776 Lisp_Object valcontents
;
1777 register struct buffer
*buf
;
1780 buf
= current_buffer
;
1783 CHECK_BUFFER (buffer
);
1784 buf
= XBUFFER (buffer
);
1787 CHECK_SYMBOL (variable
);
1788 variable
= indirect_variable (variable
);
1790 valcontents
= SYMBOL_VALUE (variable
);
1791 if (BUFFER_LOCAL_VALUEP (valcontents
)
1792 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1794 Lisp_Object tail
, elt
;
1796 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1799 if (EQ (variable
, XCAR (elt
)))
1803 if (BUFFER_OBJFWDP (valcontents
))
1805 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1806 int idx
= PER_BUFFER_IDX (offset
);
1807 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1813 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1815 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1816 More precisely, this means that setting the variable \(with `set' or`setq'),
1817 while it does not have a `let'-style binding that was made in BUFFER,
1818 will produce a buffer local binding. See Info node
1819 `(elisp)Creating Buffer-Local'.
1820 BUFFER defaults to the current buffer. */)
1822 register Lisp_Object variable
, buffer
;
1824 Lisp_Object valcontents
;
1825 register struct buffer
*buf
;
1828 buf
= current_buffer
;
1831 CHECK_BUFFER (buffer
);
1832 buf
= XBUFFER (buffer
);
1835 CHECK_SYMBOL (variable
);
1836 variable
= indirect_variable (variable
);
1838 valcontents
= SYMBOL_VALUE (variable
);
1840 /* This means that make-variable-buffer-local was done. */
1841 if (BUFFER_LOCAL_VALUEP (valcontents
))
1843 /* All these slots become local if they are set. */
1844 if (BUFFER_OBJFWDP (valcontents
))
1846 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1848 Lisp_Object tail
, elt
;
1849 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1852 if (EQ (variable
, XCAR (elt
)))
1859 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1861 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1862 If the current binding is buffer-local, the value is the current buffer.
1863 If the current binding is frame-local, the value is the selected frame.
1864 If the current binding is global (the default), the value is nil. */)
1866 register Lisp_Object variable
;
1868 Lisp_Object valcontents
;
1870 CHECK_SYMBOL (variable
);
1871 variable
= indirect_variable (variable
);
1873 /* Make sure the current binding is actually swapped in. */
1874 find_symbol_value (variable
);
1876 valcontents
= XSYMBOL (variable
)->value
;
1878 if (BUFFER_LOCAL_VALUEP (valcontents
)
1879 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1880 || BUFFER_OBJFWDP (valcontents
))
1882 /* For a local variable, record both the symbol and which
1883 buffer's or frame's value we are saving. */
1884 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1885 return Fcurrent_buffer ();
1886 else if (!BUFFER_OBJFWDP (valcontents
)
1887 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1888 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1894 /* Find the function at the end of a chain of symbol function indirections. */
1896 /* If OBJECT is a symbol, find the end of its function chain and
1897 return the value found there. If OBJECT is not a symbol, just
1898 return it. If there is a cycle in the function chain, signal a
1899 cyclic-function-indirection error.
1901 This is like Findirect_function, except that it doesn't signal an
1902 error if the chain ends up unbound. */
1904 indirect_function (object
)
1905 register Lisp_Object object
;
1907 Lisp_Object tortoise
, hare
;
1909 hare
= tortoise
= object
;
1913 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1915 hare
= XSYMBOL (hare
)->function
;
1916 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1918 hare
= XSYMBOL (hare
)->function
;
1920 tortoise
= XSYMBOL (tortoise
)->function
;
1922 if (EQ (hare
, tortoise
))
1923 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1929 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1930 doc
: /* Return the function at the end of OBJECT's function chain.
1931 If OBJECT is a symbol, follow all function indirections and return the final
1933 If OBJECT is not a symbol, just return it.
1934 Signal a void-function error if the final symbol is unbound.
1935 Signal a cyclic-function-indirection error if there is a loop in the
1936 function chain of symbols. */)
1938 register Lisp_Object object
;
1942 result
= indirect_function (object
);
1944 if (EQ (result
, Qunbound
))
1945 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1949 /* Extract and set vector and string elements */
1951 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1952 doc
: /* Return the element of ARRAY at index IDX.
1953 ARRAY may be a vector, a string, a char-table, a bool-vector,
1954 or a byte-code object. IDX starts at 0. */)
1956 register Lisp_Object array
;
1959 register int idxval
;
1962 idxval
= XINT (idx
);
1963 if (STRINGP (array
))
1967 if (idxval
< 0 || idxval
>= SCHARS (array
))
1968 args_out_of_range (array
, idx
);
1969 if (! STRING_MULTIBYTE (array
))
1970 return make_number ((unsigned char) SREF (array
, idxval
));
1971 idxval_byte
= string_char_to_byte (array
, idxval
);
1973 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1974 SBYTES (array
) - idxval_byte
);
1975 return make_number (c
);
1977 else if (BOOL_VECTOR_P (array
))
1981 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1982 args_out_of_range (array
, idx
);
1984 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1985 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1987 else if (CHAR_TABLE_P (array
))
1994 args_out_of_range (array
, idx
);
1995 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1997 if (! SINGLE_BYTE_CHAR_P (idxval
))
1998 args_out_of_range (array
, idx
);
1999 /* For ASCII and 8-bit European characters, the element is
2000 stored in the top table. */
2001 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2005 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2006 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2007 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2008 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2011 val
= XCHAR_TABLE (array
)->defalt
;
2012 while (NILP (val
)) /* Follow parents until we find some value. */
2014 array
= XCHAR_TABLE (array
)->parent
;
2017 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2019 val
= XCHAR_TABLE (array
)->defalt
;
2026 Lisp_Object sub_table
;
2027 Lisp_Object current_default
;
2029 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2030 if (code
[1] < 32) code
[1] = -1;
2031 else if (code
[2] < 32) code
[2] = -1;
2033 /* Here, the possible range of CODE[0] (== charset ID) is
2034 128..MAX_CHARSET. Since the top level char table contains
2035 data for multibyte characters after 256th element, we must
2036 increment CODE[0] by 128 to get a correct index. */
2038 code
[3] = -1; /* anchor */
2040 try_parent_char_table
:
2041 current_default
= XCHAR_TABLE (array
)->defalt
;
2043 for (i
= 0; code
[i
] >= 0; i
++)
2045 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2046 if (SUB_CHAR_TABLE_P (val
))
2049 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2050 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2055 val
= current_default
;
2058 array
= XCHAR_TABLE (array
)->parent
;
2060 goto try_parent_char_table
;
2065 /* Reaching here means IDXVAL is a generic character in
2066 which each character or a group has independent value.
2067 Essentially it's nonsense to get a value for such a
2068 generic character, but for backward compatibility, we try
2069 the default value and parent. */
2070 val
= current_default
;
2073 array
= XCHAR_TABLE (array
)->parent
;
2075 goto try_parent_char_table
;
2083 if (VECTORP (array
))
2084 size
= XVECTOR (array
)->size
;
2085 else if (COMPILEDP (array
))
2086 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2088 wrong_type_argument (Qarrayp
, array
);
2090 if (idxval
< 0 || idxval
>= size
)
2091 args_out_of_range (array
, idx
);
2092 return XVECTOR (array
)->contents
[idxval
];
2096 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2097 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2098 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2099 bool-vector. IDX starts at 0. */)
2100 (array
, idx
, newelt
)
2101 register Lisp_Object array
;
2102 Lisp_Object idx
, newelt
;
2104 register int idxval
;
2107 idxval
= XINT (idx
);
2108 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2109 && ! CHAR_TABLE_P (array
))
2110 array
= wrong_type_argument (Qarrayp
, array
);
2111 CHECK_IMPURE (array
);
2113 if (VECTORP (array
))
2115 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2116 args_out_of_range (array
, idx
);
2117 XVECTOR (array
)->contents
[idxval
] = newelt
;
2119 else if (BOOL_VECTOR_P (array
))
2123 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2124 args_out_of_range (array
, idx
);
2126 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2128 if (! NILP (newelt
))
2129 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2131 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2132 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2134 else if (CHAR_TABLE_P (array
))
2137 args_out_of_range (array
, idx
);
2138 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2140 if (! SINGLE_BYTE_CHAR_P (idxval
))
2141 args_out_of_range (array
, idx
);
2142 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2149 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2150 if (code
[1] < 32) code
[1] = -1;
2151 else if (code
[2] < 32) code
[2] = -1;
2153 /* See the comment of the corresponding part in Faref. */
2155 code
[3] = -1; /* anchor */
2156 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2158 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2159 if (SUB_CHAR_TABLE_P (val
))
2165 /* VAL is a leaf. Create a sub char table with the
2166 initial value VAL and look into it. */
2168 temp
= make_sub_char_table (val
);
2169 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2173 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2176 else if (STRING_MULTIBYTE (array
))
2178 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2179 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2181 if (idxval
< 0 || idxval
>= SCHARS (array
))
2182 args_out_of_range (array
, idx
);
2183 CHECK_NUMBER (newelt
);
2185 nbytes
= SBYTES (array
);
2187 idxval_byte
= string_char_to_byte (array
, idxval
);
2188 p1
= SDATA (array
) + idxval_byte
;
2189 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2190 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2191 if (prev_bytes
!= new_bytes
)
2193 /* We must relocate the string data. */
2194 int nchars
= SCHARS (array
);
2198 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2199 bcopy (SDATA (array
), str
, nbytes
);
2200 allocate_string_data (XSTRING (array
), nchars
,
2201 nbytes
+ new_bytes
- prev_bytes
);
2202 bcopy (str
, SDATA (array
), idxval_byte
);
2203 p1
= SDATA (array
) + idxval_byte
;
2204 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2205 nbytes
- (idxval_byte
+ prev_bytes
));
2207 clear_string_char_byte_cache ();
2214 if (idxval
< 0 || idxval
>= SCHARS (array
))
2215 args_out_of_range (array
, idx
);
2216 CHECK_NUMBER (newelt
);
2218 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2219 SSET (array
, idxval
, XINT (newelt
));
2222 /* We must relocate the string data while converting it to
2224 int idxval_byte
, prev_bytes
, new_bytes
;
2225 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2226 unsigned char *origstr
= SDATA (array
), *str
;
2230 nchars
= SCHARS (array
);
2231 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2232 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2234 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2235 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2236 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2238 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2239 allocate_string_data (XSTRING (array
), nchars
,
2240 nbytes
+ new_bytes
- prev_bytes
);
2241 bcopy (str
, SDATA (array
), idxval_byte
);
2242 p1
= SDATA (array
) + idxval_byte
;
2245 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2246 nbytes
- (idxval_byte
+ prev_bytes
));
2248 clear_string_char_byte_cache ();
2255 /* Arithmetic functions */
2257 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2260 arithcompare (num1
, num2
, comparison
)
2261 Lisp_Object num1
, num2
;
2262 enum comparison comparison
;
2264 double f1
= 0, f2
= 0;
2267 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2268 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2270 if (FLOATP (num1
) || FLOATP (num2
))
2273 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2274 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2280 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2285 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2290 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2295 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2300 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2305 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2314 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2315 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2317 register Lisp_Object num1
, num2
;
2319 return arithcompare (num1
, num2
, equal
);
2322 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2323 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2325 register Lisp_Object num1
, num2
;
2327 return arithcompare (num1
, num2
, less
);
2330 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2331 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2333 register Lisp_Object num1
, num2
;
2335 return arithcompare (num1
, num2
, grtr
);
2338 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2339 doc
: /* Return t if first arg is less than or equal to second arg.
2340 Both must be numbers or markers. */)
2342 register Lisp_Object num1
, num2
;
2344 return arithcompare (num1
, num2
, less_or_equal
);
2347 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2348 doc
: /* Return t if first arg is greater than or equal to second arg.
2349 Both must be numbers or markers. */)
2351 register Lisp_Object num1
, num2
;
2353 return arithcompare (num1
, num2
, grtr_or_equal
);
2356 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2357 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2359 register Lisp_Object num1
, num2
;
2361 return arithcompare (num1
, num2
, notequal
);
2364 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2365 doc
: /* Return t if NUMBER is zero. */)
2367 register Lisp_Object number
;
2369 CHECK_NUMBER_OR_FLOAT (number
);
2371 if (FLOATP (number
))
2373 if (XFLOAT_DATA (number
) == 0.0)
2383 /* Convert between long values and pairs of Lisp integers. */
2389 unsigned long top
= i
>> 16;
2390 unsigned int bot
= i
& 0xFFFF;
2392 return make_number (bot
);
2393 if (top
== (unsigned long)-1 >> 16)
2394 return Fcons (make_number (-1), make_number (bot
));
2395 return Fcons (make_number (top
), make_number (bot
));
2402 Lisp_Object top
, bot
;
2409 return ((XINT (top
) << 16) | XINT (bot
));
2412 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2413 doc
: /* Return the decimal representation of NUMBER as a string.
2414 Uses a minus sign if negative.
2415 NUMBER may be an integer or a floating point number. */)
2419 char buffer
[VALBITS
];
2421 CHECK_NUMBER_OR_FLOAT (number
);
2423 if (FLOATP (number
))
2425 char pigbuf
[350]; /* see comments in float_to_string */
2427 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2428 return build_string (pigbuf
);
2431 if (sizeof (int) == sizeof (EMACS_INT
))
2432 sprintf (buffer
, "%d", XINT (number
));
2433 else if (sizeof (long) == sizeof (EMACS_INT
))
2434 sprintf (buffer
, "%ld", (long) XINT (number
));
2437 return build_string (buffer
);
2441 digit_to_number (character
, base
)
2442 int character
, base
;
2446 if (character
>= '0' && character
<= '9')
2447 digit
= character
- '0';
2448 else if (character
>= 'a' && character
<= 'z')
2449 digit
= character
- 'a' + 10;
2450 else if (character
>= 'A' && character
<= 'Z')
2451 digit
= character
- 'A' + 10;
2461 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2462 doc
: /* Parse STRING as a decimal number and return the number.
2463 This parses both integers and floating point numbers.
2464 It ignores leading spaces and tabs.
2466 If BASE, interpret STRING as a number in that base. If BASE isn't
2467 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2468 If the base used is not 10, floating point is not recognized. */)
2470 register Lisp_Object string
, base
;
2472 register unsigned char *p
;
2477 CHECK_STRING (string
);
2483 CHECK_NUMBER (base
);
2485 if (b
< 2 || b
> 16)
2486 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2489 /* Skip any whitespace at the front of the number. Some versions of
2490 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2492 while (*p
== ' ' || *p
== '\t')
2503 if (isfloat_string (p
) && b
== 10)
2504 val
= make_float (sign
* atof (p
));
2511 int digit
= digit_to_number (*p
++, b
);
2517 val
= make_fixnum_or_float (sign
* v
);
2537 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2538 int, Lisp_Object
*));
2539 extern Lisp_Object
fmod_float ();
2542 arith_driver (code
, nargs
, args
)
2545 register Lisp_Object
*args
;
2547 register Lisp_Object val
;
2548 register int argnum
;
2549 register EMACS_INT accum
= 0;
2550 register EMACS_INT next
;
2552 switch (SWITCH_ENUM_CAST (code
))
2570 for (argnum
= 0; argnum
< nargs
; argnum
++)
2572 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2574 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2577 return float_arith_driver ((double) accum
, argnum
, code
,
2580 next
= XINT (args
[argnum
]);
2581 switch (SWITCH_ENUM_CAST (code
))
2587 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2598 Fsignal (Qarith_error
, Qnil
);
2612 if (!argnum
|| next
> accum
)
2616 if (!argnum
|| next
< accum
)
2622 XSETINT (val
, accum
);
2627 #define isnan(x) ((x) != (x))
2630 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2632 register int argnum
;
2635 register Lisp_Object
*args
;
2637 register Lisp_Object val
;
2640 for (; argnum
< nargs
; argnum
++)
2642 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2643 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2647 next
= XFLOAT_DATA (val
);
2651 args
[argnum
] = val
; /* runs into a compiler bug. */
2652 next
= XINT (args
[argnum
]);
2654 switch (SWITCH_ENUM_CAST (code
))
2660 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2670 if (! IEEE_FLOATING_POINT
&& next
== 0)
2671 Fsignal (Qarith_error
, Qnil
);
2678 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2680 if (!argnum
|| isnan (next
) || next
> accum
)
2684 if (!argnum
|| isnan (next
) || next
< accum
)
2690 return make_float (accum
);
2694 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2695 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2696 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2701 return arith_driver (Aadd
, nargs
, args
);
2704 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2705 doc
: /* Negate number or subtract numbers or markers and return the result.
2706 With one arg, negates it. With more than one arg,
2707 subtracts all but the first from the first.
2708 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2713 return arith_driver (Asub
, nargs
, args
);
2716 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2717 doc
: /* Return product of any number of arguments, which are numbers or markers.
2718 usage: (* &rest NUMBERS-OR-MARKERS) */)
2723 return arith_driver (Amult
, nargs
, args
);
2726 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2727 doc
: /* Return first argument divided by all the remaining arguments.
2728 The arguments must be numbers or markers.
2729 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2735 for (argnum
= 2; argnum
< nargs
; argnum
++)
2736 if (FLOATP (args
[argnum
]))
2737 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2738 return arith_driver (Adiv
, nargs
, args
);
2741 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2742 doc
: /* Return remainder of X divided by Y.
2743 Both must be integers or markers. */)
2745 register Lisp_Object x
, y
;
2749 CHECK_NUMBER_COERCE_MARKER (x
);
2750 CHECK_NUMBER_COERCE_MARKER (y
);
2752 if (XFASTINT (y
) == 0)
2753 Fsignal (Qarith_error
, Qnil
);
2755 XSETINT (val
, XINT (x
) % XINT (y
));
2769 /* If the magnitude of the result exceeds that of the divisor, or
2770 the sign of the result does not agree with that of the dividend,
2771 iterate with the reduced value. This does not yield a
2772 particularly accurate result, but at least it will be in the
2773 range promised by fmod. */
2775 r
-= f2
* floor (r
/ f2
);
2776 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2780 #endif /* ! HAVE_FMOD */
2782 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2783 doc
: /* Return X modulo Y.
2784 The result falls between zero (inclusive) and Y (exclusive).
2785 Both X and Y must be numbers or markers. */)
2787 register Lisp_Object x
, y
;
2792 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2793 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2795 if (FLOATP (x
) || FLOATP (y
))
2796 return fmod_float (x
, y
);
2802 Fsignal (Qarith_error
, Qnil
);
2806 /* If the "remainder" comes out with the wrong sign, fix it. */
2807 if (i2
< 0 ? i1
> 0 : i1
< 0)
2814 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2815 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2816 The value is always a number; markers are converted to numbers.
2817 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2822 return arith_driver (Amax
, nargs
, args
);
2825 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2826 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2827 The value is always a number; markers are converted to numbers.
2828 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2833 return arith_driver (Amin
, nargs
, args
);
2836 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2837 doc
: /* Return bitwise-and of all the arguments.
2838 Arguments may be integers, or markers converted to integers.
2839 usage: (logand &rest INTS-OR-MARKERS) */)
2844 return arith_driver (Alogand
, nargs
, args
);
2847 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2848 doc
: /* Return bitwise-or of all the arguments.
2849 Arguments may be integers, or markers converted to integers.
2850 usage: (logior &rest INTS-OR-MARKERS) */)
2855 return arith_driver (Alogior
, nargs
, args
);
2858 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2859 doc
: /* Return bitwise-exclusive-or of all the arguments.
2860 Arguments may be integers, or markers converted to integers.
2861 usage: (logxor &rest INTS-OR-MARKERS) */)
2866 return arith_driver (Alogxor
, nargs
, args
);
2869 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2870 doc
: /* Return VALUE with its bits shifted left by COUNT.
2871 If COUNT is negative, shifting is actually to the right.
2872 In this case, the sign bit is duplicated. */)
2874 register Lisp_Object value
, count
;
2876 register Lisp_Object val
;
2878 CHECK_NUMBER (value
);
2879 CHECK_NUMBER (count
);
2881 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2883 else if (XINT (count
) > 0)
2884 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2885 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2886 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2888 XSETINT (val
, XINT (value
) >> -XINT (count
));
2892 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2893 doc
: /* Return VALUE with its bits shifted left by COUNT.
2894 If COUNT is negative, shifting is actually to the right.
2895 In this case, zeros are shifted in on the left. */)
2897 register Lisp_Object value
, count
;
2899 register Lisp_Object val
;
2901 CHECK_NUMBER (value
);
2902 CHECK_NUMBER (count
);
2904 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2906 else if (XINT (count
) > 0)
2907 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2908 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2911 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2915 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2916 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2917 Markers are converted to integers. */)
2919 register Lisp_Object number
;
2921 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2923 if (FLOATP (number
))
2924 return (make_float (1.0 + XFLOAT_DATA (number
)));
2926 XSETINT (number
, XINT (number
) + 1);
2930 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2931 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2932 Markers are converted to integers. */)
2934 register Lisp_Object number
;
2936 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2938 if (FLOATP (number
))
2939 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2941 XSETINT (number
, XINT (number
) - 1);
2945 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2946 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2948 register Lisp_Object number
;
2950 CHECK_NUMBER (number
);
2951 XSETINT (number
, ~XINT (number
));
2955 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2956 doc
: /* Return the byteorder for the machine.
2957 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2958 lowercase l) for small endian machines. */)
2961 unsigned i
= 0x04030201;
2962 int order
= *(char *)&i
== 1 ? 108 : 66;
2964 return make_number (order
);
2972 Lisp_Object error_tail
, arith_tail
;
2974 Qquote
= intern ("quote");
2975 Qlambda
= intern ("lambda");
2976 Qsubr
= intern ("subr");
2977 Qerror_conditions
= intern ("error-conditions");
2978 Qerror_message
= intern ("error-message");
2979 Qtop_level
= intern ("top-level");
2981 Qerror
= intern ("error");
2982 Qquit
= intern ("quit");
2983 Qwrong_type_argument
= intern ("wrong-type-argument");
2984 Qargs_out_of_range
= intern ("args-out-of-range");
2985 Qvoid_function
= intern ("void-function");
2986 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2987 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2988 Qvoid_variable
= intern ("void-variable");
2989 Qsetting_constant
= intern ("setting-constant");
2990 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2992 Qinvalid_function
= intern ("invalid-function");
2993 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2994 Qno_catch
= intern ("no-catch");
2995 Qend_of_file
= intern ("end-of-file");
2996 Qarith_error
= intern ("arith-error");
2997 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2998 Qend_of_buffer
= intern ("end-of-buffer");
2999 Qbuffer_read_only
= intern ("buffer-read-only");
3000 Qtext_read_only
= intern ("text-read-only");
3001 Qmark_inactive
= intern ("mark-inactive");
3003 Qlistp
= intern ("listp");
3004 Qconsp
= intern ("consp");
3005 Qsymbolp
= intern ("symbolp");
3006 Qkeywordp
= intern ("keywordp");
3007 Qintegerp
= intern ("integerp");
3008 Qnatnump
= intern ("natnump");
3009 Qwholenump
= intern ("wholenump");
3010 Qstringp
= intern ("stringp");
3011 Qarrayp
= intern ("arrayp");
3012 Qsequencep
= intern ("sequencep");
3013 Qbufferp
= intern ("bufferp");
3014 Qvectorp
= intern ("vectorp");
3015 Qchar_or_string_p
= intern ("char-or-string-p");
3016 Qmarkerp
= intern ("markerp");
3017 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3018 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3019 Qboundp
= intern ("boundp");
3020 Qfboundp
= intern ("fboundp");
3022 Qfloatp
= intern ("floatp");
3023 Qnumberp
= intern ("numberp");
3024 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3026 Qchar_table_p
= intern ("char-table-p");
3027 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3029 Qsubrp
= intern ("subrp");
3030 Qunevalled
= intern ("unevalled");
3031 Qmany
= intern ("many");
3033 Qcdr
= intern ("cdr");
3035 /* Handle automatic advice activation */
3036 Qad_advice_info
= intern ("ad-advice-info");
3037 Qad_activate_internal
= intern ("ad-activate-internal");
3039 error_tail
= Fcons (Qerror
, Qnil
);
3041 /* ERROR is used as a signaler for random errors for which nothing else is right */
3043 Fput (Qerror
, Qerror_conditions
,
3045 Fput (Qerror
, Qerror_message
,
3046 build_string ("error"));
3048 Fput (Qquit
, Qerror_conditions
,
3049 Fcons (Qquit
, Qnil
));
3050 Fput (Qquit
, Qerror_message
,
3051 build_string ("Quit"));
3053 Fput (Qwrong_type_argument
, Qerror_conditions
,
3054 Fcons (Qwrong_type_argument
, error_tail
));
3055 Fput (Qwrong_type_argument
, Qerror_message
,
3056 build_string ("Wrong type argument"));
3058 Fput (Qargs_out_of_range
, Qerror_conditions
,
3059 Fcons (Qargs_out_of_range
, error_tail
));
3060 Fput (Qargs_out_of_range
, Qerror_message
,
3061 build_string ("Args out of range"));
3063 Fput (Qvoid_function
, Qerror_conditions
,
3064 Fcons (Qvoid_function
, error_tail
));
3065 Fput (Qvoid_function
, Qerror_message
,
3066 build_string ("Symbol's function definition is void"));
3068 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3069 Fcons (Qcyclic_function_indirection
, error_tail
));
3070 Fput (Qcyclic_function_indirection
, Qerror_message
,
3071 build_string ("Symbol's chain of function indirections contains a loop"));
3073 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3074 Fcons (Qcyclic_variable_indirection
, error_tail
));
3075 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3076 build_string ("Symbol's chain of variable indirections contains a loop"));
3078 Qcircular_list
= intern ("circular-list");
3079 staticpro (&Qcircular_list
);
3080 Fput (Qcircular_list
, Qerror_conditions
,
3081 Fcons (Qcircular_list
, error_tail
));
3082 Fput (Qcircular_list
, Qerror_message
,
3083 build_string ("List contains a loop"));
3085 Fput (Qvoid_variable
, Qerror_conditions
,
3086 Fcons (Qvoid_variable
, error_tail
));
3087 Fput (Qvoid_variable
, Qerror_message
,
3088 build_string ("Symbol's value as variable is void"));
3090 Fput (Qsetting_constant
, Qerror_conditions
,
3091 Fcons (Qsetting_constant
, error_tail
));
3092 Fput (Qsetting_constant
, Qerror_message
,
3093 build_string ("Attempt to set a constant symbol"));
3095 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3096 Fcons (Qinvalid_read_syntax
, error_tail
));
3097 Fput (Qinvalid_read_syntax
, Qerror_message
,
3098 build_string ("Invalid read syntax"));
3100 Fput (Qinvalid_function
, Qerror_conditions
,
3101 Fcons (Qinvalid_function
, error_tail
));
3102 Fput (Qinvalid_function
, Qerror_message
,
3103 build_string ("Invalid function"));
3105 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3106 Fcons (Qwrong_number_of_arguments
, error_tail
));
3107 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3108 build_string ("Wrong number of arguments"));
3110 Fput (Qno_catch
, Qerror_conditions
,
3111 Fcons (Qno_catch
, error_tail
));
3112 Fput (Qno_catch
, Qerror_message
,
3113 build_string ("No catch for tag"));
3115 Fput (Qend_of_file
, Qerror_conditions
,
3116 Fcons (Qend_of_file
, error_tail
));
3117 Fput (Qend_of_file
, Qerror_message
,
3118 build_string ("End of file during parsing"));
3120 arith_tail
= Fcons (Qarith_error
, error_tail
);
3121 Fput (Qarith_error
, Qerror_conditions
,
3123 Fput (Qarith_error
, Qerror_message
,
3124 build_string ("Arithmetic error"));
3126 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3127 Fcons (Qbeginning_of_buffer
, error_tail
));
3128 Fput (Qbeginning_of_buffer
, Qerror_message
,
3129 build_string ("Beginning of buffer"));
3131 Fput (Qend_of_buffer
, Qerror_conditions
,
3132 Fcons (Qend_of_buffer
, error_tail
));
3133 Fput (Qend_of_buffer
, Qerror_message
,
3134 build_string ("End of buffer"));
3136 Fput (Qbuffer_read_only
, Qerror_conditions
,
3137 Fcons (Qbuffer_read_only
, error_tail
));
3138 Fput (Qbuffer_read_only
, Qerror_message
,
3139 build_string ("Buffer is read-only"));
3141 Fput (Qtext_read_only
, Qerror_conditions
,
3142 Fcons (Qtext_read_only
, error_tail
));
3143 Fput (Qtext_read_only
, Qerror_message
,
3144 build_string ("Text is read-only"));
3146 Qrange_error
= intern ("range-error");
3147 Qdomain_error
= intern ("domain-error");
3148 Qsingularity_error
= intern ("singularity-error");
3149 Qoverflow_error
= intern ("overflow-error");
3150 Qunderflow_error
= intern ("underflow-error");
3152 Fput (Qdomain_error
, Qerror_conditions
,
3153 Fcons (Qdomain_error
, arith_tail
));
3154 Fput (Qdomain_error
, Qerror_message
,
3155 build_string ("Arithmetic domain error"));
3157 Fput (Qrange_error
, Qerror_conditions
,
3158 Fcons (Qrange_error
, arith_tail
));
3159 Fput (Qrange_error
, Qerror_message
,
3160 build_string ("Arithmetic range error"));
3162 Fput (Qsingularity_error
, Qerror_conditions
,
3163 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3164 Fput (Qsingularity_error
, Qerror_message
,
3165 build_string ("Arithmetic singularity error"));
3167 Fput (Qoverflow_error
, Qerror_conditions
,
3168 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3169 Fput (Qoverflow_error
, Qerror_message
,
3170 build_string ("Arithmetic overflow error"));
3172 Fput (Qunderflow_error
, Qerror_conditions
,
3173 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3174 Fput (Qunderflow_error
, Qerror_message
,
3175 build_string ("Arithmetic underflow error"));
3177 staticpro (&Qrange_error
);
3178 staticpro (&Qdomain_error
);
3179 staticpro (&Qsingularity_error
);
3180 staticpro (&Qoverflow_error
);
3181 staticpro (&Qunderflow_error
);
3185 staticpro (&Qquote
);
3186 staticpro (&Qlambda
);
3188 staticpro (&Qunbound
);
3189 staticpro (&Qerror_conditions
);
3190 staticpro (&Qerror_message
);
3191 staticpro (&Qtop_level
);
3193 staticpro (&Qerror
);
3195 staticpro (&Qwrong_type_argument
);
3196 staticpro (&Qargs_out_of_range
);
3197 staticpro (&Qvoid_function
);
3198 staticpro (&Qcyclic_function_indirection
);
3199 staticpro (&Qcyclic_variable_indirection
);
3200 staticpro (&Qvoid_variable
);
3201 staticpro (&Qsetting_constant
);
3202 staticpro (&Qinvalid_read_syntax
);
3203 staticpro (&Qwrong_number_of_arguments
);
3204 staticpro (&Qinvalid_function
);
3205 staticpro (&Qno_catch
);
3206 staticpro (&Qend_of_file
);
3207 staticpro (&Qarith_error
);
3208 staticpro (&Qbeginning_of_buffer
);
3209 staticpro (&Qend_of_buffer
);
3210 staticpro (&Qbuffer_read_only
);
3211 staticpro (&Qtext_read_only
);
3212 staticpro (&Qmark_inactive
);
3214 staticpro (&Qlistp
);
3215 staticpro (&Qconsp
);
3216 staticpro (&Qsymbolp
);
3217 staticpro (&Qkeywordp
);
3218 staticpro (&Qintegerp
);
3219 staticpro (&Qnatnump
);
3220 staticpro (&Qwholenump
);
3221 staticpro (&Qstringp
);
3222 staticpro (&Qarrayp
);
3223 staticpro (&Qsequencep
);
3224 staticpro (&Qbufferp
);
3225 staticpro (&Qvectorp
);
3226 staticpro (&Qchar_or_string_p
);
3227 staticpro (&Qmarkerp
);
3228 staticpro (&Qbuffer_or_string_p
);
3229 staticpro (&Qinteger_or_marker_p
);
3230 staticpro (&Qfloatp
);
3231 staticpro (&Qnumberp
);
3232 staticpro (&Qnumber_or_marker_p
);
3233 staticpro (&Qchar_table_p
);
3234 staticpro (&Qvector_or_char_table_p
);
3235 staticpro (&Qsubrp
);
3237 staticpro (&Qunevalled
);
3239 staticpro (&Qboundp
);
3240 staticpro (&Qfboundp
);
3242 staticpro (&Qad_advice_info
);
3243 staticpro (&Qad_activate_internal
);
3245 /* Types that type-of returns. */
3246 Qinteger
= intern ("integer");
3247 Qsymbol
= intern ("symbol");
3248 Qstring
= intern ("string");
3249 Qcons
= intern ("cons");
3250 Qmarker
= intern ("marker");
3251 Qoverlay
= intern ("overlay");
3252 Qfloat
= intern ("float");
3253 Qwindow_configuration
= intern ("window-configuration");
3254 Qprocess
= intern ("process");
3255 Qwindow
= intern ("window");
3256 /* Qsubr = intern ("subr"); */
3257 Qcompiled_function
= intern ("compiled-function");
3258 Qbuffer
= intern ("buffer");
3259 Qframe
= intern ("frame");
3260 Qvector
= intern ("vector");
3261 Qchar_table
= intern ("char-table");
3262 Qbool_vector
= intern ("bool-vector");
3263 Qhash_table
= intern ("hash-table");
3265 staticpro (&Qinteger
);
3266 staticpro (&Qsymbol
);
3267 staticpro (&Qstring
);
3269 staticpro (&Qmarker
);
3270 staticpro (&Qoverlay
);
3271 staticpro (&Qfloat
);
3272 staticpro (&Qwindow_configuration
);
3273 staticpro (&Qprocess
);
3274 staticpro (&Qwindow
);
3275 /* staticpro (&Qsubr); */
3276 staticpro (&Qcompiled_function
);
3277 staticpro (&Qbuffer
);
3278 staticpro (&Qframe
);
3279 staticpro (&Qvector
);
3280 staticpro (&Qchar_table
);
3281 staticpro (&Qbool_vector
);
3282 staticpro (&Qhash_table
);
3284 defsubr (&Sindirect_variable
);
3285 defsubr (&Sinteractive_form
);
3288 defsubr (&Stype_of
);
3293 defsubr (&Sintegerp
);
3294 defsubr (&Sinteger_or_marker_p
);
3295 defsubr (&Snumberp
);
3296 defsubr (&Snumber_or_marker_p
);
3298 defsubr (&Snatnump
);
3299 defsubr (&Ssymbolp
);
3300 defsubr (&Skeywordp
);
3301 defsubr (&Sstringp
);
3302 defsubr (&Smultibyte_string_p
);
3303 defsubr (&Svectorp
);
3304 defsubr (&Schar_table_p
);
3305 defsubr (&Svector_or_char_table_p
);
3306 defsubr (&Sbool_vector_p
);
3308 defsubr (&Ssequencep
);
3309 defsubr (&Sbufferp
);
3310 defsubr (&Smarkerp
);
3312 defsubr (&Sbyte_code_function_p
);
3313 defsubr (&Schar_or_string_p
);
3316 defsubr (&Scar_safe
);
3317 defsubr (&Scdr_safe
);
3320 defsubr (&Ssymbol_function
);
3321 defsubr (&Sindirect_function
);
3322 defsubr (&Ssymbol_plist
);
3323 defsubr (&Ssymbol_name
);
3324 defsubr (&Smakunbound
);
3325 defsubr (&Sfmakunbound
);
3327 defsubr (&Sfboundp
);
3329 defsubr (&Sdefalias
);
3330 defsubr (&Ssetplist
);
3331 defsubr (&Ssymbol_value
);
3333 defsubr (&Sdefault_boundp
);
3334 defsubr (&Sdefault_value
);
3335 defsubr (&Sset_default
);
3336 defsubr (&Ssetq_default
);
3337 defsubr (&Smake_variable_buffer_local
);
3338 defsubr (&Smake_local_variable
);
3339 defsubr (&Skill_local_variable
);
3340 defsubr (&Smake_variable_frame_local
);
3341 defsubr (&Slocal_variable_p
);
3342 defsubr (&Slocal_variable_if_set_p
);
3343 defsubr (&Svariable_binding_locus
);
3346 defsubr (&Snumber_to_string
);
3347 defsubr (&Sstring_to_number
);
3348 defsubr (&Seqlsign
);
3371 defsubr (&Sbyteorder
);
3372 defsubr (&Ssubr_arity
);
3373 defsubr (&Ssubr_name
);
3375 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3377 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3378 doc
: /* The largest value that is representable in a Lisp integer. */);
3379 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3381 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3382 doc
: /* The smallest value that is representable in a Lisp integer. */);
3383 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3390 #if defined(USG) && !defined(POSIX_SIGNALS)
3391 /* USG systems forget handlers when they are used;
3392 must reestablish each time */
3393 signal (signo
, arith_error
);
3396 /* VMS systems are like USG. */
3397 signal (signo
, arith_error
);
3401 #else /* not BSD4_1 */
3402 sigsetmask (SIGEMPTYMASK
);
3403 #endif /* not BSD4_1 */
3405 SIGNAL_THREAD_CHECK (signo
);
3406 Fsignal (Qarith_error
, Qnil
);
3412 /* Don't do this if just dumping out.
3413 We don't want to call `signal' in this case
3414 so that we don't have trouble with dumping
3415 signal-delivering routines in an inconsistent state. */
3419 #endif /* CANNOT_DUMP */
3420 signal (SIGFPE
, arith_error
);
3423 signal (SIGEMT
, arith_error
);
3427 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3428 (do not change this comment) */