1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
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 3 of the License, or
10 (at your option) any later version.
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. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
37 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
38 static Lisp_Object Qsubr
;
39 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
40 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
41 static Lisp_Object Qwrong_type_argument
;
42 Lisp_Object Qvoid_variable
, Qvoid_function
;
43 static Lisp_Object Qcyclic_function_indirection
;
44 static Lisp_Object Qcyclic_variable_indirection
;
45 Lisp_Object Qcircular_list
;
46 static Lisp_Object Qsetting_constant
;
47 Lisp_Object Qinvalid_read_syntax
;
48 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
49 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
50 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
51 Lisp_Object Qtext_read_only
;
53 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
54 static Lisp_Object Qnatnump
;
55 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
56 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
57 Lisp_Object Qbuffer_or_string_p
;
58 static Lisp_Object Qkeywordp
, Qboundp
;
60 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
63 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
65 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
66 Lisp_Object Qrange_error
, Qoverflow_error
;
69 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
71 Lisp_Object Qinteger
, Qsymbol
;
72 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
74 static Lisp_Object Qoverlay
, Qwindow_configuration
;
75 static Lisp_Object Qprocess
, Qmarker
;
76 static Lisp_Object Qcompiled_function
, Qframe
;
78 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
79 static Lisp_Object Qsubrp
;
80 static Lisp_Object Qmany
, Qunevalled
;
81 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
82 static Lisp_Object Qdefun
;
83 Lisp_Object Qthread
, Qmutex
, Qcondition_variable
;
85 Lisp_Object Qinteractive_form
;
86 static Lisp_Object Qdefalias_fset_function
;
88 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
91 BOOLFWDP (union Lisp_Fwd
*a
)
93 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
96 INTFWDP (union Lisp_Fwd
*a
)
98 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
101 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
103 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
106 OBJFWDP (union Lisp_Fwd
*a
)
108 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
111 static struct Lisp_Boolfwd
*
112 XBOOLFWD (union Lisp_Fwd
*a
)
114 eassert (BOOLFWDP (a
));
115 return &a
->u_boolfwd
;
117 static struct Lisp_Kboard_Objfwd
*
118 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
120 eassert (KBOARD_OBJFWDP (a
));
121 return &a
->u_kboard_objfwd
;
123 static struct Lisp_Intfwd
*
124 XINTFWD (union Lisp_Fwd
*a
)
126 eassert (INTFWDP (a
));
129 static struct Lisp_Objfwd
*
130 XOBJFWD (union Lisp_Fwd
*a
)
132 eassert (OBJFWDP (a
));
137 CHECK_SUBR (Lisp_Object x
)
139 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
143 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
145 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
150 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
152 return XCDR (blv
->valcell
);
156 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
158 XSETCDR (blv
->valcell
, val
);
162 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
168 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
174 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
180 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
182 /* If VALUE is not even a valid Lisp object, we'd want to abort here
183 where we can get a backtrace showing where it came from. We used
184 to try and do that by checking the tagbits, but nowadays all
185 tagbits are potentially valid. */
186 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
189 xsignal2 (Qwrong_type_argument
, predicate
, value
);
193 pure_write_error (Lisp_Object obj
)
195 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
199 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
201 xsignal2 (Qargs_out_of_range
, a1
, a2
);
205 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
207 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
211 /* Data type predicates. */
213 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
214 doc
: /* Return t if the two args are the same Lisp object. */)
215 (Lisp_Object obj1
, Lisp_Object obj2
)
222 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
223 doc
: /* Return t if OBJECT is nil. */)
231 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
232 doc
: /* Return a symbol representing the type of OBJECT.
233 The symbol returned names the object's basic type;
234 for example, (type-of 1) returns `integer'. */)
237 switch (XTYPE (object
))
252 switch (XMISCTYPE (object
))
254 case Lisp_Misc_Marker
:
256 case Lisp_Misc_Overlay
:
258 case Lisp_Misc_Float
:
263 case Lisp_Vectorlike
:
264 if (WINDOW_CONFIGURATIONP (object
))
265 return Qwindow_configuration
;
266 if (PROCESSP (object
))
268 if (WINDOWP (object
))
272 if (COMPILEDP (object
))
273 return Qcompiled_function
;
274 if (BUFFERP (object
))
276 if (CHAR_TABLE_P (object
))
278 if (BOOL_VECTOR_P (object
))
282 if (HASH_TABLE_P (object
))
284 if (FONT_SPEC_P (object
))
286 if (FONT_ENTITY_P (object
))
288 if (FONT_OBJECT_P (object
))
290 if (THREADP (object
))
294 if (CONDVARP (object
))
295 return Qcondition_variable
;
306 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is a cons cell. */)
315 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
324 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
326 Otherwise, return nil. */)
329 if (CONSP (object
) || NILP (object
))
334 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
335 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
338 if (CONSP (object
) || NILP (object
))
343 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
344 doc
: /* Return t if OBJECT is a symbol. */)
347 if (SYMBOLP (object
))
352 /* Define this in C to avoid unnecessarily consing up the symbol
354 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
355 doc
: /* Return t if OBJECT is a keyword.
356 This means that it is a symbol with a print name beginning with `:'
357 interned in the initial obarray. */)
361 && SREF (SYMBOL_NAME (object
), 0) == ':'
362 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
367 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a vector. */)
371 if (VECTORP (object
))
376 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is a string. */)
380 if (STRINGP (object
))
385 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
387 doc
: /* Return t if OBJECT is a multibyte string.
388 Return nil if OBJECT is either a unibyte string, or not a string. */)
391 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
396 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is a char-table. */)
400 if (CHAR_TABLE_P (object
))
405 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
406 Svector_or_char_table_p
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is a char-table or vector. */)
410 if (VECTORP (object
) || CHAR_TABLE_P (object
))
415 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
416 doc
: /* Return t if OBJECT is a bool-vector. */)
419 if (BOOL_VECTOR_P (object
))
424 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is an array (string or vector). */)
433 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
434 doc
: /* Return t if OBJECT is a sequence (list or array). */)
435 (register Lisp_Object object
)
437 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
442 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
443 doc
: /* Return t if OBJECT is an editor buffer. */)
446 if (BUFFERP (object
))
451 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
452 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
455 if (MARKERP (object
))
460 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
461 doc
: /* Return t if OBJECT is a built-in function. */)
469 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
471 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
474 if (COMPILEDP (object
))
479 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
480 doc
: /* Return t if OBJECT is a character or a string. */)
481 (register Lisp_Object object
)
483 if (CHARACTERP (object
) || STRINGP (object
))
488 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
489 doc
: /* Return t if OBJECT is an integer. */)
492 if (INTEGERP (object
))
497 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
498 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
499 (register Lisp_Object object
)
501 if (MARKERP (object
) || INTEGERP (object
))
506 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
507 doc
: /* Return t if OBJECT is a nonnegative integer. */)
510 if (NATNUMP (object
))
515 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
516 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
519 if (NUMBERP (object
))
525 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
526 Snumber_or_marker_p
, 1, 1, 0,
527 doc
: /* Return t if OBJECT is a number or a marker. */)
530 if (NUMBERP (object
) || MARKERP (object
))
535 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
536 doc
: /* Return t if OBJECT is a floating point number. */)
544 DEFUN ("threadp", Fthreadp
, Sthreadp
, 1, 1, 0,
545 doc
: /* Return t if OBJECT is a thread. */)
548 if (THREADP (object
))
554 DEFUN ("mutexp", Fmutexp
, Smutexp
, 1, 1, 0,
555 doc
: /* Return t if OBJECT is a mutex. */)
564 DEFUN ("condition-variable-p", Fcondition_variable_p
, Scondition_variable_p
,
566 doc
: /* Return t if OBJECT is a condition variable. */)
569 if (CONDVARP (object
))
575 /* Extract and set components of lists. */
577 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
578 doc
: /* Return the car of LIST. If arg is nil, return nil.
579 Error if arg is not nil and not a cons cell. See also `car-safe'.
581 See Info node `(elisp)Cons Cells' for a discussion of related basic
582 Lisp concepts such as car, cdr, cons cell and list. */)
583 (register Lisp_Object list
)
588 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
589 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
592 return CAR_SAFE (object
);
595 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
596 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
597 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
599 See Info node `(elisp)Cons Cells' for a discussion of related basic
600 Lisp concepts such as cdr, car, cons cell and list. */)
601 (register Lisp_Object list
)
606 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
607 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
610 return CDR_SAFE (object
);
613 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
614 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
615 (register Lisp_Object cell
, Lisp_Object newcar
)
619 XSETCAR (cell
, newcar
);
623 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
624 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
625 (register Lisp_Object cell
, Lisp_Object newcdr
)
629 XSETCDR (cell
, newcdr
);
633 /* Extract and set components of symbols. */
635 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
636 doc
: /* Return t if SYMBOL's value is not void.
637 Note that if `lexical-binding' is in effect, this refers to the
638 global value outside of any lexical scope. */)
639 (register Lisp_Object symbol
)
641 Lisp_Object valcontents
;
642 struct Lisp_Symbol
*sym
;
643 CHECK_SYMBOL (symbol
);
644 sym
= XSYMBOL (symbol
);
647 switch (sym
->redirect
)
649 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
650 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
651 case SYMBOL_LOCALIZED
:
653 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
655 /* In set_internal, we un-forward vars when their value is
660 swap_in_symval_forwarding (sym
, blv
);
661 valcontents
= blv_value (blv
);
665 case SYMBOL_FORWARDED
:
666 /* In set_internal, we un-forward vars when their value is
669 default: emacs_abort ();
672 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
675 /* FIXME: Make it an alias for function-symbol! */
676 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
677 doc
: /* Return t if SYMBOL's function definition is not void. */)
678 (register Lisp_Object symbol
)
680 CHECK_SYMBOL (symbol
);
681 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
684 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
685 doc
: /* Make SYMBOL's value be void.
687 (register Lisp_Object symbol
)
689 CHECK_SYMBOL (symbol
);
690 if (SYMBOL_CONSTANT_P (symbol
))
691 xsignal1 (Qsetting_constant
, symbol
);
692 Fset (symbol
, Qunbound
);
696 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
697 doc
: /* Make SYMBOL's function definition be nil.
699 (register Lisp_Object symbol
)
701 CHECK_SYMBOL (symbol
);
702 if (NILP (symbol
) || EQ (symbol
, Qt
))
703 xsignal1 (Qsetting_constant
, symbol
);
704 set_symbol_function (symbol
, Qnil
);
708 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
709 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
710 (register Lisp_Object symbol
)
712 CHECK_SYMBOL (symbol
);
713 return XSYMBOL (symbol
)->function
;
716 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
717 doc
: /* Return SYMBOL's property list. */)
718 (register Lisp_Object symbol
)
720 CHECK_SYMBOL (symbol
);
721 return XSYMBOL (symbol
)->plist
;
724 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
725 doc
: /* Return SYMBOL's name, a string. */)
726 (register Lisp_Object symbol
)
728 register Lisp_Object name
;
730 CHECK_SYMBOL (symbol
);
731 name
= SYMBOL_NAME (symbol
);
735 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
736 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
737 (register Lisp_Object symbol
, Lisp_Object definition
)
739 register Lisp_Object function
;
740 CHECK_SYMBOL (symbol
);
742 function
= XSYMBOL (symbol
)->function
;
744 if (!NILP (Vautoload_queue
) && !NILP (function
))
745 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
747 if (AUTOLOADP (function
))
748 Fput (symbol
, Qautoload
, XCDR (function
));
750 set_symbol_function (symbol
, definition
);
755 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
756 doc
: /* Set SYMBOL's function definition to DEFINITION.
757 Associates the function with the current load file, if any.
758 The optional third argument DOCSTRING specifies the documentation string
759 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
760 determined by DEFINITION.
761 The return value is undefined. */)
762 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
764 CHECK_SYMBOL (symbol
);
765 if (!NILP (Vpurify_flag
)
766 /* If `definition' is a keymap, immutable (and copying) is wrong. */
767 && !KEYMAPP (definition
))
768 definition
= Fpurecopy (definition
);
771 bool autoload
= AUTOLOADP (definition
);
772 if (NILP (Vpurify_flag
) || !autoload
)
773 { /* Only add autoload entries after dumping, because the ones before are
774 not useful and else we get loads of them from the loaddefs.el. */
776 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
777 /* Remember that the function was already an autoload. */
778 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
779 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
783 { /* Handle automatic advice activation. */
784 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
786 call2 (hook
, symbol
, definition
);
788 Ffset (symbol
, definition
);
791 if (!NILP (docstring
))
792 Fput (symbol
, Qfunction_documentation
, docstring
);
793 /* We used to return `definition', but now that `defun' and `defmacro' expand
794 to a call to `defalias', we return `symbol' for backward compatibility
799 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
800 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
801 (register Lisp_Object symbol
, Lisp_Object newplist
)
803 CHECK_SYMBOL (symbol
);
804 set_symbol_plist (symbol
, newplist
);
808 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
809 doc
: /* Return minimum and maximum number of args allowed for SUBR.
810 SUBR must be a built-in function.
811 The returned value is a pair (MIN . MAX). MIN is the minimum number
812 of args. MAX is the maximum number or the symbol `many', for a
813 function with `&rest' args, or `unevalled' for a special form. */)
816 short minargs
, maxargs
;
818 minargs
= XSUBR (subr
)->min_args
;
819 maxargs
= XSUBR (subr
)->max_args
;
820 return Fcons (make_number (minargs
),
821 maxargs
== MANY
? Qmany
822 : maxargs
== UNEVALLED
? Qunevalled
823 : make_number (maxargs
));
826 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
827 doc
: /* Return name of subroutine SUBR.
828 SUBR must be a built-in function. */)
833 name
= XSUBR (subr
)->symbol_name
;
834 return build_string (name
);
837 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
838 doc
: /* Return the interactive form of CMD or nil if none.
839 If CMD is not a command, the return value is nil.
840 Value, if non-nil, is a list \(interactive SPEC). */)
843 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
848 /* Use an `interactive-form' property if present, analogous to the
849 function-documentation property. */
851 while (SYMBOLP (fun
))
853 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
857 fun
= Fsymbol_function (fun
);
862 const char *spec
= XSUBR (fun
)->intspec
;
864 return list2 (Qinteractive
,
865 (*spec
!= '(') ? build_string (spec
) :
866 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
868 else if (COMPILEDP (fun
))
870 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
871 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
873 else if (AUTOLOADP (fun
))
874 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
875 else if (CONSP (fun
))
877 Lisp_Object funcar
= XCAR (fun
);
878 if (EQ (funcar
, Qclosure
))
879 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
880 else if (EQ (funcar
, Qlambda
))
881 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
887 /***********************************************************************
888 Getting and Setting Values of Symbols
889 ***********************************************************************/
891 /* Return the symbol holding SYMBOL's value. Signal
892 `cyclic-variable-indirection' if SYMBOL's chain of variable
893 indirections contains a loop. */
896 indirect_variable (struct Lisp_Symbol
*symbol
)
898 struct Lisp_Symbol
*tortoise
, *hare
;
900 hare
= tortoise
= symbol
;
902 while (hare
->redirect
== SYMBOL_VARALIAS
)
904 hare
= SYMBOL_ALIAS (hare
);
905 if (hare
->redirect
!= SYMBOL_VARALIAS
)
908 hare
= SYMBOL_ALIAS (hare
);
909 tortoise
= SYMBOL_ALIAS (tortoise
);
911 if (hare
== tortoise
)
914 XSETSYMBOL (tem
, symbol
);
915 xsignal1 (Qcyclic_variable_indirection
, tem
);
923 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
924 doc
: /* Return the variable at the end of OBJECT's variable chain.
925 If OBJECT is a symbol, follow its variable indirections (if any), and
926 return the variable at the end of the chain of aliases. See Info node
927 `(elisp)Variable Aliases'.
929 If OBJECT is not a symbol, just return it. If there is a loop in the
930 chain of aliases, signal a `cyclic-variable-indirection' error. */)
933 if (SYMBOLP (object
))
935 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
936 XSETSYMBOL (object
, sym
);
942 /* Given the raw contents of a symbol value cell,
943 return the Lisp value of the symbol.
944 This does not handle buffer-local variables; use
945 swap_in_symval_forwarding for that. */
948 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
950 register Lisp_Object val
;
951 switch (XFWDTYPE (valcontents
))
954 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
958 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
961 return *XOBJFWD (valcontents
)->objvar
;
963 case Lisp_Fwd_Buffer_Obj
:
964 return per_buffer_value (current_buffer
,
965 XBUFFER_OBJFWD (valcontents
)->offset
);
967 case Lisp_Fwd_Kboard_Obj
:
968 /* We used to simply use current_kboard here, but from Lisp
969 code, its value is often unexpected. It seems nicer to
970 allow constructions like this to work as intuitively expected:
972 (with-selected-frame frame
973 (define-key local-function-map "\eOP" [f1]))
975 On the other hand, this affects the semantics of
976 last-command and real-last-command, and people may rely on
977 that. I took a quick look at the Lisp codebase, and I
978 don't think anything will break. --lorentey */
979 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
980 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
981 default: emacs_abort ();
985 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
986 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
987 buffer-independent contents of the value cell: forwarded just one
988 step past the buffer-localness.
990 BUF non-zero means set the value in buffer BUF instead of the
991 current buffer. This only plays a role for per-buffer variables. */
994 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
996 switch (XFWDTYPE (valcontents
))
999 CHECK_NUMBER (newval
);
1000 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1004 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1008 *XOBJFWD (valcontents
)->objvar
= newval
;
1010 /* If this variable is a default for something stored
1011 in the buffer itself, such as default-fill-column,
1012 find the buffers that don't have local values for it
1014 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1015 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1017 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1018 - (char *) &buffer_defaults
);
1019 int idx
= PER_BUFFER_IDX (offset
);
1021 Lisp_Object tail
, buf
;
1026 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1028 struct buffer
*b
= XBUFFER (buf
);
1030 if (! PER_BUFFER_VALUE_P (b
, idx
))
1031 set_per_buffer_value (b
, offset
, newval
);
1036 case Lisp_Fwd_Buffer_Obj
:
1038 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1039 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1041 if (!NILP (predicate
) && !NILP (newval
)
1042 && NILP (call1 (predicate
, newval
)))
1043 wrong_type_argument (predicate
, newval
);
1046 buf
= current_buffer
;
1047 set_per_buffer_value (buf
, offset
, newval
);
1051 case Lisp_Fwd_Kboard_Obj
:
1053 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1054 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1055 *(Lisp_Object
*) p
= newval
;
1060 emacs_abort (); /* goto def; */
1064 /* Set up SYMBOL to refer to its global binding. This makes it safe
1065 to alter the status of other bindings. BEWARE: this may be called
1066 during the mark phase of GC, where we assume that Lisp_Object slots
1067 of BLV are marked after this function has changed them. */
1070 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1072 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1074 /* Unload the previously loaded binding. */
1076 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1078 /* Select the global binding in the symbol. */
1079 set_blv_valcell (blv
, blv
->defcell
);
1081 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1083 /* Indicate that the global binding is set up now. */
1084 set_blv_where (blv
, Qnil
);
1085 set_blv_found (blv
, 0);
1088 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1089 VALCONTENTS is the contents of its value cell,
1090 which points to a struct Lisp_Buffer_Local_Value.
1092 Return the value forwarded one step past the buffer-local stage.
1093 This could be another forwarding pointer. */
1096 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1098 register Lisp_Object tem1
;
1100 eassert (blv
== SYMBOL_BLV (symbol
));
1105 || (blv
->frame_local
1106 ? !EQ (selected_frame
, tem1
)
1107 : current_buffer
!= XBUFFER (tem1
)))
1110 /* Unload the previously loaded binding. */
1111 tem1
= blv
->valcell
;
1113 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1114 /* Choose the new binding. */
1117 XSETSYMBOL (var
, symbol
);
1118 if (blv
->frame_local
)
1120 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1121 set_blv_where (blv
, selected_frame
);
1125 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1126 set_blv_where (blv
, Fcurrent_buffer ());
1129 if (!(blv
->found
= !NILP (tem1
)))
1130 tem1
= blv
->defcell
;
1132 /* Load the new binding. */
1133 set_blv_valcell (blv
, tem1
);
1135 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1139 /* Find the value of a symbol, returning Qunbound if it's not bound.
1140 This is helpful for code which just wants to get a variable's value
1141 if it has one, without signaling an error.
1142 Note that it must not be possible to quit
1143 within this function. Great care is required for this. */
1146 find_symbol_value (Lisp_Object symbol
)
1148 struct Lisp_Symbol
*sym
;
1150 CHECK_SYMBOL (symbol
);
1151 sym
= XSYMBOL (symbol
);
1154 switch (sym
->redirect
)
1156 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1157 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1158 case SYMBOL_LOCALIZED
:
1160 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1161 swap_in_symval_forwarding (sym
, blv
);
1162 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1165 case SYMBOL_FORWARDED
:
1166 return do_symval_forwarding (SYMBOL_FWD (sym
));
1167 default: emacs_abort ();
1171 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1172 doc
: /* Return SYMBOL's value. Error if that is void.
1173 Note that if `lexical-binding' is in effect, this returns the
1174 global value outside of any lexical scope. */)
1175 (Lisp_Object symbol
)
1179 val
= find_symbol_value (symbol
);
1180 if (!EQ (val
, Qunbound
))
1183 xsignal1 (Qvoid_variable
, symbol
);
1186 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1187 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1188 (register Lisp_Object symbol
, Lisp_Object newval
)
1190 set_internal (symbol
, newval
, Qnil
, 0);
1194 /* Store the value NEWVAL into SYMBOL.
1195 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1196 (nil stands for the current buffer/frame).
1198 If BINDFLAG is false, then if this symbol is supposed to become
1199 local in every buffer where it is set, then we make it local.
1200 If BINDFLAG is true, we don't do that. */
1203 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1206 bool voide
= EQ (newval
, Qunbound
);
1207 struct Lisp_Symbol
*sym
;
1210 /* If restoring in a dead buffer, do nothing. */
1211 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1214 CHECK_SYMBOL (symbol
);
1215 if (SYMBOL_CONSTANT_P (symbol
))
1217 if (NILP (Fkeywordp (symbol
))
1218 || !EQ (newval
, Fsymbol_value (symbol
)))
1219 xsignal1 (Qsetting_constant
, symbol
);
1221 /* Allow setting keywords to their own value. */
1225 sym
= XSYMBOL (symbol
);
1228 switch (sym
->redirect
)
1230 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1231 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1232 case SYMBOL_LOCALIZED
:
1234 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1237 if (blv
->frame_local
)
1238 where
= selected_frame
;
1240 XSETBUFFER (where
, current_buffer
);
1242 /* If the current buffer is not the buffer whose binding is
1243 loaded, or if there may be frame-local bindings and the frame
1244 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1245 the default binding is loaded, the loaded binding may be the
1247 if (!EQ (blv
->where
, where
)
1248 /* Also unload a global binding (if the var is local_if_set). */
1249 || (EQ (blv
->valcell
, blv
->defcell
)))
1251 /* The currently loaded binding is not necessarily valid.
1252 We need to unload it, and choose a new binding. */
1254 /* Write out `realvalue' to the old loaded binding. */
1256 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1258 /* Find the new binding. */
1259 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1260 tem1
= Fassq (symbol
,
1262 ? XFRAME (where
)->param_alist
1263 : BVAR (XBUFFER (where
), local_var_alist
)));
1264 set_blv_where (blv
, where
);
1269 /* This buffer still sees the default value. */
1271 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1272 or if this is `let' rather than `set',
1273 make CURRENT-ALIST-ELEMENT point to itself,
1274 indicating that we're seeing the default value.
1275 Likewise if the variable has been let-bound
1276 in the current buffer. */
1277 if (bindflag
|| !blv
->local_if_set
1278 || let_shadows_buffer_binding_p (sym
))
1281 tem1
= blv
->defcell
;
1283 /* If it's a local_if_set, being set not bound,
1284 and we're not within a let that was made for this buffer,
1285 create a new buffer-local binding for the variable.
1286 That means, give this buffer a new assoc for a local value
1287 and load that binding. */
1290 /* local_if_set is only supported for buffer-local
1291 bindings, not for frame-local bindings. */
1292 eassert (!blv
->frame_local
);
1293 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1294 bset_local_var_alist
1296 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1300 /* Record which binding is now loaded. */
1301 set_blv_valcell (blv
, tem1
);
1304 /* Store the new value in the cons cell. */
1305 set_blv_value (blv
, newval
);
1310 /* If storing void (making the symbol void), forward only through
1311 buffer-local indicator, not through Lisp_Objfwd, etc. */
1314 store_symval_forwarding (blv
->fwd
, newval
,
1316 ? XBUFFER (where
) : current_buffer
);
1320 case SYMBOL_FORWARDED
:
1323 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1324 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1325 if (BUFFER_OBJFWDP (innercontents
))
1327 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1328 int idx
= PER_BUFFER_IDX (offset
);
1331 && !let_shadows_buffer_binding_p (sym
))
1332 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1336 { /* If storing void (making the symbol void), forward only through
1337 buffer-local indicator, not through Lisp_Objfwd, etc. */
1338 sym
->redirect
= SYMBOL_PLAINVAL
;
1339 SET_SYMBOL_VAL (sym
, newval
);
1342 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1345 default: emacs_abort ();
1350 /* Access or set a buffer-local symbol's default value. */
1352 /* Return the default value of SYMBOL, but don't check for voidness.
1353 Return Qunbound if it is void. */
1356 default_value (Lisp_Object symbol
)
1358 struct Lisp_Symbol
*sym
;
1360 CHECK_SYMBOL (symbol
);
1361 sym
= XSYMBOL (symbol
);
1364 switch (sym
->redirect
)
1366 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1367 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1368 case SYMBOL_LOCALIZED
:
1370 /* If var is set up for a buffer that lacks a local value for it,
1371 the current value is nominally the default value.
1372 But the `realvalue' slot may be more up to date, since
1373 ordinary setq stores just that slot. So use that. */
1374 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1375 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1376 return do_symval_forwarding (blv
->fwd
);
1378 return XCDR (blv
->defcell
);
1380 case SYMBOL_FORWARDED
:
1382 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1384 /* For a built-in buffer-local variable, get the default value
1385 rather than letting do_symval_forwarding get the current value. */
1386 if (BUFFER_OBJFWDP (valcontents
))
1388 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1389 if (PER_BUFFER_IDX (offset
) != 0)
1390 return per_buffer_default (offset
);
1393 /* For other variables, get the current value. */
1394 return do_symval_forwarding (valcontents
);
1396 default: emacs_abort ();
1400 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1401 doc
: /* Return t if SYMBOL has a non-void default value.
1402 This is the value that is seen in buffers that do not have their own values
1403 for this variable. */)
1404 (Lisp_Object symbol
)
1406 register Lisp_Object value
;
1408 value
= default_value (symbol
);
1409 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1412 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1413 doc
: /* Return SYMBOL's default value.
1414 This is the value that is seen in buffers that do not have their own values
1415 for this variable. The default value is meaningful for variables with
1416 local bindings in certain buffers. */)
1417 (Lisp_Object symbol
)
1419 Lisp_Object value
= default_value (symbol
);
1420 if (!EQ (value
, Qunbound
))
1423 xsignal1 (Qvoid_variable
, symbol
);
1426 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1427 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1428 The default value is seen in buffers that do not have their own values
1429 for this variable. */)
1430 (Lisp_Object symbol
, Lisp_Object value
)
1432 struct Lisp_Symbol
*sym
;
1434 CHECK_SYMBOL (symbol
);
1435 if (SYMBOL_CONSTANT_P (symbol
))
1437 if (NILP (Fkeywordp (symbol
))
1438 || !EQ (value
, Fdefault_value (symbol
)))
1439 xsignal1 (Qsetting_constant
, symbol
);
1441 /* Allow setting keywords to their own value. */
1444 sym
= XSYMBOL (symbol
);
1447 switch (sym
->redirect
)
1449 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1450 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1451 case SYMBOL_LOCALIZED
:
1453 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1455 /* Store new value into the DEFAULT-VALUE slot. */
1456 XSETCDR (blv
->defcell
, value
);
1458 /* If the default binding is now loaded, set the REALVALUE slot too. */
1459 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1460 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1463 case SYMBOL_FORWARDED
:
1465 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1467 /* Handle variables like case-fold-search that have special slots
1469 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1470 if (BUFFER_OBJFWDP (valcontents
))
1472 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1473 int idx
= PER_BUFFER_IDX (offset
);
1475 set_per_buffer_default (offset
, value
);
1477 /* If this variable is not always local in all buffers,
1478 set it in the buffers that don't nominally have a local value. */
1484 if (!PER_BUFFER_VALUE_P (b
, idx
))
1485 set_per_buffer_value (b
, offset
, value
);
1490 return Fset (symbol
, value
);
1492 default: emacs_abort ();
1496 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1497 doc
: /* Set the default value of variable VAR to VALUE.
1498 VAR, the variable name, is literal (not evaluated);
1499 VALUE is an expression: it is evaluated and its value returned.
1500 The default value of a variable is seen in buffers
1501 that do not have their own values for the variable.
1503 More generally, you can use multiple variables and values, as in
1504 (setq-default VAR VALUE VAR VALUE...)
1505 This sets each VAR's default value to the corresponding VALUE.
1506 The VALUE for the Nth VAR can refer to the new default values
1508 usage: (setq-default [VAR VALUE]...) */)
1511 Lisp_Object args_left
, symbol
, val
;
1512 struct gcpro gcpro1
;
1514 args_left
= val
= args
;
1517 while (CONSP (args_left
))
1519 val
= eval_sub (Fcar (XCDR (args_left
)));
1520 symbol
= XCAR (args_left
);
1521 Fset_default (symbol
, val
);
1522 args_left
= Fcdr (XCDR (args_left
));
1529 /* Lisp functions for creating and removing buffer-local variables. */
1534 union Lisp_Fwd
*fwd
;
1537 static struct Lisp_Buffer_Local_Value
*
1538 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1539 union Lisp_Val_Fwd valcontents
)
1541 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1545 XSETSYMBOL (symbol
, sym
);
1546 tem
= Fcons (symbol
, (forwarded
1547 ? do_symval_forwarding (valcontents
.fwd
)
1548 : valcontents
.value
));
1550 /* Buffer_Local_Values cannot have as realval a buffer-local
1551 or keyboard-local forwarding. */
1552 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1553 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1554 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1555 set_blv_where (blv
, Qnil
);
1556 blv
->frame_local
= 0;
1557 blv
->local_if_set
= 0;
1558 set_blv_defcell (blv
, tem
);
1559 set_blv_valcell (blv
, tem
);
1560 set_blv_found (blv
, 0);
1564 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1565 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1566 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1567 At any time, the value for the current buffer is in effect,
1568 unless the variable has never been set in this buffer,
1569 in which case the default value is in effect.
1570 Note that binding the variable with `let', or setting it while
1571 a `let'-style binding made in this buffer is in effect,
1572 does not make the variable buffer-local. Return VARIABLE.
1574 In most cases it is better to use `make-local-variable',
1575 which makes a variable local in just one buffer.
1577 The function `default-value' gets the default value and `set-default' sets it. */)
1578 (register Lisp_Object variable
)
1580 struct Lisp_Symbol
*sym
;
1581 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1582 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1583 bool forwarded
IF_LINT (= 0);
1585 CHECK_SYMBOL (variable
);
1586 sym
= XSYMBOL (variable
);
1589 switch (sym
->redirect
)
1591 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1592 case SYMBOL_PLAINVAL
:
1593 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1594 if (EQ (valcontents
.value
, Qunbound
))
1595 valcontents
.value
= Qnil
;
1597 case SYMBOL_LOCALIZED
:
1598 blv
= SYMBOL_BLV (sym
);
1599 if (blv
->frame_local
)
1600 error ("Symbol %s may not be buffer-local",
1601 SDATA (SYMBOL_NAME (variable
)));
1603 case SYMBOL_FORWARDED
:
1604 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1605 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1606 error ("Symbol %s may not be buffer-local",
1607 SDATA (SYMBOL_NAME (variable
)));
1608 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1611 default: emacs_abort ();
1615 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1619 blv
= make_blv (sym
, forwarded
, valcontents
);
1620 sym
->redirect
= SYMBOL_LOCALIZED
;
1621 SET_SYMBOL_BLV (sym
, blv
);
1624 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1625 if (let_shadows_global_binding_p (symbol
))
1626 message ("Making %s buffer-local while let-bound!",
1627 SDATA (SYMBOL_NAME (variable
)));
1631 blv
->local_if_set
= 1;
1635 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1636 1, 1, "vMake Local Variable: ",
1637 doc
: /* Make VARIABLE have a separate value in the current buffer.
1638 Other buffers will continue to share a common default value.
1639 \(The buffer-local value of VARIABLE starts out as the same value
1640 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1643 If the variable is already arranged to become local when set,
1644 this function causes a local value to exist for this buffer,
1645 just as setting the variable would do.
1647 This function returns VARIABLE, and therefore
1648 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1651 See also `make-variable-buffer-local'.
1653 Do not use `make-local-variable' to make a hook variable buffer-local.
1654 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1655 (Lisp_Object variable
)
1658 bool forwarded
IF_LINT (= 0);
1659 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1660 struct Lisp_Symbol
*sym
;
1661 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1663 CHECK_SYMBOL (variable
);
1664 sym
= XSYMBOL (variable
);
1667 switch (sym
->redirect
)
1669 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1670 case SYMBOL_PLAINVAL
:
1671 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1672 case SYMBOL_LOCALIZED
:
1673 blv
= SYMBOL_BLV (sym
);
1674 if (blv
->frame_local
)
1675 error ("Symbol %s may not be buffer-local",
1676 SDATA (SYMBOL_NAME (variable
)));
1678 case SYMBOL_FORWARDED
:
1679 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1680 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1681 error ("Symbol %s may not be buffer-local",
1682 SDATA (SYMBOL_NAME (variable
)));
1684 default: emacs_abort ();
1688 error ("Symbol %s may not be buffer-local",
1689 SDATA (SYMBOL_NAME (variable
)));
1691 if (blv
? blv
->local_if_set
1692 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1694 tem
= Fboundp (variable
);
1695 /* Make sure the symbol has a local value in this particular buffer,
1696 by setting it to the same value it already has. */
1697 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1702 blv
= make_blv (sym
, forwarded
, valcontents
);
1703 sym
->redirect
= SYMBOL_LOCALIZED
;
1704 SET_SYMBOL_BLV (sym
, blv
);
1707 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1708 if (let_shadows_global_binding_p (symbol
))
1709 message ("Making %s local to %s while let-bound!",
1710 SDATA (SYMBOL_NAME (variable
)),
1711 SDATA (BVAR (current_buffer
, name
)));
1715 /* Make sure this buffer has its own value of symbol. */
1716 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1717 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1720 if (let_shadows_buffer_binding_p (sym
))
1721 message ("Making %s buffer-local while locally let-bound!",
1722 SDATA (SYMBOL_NAME (variable
)));
1724 /* Swap out any local binding for some other buffer, and make
1725 sure the current value is permanently recorded, if it's the
1727 find_symbol_value (variable
);
1729 bset_local_var_alist
1731 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1732 BVAR (current_buffer
, local_var_alist
)));
1734 /* Make sure symbol does not think it is set up for this buffer;
1735 force it to look once again for this buffer's value. */
1736 if (current_buffer
== XBUFFER (blv
->where
))
1737 set_blv_where (blv
, Qnil
);
1738 set_blv_found (blv
, 0);
1741 /* If the symbol forwards into a C variable, then load the binding
1742 for this buffer now. If C code modifies the variable before we
1743 load the binding in, then that new value will clobber the default
1744 binding the next time we unload it. */
1746 swap_in_symval_forwarding (sym
, blv
);
1751 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1752 1, 1, "vKill Local Variable: ",
1753 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1754 From now on the default value will apply in this buffer. Return VARIABLE. */)
1755 (register Lisp_Object variable
)
1757 register Lisp_Object tem
;
1758 struct Lisp_Buffer_Local_Value
*blv
;
1759 struct Lisp_Symbol
*sym
;
1761 CHECK_SYMBOL (variable
);
1762 sym
= XSYMBOL (variable
);
1765 switch (sym
->redirect
)
1767 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1768 case SYMBOL_PLAINVAL
: return variable
;
1769 case SYMBOL_FORWARDED
:
1771 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1772 if (BUFFER_OBJFWDP (valcontents
))
1774 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1775 int idx
= PER_BUFFER_IDX (offset
);
1779 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1780 set_per_buffer_value (current_buffer
, offset
,
1781 per_buffer_default (offset
));
1786 case SYMBOL_LOCALIZED
:
1787 blv
= SYMBOL_BLV (sym
);
1788 if (blv
->frame_local
)
1791 default: emacs_abort ();
1794 /* Get rid of this buffer's alist element, if any. */
1795 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1796 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1798 bset_local_var_alist
1800 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1802 /* If the symbol is set up with the current buffer's binding
1803 loaded, recompute its value. We have to do it now, or else
1804 forwarded objects won't work right. */
1806 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1807 if (EQ (buf
, blv
->where
))
1809 set_blv_where (blv
, Qnil
);
1811 find_symbol_value (variable
);
1818 /* Lisp functions for creating and removing buffer-local variables. */
1820 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1821 when/if this is removed. */
1823 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1824 1, 1, "vMake Variable Frame Local: ",
1825 doc
: /* Enable VARIABLE to have frame-local bindings.
1826 This does not create any frame-local bindings for VARIABLE,
1827 it just makes them possible.
1829 A frame-local binding is actually a frame parameter value.
1830 If a frame F has a value for the frame parameter named VARIABLE,
1831 that also acts as a frame-local binding for VARIABLE in F--
1832 provided this function has been called to enable VARIABLE
1833 to have frame-local bindings at all.
1835 The only way to create a frame-local binding for VARIABLE in a frame
1836 is to set the VARIABLE frame parameter of that frame. See
1837 `modify-frame-parameters' for how to set frame parameters.
1839 Note that since Emacs 23.1, variables cannot be both buffer-local and
1840 frame-local any more (buffer-local bindings used to take precedence over
1841 frame-local bindings). */)
1842 (Lisp_Object variable
)
1845 union Lisp_Val_Fwd valcontents
;
1846 struct Lisp_Symbol
*sym
;
1847 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1849 CHECK_SYMBOL (variable
);
1850 sym
= XSYMBOL (variable
);
1853 switch (sym
->redirect
)
1855 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1856 case SYMBOL_PLAINVAL
:
1857 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1858 if (EQ (valcontents
.value
, Qunbound
))
1859 valcontents
.value
= Qnil
;
1861 case SYMBOL_LOCALIZED
:
1862 if (SYMBOL_BLV (sym
)->frame_local
)
1865 error ("Symbol %s may not be frame-local",
1866 SDATA (SYMBOL_NAME (variable
)));
1867 case SYMBOL_FORWARDED
:
1868 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1869 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1870 error ("Symbol %s may not be frame-local",
1871 SDATA (SYMBOL_NAME (variable
)));
1873 default: emacs_abort ();
1877 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1879 blv
= make_blv (sym
, forwarded
, valcontents
);
1880 blv
->frame_local
= 1;
1881 sym
->redirect
= SYMBOL_LOCALIZED
;
1882 SET_SYMBOL_BLV (sym
, blv
);
1885 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1886 if (let_shadows_global_binding_p (symbol
))
1887 message ("Making %s frame-local while let-bound!",
1888 SDATA (SYMBOL_NAME (variable
)));
1893 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1895 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1896 BUFFER defaults to the current buffer. */)
1897 (register Lisp_Object variable
, Lisp_Object buffer
)
1899 register struct buffer
*buf
;
1900 struct Lisp_Symbol
*sym
;
1903 buf
= current_buffer
;
1906 CHECK_BUFFER (buffer
);
1907 buf
= XBUFFER (buffer
);
1910 CHECK_SYMBOL (variable
);
1911 sym
= XSYMBOL (variable
);
1914 switch (sym
->redirect
)
1916 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1917 case SYMBOL_PLAINVAL
: return Qnil
;
1918 case SYMBOL_LOCALIZED
:
1920 Lisp_Object tail
, elt
, tmp
;
1921 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1922 XSETBUFFER (tmp
, buf
);
1923 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1925 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1926 return blv_found (blv
) ? Qt
: Qnil
;
1928 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1931 if (EQ (variable
, XCAR (elt
)))
1933 eassert (!blv
->frame_local
);
1939 case SYMBOL_FORWARDED
:
1941 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1942 if (BUFFER_OBJFWDP (valcontents
))
1944 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1945 int idx
= PER_BUFFER_IDX (offset
);
1946 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1951 default: emacs_abort ();
1955 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1957 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1958 BUFFER defaults to the current buffer.
1960 More precisely, return non-nil if either VARIABLE already has a local
1961 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1962 `make-variable-buffer-local'). */)
1963 (register Lisp_Object variable
, Lisp_Object buffer
)
1965 struct Lisp_Symbol
*sym
;
1967 CHECK_SYMBOL (variable
);
1968 sym
= XSYMBOL (variable
);
1971 switch (sym
->redirect
)
1973 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1974 case SYMBOL_PLAINVAL
: return Qnil
;
1975 case SYMBOL_LOCALIZED
:
1977 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1978 if (blv
->local_if_set
)
1980 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1981 return Flocal_variable_p (variable
, buffer
);
1983 case SYMBOL_FORWARDED
:
1984 /* All BUFFER_OBJFWD slots become local if they are set. */
1985 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1986 default: emacs_abort ();
1990 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1992 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1993 If the current binding is buffer-local, the value is the current buffer.
1994 If the current binding is frame-local, the value is the selected frame.
1995 If the current binding is global (the default), the value is nil. */)
1996 (register Lisp_Object variable
)
1998 struct Lisp_Symbol
*sym
;
2000 CHECK_SYMBOL (variable
);
2001 sym
= XSYMBOL (variable
);
2003 /* Make sure the current binding is actually swapped in. */
2004 find_symbol_value (variable
);
2007 switch (sym
->redirect
)
2009 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2010 case SYMBOL_PLAINVAL
: return Qnil
;
2011 case SYMBOL_FORWARDED
:
2013 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2014 if (KBOARD_OBJFWDP (valcontents
))
2015 return Fframe_terminal (selected_frame
);
2016 else if (!BUFFER_OBJFWDP (valcontents
))
2020 case SYMBOL_LOCALIZED
:
2021 /* For a local variable, record both the symbol and which
2022 buffer's or frame's value we are saving. */
2023 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2024 return Fcurrent_buffer ();
2025 else if (sym
->redirect
== SYMBOL_LOCALIZED
2026 && blv_found (SYMBOL_BLV (sym
)))
2027 return SYMBOL_BLV (sym
)->where
;
2030 default: emacs_abort ();
2034 /* This code is disabled now that we use the selected frame to return
2035 keyboard-local-values. */
2037 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2039 DEFUN ("terminal-local-value", Fterminal_local_value
,
2040 Sterminal_local_value
, 2, 2, 0,
2041 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2042 If SYMBOL is not a terminal-local variable, then return its normal
2043 value, like `symbol-value'.
2045 TERMINAL may be a terminal object, a frame, or nil (meaning the
2046 selected frame's terminal device). */)
2047 (Lisp_Object symbol
, Lisp_Object terminal
)
2050 struct terminal
*t
= get_terminal (terminal
, 1);
2051 push_kboard (t
->kboard
);
2052 result
= Fsymbol_value (symbol
);
2057 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2058 Sset_terminal_local_value
, 3, 3, 0,
2059 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2060 If VARIABLE is not a terminal-local variable, then set its normal
2061 binding, like `set'.
2063 TERMINAL may be a terminal object, a frame, or nil (meaning the
2064 selected frame's terminal device). */)
2065 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2068 struct terminal
*t
= get_terminal (terminal
, 1);
2069 push_kboard (d
->kboard
);
2070 result
= Fset (symbol
, value
);
2076 /* Find the function at the end of a chain of symbol function indirections. */
2078 /* If OBJECT is a symbol, find the end of its function chain and
2079 return the value found there. If OBJECT is not a symbol, just
2080 return it. If there is a cycle in the function chain, signal a
2081 cyclic-function-indirection error.
2083 This is like Findirect_function, except that it doesn't signal an
2084 error if the chain ends up unbound. */
2086 indirect_function (register Lisp_Object object
)
2088 Lisp_Object tortoise
, hare
;
2090 hare
= tortoise
= object
;
2094 if (!SYMBOLP (hare
) || NILP (hare
))
2096 hare
= XSYMBOL (hare
)->function
;
2097 if (!SYMBOLP (hare
) || NILP (hare
))
2099 hare
= XSYMBOL (hare
)->function
;
2101 tortoise
= XSYMBOL (tortoise
)->function
;
2103 if (EQ (hare
, tortoise
))
2104 xsignal1 (Qcyclic_function_indirection
, object
);
2110 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2111 doc
: /* Return the function at the end of OBJECT's function chain.
2112 If OBJECT is not a symbol, just return it. Otherwise, follow all
2113 function indirections to find the final function binding and return it.
2114 If the final symbol in the chain is unbound, signal a void-function error.
2115 Optional arg NOERROR non-nil means to return nil instead of signaling.
2116 Signal a cyclic-function-indirection error if there is a loop in the
2117 function chain of symbols. */)
2118 (register Lisp_Object object
, Lisp_Object noerror
)
2122 /* Optimize for no indirection. */
2124 if (SYMBOLP (result
) && !NILP (result
)
2125 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2126 result
= indirect_function (result
);
2131 xsignal1 (Qvoid_function
, object
);
2136 /* Extract and set vector and string elements. */
2138 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2139 doc
: /* Return the element of ARRAY at index IDX.
2140 ARRAY may be a vector, a string, a char-table, a bool-vector,
2141 or a byte-code object. IDX starts at 0. */)
2142 (register Lisp_Object array
, Lisp_Object idx
)
2144 register EMACS_INT idxval
;
2147 idxval
= XINT (idx
);
2148 if (STRINGP (array
))
2151 ptrdiff_t idxval_byte
;
2153 if (idxval
< 0 || idxval
>= SCHARS (array
))
2154 args_out_of_range (array
, idx
);
2155 if (! STRING_MULTIBYTE (array
))
2156 return make_number ((unsigned char) SREF (array
, idxval
));
2157 idxval_byte
= string_char_to_byte (array
, idxval
);
2159 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2160 return make_number (c
);
2162 else if (BOOL_VECTOR_P (array
))
2166 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2167 args_out_of_range (array
, idx
);
2169 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2170 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2172 else if (CHAR_TABLE_P (array
))
2174 CHECK_CHARACTER (idx
);
2175 return CHAR_TABLE_REF (array
, idxval
);
2180 if (VECTORP (array
))
2181 size
= ASIZE (array
);
2182 else if (COMPILEDP (array
))
2183 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2185 wrong_type_argument (Qarrayp
, array
);
2187 if (idxval
< 0 || idxval
>= size
)
2188 args_out_of_range (array
, idx
);
2189 return AREF (array
, idxval
);
2193 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2194 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2195 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2196 bool-vector. IDX starts at 0. */)
2197 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2199 register EMACS_INT idxval
;
2202 idxval
= XINT (idx
);
2203 CHECK_ARRAY (array
, Qarrayp
);
2204 CHECK_IMPURE (array
);
2206 if (VECTORP (array
))
2208 if (idxval
< 0 || idxval
>= ASIZE (array
))
2209 args_out_of_range (array
, idx
);
2210 ASET (array
, idxval
, newelt
);
2212 else if (BOOL_VECTOR_P (array
))
2216 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2217 args_out_of_range (array
, idx
);
2219 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2221 if (! NILP (newelt
))
2222 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2224 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2225 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2227 else if (CHAR_TABLE_P (array
))
2229 CHECK_CHARACTER (idx
);
2230 CHAR_TABLE_SET (array
, idxval
, newelt
);
2236 if (idxval
< 0 || idxval
>= SCHARS (array
))
2237 args_out_of_range (array
, idx
);
2238 CHECK_CHARACTER (newelt
);
2239 c
= XFASTINT (newelt
);
2241 if (STRING_MULTIBYTE (array
))
2243 ptrdiff_t idxval_byte
, nbytes
;
2244 int prev_bytes
, new_bytes
;
2245 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2247 nbytes
= SBYTES (array
);
2248 idxval_byte
= string_char_to_byte (array
, idxval
);
2249 p1
= SDATA (array
) + idxval_byte
;
2250 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2251 new_bytes
= CHAR_STRING (c
, p0
);
2252 if (prev_bytes
!= new_bytes
)
2254 /* We must relocate the string data. */
2255 ptrdiff_t nchars
= SCHARS (array
);
2257 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2259 memcpy (str
, SDATA (array
), nbytes
);
2260 allocate_string_data (XSTRING (array
), nchars
,
2261 nbytes
+ new_bytes
- prev_bytes
);
2262 memcpy (SDATA (array
), str
, idxval_byte
);
2263 p1
= SDATA (array
) + idxval_byte
;
2264 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2265 nbytes
- (idxval_byte
+ prev_bytes
));
2267 clear_string_char_byte_cache ();
2274 if (! SINGLE_BYTE_CHAR_P (c
))
2278 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2279 if (SREF (array
, i
) >= 0x80)
2280 args_out_of_range (array
, newelt
);
2281 /* ARRAY is an ASCII string. Convert it to a multibyte
2282 string, and try `aset' again. */
2283 STRING_SET_MULTIBYTE (array
);
2284 return Faset (array
, idx
, newelt
);
2286 SSET (array
, idxval
, c
);
2293 /* Arithmetic functions */
2295 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2298 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2300 double f1
= 0, f2
= 0;
2303 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2304 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2306 if (FLOATP (num1
) || FLOATP (num2
))
2309 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2310 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2316 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2321 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2326 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2331 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2336 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2341 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2350 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2351 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2352 (register Lisp_Object num1
, Lisp_Object num2
)
2354 return arithcompare (num1
, num2
, equal
);
2357 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2358 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2359 (register Lisp_Object num1
, Lisp_Object num2
)
2361 return arithcompare (num1
, num2
, less
);
2364 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2365 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2366 (register Lisp_Object num1
, Lisp_Object num2
)
2368 return arithcompare (num1
, num2
, grtr
);
2371 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2372 doc
: /* Return t if first arg is less than or equal to second arg.
2373 Both must be numbers or markers. */)
2374 (register Lisp_Object num1
, Lisp_Object num2
)
2376 return arithcompare (num1
, num2
, less_or_equal
);
2379 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2380 doc
: /* Return t if first arg is greater than or equal to second arg.
2381 Both must be numbers or markers. */)
2382 (register Lisp_Object num1
, Lisp_Object num2
)
2384 return arithcompare (num1
, num2
, grtr_or_equal
);
2387 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2388 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2389 (register Lisp_Object num1
, Lisp_Object num2
)
2391 return arithcompare (num1
, num2
, notequal
);
2394 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2395 doc
: /* Return t if NUMBER is zero. */)
2396 (register Lisp_Object number
)
2398 CHECK_NUMBER_OR_FLOAT (number
);
2400 if (FLOATP (number
))
2402 if (XFLOAT_DATA (number
) == 0.0)
2412 /* Convert the cons-of-integers, integer, or float value C to an
2413 unsigned value with maximum value MAX. Signal an error if C does not
2414 have a valid format or is out of range. */
2416 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2419 uintmax_t val
IF_LINT (= 0);
2422 valid
= 0 <= XINT (c
);
2425 else if (FLOATP (c
))
2427 double d
= XFLOAT_DATA (c
);
2429 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2435 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2437 uintmax_t top
= XFASTINT (XCAR (c
));
2438 Lisp_Object rest
= XCDR (c
);
2439 if (top
<= UINTMAX_MAX
>> 24 >> 16
2441 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2442 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2444 uintmax_t mid
= XFASTINT (XCAR (rest
));
2445 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2448 else if (top
<= UINTMAX_MAX
>> 16)
2452 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2454 val
= top
<< 16 | XFASTINT (rest
);
2460 if (! (valid
&& val
<= max
))
2461 error ("Not an in-range integer, float, or cons of integers");
2465 /* Convert the cons-of-integers, integer, or float value C to a signed
2466 value with extrema MIN and MAX. Signal an error if C does not have
2467 a valid format or is out of range. */
2469 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2472 intmax_t val
IF_LINT (= 0);
2478 else if (FLOATP (c
))
2480 double d
= XFLOAT_DATA (c
);
2482 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2488 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2490 intmax_t top
= XINT (XCAR (c
));
2491 Lisp_Object rest
= XCDR (c
);
2492 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2494 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2495 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2497 intmax_t mid
= XFASTINT (XCAR (rest
));
2498 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2501 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2505 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2507 val
= top
<< 16 | XFASTINT (rest
);
2513 if (! (valid
&& min
<= val
&& val
<= max
))
2514 error ("Not an in-range integer, float, or cons of integers");
2518 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2519 doc
: /* Return the decimal representation of NUMBER as a string.
2520 Uses a minus sign if negative.
2521 NUMBER may be an integer or a floating point number. */)
2522 (Lisp_Object number
)
2524 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2527 CHECK_NUMBER_OR_FLOAT (number
);
2529 if (FLOATP (number
))
2530 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2532 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2534 return make_unibyte_string (buffer
, len
);
2537 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2538 doc
: /* Parse STRING as a decimal number and return the number.
2539 This parses both integers and floating point numbers.
2540 It ignores leading spaces and tabs, and all trailing chars.
2542 If BASE, interpret STRING as a number in that base. If BASE isn't
2543 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2544 If the base used is not 10, STRING is always parsed as integer. */)
2545 (register Lisp_Object string
, Lisp_Object base
)
2551 CHECK_STRING (string
);
2557 CHECK_NUMBER (base
);
2558 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2559 xsignal1 (Qargs_out_of_range
, base
);
2563 p
= SSDATA (string
);
2564 while (*p
== ' ' || *p
== '\t')
2567 val
= string_to_number (p
, b
, 1);
2568 return NILP (val
) ? make_number (0) : val
;
2584 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2585 ptrdiff_t, Lisp_Object
*);
2587 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2590 ptrdiff_t argnum
, ok_args
;
2591 EMACS_INT accum
= 0;
2592 EMACS_INT next
, ok_accum
;
2613 for (argnum
= 0; argnum
< nargs
; argnum
++)
2621 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2623 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2626 return float_arith_driver (ok_accum
, ok_args
, code
,
2629 next
= XINT (args
[argnum
]);
2633 if (INT_ADD_OVERFLOW (accum
, next
))
2641 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2646 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2649 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2651 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2653 accum
= ab
& INTMASK
;
2664 xsignal0 (Qarith_error
);
2678 if (!argnum
|| next
> accum
)
2682 if (!argnum
|| next
< accum
)
2688 XSETINT (val
, accum
);
2693 #define isnan(x) ((x) != (x))
2696 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2697 ptrdiff_t nargs
, Lisp_Object
*args
)
2699 register Lisp_Object val
;
2702 for (; argnum
< nargs
; argnum
++)
2704 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2705 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2709 next
= XFLOAT_DATA (val
);
2713 args
[argnum
] = val
; /* runs into a compiler bug. */
2714 next
= XINT (args
[argnum
]);
2722 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2732 if (! IEEE_FLOATING_POINT
&& next
== 0)
2733 xsignal0 (Qarith_error
);
2740 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2742 if (!argnum
|| isnan (next
) || next
> accum
)
2746 if (!argnum
|| isnan (next
) || next
< accum
)
2752 return make_float (accum
);
2756 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2757 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2758 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2759 (ptrdiff_t nargs
, Lisp_Object
*args
)
2761 return arith_driver (Aadd
, nargs
, args
);
2764 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2765 doc
: /* Negate number or subtract numbers or markers and return the result.
2766 With one arg, negates it. With more than one arg,
2767 subtracts all but the first from the first.
2768 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2769 (ptrdiff_t nargs
, Lisp_Object
*args
)
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) */)
2777 (ptrdiff_t nargs
, Lisp_Object
*args
)
2779 return arith_driver (Amult
, nargs
, args
);
2782 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2783 doc
: /* Return first argument divided by all the remaining arguments.
2784 The arguments must be numbers or markers.
2785 usage: (/ DIVIDEND &rest DIVISORS) */)
2786 (ptrdiff_t nargs
, Lisp_Object
*args
)
2789 for (argnum
= 2; argnum
< nargs
; argnum
++)
2790 if (FLOATP (args
[argnum
]))
2791 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2792 return arith_driver (Adiv
, nargs
, args
);
2795 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2796 doc
: /* Return remainder of X divided by Y.
2797 Both must be integers or markers. */)
2798 (register Lisp_Object x
, Lisp_Object y
)
2802 CHECK_NUMBER_COERCE_MARKER (x
);
2803 CHECK_NUMBER_COERCE_MARKER (y
);
2806 xsignal0 (Qarith_error
);
2808 XSETINT (val
, XINT (x
) % XINT (y
));
2812 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2813 doc
: /* Return X modulo Y.
2814 The result falls between zero (inclusive) and Y (exclusive).
2815 Both X and Y must be numbers or markers. */)
2816 (register Lisp_Object x
, Lisp_Object y
)
2821 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2822 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2824 if (FLOATP (x
) || FLOATP (y
))
2825 return fmod_float (x
, y
);
2831 xsignal0 (Qarith_error
);
2835 /* If the "remainder" comes out with the wrong sign, fix it. */
2836 if (i2
< 0 ? i1
> 0 : i1
< 0)
2843 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2844 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2845 The value is always a number; markers are converted to numbers.
2846 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2847 (ptrdiff_t nargs
, Lisp_Object
*args
)
2849 return arith_driver (Amax
, nargs
, args
);
2852 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2853 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2854 The value is always a number; markers are converted to numbers.
2855 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2856 (ptrdiff_t nargs
, Lisp_Object
*args
)
2858 return arith_driver (Amin
, nargs
, args
);
2861 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2862 doc
: /* Return bitwise-and of all the arguments.
2863 Arguments may be integers, or markers converted to integers.
2864 usage: (logand &rest INTS-OR-MARKERS) */)
2865 (ptrdiff_t nargs
, Lisp_Object
*args
)
2867 return arith_driver (Alogand
, nargs
, args
);
2870 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2871 doc
: /* Return bitwise-or of all the arguments.
2872 Arguments may be integers, or markers converted to integers.
2873 usage: (logior &rest INTS-OR-MARKERS) */)
2874 (ptrdiff_t nargs
, Lisp_Object
*args
)
2876 return arith_driver (Alogior
, nargs
, args
);
2879 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2880 doc
: /* Return bitwise-exclusive-or of all the arguments.
2881 Arguments may be integers, or markers converted to integers.
2882 usage: (logxor &rest INTS-OR-MARKERS) */)
2883 (ptrdiff_t nargs
, Lisp_Object
*args
)
2885 return arith_driver (Alogxor
, nargs
, args
);
2888 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2889 doc
: /* Return VALUE with its bits shifted left by COUNT.
2890 If COUNT is negative, shifting is actually to the right.
2891 In this case, the sign bit is duplicated. */)
2892 (register Lisp_Object value
, Lisp_Object count
)
2894 register Lisp_Object val
;
2896 CHECK_NUMBER (value
);
2897 CHECK_NUMBER (count
);
2899 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2901 else if (XINT (count
) > 0)
2902 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2903 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2904 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2906 XSETINT (val
, XINT (value
) >> -XINT (count
));
2910 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2911 doc
: /* Return VALUE with its bits shifted left by COUNT.
2912 If COUNT is negative, shifting is actually to the right.
2913 In this case, zeros are shifted in on the left. */)
2914 (register Lisp_Object value
, Lisp_Object count
)
2916 register Lisp_Object val
;
2918 CHECK_NUMBER (value
);
2919 CHECK_NUMBER (count
);
2921 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2923 else if (XINT (count
) > 0)
2924 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2925 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2928 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2932 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2933 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2934 Markers are converted to integers. */)
2935 (register Lisp_Object number
)
2937 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2939 if (FLOATP (number
))
2940 return (make_float (1.0 + XFLOAT_DATA (number
)));
2942 XSETINT (number
, XINT (number
) + 1);
2946 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2947 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2948 Markers are converted to integers. */)
2949 (register Lisp_Object number
)
2951 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2953 if (FLOATP (number
))
2954 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2956 XSETINT (number
, XINT (number
) - 1);
2960 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2961 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2962 (register Lisp_Object number
)
2964 CHECK_NUMBER (number
);
2965 XSETINT (number
, ~XINT (number
));
2969 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2970 doc
: /* Return the byteorder for the machine.
2971 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2972 lowercase l) for small endian machines. */)
2975 unsigned i
= 0x04030201;
2976 int order
= *(char *)&i
== 1 ? 108 : 66;
2978 return make_number (order
);
2986 Lisp_Object error_tail
, arith_tail
;
2988 DEFSYM (Qquote
, "quote");
2989 DEFSYM (Qlambda
, "lambda");
2990 DEFSYM (Qsubr
, "subr");
2991 DEFSYM (Qerror_conditions
, "error-conditions");
2992 DEFSYM (Qerror_message
, "error-message");
2993 DEFSYM (Qtop_level
, "top-level");
2995 DEFSYM (Qerror
, "error");
2996 DEFSYM (Quser_error
, "user-error");
2997 DEFSYM (Qquit
, "quit");
2998 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2999 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3000 DEFSYM (Qvoid_function
, "void-function");
3001 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3002 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3003 DEFSYM (Qvoid_variable
, "void-variable");
3004 DEFSYM (Qsetting_constant
, "setting-constant");
3005 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3007 DEFSYM (Qinvalid_function
, "invalid-function");
3008 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3009 DEFSYM (Qno_catch
, "no-catch");
3010 DEFSYM (Qend_of_file
, "end-of-file");
3011 DEFSYM (Qarith_error
, "arith-error");
3012 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3013 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3014 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3015 DEFSYM (Qtext_read_only
, "text-read-only");
3016 DEFSYM (Qmark_inactive
, "mark-inactive");
3018 DEFSYM (Qlistp
, "listp");
3019 DEFSYM (Qconsp
, "consp");
3020 DEFSYM (Qsymbolp
, "symbolp");
3021 DEFSYM (Qkeywordp
, "keywordp");
3022 DEFSYM (Qintegerp
, "integerp");
3023 DEFSYM (Qnatnump
, "natnump");
3024 DEFSYM (Qwholenump
, "wholenump");
3025 DEFSYM (Qstringp
, "stringp");
3026 DEFSYM (Qarrayp
, "arrayp");
3027 DEFSYM (Qsequencep
, "sequencep");
3028 DEFSYM (Qbufferp
, "bufferp");
3029 DEFSYM (Qvectorp
, "vectorp");
3030 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3031 DEFSYM (Qmarkerp
, "markerp");
3032 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3033 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3034 DEFSYM (Qboundp
, "boundp");
3035 DEFSYM (Qfboundp
, "fboundp");
3037 DEFSYM (Qfloatp
, "floatp");
3038 DEFSYM (Qnumberp
, "numberp");
3039 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3041 DEFSYM (Qchar_table_p
, "char-table-p");
3042 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3044 DEFSYM (Qsubrp
, "subrp");
3045 DEFSYM (Qunevalled
, "unevalled");
3046 DEFSYM (Qmany
, "many");
3048 DEFSYM (Qcdr
, "cdr");
3050 /* Handle automatic advice activation. */
3051 DEFSYM (Qad_advice_info
, "ad-advice-info");
3052 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3054 error_tail
= pure_cons (Qerror
, Qnil
);
3056 /* ERROR is used as a signaler for random errors for which nothing else is
3059 Fput (Qerror
, Qerror_conditions
,
3061 Fput (Qerror
, Qerror_message
,
3062 build_pure_c_string ("error"));
3064 #define PUT_ERROR(sym, tail, msg) \
3065 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3066 Fput (sym, Qerror_message, build_pure_c_string (msg))
3068 PUT_ERROR (Qquit
, Qnil
, "Quit");
3070 PUT_ERROR (Quser_error
, error_tail
, "");
3071 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3072 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3073 PUT_ERROR (Qvoid_function
, error_tail
,
3074 "Symbol's function definition is void");
3075 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3076 "Symbol's chain of function indirections contains a loop");
3077 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3078 "Symbol's chain of variable indirections contains a loop");
3079 DEFSYM (Qcircular_list
, "circular-list");
3080 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3081 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3082 PUT_ERROR (Qsetting_constant
, error_tail
,
3083 "Attempt to set a constant symbol");
3084 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3085 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3086 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3087 "Wrong number of arguments");
3088 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3089 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3091 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3092 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3093 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3095 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3096 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3097 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3098 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3099 "Text is read-only");
3101 DEFSYM (Qrange_error
, "range-error");
3102 DEFSYM (Qdomain_error
, "domain-error");
3103 DEFSYM (Qsingularity_error
, "singularity-error");
3104 DEFSYM (Qoverflow_error
, "overflow-error");
3105 DEFSYM (Qunderflow_error
, "underflow-error");
3107 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3109 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3111 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3112 "Arithmetic singularity error");
3114 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3115 "Arithmetic overflow error");
3116 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3117 "Arithmetic underflow error");
3121 staticpro (&Qunbound
);
3123 /* Types that type-of returns. */
3124 DEFSYM (Qinteger
, "integer");
3125 DEFSYM (Qsymbol
, "symbol");
3126 DEFSYM (Qstring
, "string");
3127 DEFSYM (Qcons
, "cons");
3128 DEFSYM (Qmarker
, "marker");
3129 DEFSYM (Qoverlay
, "overlay");
3130 DEFSYM (Qfloat
, "float");
3131 DEFSYM (Qwindow_configuration
, "window-configuration");
3132 DEFSYM (Qprocess
, "process");
3133 DEFSYM (Qwindow
, "window");
3134 DEFSYM (Qcompiled_function
, "compiled-function");
3135 DEFSYM (Qbuffer
, "buffer");
3136 DEFSYM (Qframe
, "frame");
3137 DEFSYM (Qvector
, "vector");
3138 DEFSYM (Qchar_table
, "char-table");
3139 DEFSYM (Qbool_vector
, "bool-vector");
3140 DEFSYM (Qhash_table
, "hash-table");
3141 DEFSYM (Qthread
, "thread");
3142 DEFSYM (Qmutex
, "mutex");
3143 DEFSYM (Qcondition_variable
, "condition-variable");
3144 DEFSYM (Qmisc
, "misc");
3146 DEFSYM (Qdefun
, "defun");
3148 DEFSYM (Qfont_spec
, "font-spec");
3149 DEFSYM (Qfont_entity
, "font-entity");
3150 DEFSYM (Qfont_object
, "font-object");
3152 DEFSYM (Qinteractive_form
, "interactive-form");
3153 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3155 defsubr (&Sindirect_variable
);
3156 defsubr (&Sinteractive_form
);
3159 defsubr (&Stype_of
);
3164 defsubr (&Sintegerp
);
3165 defsubr (&Sinteger_or_marker_p
);
3166 defsubr (&Snumberp
);
3167 defsubr (&Snumber_or_marker_p
);
3169 defsubr (&Snatnump
);
3170 defsubr (&Ssymbolp
);
3171 defsubr (&Skeywordp
);
3172 defsubr (&Sstringp
);
3173 defsubr (&Smultibyte_string_p
);
3174 defsubr (&Svectorp
);
3175 defsubr (&Schar_table_p
);
3176 defsubr (&Svector_or_char_table_p
);
3177 defsubr (&Sbool_vector_p
);
3179 defsubr (&Ssequencep
);
3180 defsubr (&Sbufferp
);
3181 defsubr (&Smarkerp
);
3183 defsubr (&Sbyte_code_function_p
);
3184 defsubr (&Schar_or_string_p
);
3185 defsubr (&Sthreadp
);
3187 defsubr (&Scondition_variable_p
);
3190 defsubr (&Scar_safe
);
3191 defsubr (&Scdr_safe
);
3194 defsubr (&Ssymbol_function
);
3195 defsubr (&Sindirect_function
);
3196 defsubr (&Ssymbol_plist
);
3197 defsubr (&Ssymbol_name
);
3198 defsubr (&Smakunbound
);
3199 defsubr (&Sfmakunbound
);
3201 defsubr (&Sfboundp
);
3203 defsubr (&Sdefalias
);
3204 defsubr (&Ssetplist
);
3205 defsubr (&Ssymbol_value
);
3207 defsubr (&Sdefault_boundp
);
3208 defsubr (&Sdefault_value
);
3209 defsubr (&Sset_default
);
3210 defsubr (&Ssetq_default
);
3211 defsubr (&Smake_variable_buffer_local
);
3212 defsubr (&Smake_local_variable
);
3213 defsubr (&Skill_local_variable
);
3214 defsubr (&Smake_variable_frame_local
);
3215 defsubr (&Slocal_variable_p
);
3216 defsubr (&Slocal_variable_if_set_p
);
3217 defsubr (&Svariable_binding_locus
);
3218 #if 0 /* XXX Remove this. --lorentey */
3219 defsubr (&Sterminal_local_value
);
3220 defsubr (&Sset_terminal_local_value
);
3224 defsubr (&Snumber_to_string
);
3225 defsubr (&Sstring_to_number
);
3226 defsubr (&Seqlsign
);
3249 defsubr (&Sbyteorder
);
3250 defsubr (&Ssubr_arity
);
3251 defsubr (&Ssubr_name
);
3253 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3255 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3256 doc
: /* The largest value that is representable in a Lisp integer. */);
3257 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3258 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3260 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3261 doc
: /* The smallest value that is representable in a Lisp integer. */);
3262 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3263 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;