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"
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
);
135 error ("Attempt to modify read-only object");
139 args_out_of_range (a1
, a2
)
143 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
147 args_out_of_range_3 (a1
, a2
, a3
)
148 Lisp_Object a1
, a2
, a3
;
151 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
154 /* On some machines, XINT needs a temporary location.
155 Here it is, in case it is needed. */
157 int sign_extend_temp
;
159 /* On a few machines, XINT can only be done by calling this. */
162 sign_extend_lisp_int (num
)
165 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
166 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
168 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
171 /* Data type predicates */
173 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
174 doc
: /* Return t if the two args are the same Lisp object. */)
176 Lisp_Object obj1
, obj2
;
183 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
184 doc
: /* Return t if OBJECT is nil. */)
193 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
194 doc
: /* Return a symbol representing the type of OBJECT.
195 The symbol returned names the object's basic type;
196 for example, (type-of 1) returns `integer'. */)
200 switch (XGCTYPE (object
))
215 switch (XMISCTYPE (object
))
217 case Lisp_Misc_Marker
:
219 case Lisp_Misc_Overlay
:
221 case Lisp_Misc_Float
:
226 case Lisp_Vectorlike
:
227 if (GC_WINDOW_CONFIGURATIONP (object
))
228 return Qwindow_configuration
;
229 if (GC_PROCESSP (object
))
231 if (GC_WINDOWP (object
))
233 if (GC_SUBRP (object
))
235 if (GC_COMPILEDP (object
))
236 return Qcompiled_function
;
237 if (GC_BUFFERP (object
))
239 if (GC_CHAR_TABLE_P (object
))
241 if (GC_BOOL_VECTOR_P (object
))
243 if (GC_FRAMEP (object
))
245 if (GC_HASH_TABLE_P (object
))
257 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
258 doc
: /* Return t if OBJECT is a cons cell. */)
267 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
268 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
277 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
278 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
279 Otherwise, return nil. */)
283 if (CONSP (object
) || NILP (object
))
288 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
289 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
293 if (CONSP (object
) || NILP (object
))
298 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
299 doc
: /* Return t if OBJECT is a symbol. */)
303 if (SYMBOLP (object
))
308 /* Define this in C to avoid unnecessarily consing up the symbol
310 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
311 doc
: /* Return t if OBJECT is a keyword.
312 This means that it is a symbol with a print name beginning with `:'
313 interned in the initial obarray. */)
318 && SREF (SYMBOL_NAME (object
), 0) == ':'
319 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
324 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a vector. */)
329 if (VECTORP (object
))
334 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
335 doc
: /* Return t if OBJECT is a string. */)
339 if (STRINGP (object
))
344 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
346 doc
: /* Return t if OBJECT is a multibyte string. */)
350 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
355 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
356 doc
: /* Return t if OBJECT is a char-table. */)
360 if (CHAR_TABLE_P (object
))
365 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
366 Svector_or_char_table_p
, 1, 1, 0,
367 doc
: /* Return t if OBJECT is a char-table or vector. */)
371 if (VECTORP (object
) || CHAR_TABLE_P (object
))
376 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is a bool-vector. */)
381 if (BOOL_VECTOR_P (object
))
386 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is an array (string or vector). */)
391 if (VECTORP (object
) || STRINGP (object
)
392 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
397 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is a sequence (list or array). */)
400 register Lisp_Object object
;
402 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
403 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
408 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
409 doc
: /* Return t if OBJECT is an editor buffer. */)
413 if (BUFFERP (object
))
418 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
423 if (MARKERP (object
))
428 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
429 doc
: /* Return t if OBJECT is a built-in function. */)
438 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
440 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
444 if (COMPILEDP (object
))
449 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
450 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
452 register Lisp_Object object
;
454 if (INTEGERP (object
) || STRINGP (object
))
459 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
460 doc
: /* Return t if OBJECT is an integer. */)
464 if (INTEGERP (object
))
469 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
470 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
472 register Lisp_Object object
;
474 if (MARKERP (object
) || INTEGERP (object
))
479 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
480 doc
: /* Return t if OBJECT is a nonnegative integer. */)
484 if (NATNUMP (object
))
489 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
490 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
494 if (NUMBERP (object
))
500 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
501 Snumber_or_marker_p
, 1, 1, 0,
502 doc
: /* Return t if OBJECT is a number or a marker. */)
506 if (NUMBERP (object
) || MARKERP (object
))
511 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
512 doc
: /* Return t if OBJECT is a floating point number. */)
522 /* Extract and set components of lists */
524 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
525 doc
: /* Return the car of LIST. If arg is nil, return nil.
526 Error if arg is not nil and not a cons cell. See also `car-safe'.
528 See Info node `(elisp)Cons Cells' for a discussion of related basic
529 Lisp concepts such as car, cdr, cons cell and list. */)
531 register Lisp_Object list
;
537 else if (EQ (list
, Qnil
))
540 list
= wrong_type_argument (Qlistp
, list
);
544 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
545 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
550 return XCAR (object
);
555 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
556 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
557 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
559 See Info node `(elisp)Cons Cells' for a discussion of related basic
560 Lisp concepts such as cdr, car, cons cell and list. */)
562 register Lisp_Object list
;
568 else if (EQ (list
, Qnil
))
571 list
= wrong_type_argument (Qlistp
, list
);
575 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
576 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
581 return XCDR (object
);
586 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
587 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
589 register Lisp_Object cell
, newcar
;
592 cell
= wrong_type_argument (Qconsp
, cell
);
595 XSETCAR (cell
, newcar
);
599 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
600 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
602 register Lisp_Object cell
, newcdr
;
605 cell
= wrong_type_argument (Qconsp
, cell
);
608 XSETCDR (cell
, newcdr
);
612 /* Extract and set components of symbols */
614 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
615 doc
: /* Return t if SYMBOL's value is not void. */)
617 register Lisp_Object symbol
;
619 Lisp_Object valcontents
;
620 CHECK_SYMBOL (symbol
);
622 valcontents
= SYMBOL_VALUE (symbol
);
624 if (BUFFER_LOCAL_VALUEP (valcontents
)
625 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
626 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
628 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
631 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
632 doc
: /* Return t if SYMBOL's function definition is not void. */)
634 register Lisp_Object symbol
;
636 CHECK_SYMBOL (symbol
);
637 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
640 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
641 doc
: /* Make SYMBOL's value be void.
644 register Lisp_Object symbol
;
646 CHECK_SYMBOL (symbol
);
647 if (XSYMBOL (symbol
)->constant
)
648 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
649 Fset (symbol
, Qunbound
);
653 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
654 doc
: /* Make SYMBOL's function definition be void.
657 register Lisp_Object symbol
;
659 CHECK_SYMBOL (symbol
);
660 if (NILP (symbol
) || EQ (symbol
, Qt
))
661 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
662 XSYMBOL (symbol
)->function
= Qunbound
;
666 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
667 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
669 register Lisp_Object symbol
;
671 CHECK_SYMBOL (symbol
);
672 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
673 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
674 return XSYMBOL (symbol
)->function
;
677 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
678 doc
: /* Return SYMBOL's property list. */)
680 register Lisp_Object symbol
;
682 CHECK_SYMBOL (symbol
);
683 return XSYMBOL (symbol
)->plist
;
686 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
687 doc
: /* Return SYMBOL's name, a string. */)
689 register Lisp_Object symbol
;
691 register Lisp_Object name
;
693 CHECK_SYMBOL (symbol
);
694 name
= SYMBOL_NAME (symbol
);
698 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
699 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
701 register Lisp_Object symbol
, definition
;
703 CHECK_SYMBOL (symbol
);
704 if (NILP (symbol
) || EQ (symbol
, Qt
))
705 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
706 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
707 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
709 XSYMBOL (symbol
)->function
= definition
;
710 /* Handle automatic advice activation */
711 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
713 call2 (Qad_activate_internal
, symbol
, Qnil
);
714 definition
= XSYMBOL (symbol
)->function
;
719 extern Lisp_Object Qfunction_documentation
;
721 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
722 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
723 Associates the function with the current load file, if any.
724 The optional third argument DOCSTRING specifies the documentation string
725 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
726 determined by DEFINITION. */)
727 (symbol
, definition
, docstring
)
728 register Lisp_Object symbol
, definition
, docstring
;
730 CHECK_SYMBOL (symbol
);
731 if (CONSP (XSYMBOL (symbol
)->function
)
732 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
733 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
734 definition
= Ffset (symbol
, definition
);
735 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
736 if (!NILP (docstring
))
737 Fput (symbol
, Qfunction_documentation
, docstring
);
741 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
742 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
744 register Lisp_Object symbol
, newplist
;
746 CHECK_SYMBOL (symbol
);
747 XSYMBOL (symbol
)->plist
= newplist
;
751 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
752 doc
: /* Return minimum and maximum number of args allowed for SUBR.
753 SUBR must be a built-in function.
754 The returned value is a pair (MIN . MAX). MIN is the minimum number
755 of args. MAX is the maximum number or the symbol `many', for a
756 function with `&rest' args, or `unevalled' for a special form. */)
760 short minargs
, maxargs
;
762 wrong_type_argument (Qsubrp
, subr
);
763 minargs
= XSUBR (subr
)->min_args
;
764 maxargs
= XSUBR (subr
)->max_args
;
766 return Fcons (make_number (minargs
), Qmany
);
767 else if (maxargs
== UNEVALLED
)
768 return Fcons (make_number (minargs
), Qunevalled
);
770 return Fcons (make_number (minargs
), make_number (maxargs
));
773 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
774 doc
: /* Return name of subroutine SUBR.
775 SUBR must be a built-in function. */)
781 wrong_type_argument (Qsubrp
, subr
);
782 name
= XSUBR (subr
)->symbol_name
;
783 return make_string (name
, strlen (name
));
786 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
787 doc
: /* Return the interactive form of CMD or nil if none.
788 If CMD is not a command, the return value is nil.
789 Value, if non-nil, is a list \(interactive SPEC). */)
793 Lisp_Object fun
= indirect_function (cmd
);
797 if (XSUBR (fun
)->prompt
)
798 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
800 else if (COMPILEDP (fun
))
802 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
803 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
805 else if (CONSP (fun
))
807 Lisp_Object funcar
= XCAR (fun
);
808 if (EQ (funcar
, Qlambda
))
809 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
810 else if (EQ (funcar
, Qautoload
))
814 do_autoload (fun
, cmd
);
816 return Finteractive_form (cmd
);
823 /***********************************************************************
824 Getting and Setting Values of Symbols
825 ***********************************************************************/
827 /* Return the symbol holding SYMBOL's value. Signal
828 `cyclic-variable-indirection' if SYMBOL's chain of variable
829 indirections contains a loop. */
832 indirect_variable (symbol
)
835 Lisp_Object tortoise
, hare
;
837 hare
= tortoise
= symbol
;
839 while (XSYMBOL (hare
)->indirect_variable
)
841 hare
= XSYMBOL (hare
)->value
;
842 if (!XSYMBOL (hare
)->indirect_variable
)
845 hare
= XSYMBOL (hare
)->value
;
846 tortoise
= XSYMBOL (tortoise
)->value
;
848 if (EQ (hare
, tortoise
))
849 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
856 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
857 doc
: /* Return the variable at the end of OBJECT's variable chain.
858 If OBJECT is a symbol, follow all variable indirections and return the final
859 variable. If OBJECT is not a symbol, just return it.
860 Signal a cyclic-variable-indirection error if there is a loop in the
861 variable chain of symbols. */)
865 if (SYMBOLP (object
))
866 object
= indirect_variable (object
);
871 /* Given the raw contents of a symbol value cell,
872 return the Lisp value of the symbol.
873 This does not handle buffer-local variables; use
874 swap_in_symval_forwarding for that. */
877 do_symval_forwarding (valcontents
)
878 register Lisp_Object valcontents
;
880 register Lisp_Object val
;
882 if (MISCP (valcontents
))
883 switch (XMISCTYPE (valcontents
))
885 case Lisp_Misc_Intfwd
:
886 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
889 case Lisp_Misc_Boolfwd
:
890 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
892 case Lisp_Misc_Objfwd
:
893 return *XOBJFWD (valcontents
)->objvar
;
895 case Lisp_Misc_Buffer_Objfwd
:
896 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
897 return PER_BUFFER_VALUE (current_buffer
, offset
);
899 case Lisp_Misc_Kboard_Objfwd
:
900 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
901 /* We used to simply use current_kboard here, but from Lisp
902 code, it's value is often unexpected. It seems nicer to
903 allow constructions like this to work as intuitively expected:
905 (with-selected-frame frame
906 (define-key local-function-map "\eOP" [f1]))
908 On the other hand, this affects the semantics of
909 last-command and real-last-command, and people may rely on
910 that. I took a quick look at the Lisp codebase, and I
911 don't think anything will break. --lorentey */
912 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
917 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
918 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
919 buffer-independent contents of the value cell: forwarded just one
920 step past the buffer-localness.
922 BUF non-zero means set the value in buffer BUF instead of the
923 current buffer. This only plays a role for per-buffer variables. */
926 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
928 register Lisp_Object valcontents
, newval
;
931 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
934 switch (XMISCTYPE (valcontents
))
936 case Lisp_Misc_Intfwd
:
937 CHECK_NUMBER (newval
);
938 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
939 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
940 error ("Value out of range for variable `%s'",
941 SDATA (SYMBOL_NAME (symbol
)));
944 case Lisp_Misc_Boolfwd
:
945 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
948 case Lisp_Misc_Objfwd
:
949 *XOBJFWD (valcontents
)->objvar
= newval
;
951 /* If this variable is a default for something stored
952 in the buffer itself, such as default-fill-column,
953 find the buffers that don't have local values for it
955 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
956 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
958 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
959 - (char *) &buffer_defaults
);
960 int idx
= PER_BUFFER_IDX (offset
);
967 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
972 buf
= Fcdr (XCAR (tail
));
973 if (!BUFFERP (buf
)) continue;
976 if (! PER_BUFFER_VALUE_P (b
, idx
))
977 PER_BUFFER_VALUE (b
, offset
) = newval
;
982 case Lisp_Misc_Buffer_Objfwd
:
984 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
987 type
= PER_BUFFER_TYPE (offset
);
988 if (! NILP (type
) && ! NILP (newval
)
989 && XTYPE (newval
) != XINT (type
))
990 buffer_slot_type_mismatch (offset
);
993 buf
= current_buffer
;
994 PER_BUFFER_VALUE (buf
, offset
) = newval
;
998 case Lisp_Misc_Kboard_Objfwd
:
1000 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1001 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1002 *(Lisp_Object
*) p
= newval
;
1013 valcontents
= SYMBOL_VALUE (symbol
);
1014 if (BUFFER_LOCAL_VALUEP (valcontents
)
1015 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1016 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1018 SET_SYMBOL_VALUE (symbol
, newval
);
1022 /* Set up SYMBOL to refer to its global binding.
1023 This makes it safe to alter the status of other bindings. */
1026 swap_in_global_binding (symbol
)
1029 Lisp_Object valcontents
, cdr
;
1031 valcontents
= SYMBOL_VALUE (symbol
);
1032 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1033 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1035 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1037 /* Unload the previously loaded binding. */
1038 Fsetcdr (XCAR (cdr
),
1039 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1041 /* Select the global binding in the symbol. */
1043 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1045 /* Indicate that the global binding is set up now. */
1046 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1047 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1048 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1049 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1052 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1053 VALCONTENTS is the contents of its value cell,
1054 which points to a struct Lisp_Buffer_Local_Value.
1056 Return the value forwarded one step past the buffer-local stage.
1057 This could be another forwarding pointer. */
1060 swap_in_symval_forwarding (symbol
, valcontents
)
1061 Lisp_Object symbol
, valcontents
;
1063 register Lisp_Object tem1
;
1065 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1068 || current_buffer
!= XBUFFER (tem1
)
1069 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1070 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1072 if (XSYMBOL (symbol
)->indirect_variable
)
1073 symbol
= indirect_variable (symbol
);
1075 /* Unload the previously loaded binding. */
1076 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1078 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1079 /* Choose the new binding. */
1080 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1081 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1082 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1085 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1086 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1088 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1090 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1093 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1095 /* Load the new binding. */
1096 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1097 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1098 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1099 store_symval_forwarding (symbol
,
1100 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1103 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1106 /* Find the value of a symbol, returning Qunbound if it's not bound.
1107 This is helpful for code which just wants to get a variable's value
1108 if it has one, without signaling an error.
1109 Note that it must not be possible to quit
1110 within this function. Great care is required for this. */
1113 find_symbol_value (symbol
)
1116 register Lisp_Object valcontents
;
1117 register Lisp_Object val
;
1119 CHECK_SYMBOL (symbol
);
1120 valcontents
= SYMBOL_VALUE (symbol
);
1122 if (BUFFER_LOCAL_VALUEP (valcontents
)
1123 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1124 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1126 if (MISCP (valcontents
))
1128 switch (XMISCTYPE (valcontents
))
1130 case Lisp_Misc_Intfwd
:
1131 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1134 case Lisp_Misc_Boolfwd
:
1135 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1137 case Lisp_Misc_Objfwd
:
1138 return *XOBJFWD (valcontents
)->objvar
;
1140 case Lisp_Misc_Buffer_Objfwd
:
1141 return PER_BUFFER_VALUE (current_buffer
,
1142 XBUFFER_OBJFWD (valcontents
)->offset
);
1144 case Lisp_Misc_Kboard_Objfwd
:
1145 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1146 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1153 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1154 doc
: /* Return SYMBOL's value. Error if that is void. */)
1160 val
= find_symbol_value (symbol
);
1161 if (EQ (val
, Qunbound
))
1162 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1167 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1168 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1170 register Lisp_Object symbol
, newval
;
1172 return set_internal (symbol
, newval
, current_buffer
, 0);
1175 /* Return 1 if SYMBOL currently has a let-binding
1176 which was made in the buffer that is now current. */
1179 let_shadows_buffer_binding_p (symbol
)
1182 volatile struct specbinding
*p
;
1184 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1186 && CONSP (p
->symbol
))
1188 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1189 if ((EQ (symbol
, let_bound_symbol
)
1190 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1191 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1192 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1196 return p
>= specpdl
;
1199 /* Store the value NEWVAL into SYMBOL.
1200 If buffer-locality is an issue, BUF specifies which buffer to use.
1201 (0 stands for the current buffer.)
1203 If BINDFLAG is zero, then if this symbol is supposed to become
1204 local in every buffer where it is set, then we make it local.
1205 If BINDFLAG is nonzero, we don't do that. */
1208 set_internal (symbol
, newval
, buf
, bindflag
)
1209 register Lisp_Object symbol
, newval
;
1213 int voide
= EQ (newval
, Qunbound
);
1215 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1218 buf
= current_buffer
;
1220 /* If restoring in a dead buffer, do nothing. */
1221 if (NILP (buf
->name
))
1224 CHECK_SYMBOL (symbol
);
1225 if (SYMBOL_CONSTANT_P (symbol
)
1226 && (NILP (Fkeywordp (symbol
))
1227 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1228 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1230 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1232 if (BUFFER_OBJFWDP (valcontents
))
1234 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1235 int idx
= PER_BUFFER_IDX (offset
);
1238 && !let_shadows_buffer_binding_p (symbol
))
1239 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1241 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1242 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1244 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1245 if (XSYMBOL (symbol
)->indirect_variable
)
1246 symbol
= indirect_variable (symbol
);
1248 /* What binding is loaded right now? */
1249 current_alist_element
1250 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1252 /* If the current buffer is not the buffer whose binding is
1253 loaded, or if there may be frame-local bindings and the frame
1254 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1255 the default binding is loaded, the loaded binding may be the
1257 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1258 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1259 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1260 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1261 || (BUFFER_LOCAL_VALUEP (valcontents
)
1262 && EQ (XCAR (current_alist_element
),
1263 current_alist_element
)))
1265 /* The currently loaded binding is not necessarily valid.
1266 We need to unload it, and choose a new binding. */
1268 /* Write out `realvalue' to the old loaded binding. */
1269 Fsetcdr (current_alist_element
,
1270 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1272 /* Find the new binding. */
1273 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1274 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1275 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1279 /* This buffer still sees the default value. */
1281 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1282 or if this is `let' rather than `set',
1283 make CURRENT-ALIST-ELEMENT point to itself,
1284 indicating that we're seeing the default value.
1285 Likewise if the variable has been let-bound
1286 in the current buffer. */
1287 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1288 || let_shadows_buffer_binding_p (symbol
))
1290 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1292 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1293 tem1
= Fassq (symbol
,
1294 XFRAME (selected_frame
)->param_alist
);
1297 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1299 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1301 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1302 and we're not within a let that was made for this buffer,
1303 create a new buffer-local binding for the variable.
1304 That means, give this buffer a new assoc for a local value
1305 and load that binding. */
1308 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1309 buf
->local_var_alist
1310 = Fcons (tem1
, buf
->local_var_alist
);
1314 /* Record which binding is now loaded. */
1315 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1318 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1319 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1320 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1322 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1325 /* If storing void (making the symbol void), forward only through
1326 buffer-local indicator, not through Lisp_Objfwd, etc. */
1328 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1330 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1332 /* If we just set a variable whose current binding is frame-local,
1333 store the new value in the frame parameter too. */
1335 if (BUFFER_LOCAL_VALUEP (valcontents
)
1336 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1338 /* What binding is loaded right now? */
1339 current_alist_element
1340 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1342 /* If the current buffer is not the buffer whose binding is
1343 loaded, or if there may be frame-local bindings and the frame
1344 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1345 the default binding is loaded, the loaded binding may be the
1347 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1348 XSETCDR (current_alist_element
, newval
);
1354 /* Access or set a buffer-local symbol's default value. */
1356 /* Return the default value of SYMBOL, but don't check for voidness.
1357 Return Qunbound if it is void. */
1360 default_value (symbol
)
1363 register Lisp_Object valcontents
;
1365 CHECK_SYMBOL (symbol
);
1366 valcontents
= SYMBOL_VALUE (symbol
);
1368 /* For a built-in buffer-local variable, get the default value
1369 rather than letting do_symval_forwarding get the current value. */
1370 if (BUFFER_OBJFWDP (valcontents
))
1372 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1373 if (PER_BUFFER_IDX (offset
) != 0)
1374 return PER_BUFFER_DEFAULT (offset
);
1377 /* Handle user-created local variables. */
1378 if (BUFFER_LOCAL_VALUEP (valcontents
)
1379 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1381 /* If var is set up for a buffer that lacks a local value for it,
1382 the current value is nominally the default value.
1383 But the `realvalue' slot may be more up to date, since
1384 ordinary setq stores just that slot. So use that. */
1385 Lisp_Object current_alist_element
, alist_element_car
;
1386 current_alist_element
1387 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1388 alist_element_car
= XCAR (current_alist_element
);
1389 if (EQ (alist_element_car
, current_alist_element
))
1390 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1392 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1394 /* For other variables, get the current value. */
1395 return do_symval_forwarding (valcontents
);
1398 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1399 doc
: /* Return t if SYMBOL has a non-void default value.
1400 This is the value that is seen in buffers that do not have their own values
1401 for this variable. */)
1405 register Lisp_Object value
;
1407 value
= default_value (symbol
);
1408 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1411 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1412 doc
: /* Return SYMBOL's default value.
1413 This is the value that is seen in buffers that do not have their own values
1414 for this variable. The default value is meaningful for variables with
1415 local bindings in certain buffers. */)
1419 register Lisp_Object value
;
1421 value
= default_value (symbol
);
1422 if (EQ (value
, Qunbound
))
1423 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1427 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1428 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1429 The default value is seen in buffers that do not have their own values
1430 for this variable. */)
1432 Lisp_Object symbol
, value
;
1434 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1436 CHECK_SYMBOL (symbol
);
1437 valcontents
= SYMBOL_VALUE (symbol
);
1439 /* Handle variables like case-fold-search that have special slots
1440 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1442 if (BUFFER_OBJFWDP (valcontents
))
1444 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1445 int idx
= PER_BUFFER_IDX (offset
);
1447 PER_BUFFER_DEFAULT (offset
) = value
;
1449 /* If this variable is not always local in all buffers,
1450 set it in the buffers that don't nominally have a local value. */
1455 for (b
= all_buffers
; b
; b
= b
->next
)
1456 if (!PER_BUFFER_VALUE_P (b
, idx
))
1457 PER_BUFFER_VALUE (b
, offset
) = value
;
1462 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1463 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1464 return Fset (symbol
, value
);
1466 /* Store new value into the DEFAULT-VALUE slot. */
1467 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1469 /* If the default binding is now loaded, set the REALVALUE slot too. */
1470 current_alist_element
1471 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1472 alist_element_buffer
= Fcar (current_alist_element
);
1473 if (EQ (alist_element_buffer
, current_alist_element
))
1474 store_symval_forwarding (symbol
,
1475 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1481 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1482 doc
: /* Set the default value of variable VAR to VALUE.
1483 VAR, the variable name, is literal (not evaluated);
1484 VALUE is an expression: it is evaluated and its value returned.
1485 The default value of a variable is seen in buffers
1486 that do not have their own values for the variable.
1488 More generally, you can use multiple variables and values, as in
1489 (setq-default VAR VALUE VAR VALUE...)
1490 This sets each VAR's default value to the corresponding VALUE.
1491 The VALUE for the Nth VAR can refer to the new default values
1493 usage: (setq-default [VAR VALUE...]) */)
1497 register Lisp_Object args_left
;
1498 register Lisp_Object val
, symbol
;
1499 struct gcpro gcpro1
;
1509 val
= Feval (Fcar (Fcdr (args_left
)));
1510 symbol
= XCAR (args_left
);
1511 Fset_default (symbol
, val
);
1512 args_left
= Fcdr (XCDR (args_left
));
1514 while (!NILP (args_left
));
1520 /* Lisp functions for creating and removing buffer-local variables. */
1522 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1523 1, 1, "vMake Variable Buffer Local: ",
1524 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1525 At any time, the value for the current buffer is in effect,
1526 unless the variable has never been set in this buffer,
1527 in which case the default value is in effect.
1528 Note that binding the variable with `let', or setting it while
1529 a `let'-style binding made in this buffer is in effect,
1530 does not make the variable buffer-local. Return VARIABLE.
1532 In most cases it is better to use `make-local-variable',
1533 which makes a variable local in just one buffer.
1535 The function `default-value' gets the default value and `set-default' sets it. */)
1537 register Lisp_Object variable
;
1539 register Lisp_Object tem
, valcontents
, newval
;
1541 CHECK_SYMBOL (variable
);
1542 variable
= indirect_variable (variable
);
1544 valcontents
= SYMBOL_VALUE (variable
);
1545 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1546 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1548 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1550 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1552 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1555 if (EQ (valcontents
, Qunbound
))
1556 SET_SYMBOL_VALUE (variable
, Qnil
);
1557 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1559 newval
= allocate_misc ();
1560 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1561 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1562 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1563 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1564 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1565 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1566 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1567 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1568 SET_SYMBOL_VALUE (variable
, newval
);
1572 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1573 1, 1, "vMake Local Variable: ",
1574 doc
: /* Make VARIABLE have a separate value in the current buffer.
1575 Other buffers will continue to share a common default value.
1576 \(The buffer-local value of VARIABLE starts out as the same value
1577 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1580 If the variable is already arranged to become local when set,
1581 this function causes a local value to exist for this buffer,
1582 just as setting the variable would do.
1584 This function returns VARIABLE, and therefore
1585 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1588 See also `make-variable-buffer-local'.
1590 Do not use `make-local-variable' to make a hook variable buffer-local.
1591 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1593 register Lisp_Object variable
;
1595 register Lisp_Object tem
, valcontents
;
1597 CHECK_SYMBOL (variable
);
1598 variable
= indirect_variable (variable
);
1600 valcontents
= SYMBOL_VALUE (variable
);
1601 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1602 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1604 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1606 tem
= Fboundp (variable
);
1608 /* Make sure the symbol has a local value in this particular buffer,
1609 by setting it to the same value it already has. */
1610 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1613 /* Make sure symbol is set up to hold per-buffer values. */
1614 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1617 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1619 newval
= allocate_misc ();
1620 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1621 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1622 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1623 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1624 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1625 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1626 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1627 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1628 SET_SYMBOL_VALUE (variable
, newval
);;
1630 /* Make sure this buffer has its own value of symbol. */
1631 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1634 /* Swap out any local binding for some other buffer, and make
1635 sure the current value is permanently recorded, if it's the
1637 find_symbol_value (variable
);
1639 current_buffer
->local_var_alist
1640 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1641 current_buffer
->local_var_alist
);
1643 /* Make sure symbol does not think it is set up for this buffer;
1644 force it to look once again for this buffer's value. */
1646 Lisp_Object
*pvalbuf
;
1648 valcontents
= SYMBOL_VALUE (variable
);
1650 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1651 if (current_buffer
== XBUFFER (*pvalbuf
))
1653 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1657 /* If the symbol forwards into a C variable, then load the binding
1658 for this buffer now. If C code modifies the variable before we
1659 load the binding in, then that new value will clobber the default
1660 binding the next time we unload it. */
1661 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1662 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1663 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1668 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1669 1, 1, "vKill Local Variable: ",
1670 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1671 From now on the default value will apply in this buffer. Return VARIABLE. */)
1673 register Lisp_Object variable
;
1675 register Lisp_Object tem
, valcontents
;
1677 CHECK_SYMBOL (variable
);
1678 variable
= indirect_variable (variable
);
1680 valcontents
= SYMBOL_VALUE (variable
);
1682 if (BUFFER_OBJFWDP (valcontents
))
1684 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1685 int idx
= PER_BUFFER_IDX (offset
);
1689 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1690 PER_BUFFER_VALUE (current_buffer
, offset
)
1691 = PER_BUFFER_DEFAULT (offset
);
1696 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1697 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1700 /* Get rid of this buffer's alist element, if any. */
1702 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1704 current_buffer
->local_var_alist
1705 = Fdelq (tem
, current_buffer
->local_var_alist
);
1707 /* If the symbol is set up with the current buffer's binding
1708 loaded, recompute its value. We have to do it now, or else
1709 forwarded objects won't work right. */
1711 Lisp_Object
*pvalbuf
, buf
;
1712 valcontents
= SYMBOL_VALUE (variable
);
1713 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1714 XSETBUFFER (buf
, current_buffer
);
1715 if (EQ (buf
, *pvalbuf
))
1718 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1719 find_symbol_value (variable
);
1726 /* Lisp functions for creating and removing buffer-local variables. */
1728 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1729 1, 1, "vMake Variable Frame Local: ",
1730 doc
: /* Enable VARIABLE to have frame-local bindings.
1731 This does not create any frame-local bindings for VARIABLE,
1732 it just makes them possible.
1734 A frame-local binding is actually a frame parameter value.
1735 If a frame F has a value for the frame parameter named VARIABLE,
1736 that also acts as a frame-local binding for VARIABLE in F--
1737 provided this function has been called to enable VARIABLE
1738 to have frame-local bindings at all.
1740 The only way to create a frame-local binding for VARIABLE in a frame
1741 is to set the VARIABLE frame parameter of that frame. See
1742 `modify-frame-parameters' for how to set frame parameters.
1744 Buffer-local bindings take precedence over frame-local bindings. */)
1746 register Lisp_Object variable
;
1748 register Lisp_Object tem
, valcontents
, newval
;
1750 CHECK_SYMBOL (variable
);
1751 variable
= indirect_variable (variable
);
1753 valcontents
= SYMBOL_VALUE (variable
);
1754 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1755 || BUFFER_OBJFWDP (valcontents
))
1756 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1758 if (BUFFER_LOCAL_VALUEP (valcontents
)
1759 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1761 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1765 if (EQ (valcontents
, Qunbound
))
1766 SET_SYMBOL_VALUE (variable
, Qnil
);
1767 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1769 newval
= allocate_misc ();
1770 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1771 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1772 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1773 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1774 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1775 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1776 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1777 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1778 SET_SYMBOL_VALUE (variable
, newval
);
1782 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1784 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1785 BUFFER defaults to the current buffer. */)
1787 register Lisp_Object variable
, buffer
;
1789 Lisp_Object valcontents
;
1790 register struct buffer
*buf
;
1793 buf
= current_buffer
;
1796 CHECK_BUFFER (buffer
);
1797 buf
= XBUFFER (buffer
);
1800 CHECK_SYMBOL (variable
);
1801 variable
= indirect_variable (variable
);
1803 valcontents
= SYMBOL_VALUE (variable
);
1804 if (BUFFER_LOCAL_VALUEP (valcontents
)
1805 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1807 Lisp_Object tail
, elt
;
1809 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1812 if (EQ (variable
, XCAR (elt
)))
1816 if (BUFFER_OBJFWDP (valcontents
))
1818 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1819 int idx
= PER_BUFFER_IDX (offset
);
1820 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1826 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1828 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1829 More precisely, this means that setting the variable \(with `set' or`setq'),
1830 while it does not have a `let'-style binding that was made in BUFFER,
1831 will produce a buffer local binding. See Info node
1832 `(elisp)Creating Buffer-Local'.
1833 BUFFER defaults to the current buffer. */)
1835 register Lisp_Object variable
, buffer
;
1837 Lisp_Object valcontents
;
1838 register struct buffer
*buf
;
1841 buf
= current_buffer
;
1844 CHECK_BUFFER (buffer
);
1845 buf
= XBUFFER (buffer
);
1848 CHECK_SYMBOL (variable
);
1849 variable
= indirect_variable (variable
);
1851 valcontents
= SYMBOL_VALUE (variable
);
1853 /* This means that make-variable-buffer-local was done. */
1854 if (BUFFER_LOCAL_VALUEP (valcontents
))
1856 /* All these slots become local if they are set. */
1857 if (BUFFER_OBJFWDP (valcontents
))
1859 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1861 Lisp_Object tail
, elt
;
1862 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1865 if (EQ (variable
, XCAR (elt
)))
1872 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1874 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1875 If the current binding is buffer-local, the value is the current buffer.
1876 If the current binding is frame-local, the value is the selected frame.
1877 If the current binding is global (the default), the value is nil. */)
1879 register Lisp_Object variable
;
1881 Lisp_Object valcontents
;
1883 CHECK_SYMBOL (variable
);
1884 variable
= indirect_variable (variable
);
1886 /* Make sure the current binding is actually swapped in. */
1887 find_symbol_value (variable
);
1889 valcontents
= XSYMBOL (variable
)->value
;
1891 if (BUFFER_LOCAL_VALUEP (valcontents
)
1892 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1893 || BUFFER_OBJFWDP (valcontents
))
1895 /* For a local variable, record both the symbol and which
1896 buffer's or frame's value we are saving. */
1897 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1898 return Fcurrent_buffer ();
1899 else if (!BUFFER_OBJFWDP (valcontents
)
1900 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1901 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1907 /* This code is disabled now that we use the selected frame to return
1908 keyboard-local-values. */
1910 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1912 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1913 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1914 If SYMBOL is not a terminal-local variable, then return its normal
1915 value, like `symbol-value'.
1917 TERMINAL may be a terminal id, a frame, or nil (meaning the
1918 selected frame's terminal device). */)
1921 Lisp_Object terminal
;
1924 struct terminal
*t
= get_terminal (terminal
, 1);
1925 push_kboard (t
->kboard
);
1926 result
= Fsymbol_value (symbol
);
1931 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1932 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1933 If VARIABLE is not a terminal-local variable, then set its normal
1934 binding, like `set'.
1936 TERMINAL may be a terminal id, a frame, or nil (meaning the
1937 selected frame's terminal device). */)
1938 (symbol
, terminal
, value
)
1940 Lisp_Object terminal
;
1944 struct terminal
*t
= get_terminal (terminal
, 1);
1945 push_kboard (d
->kboard
);
1946 result
= Fset (symbol
, value
);
1952 /* Find the function at the end of a chain of symbol function indirections. */
1954 /* If OBJECT is a symbol, find the end of its function chain and
1955 return the value found there. If OBJECT is not a symbol, just
1956 return it. If there is a cycle in the function chain, signal a
1957 cyclic-function-indirection error.
1959 This is like Findirect_function, except that it doesn't signal an
1960 error if the chain ends up unbound. */
1962 indirect_function (object
)
1963 register Lisp_Object object
;
1965 Lisp_Object tortoise
, hare
;
1967 hare
= tortoise
= object
;
1971 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1973 hare
= XSYMBOL (hare
)->function
;
1974 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1976 hare
= XSYMBOL (hare
)->function
;
1978 tortoise
= XSYMBOL (tortoise
)->function
;
1980 if (EQ (hare
, tortoise
))
1981 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1987 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1988 doc
: /* Return the function at the end of OBJECT's function chain.
1989 If OBJECT is a symbol, follow all function indirections and return the final
1991 If OBJECT is not a symbol, just return it.
1992 Signal a void-function error if the final symbol is unbound.
1993 Signal a cyclic-function-indirection error if there is a loop in the
1994 function chain of symbols. */)
1996 register Lisp_Object object
;
2000 result
= indirect_function (object
);
2002 if (EQ (result
, Qunbound
))
2003 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
2007 /* Extract and set vector and string elements */
2009 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2010 doc
: /* Return the element of ARRAY at index IDX.
2011 ARRAY may be a vector, a string, a char-table, a bool-vector,
2012 or a byte-code object. IDX starts at 0. */)
2014 register Lisp_Object array
;
2017 register int idxval
;
2020 idxval
= XINT (idx
);
2021 if (STRINGP (array
))
2025 if (idxval
< 0 || idxval
>= SCHARS (array
))
2026 args_out_of_range (array
, idx
);
2027 if (! STRING_MULTIBYTE (array
))
2028 return make_number ((unsigned char) SREF (array
, idxval
));
2029 idxval_byte
= string_char_to_byte (array
, idxval
);
2031 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2032 SBYTES (array
) - idxval_byte
);
2033 return make_number (c
);
2035 else if (BOOL_VECTOR_P (array
))
2039 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2040 args_out_of_range (array
, idx
);
2042 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2043 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2045 else if (CHAR_TABLE_P (array
))
2052 args_out_of_range (array
, idx
);
2053 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2055 if (! SINGLE_BYTE_CHAR_P (idxval
))
2056 args_out_of_range (array
, idx
);
2057 /* For ASCII and 8-bit European characters, the element is
2058 stored in the top table. */
2059 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2063 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2064 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2065 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2066 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2069 val
= XCHAR_TABLE (array
)->defalt
;
2070 while (NILP (val
)) /* Follow parents until we find some value. */
2072 array
= XCHAR_TABLE (array
)->parent
;
2075 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2077 val
= XCHAR_TABLE (array
)->defalt
;
2084 Lisp_Object sub_table
;
2085 Lisp_Object current_default
;
2087 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2088 if (code
[1] < 32) code
[1] = -1;
2089 else if (code
[2] < 32) code
[2] = -1;
2091 /* Here, the possible range of CODE[0] (== charset ID) is
2092 128..MAX_CHARSET. Since the top level char table contains
2093 data for multibyte characters after 256th element, we must
2094 increment CODE[0] by 128 to get a correct index. */
2096 code
[3] = -1; /* anchor */
2098 try_parent_char_table
:
2099 current_default
= XCHAR_TABLE (array
)->defalt
;
2101 for (i
= 0; code
[i
] >= 0; i
++)
2103 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2104 if (SUB_CHAR_TABLE_P (val
))
2107 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2108 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2113 val
= current_default
;
2116 array
= XCHAR_TABLE (array
)->parent
;
2118 goto try_parent_char_table
;
2123 /* Reaching here means IDXVAL is a generic character in
2124 which each character or a group has independent value.
2125 Essentially it's nonsense to get a value for such a
2126 generic character, but for backward compatibility, we try
2127 the default value and parent. */
2128 val
= current_default
;
2131 array
= XCHAR_TABLE (array
)->parent
;
2133 goto try_parent_char_table
;
2141 if (VECTORP (array
))
2142 size
= XVECTOR (array
)->size
;
2143 else if (COMPILEDP (array
))
2144 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2146 wrong_type_argument (Qarrayp
, array
);
2148 if (idxval
< 0 || idxval
>= size
)
2149 args_out_of_range (array
, idx
);
2150 return XVECTOR (array
)->contents
[idxval
];
2154 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2155 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2156 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2157 bool-vector. IDX starts at 0. */)
2158 (array
, idx
, newelt
)
2159 register Lisp_Object array
;
2160 Lisp_Object idx
, newelt
;
2162 register int idxval
;
2165 idxval
= XINT (idx
);
2166 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2167 && ! CHAR_TABLE_P (array
))
2168 array
= wrong_type_argument (Qarrayp
, array
);
2169 CHECK_IMPURE (array
);
2171 if (VECTORP (array
))
2173 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2174 args_out_of_range (array
, idx
);
2175 XVECTOR (array
)->contents
[idxval
] = newelt
;
2177 else if (BOOL_VECTOR_P (array
))
2181 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2182 args_out_of_range (array
, idx
);
2184 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2186 if (! NILP (newelt
))
2187 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2189 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2190 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2192 else if (CHAR_TABLE_P (array
))
2195 args_out_of_range (array
, idx
);
2196 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2198 if (! SINGLE_BYTE_CHAR_P (idxval
))
2199 args_out_of_range (array
, idx
);
2200 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2207 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2208 if (code
[1] < 32) code
[1] = -1;
2209 else if (code
[2] < 32) code
[2] = -1;
2211 /* See the comment of the corresponding part in Faref. */
2213 code
[3] = -1; /* anchor */
2214 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2216 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2217 if (SUB_CHAR_TABLE_P (val
))
2223 /* VAL is a leaf. Create a sub char table with the
2224 initial value VAL and look into it. */
2226 temp
= make_sub_char_table (val
);
2227 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2231 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2234 else if (STRING_MULTIBYTE (array
))
2236 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2237 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2239 if (idxval
< 0 || idxval
>= SCHARS (array
))
2240 args_out_of_range (array
, idx
);
2241 CHECK_NUMBER (newelt
);
2243 nbytes
= SBYTES (array
);
2245 idxval_byte
= string_char_to_byte (array
, idxval
);
2246 p1
= SDATA (array
) + idxval_byte
;
2247 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2248 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2249 if (prev_bytes
!= new_bytes
)
2251 /* We must relocate the string data. */
2252 int nchars
= SCHARS (array
);
2256 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2257 bcopy (SDATA (array
), str
, nbytes
);
2258 allocate_string_data (XSTRING (array
), nchars
,
2259 nbytes
+ new_bytes
- prev_bytes
);
2260 bcopy (str
, SDATA (array
), idxval_byte
);
2261 p1
= SDATA (array
) + idxval_byte
;
2262 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2263 nbytes
- (idxval_byte
+ prev_bytes
));
2265 clear_string_char_byte_cache ();
2272 if (idxval
< 0 || idxval
>= SCHARS (array
))
2273 args_out_of_range (array
, idx
);
2274 CHECK_NUMBER (newelt
);
2276 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2277 SSET (array
, idxval
, XINT (newelt
));
2280 /* We must relocate the string data while converting it to
2282 int idxval_byte
, prev_bytes
, new_bytes
;
2283 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2284 unsigned char *origstr
= SDATA (array
), *str
;
2288 nchars
= SCHARS (array
);
2289 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2290 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2292 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2293 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2294 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2296 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2297 allocate_string_data (XSTRING (array
), nchars
,
2298 nbytes
+ new_bytes
- prev_bytes
);
2299 bcopy (str
, SDATA (array
), idxval_byte
);
2300 p1
= SDATA (array
) + idxval_byte
;
2303 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2304 nbytes
- (idxval_byte
+ prev_bytes
));
2306 clear_string_char_byte_cache ();
2313 /* Arithmetic functions */
2315 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2318 arithcompare (num1
, num2
, comparison
)
2319 Lisp_Object num1
, num2
;
2320 enum comparison comparison
;
2322 double f1
= 0, f2
= 0;
2325 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2326 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2328 if (FLOATP (num1
) || FLOATP (num2
))
2331 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2332 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2338 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2343 if (floatp
? f1
!= f2
: XINT (num1
) != 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
))
2372 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2373 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2375 register Lisp_Object num1
, num2
;
2377 return arithcompare (num1
, num2
, equal
);
2380 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2381 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2383 register Lisp_Object num1
, num2
;
2385 return arithcompare (num1
, num2
, less
);
2388 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2389 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2391 register Lisp_Object num1
, num2
;
2393 return arithcompare (num1
, num2
, grtr
);
2396 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2397 doc
: /* Return t if first arg is less than or equal to second arg.
2398 Both must be numbers or markers. */)
2400 register Lisp_Object num1
, num2
;
2402 return arithcompare (num1
, num2
, less_or_equal
);
2405 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2406 doc
: /* Return t if first arg is greater than or equal to second arg.
2407 Both must be numbers or markers. */)
2409 register Lisp_Object num1
, num2
;
2411 return arithcompare (num1
, num2
, grtr_or_equal
);
2414 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2415 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2417 register Lisp_Object num1
, num2
;
2419 return arithcompare (num1
, num2
, notequal
);
2422 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2423 doc
: /* Return t if NUMBER is zero. */)
2425 register Lisp_Object number
;
2427 CHECK_NUMBER_OR_FLOAT (number
);
2429 if (FLOATP (number
))
2431 if (XFLOAT_DATA (number
) == 0.0)
2441 /* Convert between long values and pairs of Lisp integers. */
2447 unsigned long top
= i
>> 16;
2448 unsigned int bot
= i
& 0xFFFF;
2450 return make_number (bot
);
2451 if (top
== (unsigned long)-1 >> 16)
2452 return Fcons (make_number (-1), make_number (bot
));
2453 return Fcons (make_number (top
), make_number (bot
));
2460 Lisp_Object top
, bot
;
2467 return ((XINT (top
) << 16) | XINT (bot
));
2470 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2471 doc
: /* Return the decimal representation of NUMBER as a string.
2472 Uses a minus sign if negative.
2473 NUMBER may be an integer or a floating point number. */)
2477 char buffer
[VALBITS
];
2479 CHECK_NUMBER_OR_FLOAT (number
);
2481 if (FLOATP (number
))
2483 char pigbuf
[350]; /* see comments in float_to_string */
2485 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2486 return build_string (pigbuf
);
2489 if (sizeof (int) == sizeof (EMACS_INT
))
2490 sprintf (buffer
, "%d", XINT (number
));
2491 else if (sizeof (long) == sizeof (EMACS_INT
))
2492 sprintf (buffer
, "%ld", (long) XINT (number
));
2495 return build_string (buffer
);
2499 digit_to_number (character
, base
)
2500 int character
, base
;
2504 if (character
>= '0' && character
<= '9')
2505 digit
= character
- '0';
2506 else if (character
>= 'a' && character
<= 'z')
2507 digit
= character
- 'a' + 10;
2508 else if (character
>= 'A' && character
<= 'Z')
2509 digit
= character
- 'A' + 10;
2519 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2520 doc
: /* Parse STRING as a decimal number and return the number.
2521 This parses both integers and floating point numbers.
2522 It ignores leading spaces and tabs.
2524 If BASE, interpret STRING as a number in that base. If BASE isn't
2525 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2526 If the base used is not 10, floating point is not recognized. */)
2528 register Lisp_Object string
, base
;
2530 register unsigned char *p
;
2535 CHECK_STRING (string
);
2541 CHECK_NUMBER (base
);
2543 if (b
< 2 || b
> 16)
2544 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2547 /* Skip any whitespace at the front of the number. Some versions of
2548 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2550 while (*p
== ' ' || *p
== '\t')
2561 if (isfloat_string (p
) && b
== 10)
2562 val
= make_float (sign
* atof (p
));
2569 int digit
= digit_to_number (*p
++, b
);
2575 val
= make_fixnum_or_float (sign
* v
);
2595 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2596 int, Lisp_Object
*));
2597 extern Lisp_Object
fmod_float ();
2600 arith_driver (code
, nargs
, args
)
2603 register Lisp_Object
*args
;
2605 register Lisp_Object val
;
2606 register int argnum
;
2607 register EMACS_INT accum
= 0;
2608 register EMACS_INT next
;
2610 switch (SWITCH_ENUM_CAST (code
))
2628 for (argnum
= 0; argnum
< nargs
; argnum
++)
2630 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2632 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2635 return float_arith_driver ((double) accum
, argnum
, code
,
2638 next
= XINT (args
[argnum
]);
2639 switch (SWITCH_ENUM_CAST (code
))
2645 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2656 Fsignal (Qarith_error
, Qnil
);
2670 if (!argnum
|| next
> accum
)
2674 if (!argnum
|| next
< accum
)
2680 XSETINT (val
, accum
);
2685 #define isnan(x) ((x) != (x))
2688 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2690 register int argnum
;
2693 register Lisp_Object
*args
;
2695 register Lisp_Object val
;
2698 for (; argnum
< nargs
; argnum
++)
2700 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2701 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2705 next
= XFLOAT_DATA (val
);
2709 args
[argnum
] = val
; /* runs into a compiler bug. */
2710 next
= XINT (args
[argnum
]);
2712 switch (SWITCH_ENUM_CAST (code
))
2718 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2728 if (! IEEE_FLOATING_POINT
&& next
== 0)
2729 Fsignal (Qarith_error
, Qnil
);
2736 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2738 if (!argnum
|| isnan (next
) || next
> accum
)
2742 if (!argnum
|| isnan (next
) || next
< accum
)
2748 return make_float (accum
);
2752 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2753 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2754 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2759 return arith_driver (Aadd
, nargs
, args
);
2762 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2763 doc
: /* Negate number or subtract numbers or markers and return the result.
2764 With one arg, negates it. With more than one arg,
2765 subtracts all but the first from the first.
2766 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2771 return arith_driver (Asub
, nargs
, args
);
2774 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2775 doc
: /* Return product of any number of arguments, which are numbers or markers.
2776 usage: (* &rest NUMBERS-OR-MARKERS) */)
2781 return arith_driver (Amult
, nargs
, args
);
2784 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2785 doc
: /* Return first argument divided by all the remaining arguments.
2786 The arguments must be numbers or markers.
2787 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2793 for (argnum
= 2; argnum
< nargs
; argnum
++)
2794 if (FLOATP (args
[argnum
]))
2795 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2796 return arith_driver (Adiv
, nargs
, args
);
2799 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2800 doc
: /* Return remainder of X divided by Y.
2801 Both must be integers or markers. */)
2803 register Lisp_Object x
, y
;
2807 CHECK_NUMBER_COERCE_MARKER (x
);
2808 CHECK_NUMBER_COERCE_MARKER (y
);
2810 if (XFASTINT (y
) == 0)
2811 Fsignal (Qarith_error
, Qnil
);
2813 XSETINT (val
, XINT (x
) % XINT (y
));
2827 /* If the magnitude of the result exceeds that of the divisor, or
2828 the sign of the result does not agree with that of the dividend,
2829 iterate with the reduced value. This does not yield a
2830 particularly accurate result, but at least it will be in the
2831 range promised by fmod. */
2833 r
-= f2
* floor (r
/ f2
);
2834 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2838 #endif /* ! HAVE_FMOD */
2840 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2841 doc
: /* Return X modulo Y.
2842 The result falls between zero (inclusive) and Y (exclusive).
2843 Both X and Y must be numbers or markers. */)
2845 register Lisp_Object x
, y
;
2850 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2851 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2853 if (FLOATP (x
) || FLOATP (y
))
2854 return fmod_float (x
, y
);
2860 Fsignal (Qarith_error
, Qnil
);
2864 /* If the "remainder" comes out with the wrong sign, fix it. */
2865 if (i2
< 0 ? i1
> 0 : i1
< 0)
2872 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2873 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2874 The value is always a number; markers are converted to numbers.
2875 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2880 return arith_driver (Amax
, nargs
, args
);
2883 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2884 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2885 The value is always a number; markers are converted to numbers.
2886 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2891 return arith_driver (Amin
, nargs
, args
);
2894 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2895 doc
: /* Return bitwise-and of all the arguments.
2896 Arguments may be integers, or markers converted to integers.
2897 usage: (logand &rest INTS-OR-MARKERS) */)
2902 return arith_driver (Alogand
, nargs
, args
);
2905 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2906 doc
: /* Return bitwise-or of all the arguments.
2907 Arguments may be integers, or markers converted to integers.
2908 usage: (logior &rest INTS-OR-MARKERS) */)
2913 return arith_driver (Alogior
, nargs
, args
);
2916 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2917 doc
: /* Return bitwise-exclusive-or of all the arguments.
2918 Arguments may be integers, or markers converted to integers.
2919 usage: (logxor &rest INTS-OR-MARKERS) */)
2924 return arith_driver (Alogxor
, nargs
, args
);
2927 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2928 doc
: /* Return VALUE with its bits shifted left by COUNT.
2929 If COUNT is negative, shifting is actually to the right.
2930 In this case, the sign bit is duplicated. */)
2932 register Lisp_Object value
, count
;
2934 register Lisp_Object val
;
2936 CHECK_NUMBER (value
);
2937 CHECK_NUMBER (count
);
2939 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2941 else if (XINT (count
) > 0)
2942 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2943 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2944 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2946 XSETINT (val
, XINT (value
) >> -XINT (count
));
2950 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2951 doc
: /* Return VALUE with its bits shifted left by COUNT.
2952 If COUNT is negative, shifting is actually to the right.
2953 In this case, zeros are shifted in on the left. */)
2955 register Lisp_Object value
, count
;
2957 register Lisp_Object val
;
2959 CHECK_NUMBER (value
);
2960 CHECK_NUMBER (count
);
2962 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2964 else if (XINT (count
) > 0)
2965 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2966 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2969 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2973 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2974 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2975 Markers are converted to integers. */)
2977 register Lisp_Object number
;
2979 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2981 if (FLOATP (number
))
2982 return (make_float (1.0 + XFLOAT_DATA (number
)));
2984 XSETINT (number
, XINT (number
) + 1);
2988 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2989 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2990 Markers are converted to integers. */)
2992 register Lisp_Object number
;
2994 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2996 if (FLOATP (number
))
2997 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2999 XSETINT (number
, XINT (number
) - 1);
3003 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3004 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3006 register Lisp_Object number
;
3008 CHECK_NUMBER (number
);
3009 XSETINT (number
, ~XINT (number
));
3013 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3014 doc
: /* Return the byteorder for the machine.
3015 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3016 lowercase l) for small endian machines. */)
3019 unsigned i
= 0x04030201;
3020 int order
= *(char *)&i
== 1 ? 108 : 66;
3022 return make_number (order
);
3030 Lisp_Object error_tail
, arith_tail
;
3032 Qquote
= intern ("quote");
3033 Qlambda
= intern ("lambda");
3034 Qsubr
= intern ("subr");
3035 Qerror_conditions
= intern ("error-conditions");
3036 Qerror_message
= intern ("error-message");
3037 Qtop_level
= intern ("top-level");
3039 Qerror
= intern ("error");
3040 Qquit
= intern ("quit");
3041 Qwrong_type_argument
= intern ("wrong-type-argument");
3042 Qargs_out_of_range
= intern ("args-out-of-range");
3043 Qvoid_function
= intern ("void-function");
3044 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3045 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3046 Qvoid_variable
= intern ("void-variable");
3047 Qsetting_constant
= intern ("setting-constant");
3048 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3050 Qinvalid_function
= intern ("invalid-function");
3051 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3052 Qno_catch
= intern ("no-catch");
3053 Qend_of_file
= intern ("end-of-file");
3054 Qarith_error
= intern ("arith-error");
3055 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3056 Qend_of_buffer
= intern ("end-of-buffer");
3057 Qbuffer_read_only
= intern ("buffer-read-only");
3058 Qtext_read_only
= intern ("text-read-only");
3059 Qmark_inactive
= intern ("mark-inactive");
3061 Qlistp
= intern ("listp");
3062 Qconsp
= intern ("consp");
3063 Qsymbolp
= intern ("symbolp");
3064 Qkeywordp
= intern ("keywordp");
3065 Qintegerp
= intern ("integerp");
3066 Qnatnump
= intern ("natnump");
3067 Qwholenump
= intern ("wholenump");
3068 Qstringp
= intern ("stringp");
3069 Qarrayp
= intern ("arrayp");
3070 Qsequencep
= intern ("sequencep");
3071 Qbufferp
= intern ("bufferp");
3072 Qvectorp
= intern ("vectorp");
3073 Qchar_or_string_p
= intern ("char-or-string-p");
3074 Qmarkerp
= intern ("markerp");
3075 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3076 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3077 Qboundp
= intern ("boundp");
3078 Qfboundp
= intern ("fboundp");
3080 Qfloatp
= intern ("floatp");
3081 Qnumberp
= intern ("numberp");
3082 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3084 Qchar_table_p
= intern ("char-table-p");
3085 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3087 Qsubrp
= intern ("subrp");
3088 Qunevalled
= intern ("unevalled");
3089 Qmany
= intern ("many");
3091 Qcdr
= intern ("cdr");
3093 /* Handle automatic advice activation */
3094 Qad_advice_info
= intern ("ad-advice-info");
3095 Qad_activate_internal
= intern ("ad-activate-internal");
3097 error_tail
= Fcons (Qerror
, Qnil
);
3099 /* ERROR is used as a signaler for random errors for which nothing else is right */
3101 Fput (Qerror
, Qerror_conditions
,
3103 Fput (Qerror
, Qerror_message
,
3104 build_string ("error"));
3106 Fput (Qquit
, Qerror_conditions
,
3107 Fcons (Qquit
, Qnil
));
3108 Fput (Qquit
, Qerror_message
,
3109 build_string ("Quit"));
3111 Fput (Qwrong_type_argument
, Qerror_conditions
,
3112 Fcons (Qwrong_type_argument
, error_tail
));
3113 Fput (Qwrong_type_argument
, Qerror_message
,
3114 build_string ("Wrong type argument"));
3116 Fput (Qargs_out_of_range
, Qerror_conditions
,
3117 Fcons (Qargs_out_of_range
, error_tail
));
3118 Fput (Qargs_out_of_range
, Qerror_message
,
3119 build_string ("Args out of range"));
3121 Fput (Qvoid_function
, Qerror_conditions
,
3122 Fcons (Qvoid_function
, error_tail
));
3123 Fput (Qvoid_function
, Qerror_message
,
3124 build_string ("Symbol's function definition is void"));
3126 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3127 Fcons (Qcyclic_function_indirection
, error_tail
));
3128 Fput (Qcyclic_function_indirection
, Qerror_message
,
3129 build_string ("Symbol's chain of function indirections contains a loop"));
3131 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3132 Fcons (Qcyclic_variable_indirection
, error_tail
));
3133 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3134 build_string ("Symbol's chain of variable indirections contains a loop"));
3136 Qcircular_list
= intern ("circular-list");
3137 staticpro (&Qcircular_list
);
3138 Fput (Qcircular_list
, Qerror_conditions
,
3139 Fcons (Qcircular_list
, error_tail
));
3140 Fput (Qcircular_list
, Qerror_message
,
3141 build_string ("List contains a loop"));
3143 Fput (Qvoid_variable
, Qerror_conditions
,
3144 Fcons (Qvoid_variable
, error_tail
));
3145 Fput (Qvoid_variable
, Qerror_message
,
3146 build_string ("Symbol's value as variable is void"));
3148 Fput (Qsetting_constant
, Qerror_conditions
,
3149 Fcons (Qsetting_constant
, error_tail
));
3150 Fput (Qsetting_constant
, Qerror_message
,
3151 build_string ("Attempt to set a constant symbol"));
3153 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3154 Fcons (Qinvalid_read_syntax
, error_tail
));
3155 Fput (Qinvalid_read_syntax
, Qerror_message
,
3156 build_string ("Invalid read syntax"));
3158 Fput (Qinvalid_function
, Qerror_conditions
,
3159 Fcons (Qinvalid_function
, error_tail
));
3160 Fput (Qinvalid_function
, Qerror_message
,
3161 build_string ("Invalid function"));
3163 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3164 Fcons (Qwrong_number_of_arguments
, error_tail
));
3165 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3166 build_string ("Wrong number of arguments"));
3168 Fput (Qno_catch
, Qerror_conditions
,
3169 Fcons (Qno_catch
, error_tail
));
3170 Fput (Qno_catch
, Qerror_message
,
3171 build_string ("No catch for tag"));
3173 Fput (Qend_of_file
, Qerror_conditions
,
3174 Fcons (Qend_of_file
, error_tail
));
3175 Fput (Qend_of_file
, Qerror_message
,
3176 build_string ("End of file during parsing"));
3178 arith_tail
= Fcons (Qarith_error
, error_tail
);
3179 Fput (Qarith_error
, Qerror_conditions
,
3181 Fput (Qarith_error
, Qerror_message
,
3182 build_string ("Arithmetic error"));
3184 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3185 Fcons (Qbeginning_of_buffer
, error_tail
));
3186 Fput (Qbeginning_of_buffer
, Qerror_message
,
3187 build_string ("Beginning of buffer"));
3189 Fput (Qend_of_buffer
, Qerror_conditions
,
3190 Fcons (Qend_of_buffer
, error_tail
));
3191 Fput (Qend_of_buffer
, Qerror_message
,
3192 build_string ("End of buffer"));
3194 Fput (Qbuffer_read_only
, Qerror_conditions
,
3195 Fcons (Qbuffer_read_only
, error_tail
));
3196 Fput (Qbuffer_read_only
, Qerror_message
,
3197 build_string ("Buffer is read-only"));
3199 Fput (Qtext_read_only
, Qerror_conditions
,
3200 Fcons (Qtext_read_only
, error_tail
));
3201 Fput (Qtext_read_only
, Qerror_message
,
3202 build_string ("Text is read-only"));
3204 Qrange_error
= intern ("range-error");
3205 Qdomain_error
= intern ("domain-error");
3206 Qsingularity_error
= intern ("singularity-error");
3207 Qoverflow_error
= intern ("overflow-error");
3208 Qunderflow_error
= intern ("underflow-error");
3210 Fput (Qdomain_error
, Qerror_conditions
,
3211 Fcons (Qdomain_error
, arith_tail
));
3212 Fput (Qdomain_error
, Qerror_message
,
3213 build_string ("Arithmetic domain error"));
3215 Fput (Qrange_error
, Qerror_conditions
,
3216 Fcons (Qrange_error
, arith_tail
));
3217 Fput (Qrange_error
, Qerror_message
,
3218 build_string ("Arithmetic range error"));
3220 Fput (Qsingularity_error
, Qerror_conditions
,
3221 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3222 Fput (Qsingularity_error
, Qerror_message
,
3223 build_string ("Arithmetic singularity error"));
3225 Fput (Qoverflow_error
, Qerror_conditions
,
3226 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3227 Fput (Qoverflow_error
, Qerror_message
,
3228 build_string ("Arithmetic overflow error"));
3230 Fput (Qunderflow_error
, Qerror_conditions
,
3231 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3232 Fput (Qunderflow_error
, Qerror_message
,
3233 build_string ("Arithmetic underflow error"));
3235 staticpro (&Qrange_error
);
3236 staticpro (&Qdomain_error
);
3237 staticpro (&Qsingularity_error
);
3238 staticpro (&Qoverflow_error
);
3239 staticpro (&Qunderflow_error
);
3243 staticpro (&Qquote
);
3244 staticpro (&Qlambda
);
3246 staticpro (&Qunbound
);
3247 staticpro (&Qerror_conditions
);
3248 staticpro (&Qerror_message
);
3249 staticpro (&Qtop_level
);
3251 staticpro (&Qerror
);
3253 staticpro (&Qwrong_type_argument
);
3254 staticpro (&Qargs_out_of_range
);
3255 staticpro (&Qvoid_function
);
3256 staticpro (&Qcyclic_function_indirection
);
3257 staticpro (&Qcyclic_variable_indirection
);
3258 staticpro (&Qvoid_variable
);
3259 staticpro (&Qsetting_constant
);
3260 staticpro (&Qinvalid_read_syntax
);
3261 staticpro (&Qwrong_number_of_arguments
);
3262 staticpro (&Qinvalid_function
);
3263 staticpro (&Qno_catch
);
3264 staticpro (&Qend_of_file
);
3265 staticpro (&Qarith_error
);
3266 staticpro (&Qbeginning_of_buffer
);
3267 staticpro (&Qend_of_buffer
);
3268 staticpro (&Qbuffer_read_only
);
3269 staticpro (&Qtext_read_only
);
3270 staticpro (&Qmark_inactive
);
3272 staticpro (&Qlistp
);
3273 staticpro (&Qconsp
);
3274 staticpro (&Qsymbolp
);
3275 staticpro (&Qkeywordp
);
3276 staticpro (&Qintegerp
);
3277 staticpro (&Qnatnump
);
3278 staticpro (&Qwholenump
);
3279 staticpro (&Qstringp
);
3280 staticpro (&Qarrayp
);
3281 staticpro (&Qsequencep
);
3282 staticpro (&Qbufferp
);
3283 staticpro (&Qvectorp
);
3284 staticpro (&Qchar_or_string_p
);
3285 staticpro (&Qmarkerp
);
3286 staticpro (&Qbuffer_or_string_p
);
3287 staticpro (&Qinteger_or_marker_p
);
3288 staticpro (&Qfloatp
);
3289 staticpro (&Qnumberp
);
3290 staticpro (&Qnumber_or_marker_p
);
3291 staticpro (&Qchar_table_p
);
3292 staticpro (&Qvector_or_char_table_p
);
3293 staticpro (&Qsubrp
);
3295 staticpro (&Qunevalled
);
3297 staticpro (&Qboundp
);
3298 staticpro (&Qfboundp
);
3300 staticpro (&Qad_advice_info
);
3301 staticpro (&Qad_activate_internal
);
3303 /* Types that type-of returns. */
3304 Qinteger
= intern ("integer");
3305 Qsymbol
= intern ("symbol");
3306 Qstring
= intern ("string");
3307 Qcons
= intern ("cons");
3308 Qmarker
= intern ("marker");
3309 Qoverlay
= intern ("overlay");
3310 Qfloat
= intern ("float");
3311 Qwindow_configuration
= intern ("window-configuration");
3312 Qprocess
= intern ("process");
3313 Qwindow
= intern ("window");
3314 /* Qsubr = intern ("subr"); */
3315 Qcompiled_function
= intern ("compiled-function");
3316 Qbuffer
= intern ("buffer");
3317 Qframe
= intern ("frame");
3318 Qvector
= intern ("vector");
3319 Qchar_table
= intern ("char-table");
3320 Qbool_vector
= intern ("bool-vector");
3321 Qhash_table
= intern ("hash-table");
3323 staticpro (&Qinteger
);
3324 staticpro (&Qsymbol
);
3325 staticpro (&Qstring
);
3327 staticpro (&Qmarker
);
3328 staticpro (&Qoverlay
);
3329 staticpro (&Qfloat
);
3330 staticpro (&Qwindow_configuration
);
3331 staticpro (&Qprocess
);
3332 staticpro (&Qwindow
);
3333 /* staticpro (&Qsubr); */
3334 staticpro (&Qcompiled_function
);
3335 staticpro (&Qbuffer
);
3336 staticpro (&Qframe
);
3337 staticpro (&Qvector
);
3338 staticpro (&Qchar_table
);
3339 staticpro (&Qbool_vector
);
3340 staticpro (&Qhash_table
);
3342 defsubr (&Sindirect_variable
);
3343 defsubr (&Sinteractive_form
);
3346 defsubr (&Stype_of
);
3351 defsubr (&Sintegerp
);
3352 defsubr (&Sinteger_or_marker_p
);
3353 defsubr (&Snumberp
);
3354 defsubr (&Snumber_or_marker_p
);
3356 defsubr (&Snatnump
);
3357 defsubr (&Ssymbolp
);
3358 defsubr (&Skeywordp
);
3359 defsubr (&Sstringp
);
3360 defsubr (&Smultibyte_string_p
);
3361 defsubr (&Svectorp
);
3362 defsubr (&Schar_table_p
);
3363 defsubr (&Svector_or_char_table_p
);
3364 defsubr (&Sbool_vector_p
);
3366 defsubr (&Ssequencep
);
3367 defsubr (&Sbufferp
);
3368 defsubr (&Smarkerp
);
3370 defsubr (&Sbyte_code_function_p
);
3371 defsubr (&Schar_or_string_p
);
3374 defsubr (&Scar_safe
);
3375 defsubr (&Scdr_safe
);
3378 defsubr (&Ssymbol_function
);
3379 defsubr (&Sindirect_function
);
3380 defsubr (&Ssymbol_plist
);
3381 defsubr (&Ssymbol_name
);
3382 defsubr (&Smakunbound
);
3383 defsubr (&Sfmakunbound
);
3385 defsubr (&Sfboundp
);
3387 defsubr (&Sdefalias
);
3388 defsubr (&Ssetplist
);
3389 defsubr (&Ssymbol_value
);
3391 defsubr (&Sdefault_boundp
);
3392 defsubr (&Sdefault_value
);
3393 defsubr (&Sset_default
);
3394 defsubr (&Ssetq_default
);
3395 defsubr (&Smake_variable_buffer_local
);
3396 defsubr (&Smake_local_variable
);
3397 defsubr (&Skill_local_variable
);
3398 defsubr (&Smake_variable_frame_local
);
3399 defsubr (&Slocal_variable_p
);
3400 defsubr (&Slocal_variable_if_set_p
);
3401 defsubr (&Svariable_binding_locus
);
3402 #if 0 /* XXX Remove this. --lorentey */
3403 defsubr (&Sterminal_local_value
);
3404 defsubr (&Sset_terminal_local_value
);
3408 defsubr (&Snumber_to_string
);
3409 defsubr (&Sstring_to_number
);
3410 defsubr (&Seqlsign
);
3433 defsubr (&Sbyteorder
);
3434 defsubr (&Ssubr_arity
);
3435 defsubr (&Ssubr_name
);
3437 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3439 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3440 doc
: /* The largest value that is representable in a Lisp integer. */);
3441 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3443 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3444 doc
: /* The smallest value that is representable in a Lisp integer. */);
3445 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3452 #if defined(USG) && !defined(POSIX_SIGNALS)
3453 /* USG systems forget handlers when they are used;
3454 must reestablish each time */
3455 signal (signo
, arith_error
);
3458 /* VMS systems are like USG. */
3459 signal (signo
, arith_error
);
3463 #else /* not BSD4_1 */
3464 sigsetmask (SIGEMPTYMASK
);
3465 #endif /* not BSD4_1 */
3467 SIGNAL_THREAD_CHECK (signo
);
3468 Fsignal (Qarith_error
, Qnil
);
3474 /* Don't do this if just dumping out.
3475 We don't want to call `signal' in this case
3476 so that we don't have trouble with dumping
3477 signal-delivering routines in an inconsistent state. */
3481 #endif /* CANNOT_DUMP */
3482 signal (SIGFPE
, arith_error
);
3485 signal (SIGEMT
, arith_error
);
3489 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3490 (do not change this comment) */