1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006 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"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
49 /* Work around a problem that happens because math.h on hpux 7
50 defines two static variables--which, in Emacs, are not really static,
51 because `static' is defined as nothing. The problem is that they are
52 here, in floatfns.c, and in lread.c.
53 These macros prevent the name conflict. */
54 #if defined (HPUX) && !defined (HPUX8)
55 #define _MAXLDBL data_c_maxldbl
56 #define _NMAXLDBL data_c_nmaxldbl
62 extern double atof ();
65 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
66 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
67 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
68 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
69 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
70 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
71 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
72 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
73 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
74 Lisp_Object Qtext_read_only
;
76 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
77 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
78 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
79 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
80 Lisp_Object Qboundp
, Qfboundp
;
81 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
84 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
86 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
87 Lisp_Object Qoverflow_error
, Qunderflow_error
;
90 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
93 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
94 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
96 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
97 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
98 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
100 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
102 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
106 circular_list_error (list
)
109 Fsignal (Qcircular_list
, list
);
114 wrong_type_argument (predicate
, value
)
115 register Lisp_Object predicate
, value
;
117 register Lisp_Object tem
;
120 /* If VALUE is not even a valid Lisp object, abort here
121 where we can get a backtrace showing where it came from. */
122 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
125 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
126 tem
= call1 (predicate
, value
);
129 /* This function is marked as NO_RETURN, gcc would warn if it has a
130 return statement or if falls off the function. Other compilers
131 warn if no return statement is present. */
142 error ("Attempt to modify read-only object");
146 args_out_of_range (a1
, a2
)
150 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
154 args_out_of_range_3 (a1
, a2
, a3
)
155 Lisp_Object a1
, a2
, a3
;
158 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
161 /* On some machines, XINT needs a temporary location.
162 Here it is, in case it is needed. */
164 int sign_extend_temp
;
166 /* On a few machines, XINT can only be done by calling this. */
169 sign_extend_lisp_int (num
)
172 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
173 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
175 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
178 /* Data type predicates */
180 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
181 doc
: /* Return t if the two args are the same Lisp object. */)
183 Lisp_Object obj1
, obj2
;
190 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
191 doc
: /* Return t if OBJECT is nil. */)
200 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
201 doc
: /* Return a symbol representing the type of OBJECT.
202 The symbol returned names the object's basic type;
203 for example, (type-of 1) returns `integer'. */)
207 switch (XGCTYPE (object
))
222 switch (XMISCTYPE (object
))
224 case Lisp_Misc_Marker
:
226 case Lisp_Misc_Overlay
:
228 case Lisp_Misc_Float
:
233 case Lisp_Vectorlike
:
234 if (GC_WINDOW_CONFIGURATIONP (object
))
235 return Qwindow_configuration
;
236 if (GC_PROCESSP (object
))
238 if (GC_WINDOWP (object
))
240 if (GC_SUBRP (object
))
242 if (GC_COMPILEDP (object
))
243 return Qcompiled_function
;
244 if (GC_BUFFERP (object
))
246 if (GC_CHAR_TABLE_P (object
))
248 if (GC_BOOL_VECTOR_P (object
))
250 if (GC_FRAMEP (object
))
252 if (GC_HASH_TABLE_P (object
))
264 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
265 doc
: /* Return t if OBJECT is a cons cell. */)
274 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
275 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
284 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
285 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
286 Otherwise, return nil. */)
290 if (CONSP (object
) || NILP (object
))
295 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
296 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
300 if (CONSP (object
) || NILP (object
))
305 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
306 doc
: /* Return t if OBJECT is a symbol. */)
310 if (SYMBOLP (object
))
315 /* Define this in C to avoid unnecessarily consing up the symbol
317 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
318 doc
: /* Return t if OBJECT is a keyword.
319 This means that it is a symbol with a print name beginning with `:'
320 interned in the initial obarray. */)
325 && SREF (SYMBOL_NAME (object
), 0) == ':'
326 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
331 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
332 doc
: /* Return t if OBJECT is a vector. */)
336 if (VECTORP (object
))
341 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
342 doc
: /* Return t if OBJECT is a string. */)
346 if (STRINGP (object
))
351 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
353 doc
: /* Return t if OBJECT is a multibyte string. */)
357 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
362 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a char-table. */)
367 if (CHAR_TABLE_P (object
))
372 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
373 Svector_or_char_table_p
, 1, 1, 0,
374 doc
: /* Return t if OBJECT is a char-table or vector. */)
378 if (VECTORP (object
) || CHAR_TABLE_P (object
))
383 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
384 doc
: /* Return t if OBJECT is a bool-vector. */)
388 if (BOOL_VECTOR_P (object
))
393 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
394 doc
: /* Return t if OBJECT is an array (string or vector). */)
398 if (VECTORP (object
) || STRINGP (object
)
399 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
404 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is a sequence (list or array). */)
407 register Lisp_Object object
;
409 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
410 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
415 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
416 doc
: /* Return t if OBJECT is an editor buffer. */)
420 if (BUFFERP (object
))
425 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
426 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
430 if (MARKERP (object
))
435 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
436 doc
: /* Return t if OBJECT is a built-in function. */)
445 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
447 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
451 if (COMPILEDP (object
))
456 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
457 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
459 register Lisp_Object object
;
461 if (INTEGERP (object
) || STRINGP (object
))
466 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
467 doc
: /* Return t if OBJECT is an integer. */)
471 if (INTEGERP (object
))
476 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
477 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
479 register Lisp_Object object
;
481 if (MARKERP (object
) || INTEGERP (object
))
486 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
487 doc
: /* Return t if OBJECT is a nonnegative integer. */)
491 if (NATNUMP (object
))
496 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
497 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
501 if (NUMBERP (object
))
507 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
508 Snumber_or_marker_p
, 1, 1, 0,
509 doc
: /* Return t if OBJECT is a number or a marker. */)
513 if (NUMBERP (object
) || MARKERP (object
))
518 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
519 doc
: /* Return t if OBJECT is a floating point number. */)
529 /* Extract and set components of lists */
531 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
532 doc
: /* Return the car of LIST. If arg is nil, return nil.
533 Error if arg is not nil and not a cons cell. See also `car-safe'.
535 See Info node `(elisp)Cons Cells' for a discussion of related basic
536 Lisp concepts such as car, cdr, cons cell and list. */)
538 register Lisp_Object list
;
544 else if (EQ (list
, Qnil
))
547 list
= wrong_type_argument (Qlistp
, list
);
551 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
552 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
557 return XCAR (object
);
562 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
563 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
564 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
566 See Info node `(elisp)Cons Cells' for a discussion of related basic
567 Lisp concepts such as cdr, car, cons cell and list. */)
569 register Lisp_Object list
;
575 else if (EQ (list
, Qnil
))
578 list
= wrong_type_argument (Qlistp
, list
);
582 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
583 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
588 return XCDR (object
);
593 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
594 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
596 register Lisp_Object cell
, newcar
;
599 cell
= wrong_type_argument (Qconsp
, cell
);
602 XSETCAR (cell
, newcar
);
606 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
607 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
609 register Lisp_Object cell
, newcdr
;
612 cell
= wrong_type_argument (Qconsp
, cell
);
615 XSETCDR (cell
, newcdr
);
619 /* Extract and set components of symbols */
621 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
622 doc
: /* Return t if SYMBOL's value is not void. */)
624 register Lisp_Object symbol
;
626 Lisp_Object valcontents
;
627 CHECK_SYMBOL (symbol
);
629 valcontents
= SYMBOL_VALUE (symbol
);
631 if (BUFFER_LOCAL_VALUEP (valcontents
)
632 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
633 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
635 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
638 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
639 doc
: /* Return t if SYMBOL's function definition is not void. */)
641 register Lisp_Object symbol
;
643 CHECK_SYMBOL (symbol
);
644 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
647 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
648 doc
: /* Make SYMBOL's value be void.
651 register Lisp_Object symbol
;
653 CHECK_SYMBOL (symbol
);
654 if (XSYMBOL (symbol
)->constant
)
655 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
656 Fset (symbol
, Qunbound
);
660 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
661 doc
: /* Make SYMBOL's function definition be void.
664 register Lisp_Object symbol
;
666 CHECK_SYMBOL (symbol
);
667 if (NILP (symbol
) || EQ (symbol
, Qt
))
668 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
669 XSYMBOL (symbol
)->function
= Qunbound
;
673 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
674 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
676 register Lisp_Object symbol
;
678 CHECK_SYMBOL (symbol
);
679 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
680 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
681 return XSYMBOL (symbol
)->function
;
684 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
685 doc
: /* Return SYMBOL's property list. */)
687 register Lisp_Object symbol
;
689 CHECK_SYMBOL (symbol
);
690 return XSYMBOL (symbol
)->plist
;
693 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
694 doc
: /* Return SYMBOL's name, a string. */)
696 register Lisp_Object symbol
;
698 register Lisp_Object name
;
700 CHECK_SYMBOL (symbol
);
701 name
= SYMBOL_NAME (symbol
);
705 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
706 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
708 register Lisp_Object symbol
, definition
;
710 CHECK_SYMBOL (symbol
);
711 if (NILP (symbol
) || EQ (symbol
, Qt
))
712 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
713 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
714 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
716 XSYMBOL (symbol
)->function
= definition
;
717 /* Handle automatic advice activation */
718 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
720 call2 (Qad_activate_internal
, symbol
, Qnil
);
721 definition
= XSYMBOL (symbol
)->function
;
726 extern Lisp_Object Qfunction_documentation
;
728 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
729 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
730 Associates the function with the current load file, if any.
731 The optional third argument DOCSTRING specifies the documentation string
732 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
733 determined by DEFINITION. */)
734 (symbol
, definition
, docstring
)
735 register Lisp_Object symbol
, definition
, docstring
;
737 CHECK_SYMBOL (symbol
);
738 if (CONSP (XSYMBOL (symbol
)->function
)
739 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
740 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
741 definition
= Ffset (symbol
, definition
);
742 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
743 if (!NILP (docstring
))
744 Fput (symbol
, Qfunction_documentation
, docstring
);
748 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
749 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
751 register Lisp_Object symbol
, newplist
;
753 CHECK_SYMBOL (symbol
);
754 XSYMBOL (symbol
)->plist
= newplist
;
758 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
759 doc
: /* Return minimum and maximum number of args allowed for SUBR.
760 SUBR must be a built-in function.
761 The returned value is a pair (MIN . MAX). MIN is the minimum number
762 of args. MAX is the maximum number or the symbol `many', for a
763 function with `&rest' args, or `unevalled' for a special form. */)
767 short minargs
, maxargs
;
769 wrong_type_argument (Qsubrp
, subr
);
770 minargs
= XSUBR (subr
)->min_args
;
771 maxargs
= XSUBR (subr
)->max_args
;
773 return Fcons (make_number (minargs
), Qmany
);
774 else if (maxargs
== UNEVALLED
)
775 return Fcons (make_number (minargs
), Qunevalled
);
777 return Fcons (make_number (minargs
), make_number (maxargs
));
780 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
781 doc
: /* Return name of subroutine SUBR.
782 SUBR must be a built-in function. */)
788 wrong_type_argument (Qsubrp
, subr
);
789 name
= XSUBR (subr
)->symbol_name
;
790 return make_string (name
, strlen (name
));
793 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
794 doc
: /* Return the interactive form of CMD or nil if none.
795 If CMD is not a command, the return value is nil.
796 Value, if non-nil, is a list \(interactive SPEC). */)
800 Lisp_Object fun
= indirect_function (cmd
);
804 if (XSUBR (fun
)->prompt
)
805 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
807 else if (COMPILEDP (fun
))
809 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
810 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
812 else if (CONSP (fun
))
814 Lisp_Object funcar
= XCAR (fun
);
815 if (EQ (funcar
, Qlambda
))
816 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
817 else if (EQ (funcar
, Qautoload
))
821 do_autoload (fun
, cmd
);
823 return Finteractive_form (cmd
);
830 /***********************************************************************
831 Getting and Setting Values of Symbols
832 ***********************************************************************/
834 /* Return the symbol holding SYMBOL's value. Signal
835 `cyclic-variable-indirection' if SYMBOL's chain of variable
836 indirections contains a loop. */
839 indirect_variable (symbol
)
842 Lisp_Object tortoise
, hare
;
844 hare
= tortoise
= symbol
;
846 while (XSYMBOL (hare
)->indirect_variable
)
848 hare
= XSYMBOL (hare
)->value
;
849 if (!XSYMBOL (hare
)->indirect_variable
)
852 hare
= XSYMBOL (hare
)->value
;
853 tortoise
= XSYMBOL (tortoise
)->value
;
855 if (EQ (hare
, tortoise
))
856 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
863 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
864 doc
: /* Return the variable at the end of OBJECT's variable chain.
865 If OBJECT is a symbol, follow all variable indirections and return the final
866 variable. If OBJECT is not a symbol, just return it.
867 Signal a cyclic-variable-indirection error if there is a loop in the
868 variable chain of symbols. */)
872 if (SYMBOLP (object
))
873 object
= indirect_variable (object
);
878 /* Given the raw contents of a symbol value cell,
879 return the Lisp value of the symbol.
880 This does not handle buffer-local variables; use
881 swap_in_symval_forwarding for that. */
884 do_symval_forwarding (valcontents
)
885 register Lisp_Object valcontents
;
887 register Lisp_Object val
;
889 if (MISCP (valcontents
))
890 switch (XMISCTYPE (valcontents
))
892 case Lisp_Misc_Intfwd
:
893 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
896 case Lisp_Misc_Boolfwd
:
897 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
899 case Lisp_Misc_Objfwd
:
900 return *XOBJFWD (valcontents
)->objvar
;
902 case Lisp_Misc_Buffer_Objfwd
:
903 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
904 return PER_BUFFER_VALUE (current_buffer
, offset
);
906 case Lisp_Misc_Kboard_Objfwd
:
907 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
908 /* We used to simply use current_kboard here, but from Lisp
909 code, it's value is often unexpected. It seems nicer to
910 allow constructions like this to work as intuitively expected:
912 (with-selected-frame frame
913 (define-key local-function-map "\eOP" [f1]))
915 On the other hand, this affects the semantics of
916 last-command and real-last-command, and people may rely on
917 that. I took a quick look at the Lisp codebase, and I
918 don't think anything will break. --lorentey */
919 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
924 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
925 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
926 buffer-independent contents of the value cell: forwarded just one
927 step past the buffer-localness.
929 BUF non-zero means set the value in buffer BUF instead of the
930 current buffer. This only plays a role for per-buffer variables. */
933 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
935 register Lisp_Object valcontents
, newval
;
938 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
941 switch (XMISCTYPE (valcontents
))
943 case Lisp_Misc_Intfwd
:
944 CHECK_NUMBER (newval
);
945 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
946 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
947 error ("Value out of range for variable `%s'",
948 SDATA (SYMBOL_NAME (symbol
)));
951 case Lisp_Misc_Boolfwd
:
952 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
955 case Lisp_Misc_Objfwd
:
956 *XOBJFWD (valcontents
)->objvar
= newval
;
958 /* If this variable is a default for something stored
959 in the buffer itself, such as default-fill-column,
960 find the buffers that don't have local values for it
962 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
963 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
965 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
966 - (char *) &buffer_defaults
);
967 int idx
= PER_BUFFER_IDX (offset
);
974 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
979 buf
= Fcdr (XCAR (tail
));
980 if (!BUFFERP (buf
)) continue;
983 if (! PER_BUFFER_VALUE_P (b
, idx
))
984 PER_BUFFER_VALUE (b
, offset
) = newval
;
989 case Lisp_Misc_Buffer_Objfwd
:
991 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
994 type
= PER_BUFFER_TYPE (offset
);
995 if (! NILP (type
) && ! NILP (newval
)
996 && XTYPE (newval
) != XINT (type
))
997 buffer_slot_type_mismatch (offset
);
1000 buf
= current_buffer
;
1001 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1005 case Lisp_Misc_Kboard_Objfwd
:
1007 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1008 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1009 *(Lisp_Object
*) p
= newval
;
1020 valcontents
= SYMBOL_VALUE (symbol
);
1021 if (BUFFER_LOCAL_VALUEP (valcontents
)
1022 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1023 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1025 SET_SYMBOL_VALUE (symbol
, newval
);
1029 /* Set up SYMBOL to refer to its global binding.
1030 This makes it safe to alter the status of other bindings. */
1033 swap_in_global_binding (symbol
)
1036 Lisp_Object valcontents
, cdr
;
1038 valcontents
= SYMBOL_VALUE (symbol
);
1039 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1040 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1042 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1044 /* Unload the previously loaded binding. */
1045 Fsetcdr (XCAR (cdr
),
1046 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1048 /* Select the global binding in the symbol. */
1050 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1052 /* Indicate that the global binding is set up now. */
1053 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1054 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1055 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1056 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1059 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1060 VALCONTENTS is the contents of its value cell,
1061 which points to a struct Lisp_Buffer_Local_Value.
1063 Return the value forwarded one step past the buffer-local stage.
1064 This could be another forwarding pointer. */
1067 swap_in_symval_forwarding (symbol
, valcontents
)
1068 Lisp_Object symbol
, valcontents
;
1070 register Lisp_Object tem1
;
1072 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1075 || current_buffer
!= XBUFFER (tem1
)
1076 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1077 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1079 if (XSYMBOL (symbol
)->indirect_variable
)
1080 symbol
= indirect_variable (symbol
);
1082 /* Unload the previously loaded binding. */
1083 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1085 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1086 /* Choose the new binding. */
1087 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1088 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1089 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1092 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1093 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1095 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1097 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1100 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1102 /* Load the new binding. */
1103 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1104 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1105 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1106 store_symval_forwarding (symbol
,
1107 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1110 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1113 /* Find the value of a symbol, returning Qunbound if it's not bound.
1114 This is helpful for code which just wants to get a variable's value
1115 if it has one, without signaling an error.
1116 Note that it must not be possible to quit
1117 within this function. Great care is required for this. */
1120 find_symbol_value (symbol
)
1123 register Lisp_Object valcontents
;
1124 register Lisp_Object val
;
1126 CHECK_SYMBOL (symbol
);
1127 valcontents
= SYMBOL_VALUE (symbol
);
1129 if (BUFFER_LOCAL_VALUEP (valcontents
)
1130 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1131 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1133 if (MISCP (valcontents
))
1135 switch (XMISCTYPE (valcontents
))
1137 case Lisp_Misc_Intfwd
:
1138 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1141 case Lisp_Misc_Boolfwd
:
1142 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1144 case Lisp_Misc_Objfwd
:
1145 return *XOBJFWD (valcontents
)->objvar
;
1147 case Lisp_Misc_Buffer_Objfwd
:
1148 return PER_BUFFER_VALUE (current_buffer
,
1149 XBUFFER_OBJFWD (valcontents
)->offset
);
1151 case Lisp_Misc_Kboard_Objfwd
:
1152 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1153 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1160 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1161 doc
: /* Return SYMBOL's value. Error if that is void. */)
1167 val
= find_symbol_value (symbol
);
1168 if (EQ (val
, Qunbound
))
1169 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1174 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1175 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1177 register Lisp_Object symbol
, newval
;
1179 return set_internal (symbol
, newval
, current_buffer
, 0);
1182 /* Return 1 if SYMBOL currently has a let-binding
1183 which was made in the buffer that is now current. */
1186 let_shadows_buffer_binding_p (symbol
)
1189 volatile struct specbinding
*p
;
1191 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1193 && CONSP (p
->symbol
))
1195 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1196 if ((EQ (symbol
, let_bound_symbol
)
1197 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1198 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1199 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1203 return p
>= specpdl
;
1206 /* Store the value NEWVAL into SYMBOL.
1207 If buffer-locality is an issue, BUF specifies which buffer to use.
1208 (0 stands for the current buffer.)
1210 If BINDFLAG is zero, then if this symbol is supposed to become
1211 local in every buffer where it is set, then we make it local.
1212 If BINDFLAG is nonzero, we don't do that. */
1215 set_internal (symbol
, newval
, buf
, bindflag
)
1216 register Lisp_Object symbol
, newval
;
1220 int voide
= EQ (newval
, Qunbound
);
1222 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1225 buf
= current_buffer
;
1227 /* If restoring in a dead buffer, do nothing. */
1228 if (NILP (buf
->name
))
1231 CHECK_SYMBOL (symbol
);
1232 if (SYMBOL_CONSTANT_P (symbol
)
1233 && (NILP (Fkeywordp (symbol
))
1234 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1235 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1237 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1239 if (BUFFER_OBJFWDP (valcontents
))
1241 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1242 int idx
= PER_BUFFER_IDX (offset
);
1245 && !let_shadows_buffer_binding_p (symbol
))
1246 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1248 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1249 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1251 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1252 if (XSYMBOL (symbol
)->indirect_variable
)
1253 symbol
= indirect_variable (symbol
);
1255 /* What binding is loaded right now? */
1256 current_alist_element
1257 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1259 /* If the current buffer is not the buffer whose binding is
1260 loaded, or if there may be frame-local bindings and the frame
1261 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1262 the default binding is loaded, the loaded binding may be the
1264 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1265 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1266 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1267 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1268 || (BUFFER_LOCAL_VALUEP (valcontents
)
1269 && EQ (XCAR (current_alist_element
),
1270 current_alist_element
)))
1272 /* The currently loaded binding is not necessarily valid.
1273 We need to unload it, and choose a new binding. */
1275 /* Write out `realvalue' to the old loaded binding. */
1276 Fsetcdr (current_alist_element
,
1277 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1279 /* Find the new binding. */
1280 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1281 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1282 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1286 /* This buffer still sees the default value. */
1288 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1289 or if this is `let' rather than `set',
1290 make CURRENT-ALIST-ELEMENT point to itself,
1291 indicating that we're seeing the default value.
1292 Likewise if the variable has been let-bound
1293 in the current buffer. */
1294 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1295 || let_shadows_buffer_binding_p (symbol
))
1297 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1299 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1300 tem1
= Fassq (symbol
,
1301 XFRAME (selected_frame
)->param_alist
);
1304 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1306 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1308 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1309 and we're not within a let that was made for this buffer,
1310 create a new buffer-local binding for the variable.
1311 That means, give this buffer a new assoc for a local value
1312 and load that binding. */
1315 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1316 buf
->local_var_alist
1317 = Fcons (tem1
, buf
->local_var_alist
);
1321 /* Record which binding is now loaded. */
1322 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1325 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1326 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1327 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1329 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1332 /* If storing void (making the symbol void), forward only through
1333 buffer-local indicator, not through Lisp_Objfwd, etc. */
1335 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1337 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1339 /* If we just set a variable whose current binding is frame-local,
1340 store the new value in the frame parameter too. */
1342 if (BUFFER_LOCAL_VALUEP (valcontents
)
1343 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1345 /* What binding is loaded right now? */
1346 current_alist_element
1347 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1349 /* If the current buffer is not the buffer whose binding is
1350 loaded, or if there may be frame-local bindings and the frame
1351 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1352 the default binding is loaded, the loaded binding may be the
1354 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1355 XSETCDR (current_alist_element
, newval
);
1361 /* Access or set a buffer-local symbol's default value. */
1363 /* Return the default value of SYMBOL, but don't check for voidness.
1364 Return Qunbound if it is void. */
1367 default_value (symbol
)
1370 register Lisp_Object valcontents
;
1372 CHECK_SYMBOL (symbol
);
1373 valcontents
= SYMBOL_VALUE (symbol
);
1375 /* For a built-in buffer-local variable, get the default value
1376 rather than letting do_symval_forwarding get the current value. */
1377 if (BUFFER_OBJFWDP (valcontents
))
1379 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1380 if (PER_BUFFER_IDX (offset
) != 0)
1381 return PER_BUFFER_DEFAULT (offset
);
1384 /* Handle user-created local variables. */
1385 if (BUFFER_LOCAL_VALUEP (valcontents
)
1386 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1388 /* If var is set up for a buffer that lacks a local value for it,
1389 the current value is nominally the default value.
1390 But the `realvalue' slot may be more up to date, since
1391 ordinary setq stores just that slot. So use that. */
1392 Lisp_Object current_alist_element
, alist_element_car
;
1393 current_alist_element
1394 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1395 alist_element_car
= XCAR (current_alist_element
);
1396 if (EQ (alist_element_car
, current_alist_element
))
1397 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1399 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1401 /* For other variables, get the current value. */
1402 return do_symval_forwarding (valcontents
);
1405 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1406 doc
: /* Return t if SYMBOL has a non-void default value.
1407 This is the value that is seen in buffers that do not have their own values
1408 for this variable. */)
1412 register Lisp_Object value
;
1414 value
= default_value (symbol
);
1415 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1418 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1419 doc
: /* Return SYMBOL's default value.
1420 This is the value that is seen in buffers that do not have their own values
1421 for this variable. The default value is meaningful for variables with
1422 local bindings in certain buffers. */)
1426 register Lisp_Object value
;
1428 value
= default_value (symbol
);
1429 if (EQ (value
, Qunbound
))
1430 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1434 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1435 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1436 The default value is seen in buffers that do not have their own values
1437 for this variable. */)
1439 Lisp_Object symbol
, value
;
1441 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1443 CHECK_SYMBOL (symbol
);
1444 valcontents
= SYMBOL_VALUE (symbol
);
1446 /* Handle variables like case-fold-search that have special slots
1447 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1449 if (BUFFER_OBJFWDP (valcontents
))
1451 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1452 int idx
= PER_BUFFER_IDX (offset
);
1454 PER_BUFFER_DEFAULT (offset
) = value
;
1456 /* If this variable is not always local in all buffers,
1457 set it in the buffers that don't nominally have a local value. */
1462 for (b
= all_buffers
; b
; b
= b
->next
)
1463 if (!PER_BUFFER_VALUE_P (b
, idx
))
1464 PER_BUFFER_VALUE (b
, offset
) = value
;
1469 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1470 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1471 return Fset (symbol
, value
);
1473 /* Store new value into the DEFAULT-VALUE slot. */
1474 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1476 /* If the default binding is now loaded, set the REALVALUE slot too. */
1477 current_alist_element
1478 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1479 alist_element_buffer
= Fcar (current_alist_element
);
1480 if (EQ (alist_element_buffer
, current_alist_element
))
1481 store_symval_forwarding (symbol
,
1482 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1488 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1489 doc
: /* Set the default value of variable VAR to VALUE.
1490 VAR, the variable name, is literal (not evaluated);
1491 VALUE is an expression: it is evaluated and its value returned.
1492 The default value of a variable is seen in buffers
1493 that do not have their own values for the variable.
1495 More generally, you can use multiple variables and values, as in
1496 (setq-default VAR VALUE VAR VALUE...)
1497 This sets each VAR's default value to the corresponding VALUE.
1498 The VALUE for the Nth VAR can refer to the new default values
1500 usage: (setq-default [VAR VALUE...]) */)
1504 register Lisp_Object args_left
;
1505 register Lisp_Object val
, symbol
;
1506 struct gcpro gcpro1
;
1516 val
= Feval (Fcar (Fcdr (args_left
)));
1517 symbol
= XCAR (args_left
);
1518 Fset_default (symbol
, val
);
1519 args_left
= Fcdr (XCDR (args_left
));
1521 while (!NILP (args_left
));
1527 /* Lisp functions for creating and removing buffer-local variables. */
1529 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1530 1, 1, "vMake Variable Buffer Local: ",
1531 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1532 At any time, the value for the current buffer is in effect,
1533 unless the variable has never been set in this buffer,
1534 in which case the default value is in effect.
1535 Note that binding the variable with `let', or setting it while
1536 a `let'-style binding made in this buffer is in effect,
1537 does not make the variable buffer-local. Return VARIABLE.
1539 In most cases it is better to use `make-local-variable',
1540 which makes a variable local in just one buffer.
1542 The function `default-value' gets the default value and `set-default' sets it. */)
1544 register Lisp_Object variable
;
1546 register Lisp_Object tem
, valcontents
, newval
;
1548 CHECK_SYMBOL (variable
);
1549 variable
= indirect_variable (variable
);
1551 valcontents
= SYMBOL_VALUE (variable
);
1552 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1553 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1555 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1557 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1559 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1562 if (EQ (valcontents
, Qunbound
))
1563 SET_SYMBOL_VALUE (variable
, Qnil
);
1564 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1566 newval
= allocate_misc ();
1567 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1568 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1569 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1570 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1571 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1572 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1573 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1574 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1575 SET_SYMBOL_VALUE (variable
, newval
);
1579 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1580 1, 1, "vMake Local Variable: ",
1581 doc
: /* Make VARIABLE have a separate value in the current buffer.
1582 Other buffers will continue to share a common default value.
1583 \(The buffer-local value of VARIABLE starts out as the same value
1584 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1587 If the variable is already arranged to become local when set,
1588 this function causes a local value to exist for this buffer,
1589 just as setting the variable would do.
1591 This function returns VARIABLE, and therefore
1592 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1595 See also `make-variable-buffer-local'.
1597 Do not use `make-local-variable' to make a hook variable buffer-local.
1598 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1600 register Lisp_Object variable
;
1602 register Lisp_Object tem
, valcontents
;
1604 CHECK_SYMBOL (variable
);
1605 variable
= indirect_variable (variable
);
1607 valcontents
= SYMBOL_VALUE (variable
);
1608 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1609 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1611 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1613 tem
= Fboundp (variable
);
1615 /* Make sure the symbol has a local value in this particular buffer,
1616 by setting it to the same value it already has. */
1617 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1620 /* Make sure symbol is set up to hold per-buffer values. */
1621 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1624 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1626 newval
= allocate_misc ();
1627 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1628 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1629 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1630 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1631 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1632 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1633 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1634 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1635 SET_SYMBOL_VALUE (variable
, newval
);;
1637 /* Make sure this buffer has its own value of symbol. */
1638 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1641 /* Swap out any local binding for some other buffer, and make
1642 sure the current value is permanently recorded, if it's the
1644 find_symbol_value (variable
);
1646 current_buffer
->local_var_alist
1647 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1648 current_buffer
->local_var_alist
);
1650 /* Make sure symbol does not think it is set up for this buffer;
1651 force it to look once again for this buffer's value. */
1653 Lisp_Object
*pvalbuf
;
1655 valcontents
= SYMBOL_VALUE (variable
);
1657 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1658 if (current_buffer
== XBUFFER (*pvalbuf
))
1660 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1664 /* If the symbol forwards into a C variable, then load the binding
1665 for this buffer now. If C code modifies the variable before we
1666 load the binding in, then that new value will clobber the default
1667 binding the next time we unload it. */
1668 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1669 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1670 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1675 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1676 1, 1, "vKill Local Variable: ",
1677 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1678 From now on the default value will apply in this buffer. Return VARIABLE. */)
1680 register Lisp_Object variable
;
1682 register Lisp_Object tem
, valcontents
;
1684 CHECK_SYMBOL (variable
);
1685 variable
= indirect_variable (variable
);
1687 valcontents
= SYMBOL_VALUE (variable
);
1689 if (BUFFER_OBJFWDP (valcontents
))
1691 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1692 int idx
= PER_BUFFER_IDX (offset
);
1696 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1697 PER_BUFFER_VALUE (current_buffer
, offset
)
1698 = PER_BUFFER_DEFAULT (offset
);
1703 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1704 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1707 /* Get rid of this buffer's alist element, if any. */
1709 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1711 current_buffer
->local_var_alist
1712 = Fdelq (tem
, current_buffer
->local_var_alist
);
1714 /* If the symbol is set up with the current buffer's binding
1715 loaded, recompute its value. We have to do it now, or else
1716 forwarded objects won't work right. */
1718 Lisp_Object
*pvalbuf
, buf
;
1719 valcontents
= SYMBOL_VALUE (variable
);
1720 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1721 XSETBUFFER (buf
, current_buffer
);
1722 if (EQ (buf
, *pvalbuf
))
1725 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1726 find_symbol_value (variable
);
1733 /* Lisp functions for creating and removing buffer-local variables. */
1735 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1736 1, 1, "vMake Variable Frame Local: ",
1737 doc
: /* Enable VARIABLE to have frame-local bindings.
1738 This does not create any frame-local bindings for VARIABLE,
1739 it just makes them possible.
1741 A frame-local binding is actually a frame parameter value.
1742 If a frame F has a value for the frame parameter named VARIABLE,
1743 that also acts as a frame-local binding for VARIABLE in F--
1744 provided this function has been called to enable VARIABLE
1745 to have frame-local bindings at all.
1747 The only way to create a frame-local binding for VARIABLE in a frame
1748 is to set the VARIABLE frame parameter of that frame. See
1749 `modify-frame-parameters' for how to set frame parameters.
1751 Buffer-local bindings take precedence over frame-local bindings. */)
1753 register Lisp_Object variable
;
1755 register Lisp_Object tem
, valcontents
, newval
;
1757 CHECK_SYMBOL (variable
);
1758 variable
= indirect_variable (variable
);
1760 valcontents
= SYMBOL_VALUE (variable
);
1761 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1762 || BUFFER_OBJFWDP (valcontents
))
1763 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1765 if (BUFFER_LOCAL_VALUEP (valcontents
)
1766 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1768 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1772 if (EQ (valcontents
, Qunbound
))
1773 SET_SYMBOL_VALUE (variable
, Qnil
);
1774 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1776 newval
= allocate_misc ();
1777 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1778 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1779 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1780 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1781 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1782 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1783 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1784 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1785 SET_SYMBOL_VALUE (variable
, newval
);
1789 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1791 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1792 BUFFER defaults to the current buffer. */)
1794 register Lisp_Object variable
, buffer
;
1796 Lisp_Object valcontents
;
1797 register struct buffer
*buf
;
1800 buf
= current_buffer
;
1803 CHECK_BUFFER (buffer
);
1804 buf
= XBUFFER (buffer
);
1807 CHECK_SYMBOL (variable
);
1808 variable
= indirect_variable (variable
);
1810 valcontents
= SYMBOL_VALUE (variable
);
1811 if (BUFFER_LOCAL_VALUEP (valcontents
)
1812 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1814 Lisp_Object tail
, elt
;
1816 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1819 if (EQ (variable
, XCAR (elt
)))
1823 if (BUFFER_OBJFWDP (valcontents
))
1825 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1826 int idx
= PER_BUFFER_IDX (offset
);
1827 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1833 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1835 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1836 More precisely, this means that setting the variable \(with `set' or`setq'),
1837 while it does not have a `let'-style binding that was made in BUFFER,
1838 will produce a buffer local binding. See Info node
1839 `(elisp)Creating Buffer-Local'.
1840 BUFFER defaults to the current buffer. */)
1842 register Lisp_Object variable
, buffer
;
1844 Lisp_Object valcontents
;
1845 register struct buffer
*buf
;
1848 buf
= current_buffer
;
1851 CHECK_BUFFER (buffer
);
1852 buf
= XBUFFER (buffer
);
1855 CHECK_SYMBOL (variable
);
1856 variable
= indirect_variable (variable
);
1858 valcontents
= SYMBOL_VALUE (variable
);
1860 /* This means that make-variable-buffer-local was done. */
1861 if (BUFFER_LOCAL_VALUEP (valcontents
))
1863 /* All these slots become local if they are set. */
1864 if (BUFFER_OBJFWDP (valcontents
))
1866 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1868 Lisp_Object tail
, elt
;
1869 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1872 if (EQ (variable
, XCAR (elt
)))
1879 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1881 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1882 If the current binding is buffer-local, the value is the current buffer.
1883 If the current binding is frame-local, the value is the selected frame.
1884 If the current binding is global (the default), the value is nil. */)
1886 register Lisp_Object variable
;
1888 Lisp_Object valcontents
;
1890 CHECK_SYMBOL (variable
);
1891 variable
= indirect_variable (variable
);
1893 /* Make sure the current binding is actually swapped in. */
1894 find_symbol_value (variable
);
1896 valcontents
= XSYMBOL (variable
)->value
;
1898 if (BUFFER_LOCAL_VALUEP (valcontents
)
1899 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1900 || BUFFER_OBJFWDP (valcontents
))
1902 /* For a local variable, record both the symbol and which
1903 buffer's or frame's value we are saving. */
1904 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1905 return Fcurrent_buffer ();
1906 else if (!BUFFER_OBJFWDP (valcontents
)
1907 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1908 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1914 /* This code is disabled now that we use the selected frame to return
1915 keyboard-local-values. */
1917 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1919 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1920 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1921 If SYMBOL is not a terminal-local variable, then return its normal
1922 value, like `symbol-value'.
1924 TERMINAL may be a terminal id, a frame, or nil (meaning the
1925 selected frame's terminal device). */)
1928 Lisp_Object terminal
;
1931 struct terminal
*t
= get_terminal (terminal
, 1);
1932 push_kboard (t
->kboard
);
1933 result
= Fsymbol_value (symbol
);
1938 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1939 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1940 If VARIABLE is not a terminal-local variable, then set its normal
1941 binding, like `set'.
1943 TERMINAL may be a terminal id, a frame, or nil (meaning the
1944 selected frame's terminal device). */)
1945 (symbol
, terminal
, value
)
1947 Lisp_Object terminal
;
1951 struct terminal
*t
= get_terminal (terminal
, 1);
1952 push_kboard (d
->kboard
);
1953 result
= Fset (symbol
, value
);
1959 /* Find the function at the end of a chain of symbol function indirections. */
1961 /* If OBJECT is a symbol, find the end of its function chain and
1962 return the value found there. If OBJECT is not a symbol, just
1963 return it. If there is a cycle in the function chain, signal a
1964 cyclic-function-indirection error.
1966 This is like Findirect_function, except that it doesn't signal an
1967 error if the chain ends up unbound. */
1969 indirect_function (object
)
1970 register Lisp_Object object
;
1972 Lisp_Object tortoise
, hare
;
1974 hare
= tortoise
= object
;
1978 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1980 hare
= XSYMBOL (hare
)->function
;
1981 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1983 hare
= XSYMBOL (hare
)->function
;
1985 tortoise
= XSYMBOL (tortoise
)->function
;
1987 if (EQ (hare
, tortoise
))
1988 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1994 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1995 doc
: /* Return the function at the end of OBJECT's function chain.
1996 If OBJECT is not a symbol, just return it. Otherwise, follow all
1997 function indirections to find the final function binding and return it.
1998 If the final symbol in the chain is unbound, signal a void-function error.
1999 Optional arg NOERROR non-nil means to return nil instead of signalling.
2000 Signal a cyclic-function-indirection error if there is a loop in the
2001 function chain of symbols. */)
2003 register Lisp_Object object
;
2004 Lisp_Object noerror
;
2008 result
= indirect_function (object
);
2010 if (EQ (result
, Qunbound
))
2011 return (NILP (noerror
)
2012 ? Fsignal (Qvoid_function
, Fcons (object
, Qnil
))
2017 /* Extract and set vector and string elements */
2019 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2020 doc
: /* Return the element of ARRAY at index IDX.
2021 ARRAY may be a vector, a string, a char-table, a bool-vector,
2022 or a byte-code object. IDX starts at 0. */)
2024 register Lisp_Object array
;
2027 register int idxval
;
2030 idxval
= XINT (idx
);
2031 if (STRINGP (array
))
2035 if (idxval
< 0 || idxval
>= SCHARS (array
))
2036 args_out_of_range (array
, idx
);
2037 if (! STRING_MULTIBYTE (array
))
2038 return make_number ((unsigned char) SREF (array
, idxval
));
2039 idxval_byte
= string_char_to_byte (array
, idxval
);
2041 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2042 SBYTES (array
) - idxval_byte
);
2043 return make_number (c
);
2045 else if (BOOL_VECTOR_P (array
))
2049 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2050 args_out_of_range (array
, idx
);
2052 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2053 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2055 else if (CHAR_TABLE_P (array
))
2062 args_out_of_range (array
, idx
);
2063 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2065 if (! SINGLE_BYTE_CHAR_P (idxval
))
2066 args_out_of_range (array
, idx
);
2067 /* For ASCII and 8-bit European characters, the element is
2068 stored in the top table. */
2069 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2073 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2074 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2075 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2076 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2079 val
= XCHAR_TABLE (array
)->defalt
;
2080 while (NILP (val
)) /* Follow parents until we find some value. */
2082 array
= XCHAR_TABLE (array
)->parent
;
2085 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2087 val
= XCHAR_TABLE (array
)->defalt
;
2094 Lisp_Object sub_table
;
2095 Lisp_Object current_default
;
2097 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2098 if (code
[1] < 32) code
[1] = -1;
2099 else if (code
[2] < 32) code
[2] = -1;
2101 /* Here, the possible range of CODE[0] (== charset ID) is
2102 128..MAX_CHARSET. Since the top level char table contains
2103 data for multibyte characters after 256th element, we must
2104 increment CODE[0] by 128 to get a correct index. */
2106 code
[3] = -1; /* anchor */
2108 try_parent_char_table
:
2109 current_default
= XCHAR_TABLE (array
)->defalt
;
2111 for (i
= 0; code
[i
] >= 0; i
++)
2113 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2114 if (SUB_CHAR_TABLE_P (val
))
2117 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2118 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2123 val
= current_default
;
2126 array
= XCHAR_TABLE (array
)->parent
;
2128 goto try_parent_char_table
;
2133 /* Reaching here means IDXVAL is a generic character in
2134 which each character or a group has independent value.
2135 Essentially it's nonsense to get a value for such a
2136 generic character, but for backward compatibility, we try
2137 the default value and parent. */
2138 val
= current_default
;
2141 array
= XCHAR_TABLE (array
)->parent
;
2143 goto try_parent_char_table
;
2151 if (VECTORP (array
))
2152 size
= XVECTOR (array
)->size
;
2153 else if (COMPILEDP (array
))
2154 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2156 wrong_type_argument (Qarrayp
, array
);
2158 if (idxval
< 0 || idxval
>= size
)
2159 args_out_of_range (array
, idx
);
2160 return XVECTOR (array
)->contents
[idxval
];
2164 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2165 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2166 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2167 bool-vector. IDX starts at 0. */)
2168 (array
, idx
, newelt
)
2169 register Lisp_Object array
;
2170 Lisp_Object idx
, newelt
;
2172 register int idxval
;
2175 idxval
= XINT (idx
);
2176 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2177 && ! CHAR_TABLE_P (array
))
2178 array
= wrong_type_argument (Qarrayp
, array
);
2179 CHECK_IMPURE (array
);
2181 if (VECTORP (array
))
2183 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2184 args_out_of_range (array
, idx
);
2185 XVECTOR (array
)->contents
[idxval
] = newelt
;
2187 else if (BOOL_VECTOR_P (array
))
2191 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2192 args_out_of_range (array
, idx
);
2194 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2196 if (! NILP (newelt
))
2197 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2199 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2200 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2202 else if (CHAR_TABLE_P (array
))
2205 args_out_of_range (array
, idx
);
2206 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2208 if (! SINGLE_BYTE_CHAR_P (idxval
))
2209 args_out_of_range (array
, idx
);
2210 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2217 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2218 if (code
[1] < 32) code
[1] = -1;
2219 else if (code
[2] < 32) code
[2] = -1;
2221 /* See the comment of the corresponding part in Faref. */
2223 code
[3] = -1; /* anchor */
2224 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2226 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2227 if (SUB_CHAR_TABLE_P (val
))
2233 /* VAL is a leaf. Create a sub char table with the
2234 initial value VAL and look into it. */
2236 temp
= make_sub_char_table (val
);
2237 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2241 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2244 else if (STRING_MULTIBYTE (array
))
2246 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2247 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2249 if (idxval
< 0 || idxval
>= SCHARS (array
))
2250 args_out_of_range (array
, idx
);
2251 CHECK_NUMBER (newelt
);
2253 nbytes
= SBYTES (array
);
2255 idxval_byte
= string_char_to_byte (array
, idxval
);
2256 p1
= SDATA (array
) + idxval_byte
;
2257 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2258 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2259 if (prev_bytes
!= new_bytes
)
2261 /* We must relocate the string data. */
2262 int nchars
= SCHARS (array
);
2266 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2267 bcopy (SDATA (array
), str
, nbytes
);
2268 allocate_string_data (XSTRING (array
), nchars
,
2269 nbytes
+ new_bytes
- prev_bytes
);
2270 bcopy (str
, SDATA (array
), idxval_byte
);
2271 p1
= SDATA (array
) + idxval_byte
;
2272 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2273 nbytes
- (idxval_byte
+ prev_bytes
));
2275 clear_string_char_byte_cache ();
2282 if (idxval
< 0 || idxval
>= SCHARS (array
))
2283 args_out_of_range (array
, idx
);
2284 CHECK_NUMBER (newelt
);
2286 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2287 SSET (array
, idxval
, XINT (newelt
));
2290 /* We must relocate the string data while converting it to
2292 int idxval_byte
, prev_bytes
, new_bytes
;
2293 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2294 unsigned char *origstr
= SDATA (array
), *str
;
2298 nchars
= SCHARS (array
);
2299 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2300 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2302 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2303 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2304 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2306 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2307 allocate_string_data (XSTRING (array
), nchars
,
2308 nbytes
+ new_bytes
- prev_bytes
);
2309 bcopy (str
, SDATA (array
), idxval_byte
);
2310 p1
= SDATA (array
) + idxval_byte
;
2313 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2314 nbytes
- (idxval_byte
+ prev_bytes
));
2316 clear_string_char_byte_cache ();
2323 /* Arithmetic functions */
2325 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2328 arithcompare (num1
, num2
, comparison
)
2329 Lisp_Object num1
, num2
;
2330 enum comparison comparison
;
2332 double f1
= 0, f2
= 0;
2335 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2336 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2338 if (FLOATP (num1
) || FLOATP (num2
))
2341 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2342 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2348 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2353 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2358 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2363 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2368 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2373 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2382 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2383 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2385 register Lisp_Object num1
, num2
;
2387 return arithcompare (num1
, num2
, equal
);
2390 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2391 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2393 register Lisp_Object num1
, num2
;
2395 return arithcompare (num1
, num2
, less
);
2398 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2399 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2401 register Lisp_Object num1
, num2
;
2403 return arithcompare (num1
, num2
, grtr
);
2406 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2407 doc
: /* Return t if first arg is less than or equal to second arg.
2408 Both must be numbers or markers. */)
2410 register Lisp_Object num1
, num2
;
2412 return arithcompare (num1
, num2
, less_or_equal
);
2415 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2416 doc
: /* Return t if first arg is greater than or equal to second arg.
2417 Both must be numbers or markers. */)
2419 register Lisp_Object num1
, num2
;
2421 return arithcompare (num1
, num2
, grtr_or_equal
);
2424 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2425 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2427 register Lisp_Object num1
, num2
;
2429 return arithcompare (num1
, num2
, notequal
);
2432 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2433 doc
: /* Return t if NUMBER is zero. */)
2435 register Lisp_Object number
;
2437 CHECK_NUMBER_OR_FLOAT (number
);
2439 if (FLOATP (number
))
2441 if (XFLOAT_DATA (number
) == 0.0)
2451 /* Convert between long values and pairs of Lisp integers. */
2457 unsigned long top
= i
>> 16;
2458 unsigned int bot
= i
& 0xFFFF;
2460 return make_number (bot
);
2461 if (top
== (unsigned long)-1 >> 16)
2462 return Fcons (make_number (-1), make_number (bot
));
2463 return Fcons (make_number (top
), make_number (bot
));
2470 Lisp_Object top
, bot
;
2477 return ((XINT (top
) << 16) | XINT (bot
));
2480 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2481 doc
: /* Return the decimal representation of NUMBER as a string.
2482 Uses a minus sign if negative.
2483 NUMBER may be an integer or a floating point number. */)
2487 char buffer
[VALBITS
];
2489 CHECK_NUMBER_OR_FLOAT (number
);
2491 if (FLOATP (number
))
2493 char pigbuf
[350]; /* see comments in float_to_string */
2495 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2496 return build_string (pigbuf
);
2499 if (sizeof (int) == sizeof (EMACS_INT
))
2500 sprintf (buffer
, "%d", XINT (number
));
2501 else if (sizeof (long) == sizeof (EMACS_INT
))
2502 sprintf (buffer
, "%ld", (long) XINT (number
));
2505 return build_string (buffer
);
2509 digit_to_number (character
, base
)
2510 int character
, base
;
2514 if (character
>= '0' && character
<= '9')
2515 digit
= character
- '0';
2516 else if (character
>= 'a' && character
<= 'z')
2517 digit
= character
- 'a' + 10;
2518 else if (character
>= 'A' && character
<= 'Z')
2519 digit
= character
- 'A' + 10;
2529 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2530 doc
: /* Parse STRING as a decimal number and return the number.
2531 This parses both integers and floating point numbers.
2532 It ignores leading spaces and tabs.
2534 If BASE, interpret STRING as a number in that base. If BASE isn't
2535 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2536 If the base used is not 10, floating point is not recognized. */)
2538 register Lisp_Object string
, base
;
2540 register unsigned char *p
;
2545 CHECK_STRING (string
);
2551 CHECK_NUMBER (base
);
2553 if (b
< 2 || b
> 16)
2554 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2557 /* Skip any whitespace at the front of the number. Some versions of
2558 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2560 while (*p
== ' ' || *p
== '\t')
2571 if (isfloat_string (p
) && b
== 10)
2572 val
= make_float (sign
* atof (p
));
2579 int digit
= digit_to_number (*p
++, b
);
2585 val
= make_fixnum_or_float (sign
* v
);
2605 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2606 int, Lisp_Object
*));
2607 extern Lisp_Object
fmod_float ();
2610 arith_driver (code
, nargs
, args
)
2613 register Lisp_Object
*args
;
2615 register Lisp_Object val
;
2616 register int argnum
;
2617 register EMACS_INT accum
= 0;
2618 register EMACS_INT next
;
2620 switch (SWITCH_ENUM_CAST (code
))
2638 for (argnum
= 0; argnum
< nargs
; argnum
++)
2640 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2642 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2645 return float_arith_driver ((double) accum
, argnum
, code
,
2648 next
= XINT (args
[argnum
]);
2649 switch (SWITCH_ENUM_CAST (code
))
2655 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2666 Fsignal (Qarith_error
, Qnil
);
2680 if (!argnum
|| next
> accum
)
2684 if (!argnum
|| next
< accum
)
2690 XSETINT (val
, accum
);
2695 #define isnan(x) ((x) != (x))
2698 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2700 register int argnum
;
2703 register Lisp_Object
*args
;
2705 register Lisp_Object val
;
2708 for (; argnum
< nargs
; argnum
++)
2710 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2711 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2715 next
= XFLOAT_DATA (val
);
2719 args
[argnum
] = val
; /* runs into a compiler bug. */
2720 next
= XINT (args
[argnum
]);
2722 switch (SWITCH_ENUM_CAST (code
))
2728 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2738 if (! IEEE_FLOATING_POINT
&& next
== 0)
2739 Fsignal (Qarith_error
, Qnil
);
2746 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2748 if (!argnum
|| isnan (next
) || next
> accum
)
2752 if (!argnum
|| isnan (next
) || next
< accum
)
2758 return make_float (accum
);
2762 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2763 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2764 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2769 return arith_driver (Aadd
, nargs
, args
);
2772 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2773 doc
: /* Negate number or subtract numbers or markers and return the result.
2774 With one arg, negates it. With more than one arg,
2775 subtracts all but the first from the first.
2776 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2781 return arith_driver (Asub
, nargs
, args
);
2784 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2785 doc
: /* Return product of any number of arguments, which are numbers or markers.
2786 usage: (* &rest NUMBERS-OR-MARKERS) */)
2791 return arith_driver (Amult
, nargs
, args
);
2794 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2795 doc
: /* Return first argument divided by all the remaining arguments.
2796 The arguments must be numbers or markers.
2797 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2803 for (argnum
= 2; argnum
< nargs
; argnum
++)
2804 if (FLOATP (args
[argnum
]))
2805 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2806 return arith_driver (Adiv
, nargs
, args
);
2809 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2810 doc
: /* Return remainder of X divided by Y.
2811 Both must be integers or markers. */)
2813 register Lisp_Object x
, y
;
2817 CHECK_NUMBER_COERCE_MARKER (x
);
2818 CHECK_NUMBER_COERCE_MARKER (y
);
2820 if (XFASTINT (y
) == 0)
2821 Fsignal (Qarith_error
, Qnil
);
2823 XSETINT (val
, XINT (x
) % XINT (y
));
2837 /* If the magnitude of the result exceeds that of the divisor, or
2838 the sign of the result does not agree with that of the dividend,
2839 iterate with the reduced value. This does not yield a
2840 particularly accurate result, but at least it will be in the
2841 range promised by fmod. */
2843 r
-= f2
* floor (r
/ f2
);
2844 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2848 #endif /* ! HAVE_FMOD */
2850 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2851 doc
: /* Return X modulo Y.
2852 The result falls between zero (inclusive) and Y (exclusive).
2853 Both X and Y must be numbers or markers. */)
2855 register Lisp_Object x
, y
;
2860 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2861 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2863 if (FLOATP (x
) || FLOATP (y
))
2864 return fmod_float (x
, y
);
2870 Fsignal (Qarith_error
, Qnil
);
2874 /* If the "remainder" comes out with the wrong sign, fix it. */
2875 if (i2
< 0 ? i1
> 0 : i1
< 0)
2882 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2883 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2884 The value is always a number; markers are converted to numbers.
2885 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2890 return arith_driver (Amax
, nargs
, args
);
2893 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2894 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2895 The value is always a number; markers are converted to numbers.
2896 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2901 return arith_driver (Amin
, nargs
, args
);
2904 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2905 doc
: /* Return bitwise-and of all the arguments.
2906 Arguments may be integers, or markers converted to integers.
2907 usage: (logand &rest INTS-OR-MARKERS) */)
2912 return arith_driver (Alogand
, nargs
, args
);
2915 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2916 doc
: /* Return bitwise-or of all the arguments.
2917 Arguments may be integers, or markers converted to integers.
2918 usage: (logior &rest INTS-OR-MARKERS) */)
2923 return arith_driver (Alogior
, nargs
, args
);
2926 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2927 doc
: /* Return bitwise-exclusive-or of all the arguments.
2928 Arguments may be integers, or markers converted to integers.
2929 usage: (logxor &rest INTS-OR-MARKERS) */)
2934 return arith_driver (Alogxor
, nargs
, args
);
2937 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2938 doc
: /* Return VALUE with its bits shifted left by COUNT.
2939 If COUNT is negative, shifting is actually to the right.
2940 In this case, the sign bit is duplicated. */)
2942 register Lisp_Object value
, count
;
2944 register Lisp_Object val
;
2946 CHECK_NUMBER (value
);
2947 CHECK_NUMBER (count
);
2949 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2951 else if (XINT (count
) > 0)
2952 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2953 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2954 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2956 XSETINT (val
, XINT (value
) >> -XINT (count
));
2960 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2961 doc
: /* Return VALUE with its bits shifted left by COUNT.
2962 If COUNT is negative, shifting is actually to the right.
2963 In this case, zeros are shifted in on the left. */)
2965 register Lisp_Object value
, count
;
2967 register Lisp_Object val
;
2969 CHECK_NUMBER (value
);
2970 CHECK_NUMBER (count
);
2972 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2974 else if (XINT (count
) > 0)
2975 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2976 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2979 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2983 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2984 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2985 Markers are converted to integers. */)
2987 register Lisp_Object number
;
2989 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2991 if (FLOATP (number
))
2992 return (make_float (1.0 + XFLOAT_DATA (number
)));
2994 XSETINT (number
, XINT (number
) + 1);
2998 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2999 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3000 Markers are converted to integers. */)
3002 register Lisp_Object number
;
3004 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3006 if (FLOATP (number
))
3007 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3009 XSETINT (number
, XINT (number
) - 1);
3013 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3014 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3016 register Lisp_Object number
;
3018 CHECK_NUMBER (number
);
3019 XSETINT (number
, ~XINT (number
));
3023 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3024 doc
: /* Return the byteorder for the machine.
3025 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3026 lowercase l) for small endian machines. */)
3029 unsigned i
= 0x04030201;
3030 int order
= *(char *)&i
== 1 ? 108 : 66;
3032 return make_number (order
);
3040 Lisp_Object error_tail
, arith_tail
;
3042 Qquote
= intern ("quote");
3043 Qlambda
= intern ("lambda");
3044 Qsubr
= intern ("subr");
3045 Qerror_conditions
= intern ("error-conditions");
3046 Qerror_message
= intern ("error-message");
3047 Qtop_level
= intern ("top-level");
3049 Qerror
= intern ("error");
3050 Qquit
= intern ("quit");
3051 Qwrong_type_argument
= intern ("wrong-type-argument");
3052 Qargs_out_of_range
= intern ("args-out-of-range");
3053 Qvoid_function
= intern ("void-function");
3054 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3055 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3056 Qvoid_variable
= intern ("void-variable");
3057 Qsetting_constant
= intern ("setting-constant");
3058 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3060 Qinvalid_function
= intern ("invalid-function");
3061 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3062 Qno_catch
= intern ("no-catch");
3063 Qend_of_file
= intern ("end-of-file");
3064 Qarith_error
= intern ("arith-error");
3065 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3066 Qend_of_buffer
= intern ("end-of-buffer");
3067 Qbuffer_read_only
= intern ("buffer-read-only");
3068 Qtext_read_only
= intern ("text-read-only");
3069 Qmark_inactive
= intern ("mark-inactive");
3071 Qlistp
= intern ("listp");
3072 Qconsp
= intern ("consp");
3073 Qsymbolp
= intern ("symbolp");
3074 Qkeywordp
= intern ("keywordp");
3075 Qintegerp
= intern ("integerp");
3076 Qnatnump
= intern ("natnump");
3077 Qwholenump
= intern ("wholenump");
3078 Qstringp
= intern ("stringp");
3079 Qarrayp
= intern ("arrayp");
3080 Qsequencep
= intern ("sequencep");
3081 Qbufferp
= intern ("bufferp");
3082 Qvectorp
= intern ("vectorp");
3083 Qchar_or_string_p
= intern ("char-or-string-p");
3084 Qmarkerp
= intern ("markerp");
3085 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3086 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3087 Qboundp
= intern ("boundp");
3088 Qfboundp
= intern ("fboundp");
3090 Qfloatp
= intern ("floatp");
3091 Qnumberp
= intern ("numberp");
3092 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3094 Qchar_table_p
= intern ("char-table-p");
3095 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3097 Qsubrp
= intern ("subrp");
3098 Qunevalled
= intern ("unevalled");
3099 Qmany
= intern ("many");
3101 Qcdr
= intern ("cdr");
3103 /* Handle automatic advice activation */
3104 Qad_advice_info
= intern ("ad-advice-info");
3105 Qad_activate_internal
= intern ("ad-activate-internal");
3107 error_tail
= Fcons (Qerror
, Qnil
);
3109 /* ERROR is used as a signaler for random errors for which nothing else is right */
3111 Fput (Qerror
, Qerror_conditions
,
3113 Fput (Qerror
, Qerror_message
,
3114 build_string ("error"));
3116 Fput (Qquit
, Qerror_conditions
,
3117 Fcons (Qquit
, Qnil
));
3118 Fput (Qquit
, Qerror_message
,
3119 build_string ("Quit"));
3121 Fput (Qwrong_type_argument
, Qerror_conditions
,
3122 Fcons (Qwrong_type_argument
, error_tail
));
3123 Fput (Qwrong_type_argument
, Qerror_message
,
3124 build_string ("Wrong type argument"));
3126 Fput (Qargs_out_of_range
, Qerror_conditions
,
3127 Fcons (Qargs_out_of_range
, error_tail
));
3128 Fput (Qargs_out_of_range
, Qerror_message
,
3129 build_string ("Args out of range"));
3131 Fput (Qvoid_function
, Qerror_conditions
,
3132 Fcons (Qvoid_function
, error_tail
));
3133 Fput (Qvoid_function
, Qerror_message
,
3134 build_string ("Symbol's function definition is void"));
3136 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3137 Fcons (Qcyclic_function_indirection
, error_tail
));
3138 Fput (Qcyclic_function_indirection
, Qerror_message
,
3139 build_string ("Symbol's chain of function indirections contains a loop"));
3141 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3142 Fcons (Qcyclic_variable_indirection
, error_tail
));
3143 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3144 build_string ("Symbol's chain of variable indirections contains a loop"));
3146 Qcircular_list
= intern ("circular-list");
3147 staticpro (&Qcircular_list
);
3148 Fput (Qcircular_list
, Qerror_conditions
,
3149 Fcons (Qcircular_list
, error_tail
));
3150 Fput (Qcircular_list
, Qerror_message
,
3151 build_string ("List contains a loop"));
3153 Fput (Qvoid_variable
, Qerror_conditions
,
3154 Fcons (Qvoid_variable
, error_tail
));
3155 Fput (Qvoid_variable
, Qerror_message
,
3156 build_string ("Symbol's value as variable is void"));
3158 Fput (Qsetting_constant
, Qerror_conditions
,
3159 Fcons (Qsetting_constant
, error_tail
));
3160 Fput (Qsetting_constant
, Qerror_message
,
3161 build_string ("Attempt to set a constant symbol"));
3163 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3164 Fcons (Qinvalid_read_syntax
, error_tail
));
3165 Fput (Qinvalid_read_syntax
, Qerror_message
,
3166 build_string ("Invalid read syntax"));
3168 Fput (Qinvalid_function
, Qerror_conditions
,
3169 Fcons (Qinvalid_function
, error_tail
));
3170 Fput (Qinvalid_function
, Qerror_message
,
3171 build_string ("Invalid function"));
3173 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3174 Fcons (Qwrong_number_of_arguments
, error_tail
));
3175 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3176 build_string ("Wrong number of arguments"));
3178 Fput (Qno_catch
, Qerror_conditions
,
3179 Fcons (Qno_catch
, error_tail
));
3180 Fput (Qno_catch
, Qerror_message
,
3181 build_string ("No catch for tag"));
3183 Fput (Qend_of_file
, Qerror_conditions
,
3184 Fcons (Qend_of_file
, error_tail
));
3185 Fput (Qend_of_file
, Qerror_message
,
3186 build_string ("End of file during parsing"));
3188 arith_tail
= Fcons (Qarith_error
, error_tail
);
3189 Fput (Qarith_error
, Qerror_conditions
,
3191 Fput (Qarith_error
, Qerror_message
,
3192 build_string ("Arithmetic error"));
3194 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3195 Fcons (Qbeginning_of_buffer
, error_tail
));
3196 Fput (Qbeginning_of_buffer
, Qerror_message
,
3197 build_string ("Beginning of buffer"));
3199 Fput (Qend_of_buffer
, Qerror_conditions
,
3200 Fcons (Qend_of_buffer
, error_tail
));
3201 Fput (Qend_of_buffer
, Qerror_message
,
3202 build_string ("End of buffer"));
3204 Fput (Qbuffer_read_only
, Qerror_conditions
,
3205 Fcons (Qbuffer_read_only
, error_tail
));
3206 Fput (Qbuffer_read_only
, Qerror_message
,
3207 build_string ("Buffer is read-only"));
3209 Fput (Qtext_read_only
, Qerror_conditions
,
3210 Fcons (Qtext_read_only
, error_tail
));
3211 Fput (Qtext_read_only
, Qerror_message
,
3212 build_string ("Text is read-only"));
3214 Qrange_error
= intern ("range-error");
3215 Qdomain_error
= intern ("domain-error");
3216 Qsingularity_error
= intern ("singularity-error");
3217 Qoverflow_error
= intern ("overflow-error");
3218 Qunderflow_error
= intern ("underflow-error");
3220 Fput (Qdomain_error
, Qerror_conditions
,
3221 Fcons (Qdomain_error
, arith_tail
));
3222 Fput (Qdomain_error
, Qerror_message
,
3223 build_string ("Arithmetic domain error"));
3225 Fput (Qrange_error
, Qerror_conditions
,
3226 Fcons (Qrange_error
, arith_tail
));
3227 Fput (Qrange_error
, Qerror_message
,
3228 build_string ("Arithmetic range error"));
3230 Fput (Qsingularity_error
, Qerror_conditions
,
3231 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3232 Fput (Qsingularity_error
, Qerror_message
,
3233 build_string ("Arithmetic singularity error"));
3235 Fput (Qoverflow_error
, Qerror_conditions
,
3236 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3237 Fput (Qoverflow_error
, Qerror_message
,
3238 build_string ("Arithmetic overflow error"));
3240 Fput (Qunderflow_error
, Qerror_conditions
,
3241 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3242 Fput (Qunderflow_error
, Qerror_message
,
3243 build_string ("Arithmetic underflow error"));
3245 staticpro (&Qrange_error
);
3246 staticpro (&Qdomain_error
);
3247 staticpro (&Qsingularity_error
);
3248 staticpro (&Qoverflow_error
);
3249 staticpro (&Qunderflow_error
);
3253 staticpro (&Qquote
);
3254 staticpro (&Qlambda
);
3256 staticpro (&Qunbound
);
3257 staticpro (&Qerror_conditions
);
3258 staticpro (&Qerror_message
);
3259 staticpro (&Qtop_level
);
3261 staticpro (&Qerror
);
3263 staticpro (&Qwrong_type_argument
);
3264 staticpro (&Qargs_out_of_range
);
3265 staticpro (&Qvoid_function
);
3266 staticpro (&Qcyclic_function_indirection
);
3267 staticpro (&Qcyclic_variable_indirection
);
3268 staticpro (&Qvoid_variable
);
3269 staticpro (&Qsetting_constant
);
3270 staticpro (&Qinvalid_read_syntax
);
3271 staticpro (&Qwrong_number_of_arguments
);
3272 staticpro (&Qinvalid_function
);
3273 staticpro (&Qno_catch
);
3274 staticpro (&Qend_of_file
);
3275 staticpro (&Qarith_error
);
3276 staticpro (&Qbeginning_of_buffer
);
3277 staticpro (&Qend_of_buffer
);
3278 staticpro (&Qbuffer_read_only
);
3279 staticpro (&Qtext_read_only
);
3280 staticpro (&Qmark_inactive
);
3282 staticpro (&Qlistp
);
3283 staticpro (&Qconsp
);
3284 staticpro (&Qsymbolp
);
3285 staticpro (&Qkeywordp
);
3286 staticpro (&Qintegerp
);
3287 staticpro (&Qnatnump
);
3288 staticpro (&Qwholenump
);
3289 staticpro (&Qstringp
);
3290 staticpro (&Qarrayp
);
3291 staticpro (&Qsequencep
);
3292 staticpro (&Qbufferp
);
3293 staticpro (&Qvectorp
);
3294 staticpro (&Qchar_or_string_p
);
3295 staticpro (&Qmarkerp
);
3296 staticpro (&Qbuffer_or_string_p
);
3297 staticpro (&Qinteger_or_marker_p
);
3298 staticpro (&Qfloatp
);
3299 staticpro (&Qnumberp
);
3300 staticpro (&Qnumber_or_marker_p
);
3301 staticpro (&Qchar_table_p
);
3302 staticpro (&Qvector_or_char_table_p
);
3303 staticpro (&Qsubrp
);
3305 staticpro (&Qunevalled
);
3307 staticpro (&Qboundp
);
3308 staticpro (&Qfboundp
);
3310 staticpro (&Qad_advice_info
);
3311 staticpro (&Qad_activate_internal
);
3313 /* Types that type-of returns. */
3314 Qinteger
= intern ("integer");
3315 Qsymbol
= intern ("symbol");
3316 Qstring
= intern ("string");
3317 Qcons
= intern ("cons");
3318 Qmarker
= intern ("marker");
3319 Qoverlay
= intern ("overlay");
3320 Qfloat
= intern ("float");
3321 Qwindow_configuration
= intern ("window-configuration");
3322 Qprocess
= intern ("process");
3323 Qwindow
= intern ("window");
3324 /* Qsubr = intern ("subr"); */
3325 Qcompiled_function
= intern ("compiled-function");
3326 Qbuffer
= intern ("buffer");
3327 Qframe
= intern ("frame");
3328 Qvector
= intern ("vector");
3329 Qchar_table
= intern ("char-table");
3330 Qbool_vector
= intern ("bool-vector");
3331 Qhash_table
= intern ("hash-table");
3333 staticpro (&Qinteger
);
3334 staticpro (&Qsymbol
);
3335 staticpro (&Qstring
);
3337 staticpro (&Qmarker
);
3338 staticpro (&Qoverlay
);
3339 staticpro (&Qfloat
);
3340 staticpro (&Qwindow_configuration
);
3341 staticpro (&Qprocess
);
3342 staticpro (&Qwindow
);
3343 /* staticpro (&Qsubr); */
3344 staticpro (&Qcompiled_function
);
3345 staticpro (&Qbuffer
);
3346 staticpro (&Qframe
);
3347 staticpro (&Qvector
);
3348 staticpro (&Qchar_table
);
3349 staticpro (&Qbool_vector
);
3350 staticpro (&Qhash_table
);
3352 defsubr (&Sindirect_variable
);
3353 defsubr (&Sinteractive_form
);
3356 defsubr (&Stype_of
);
3361 defsubr (&Sintegerp
);
3362 defsubr (&Sinteger_or_marker_p
);
3363 defsubr (&Snumberp
);
3364 defsubr (&Snumber_or_marker_p
);
3366 defsubr (&Snatnump
);
3367 defsubr (&Ssymbolp
);
3368 defsubr (&Skeywordp
);
3369 defsubr (&Sstringp
);
3370 defsubr (&Smultibyte_string_p
);
3371 defsubr (&Svectorp
);
3372 defsubr (&Schar_table_p
);
3373 defsubr (&Svector_or_char_table_p
);
3374 defsubr (&Sbool_vector_p
);
3376 defsubr (&Ssequencep
);
3377 defsubr (&Sbufferp
);
3378 defsubr (&Smarkerp
);
3380 defsubr (&Sbyte_code_function_p
);
3381 defsubr (&Schar_or_string_p
);
3384 defsubr (&Scar_safe
);
3385 defsubr (&Scdr_safe
);
3388 defsubr (&Ssymbol_function
);
3389 defsubr (&Sindirect_function
);
3390 defsubr (&Ssymbol_plist
);
3391 defsubr (&Ssymbol_name
);
3392 defsubr (&Smakunbound
);
3393 defsubr (&Sfmakunbound
);
3395 defsubr (&Sfboundp
);
3397 defsubr (&Sdefalias
);
3398 defsubr (&Ssetplist
);
3399 defsubr (&Ssymbol_value
);
3401 defsubr (&Sdefault_boundp
);
3402 defsubr (&Sdefault_value
);
3403 defsubr (&Sset_default
);
3404 defsubr (&Ssetq_default
);
3405 defsubr (&Smake_variable_buffer_local
);
3406 defsubr (&Smake_local_variable
);
3407 defsubr (&Skill_local_variable
);
3408 defsubr (&Smake_variable_frame_local
);
3409 defsubr (&Slocal_variable_p
);
3410 defsubr (&Slocal_variable_if_set_p
);
3411 defsubr (&Svariable_binding_locus
);
3412 #if 0 /* XXX Remove this. --lorentey */
3413 defsubr (&Sterminal_local_value
);
3414 defsubr (&Sset_terminal_local_value
);
3418 defsubr (&Snumber_to_string
);
3419 defsubr (&Sstring_to_number
);
3420 defsubr (&Seqlsign
);
3443 defsubr (&Sbyteorder
);
3444 defsubr (&Ssubr_arity
);
3445 defsubr (&Ssubr_name
);
3447 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3449 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3450 doc
: /* The largest value that is representable in a Lisp integer. */);
3451 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3453 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3454 doc
: /* The smallest value that is representable in a Lisp integer. */);
3455 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3462 #if defined(USG) && !defined(POSIX_SIGNALS)
3463 /* USG systems forget handlers when they are used;
3464 must reestablish each time */
3465 signal (signo
, arith_error
);
3468 /* VMS systems are like USG. */
3469 signal (signo
, arith_error
);
3473 #else /* not BSD4_1 */
3474 sigsetmask (SIGEMPTYMASK
);
3475 #endif /* not BSD4_1 */
3477 SIGNAL_THREAD_CHECK (signo
);
3478 Fsignal (Qarith_error
, Qnil
);
3484 /* Don't do this if just dumping out.
3485 We don't want to call `signal' in this case
3486 so that we don't have trouble with dumping
3487 signal-delivering routines in an inconsistent state. */
3491 #endif /* CANNOT_DUMP */
3492 signal (SIGFPE
, arith_error
);
3495 signal (SIGEMT
, arith_error
);
3499 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3500 (do not change this comment) */