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
;
84 Lisp_Object Qinteractive_form
;
85 static Lisp_Object Qdefalias_fset_function
;
87 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
90 BOOLFWDP (union Lisp_Fwd
*a
)
92 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
95 INTFWDP (union Lisp_Fwd
*a
)
97 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
100 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
102 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
105 OBJFWDP (union Lisp_Fwd
*a
)
107 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
110 static struct Lisp_Boolfwd
*
111 XBOOLFWD (union Lisp_Fwd
*a
)
113 eassert (BOOLFWDP (a
));
114 return &a
->u_boolfwd
;
116 static struct Lisp_Kboard_Objfwd
*
117 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
119 eassert (KBOARD_OBJFWDP (a
));
120 return &a
->u_kboard_objfwd
;
122 static struct Lisp_Intfwd
*
123 XINTFWD (union Lisp_Fwd
*a
)
125 eassert (INTFWDP (a
));
128 static struct Lisp_Objfwd
*
129 XOBJFWD (union Lisp_Fwd
*a
)
131 eassert (OBJFWDP (a
));
136 CHECK_SUBR (Lisp_Object x
)
138 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
142 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
144 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
149 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
151 return XCDR (blv
->valcell
);
155 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
157 XSETCDR (blv
->valcell
, val
);
161 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
167 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
173 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
179 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
181 /* If VALUE is not even a valid Lisp object, we'd want to abort here
182 where we can get a backtrace showing where it came from. We used
183 to try and do that by checking the tagbits, but nowadays all
184 tagbits are potentially valid. */
185 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
188 xsignal2 (Qwrong_type_argument
, predicate
, value
);
192 pure_write_error (Lisp_Object obj
)
194 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
198 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
200 xsignal2 (Qargs_out_of_range
, a1
, a2
);
204 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
206 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
210 /* Data type predicates. */
212 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
213 doc
: /* Return t if the two args are the same Lisp object. */)
214 (Lisp_Object obj1
, Lisp_Object obj2
)
221 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
222 doc
: /* Return t if OBJECT is nil. */)
230 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
231 doc
: /* Return a symbol representing the type of OBJECT.
232 The symbol returned names the object's basic type;
233 for example, (type-of 1) returns `integer'. */)
236 switch (XTYPE (object
))
251 switch (XMISCTYPE (object
))
253 case Lisp_Misc_Marker
:
255 case Lisp_Misc_Overlay
:
257 case Lisp_Misc_Float
:
262 case Lisp_Vectorlike
:
263 if (WINDOW_CONFIGURATIONP (object
))
264 return Qwindow_configuration
;
265 if (PROCESSP (object
))
267 if (WINDOWP (object
))
271 if (COMPILEDP (object
))
272 return Qcompiled_function
;
273 if (BUFFERP (object
))
275 if (CHAR_TABLE_P (object
))
277 if (BOOL_VECTOR_P (object
))
281 if (HASH_TABLE_P (object
))
283 if (FONT_SPEC_P (object
))
285 if (FONT_ENTITY_P (object
))
287 if (FONT_OBJECT_P (object
))
299 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
300 doc
: /* Return t if OBJECT is a cons cell. */)
308 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
309 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
317 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
318 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
319 Otherwise, return nil. */)
322 if (CONSP (object
) || NILP (object
))
327 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
328 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
331 if (CONSP (object
) || NILP (object
))
336 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
337 doc
: /* Return t if OBJECT is a symbol. */)
340 if (SYMBOLP (object
))
345 /* Define this in C to avoid unnecessarily consing up the symbol
347 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
348 doc
: /* Return t if OBJECT is a keyword.
349 This means that it is a symbol with a print name beginning with `:'
350 interned in the initial obarray. */)
354 && SREF (SYMBOL_NAME (object
), 0) == ':'
355 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
360 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
361 doc
: /* Return t if OBJECT is a vector. */)
364 if (VECTORP (object
))
369 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a string. */)
373 if (STRINGP (object
))
378 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
380 doc
: /* Return t if OBJECT is a multibyte string.
381 Return nil if OBJECT is either a unibyte string, or not a string. */)
384 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
389 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
390 doc
: /* Return t if OBJECT is a char-table. */)
393 if (CHAR_TABLE_P (object
))
398 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
399 Svector_or_char_table_p
, 1, 1, 0,
400 doc
: /* Return t if OBJECT is a char-table or vector. */)
403 if (VECTORP (object
) || CHAR_TABLE_P (object
))
408 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
409 doc
: /* Return t if OBJECT is a bool-vector. */)
412 if (BOOL_VECTOR_P (object
))
417 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is an array (string or vector). */)
426 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
427 doc
: /* Return t if OBJECT is a sequence (list or array). */)
428 (register Lisp_Object object
)
430 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
435 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
436 doc
: /* Return t if OBJECT is an editor buffer. */)
439 if (BUFFERP (object
))
444 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
445 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
448 if (MARKERP (object
))
453 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
454 doc
: /* Return t if OBJECT is a built-in function. */)
462 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
464 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
467 if (COMPILEDP (object
))
472 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
473 doc
: /* Return t if OBJECT is a character or a string. */)
474 (register Lisp_Object object
)
476 if (CHARACTERP (object
) || STRINGP (object
))
481 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
482 doc
: /* Return t if OBJECT is an integer. */)
485 if (INTEGERP (object
))
490 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
491 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
492 (register Lisp_Object object
)
494 if (MARKERP (object
) || INTEGERP (object
))
499 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
500 doc
: /* Return t if OBJECT is a nonnegative integer. */)
503 if (NATNUMP (object
))
508 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
509 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
512 if (NUMBERP (object
))
518 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
519 Snumber_or_marker_p
, 1, 1, 0,
520 doc
: /* Return t if OBJECT is a number or a marker. */)
523 if (NUMBERP (object
) || MARKERP (object
))
528 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
529 doc
: /* Return t if OBJECT is a floating point number. */)
538 /* Extract and set components of lists. */
540 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
541 doc
: /* Return the car of LIST. If arg is nil, return nil.
542 Error if arg is not nil and not a cons cell. See also `car-safe'.
544 See Info node `(elisp)Cons Cells' for a discussion of related basic
545 Lisp concepts such as car, cdr, cons cell and list. */)
546 (register Lisp_Object list
)
551 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
552 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
555 return CAR_SAFE (object
);
558 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
559 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
560 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
562 See Info node `(elisp)Cons Cells' for a discussion of related basic
563 Lisp concepts such as cdr, car, cons cell and list. */)
564 (register Lisp_Object list
)
569 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
570 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
573 return CDR_SAFE (object
);
576 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
577 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
578 (register Lisp_Object cell
, Lisp_Object newcar
)
582 XSETCAR (cell
, newcar
);
586 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
587 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
588 (register Lisp_Object cell
, Lisp_Object newcdr
)
592 XSETCDR (cell
, newcdr
);
596 /* Extract and set components of symbols. */
598 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
599 doc
: /* Return t if SYMBOL's value is not void.
600 Note that if `lexical-binding' is in effect, this refers to the
601 global value outside of any lexical scope. */)
602 (register Lisp_Object symbol
)
604 Lisp_Object valcontents
;
605 struct Lisp_Symbol
*sym
;
606 CHECK_SYMBOL (symbol
);
607 sym
= XSYMBOL (symbol
);
610 switch (sym
->redirect
)
612 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
613 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
614 case SYMBOL_LOCALIZED
:
616 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
618 /* In set_internal, we un-forward vars when their value is
623 swap_in_symval_forwarding (sym
, blv
);
624 valcontents
= blv_value (blv
);
628 case SYMBOL_FORWARDED
:
629 /* In set_internal, we un-forward vars when their value is
632 default: emacs_abort ();
635 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
638 /* FIXME: Make it an alias for function-symbol! */
639 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
640 doc
: /* Return t if SYMBOL's function definition is not void. */)
641 (register Lisp_Object symbol
)
643 CHECK_SYMBOL (symbol
);
644 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
647 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
648 doc
: /* Make SYMBOL's value be void.
650 (register Lisp_Object symbol
)
652 CHECK_SYMBOL (symbol
);
653 if (SYMBOL_CONSTANT_P (symbol
))
654 xsignal1 (Qsetting_constant
, symbol
);
655 Fset (symbol
, Qunbound
);
659 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
660 doc
: /* Make SYMBOL's function definition be nil.
662 (register Lisp_Object symbol
)
664 CHECK_SYMBOL (symbol
);
665 if (NILP (symbol
) || EQ (symbol
, Qt
))
666 xsignal1 (Qsetting_constant
, symbol
);
667 set_symbol_function (symbol
, Qnil
);
671 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
672 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
673 (register Lisp_Object symbol
)
675 CHECK_SYMBOL (symbol
);
676 return XSYMBOL (symbol
)->function
;
679 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
680 doc
: /* Return SYMBOL's property list. */)
681 (register Lisp_Object symbol
)
683 CHECK_SYMBOL (symbol
);
684 return XSYMBOL (symbol
)->plist
;
687 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
688 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. */)
700 (register Lisp_Object symbol
, Lisp_Object definition
)
702 register Lisp_Object function
;
703 CHECK_SYMBOL (symbol
);
705 function
= XSYMBOL (symbol
)->function
;
707 if (!NILP (Vautoload_queue
) && !NILP (function
))
708 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
710 if (AUTOLOADP (function
))
711 Fput (symbol
, Qautoload
, XCDR (function
));
713 set_symbol_function (symbol
, definition
);
718 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
719 doc
: /* Set SYMBOL's function definition to DEFINITION.
720 Associates the function with the current load file, if any.
721 The optional third argument DOCSTRING specifies the documentation string
722 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
723 determined by DEFINITION.
724 The return value is undefined. */)
725 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
727 CHECK_SYMBOL (symbol
);
728 if (!NILP (Vpurify_flag
)
729 /* If `definition' is a keymap, immutable (and copying) is wrong. */
730 && !KEYMAPP (definition
))
731 definition
= Fpurecopy (definition
);
734 bool autoload
= AUTOLOADP (definition
);
735 if (NILP (Vpurify_flag
) || !autoload
)
736 { /* Only add autoload entries after dumping, because the ones before are
737 not useful and else we get loads of them from the loaddefs.el. */
739 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
740 /* Remember that the function was already an autoload. */
741 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
742 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
746 { /* Handle automatic advice activation. */
747 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
749 call2 (hook
, symbol
, definition
);
751 Ffset (symbol
, definition
);
754 if (!NILP (docstring
))
755 Fput (symbol
, Qfunction_documentation
, docstring
);
756 /* We used to return `definition', but now that `defun' and `defmacro' expand
757 to a call to `defalias', we return `symbol' for backward compatibility
762 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
763 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
764 (register Lisp_Object symbol
, Lisp_Object newplist
)
766 CHECK_SYMBOL (symbol
);
767 set_symbol_plist (symbol
, newplist
);
771 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
772 doc
: /* Return minimum and maximum number of args allowed for SUBR.
773 SUBR must be a built-in function.
774 The returned value is a pair (MIN . MAX). MIN is the minimum number
775 of args. MAX is the maximum number or the symbol `many', for a
776 function with `&rest' args, or `unevalled' for a special form. */)
779 short minargs
, maxargs
;
781 minargs
= XSUBR (subr
)->min_args
;
782 maxargs
= XSUBR (subr
)->max_args
;
783 return Fcons (make_number (minargs
),
784 maxargs
== MANY
? Qmany
785 : maxargs
== UNEVALLED
? Qunevalled
786 : make_number (maxargs
));
789 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
790 doc
: /* Return name of subroutine SUBR.
791 SUBR must be a built-in function. */)
796 name
= XSUBR (subr
)->symbol_name
;
797 return build_string (name
);
800 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
801 doc
: /* Return the interactive form of CMD or nil if none.
802 If CMD is not a command, the return value is nil.
803 Value, if non-nil, is a list \(interactive SPEC). */)
806 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
811 /* Use an `interactive-form' property if present, analogous to the
812 function-documentation property. */
814 while (SYMBOLP (fun
))
816 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
820 fun
= Fsymbol_function (fun
);
825 const char *spec
= XSUBR (fun
)->intspec
;
827 return list2 (Qinteractive
,
828 (*spec
!= '(') ? build_string (spec
) :
829 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
831 else if (COMPILEDP (fun
))
833 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
834 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
836 else if (AUTOLOADP (fun
))
837 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
838 else if (CONSP (fun
))
840 Lisp_Object funcar
= XCAR (fun
);
841 if (EQ (funcar
, Qclosure
))
842 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
843 else if (EQ (funcar
, Qlambda
))
844 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
850 /***********************************************************************
851 Getting and Setting Values of Symbols
852 ***********************************************************************/
854 /* Return the symbol holding SYMBOL's value. Signal
855 `cyclic-variable-indirection' if SYMBOL's chain of variable
856 indirections contains a loop. */
859 indirect_variable (struct Lisp_Symbol
*symbol
)
861 struct Lisp_Symbol
*tortoise
, *hare
;
863 hare
= tortoise
= symbol
;
865 while (hare
->redirect
== SYMBOL_VARALIAS
)
867 hare
= SYMBOL_ALIAS (hare
);
868 if (hare
->redirect
!= SYMBOL_VARALIAS
)
871 hare
= SYMBOL_ALIAS (hare
);
872 tortoise
= SYMBOL_ALIAS (tortoise
);
874 if (hare
== tortoise
)
877 XSETSYMBOL (tem
, symbol
);
878 xsignal1 (Qcyclic_variable_indirection
, tem
);
886 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
887 doc
: /* Return the variable at the end of OBJECT's variable chain.
888 If OBJECT is a symbol, follow its variable indirections (if any), and
889 return the variable at the end of the chain of aliases. See Info node
890 `(elisp)Variable Aliases'.
892 If OBJECT is not a symbol, just return it. If there is a loop in the
893 chain of aliases, signal a `cyclic-variable-indirection' error. */)
896 if (SYMBOLP (object
))
898 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
899 XSETSYMBOL (object
, sym
);
905 /* Given the raw contents of a symbol value cell,
906 return the Lisp value of the symbol.
907 This does not handle buffer-local variables; use
908 swap_in_symval_forwarding for that. */
911 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
913 register Lisp_Object val
;
914 switch (XFWDTYPE (valcontents
))
917 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
921 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
924 return *XOBJFWD (valcontents
)->objvar
;
926 case Lisp_Fwd_Buffer_Obj
:
927 return per_buffer_value (current_buffer
,
928 XBUFFER_OBJFWD (valcontents
)->offset
);
930 case Lisp_Fwd_Kboard_Obj
:
931 /* We used to simply use current_kboard here, but from Lisp
932 code, its value is often unexpected. It seems nicer to
933 allow constructions like this to work as intuitively expected:
935 (with-selected-frame frame
936 (define-key local-function-map "\eOP" [f1]))
938 On the other hand, this affects the semantics of
939 last-command and real-last-command, and people may rely on
940 that. I took a quick look at the Lisp codebase, and I
941 don't think anything will break. --lorentey */
942 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
943 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
944 default: emacs_abort ();
948 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
949 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
950 buffer-independent contents of the value cell: forwarded just one
951 step past the buffer-localness.
953 BUF non-zero means set the value in buffer BUF instead of the
954 current buffer. This only plays a role for per-buffer variables. */
957 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
959 switch (XFWDTYPE (valcontents
))
962 CHECK_NUMBER (newval
);
963 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
967 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
971 *XOBJFWD (valcontents
)->objvar
= newval
;
973 /* If this variable is a default for something stored
974 in the buffer itself, such as default-fill-column,
975 find the buffers that don't have local values for it
977 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
978 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
980 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
981 - (char *) &buffer_defaults
);
982 int idx
= PER_BUFFER_IDX (offset
);
989 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
994 lbuf
= Fcdr (XCAR (tail
));
995 if (!BUFFERP (lbuf
)) continue;
998 if (! PER_BUFFER_VALUE_P (b
, idx
))
999 set_per_buffer_value (b
, offset
, newval
);
1004 case Lisp_Fwd_Buffer_Obj
:
1006 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1007 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1009 if (!NILP (predicate
) && !NILP (newval
)
1010 && NILP (call1 (predicate
, newval
)))
1011 wrong_type_argument (predicate
, newval
);
1014 buf
= current_buffer
;
1015 set_per_buffer_value (buf
, offset
, newval
);
1019 case Lisp_Fwd_Kboard_Obj
:
1021 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1022 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1023 *(Lisp_Object
*) p
= newval
;
1028 emacs_abort (); /* goto def; */
1032 /* Set up SYMBOL to refer to its global binding. This makes it safe
1033 to alter the status of other bindings. BEWARE: this may be called
1034 during the mark phase of GC, where we assume that Lisp_Object slots
1035 of BLV are marked after this function has changed them. */
1038 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1040 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1042 /* Unload the previously loaded binding. */
1044 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1046 /* Select the global binding in the symbol. */
1047 set_blv_valcell (blv
, blv
->defcell
);
1049 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1051 /* Indicate that the global binding is set up now. */
1052 set_blv_where (blv
, Qnil
);
1053 set_blv_found (blv
, 0);
1056 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1057 VALCONTENTS is the contents of its value cell,
1058 which points to a struct Lisp_Buffer_Local_Value.
1060 Return the value forwarded one step past the buffer-local stage.
1061 This could be another forwarding pointer. */
1064 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1066 register Lisp_Object tem1
;
1068 eassert (blv
== SYMBOL_BLV (symbol
));
1073 || (blv
->frame_local
1074 ? !EQ (selected_frame
, tem1
)
1075 : current_buffer
!= XBUFFER (tem1
)))
1078 /* Unload the previously loaded binding. */
1079 tem1
= blv
->valcell
;
1081 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1082 /* Choose the new binding. */
1085 XSETSYMBOL (var
, symbol
);
1086 if (blv
->frame_local
)
1088 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1089 set_blv_where (blv
, selected_frame
);
1093 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1094 set_blv_where (blv
, Fcurrent_buffer ());
1097 if (!(blv
->found
= !NILP (tem1
)))
1098 tem1
= blv
->defcell
;
1100 /* Load the new binding. */
1101 set_blv_valcell (blv
, tem1
);
1103 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1107 /* Find the value of a symbol, returning Qunbound if it's not bound.
1108 This is helpful for code which just wants to get a variable's value
1109 if it has one, without signaling an error.
1110 Note that it must not be possible to quit
1111 within this function. Great care is required for this. */
1114 find_symbol_value (Lisp_Object symbol
)
1116 struct Lisp_Symbol
*sym
;
1118 CHECK_SYMBOL (symbol
);
1119 sym
= XSYMBOL (symbol
);
1122 switch (sym
->redirect
)
1124 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1125 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1126 case SYMBOL_LOCALIZED
:
1128 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1129 swap_in_symval_forwarding (sym
, blv
);
1130 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1133 case SYMBOL_FORWARDED
:
1134 return do_symval_forwarding (SYMBOL_FWD (sym
));
1135 default: emacs_abort ();
1139 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1140 doc
: /* Return SYMBOL's value. Error if that is void.
1141 Note that if `lexical-binding' is in effect, this returns the
1142 global value outside of any lexical scope. */)
1143 (Lisp_Object symbol
)
1147 val
= find_symbol_value (symbol
);
1148 if (!EQ (val
, Qunbound
))
1151 xsignal1 (Qvoid_variable
, symbol
);
1154 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1155 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1156 (register Lisp_Object symbol
, Lisp_Object newval
)
1158 set_internal (symbol
, newval
, Qnil
, 0);
1162 /* Store the value NEWVAL into SYMBOL.
1163 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1164 (nil stands for the current buffer/frame).
1166 If BINDFLAG is false, then if this symbol is supposed to become
1167 local in every buffer where it is set, then we make it local.
1168 If BINDFLAG is true, we don't do that. */
1171 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1174 bool voide
= EQ (newval
, Qunbound
);
1175 struct Lisp_Symbol
*sym
;
1178 /* If restoring in a dead buffer, do nothing. */
1179 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1182 CHECK_SYMBOL (symbol
);
1183 if (SYMBOL_CONSTANT_P (symbol
))
1185 if (NILP (Fkeywordp (symbol
))
1186 || !EQ (newval
, Fsymbol_value (symbol
)))
1187 xsignal1 (Qsetting_constant
, symbol
);
1189 /* Allow setting keywords to their own value. */
1193 sym
= XSYMBOL (symbol
);
1196 switch (sym
->redirect
)
1198 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1199 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1200 case SYMBOL_LOCALIZED
:
1202 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1205 if (blv
->frame_local
)
1206 where
= selected_frame
;
1208 XSETBUFFER (where
, current_buffer
);
1210 /* If the current buffer is not the buffer whose binding is
1211 loaded, or if there may be frame-local bindings and the frame
1212 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1213 the default binding is loaded, the loaded binding may be the
1215 if (!EQ (blv
->where
, where
)
1216 /* Also unload a global binding (if the var is local_if_set). */
1217 || (EQ (blv
->valcell
, blv
->defcell
)))
1219 /* The currently loaded binding is not necessarily valid.
1220 We need to unload it, and choose a new binding. */
1222 /* Write out `realvalue' to the old loaded binding. */
1224 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1226 /* Find the new binding. */
1227 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1228 tem1
= Fassq (symbol
,
1230 ? XFRAME (where
)->param_alist
1231 : BVAR (XBUFFER (where
), local_var_alist
)));
1232 set_blv_where (blv
, where
);
1237 /* This buffer still sees the default value. */
1239 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1240 or if this is `let' rather than `set',
1241 make CURRENT-ALIST-ELEMENT point to itself,
1242 indicating that we're seeing the default value.
1243 Likewise if the variable has been let-bound
1244 in the current buffer. */
1245 if (bindflag
|| !blv
->local_if_set
1246 || let_shadows_buffer_binding_p (sym
))
1249 tem1
= blv
->defcell
;
1251 /* If it's a local_if_set, being set not bound,
1252 and we're not within a let that was made for this buffer,
1253 create a new buffer-local binding for the variable.
1254 That means, give this buffer a new assoc for a local value
1255 and load that binding. */
1258 /* local_if_set is only supported for buffer-local
1259 bindings, not for frame-local bindings. */
1260 eassert (!blv
->frame_local
);
1261 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1262 bset_local_var_alist
1264 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1268 /* Record which binding is now loaded. */
1269 set_blv_valcell (blv
, tem1
);
1272 /* Store the new value in the cons cell. */
1273 set_blv_value (blv
, newval
);
1278 /* If storing void (making the symbol void), forward only through
1279 buffer-local indicator, not through Lisp_Objfwd, etc. */
1282 store_symval_forwarding (blv
->fwd
, newval
,
1284 ? XBUFFER (where
) : current_buffer
);
1288 case SYMBOL_FORWARDED
:
1291 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1292 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1293 if (BUFFER_OBJFWDP (innercontents
))
1295 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1296 int idx
= PER_BUFFER_IDX (offset
);
1299 && !let_shadows_buffer_binding_p (sym
))
1300 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1304 { /* If storing void (making the symbol void), forward only through
1305 buffer-local indicator, not through Lisp_Objfwd, etc. */
1306 sym
->redirect
= SYMBOL_PLAINVAL
;
1307 SET_SYMBOL_VAL (sym
, newval
);
1310 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1313 default: emacs_abort ();
1318 /* Access or set a buffer-local symbol's default value. */
1320 /* Return the default value of SYMBOL, but don't check for voidness.
1321 Return Qunbound if it is void. */
1324 default_value (Lisp_Object symbol
)
1326 struct Lisp_Symbol
*sym
;
1328 CHECK_SYMBOL (symbol
);
1329 sym
= XSYMBOL (symbol
);
1332 switch (sym
->redirect
)
1334 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1335 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1336 case SYMBOL_LOCALIZED
:
1338 /* If var is set up for a buffer that lacks a local value for it,
1339 the current value is nominally the default value.
1340 But the `realvalue' slot may be more up to date, since
1341 ordinary setq stores just that slot. So use that. */
1342 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1343 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1344 return do_symval_forwarding (blv
->fwd
);
1346 return XCDR (blv
->defcell
);
1348 case SYMBOL_FORWARDED
:
1350 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1352 /* For a built-in buffer-local variable, get the default value
1353 rather than letting do_symval_forwarding get the current value. */
1354 if (BUFFER_OBJFWDP (valcontents
))
1356 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1357 if (PER_BUFFER_IDX (offset
) != 0)
1358 return per_buffer_default (offset
);
1361 /* For other variables, get the current value. */
1362 return do_symval_forwarding (valcontents
);
1364 default: emacs_abort ();
1368 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1369 doc
: /* Return t if SYMBOL has a non-void default value.
1370 This is the value that is seen in buffers that do not have their own values
1371 for this variable. */)
1372 (Lisp_Object symbol
)
1374 register Lisp_Object value
;
1376 value
= default_value (symbol
);
1377 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1380 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1381 doc
: /* Return SYMBOL's default value.
1382 This is the value that is seen in buffers that do not have their own values
1383 for this variable. The default value is meaningful for variables with
1384 local bindings in certain buffers. */)
1385 (Lisp_Object symbol
)
1387 register Lisp_Object value
;
1389 value
= default_value (symbol
);
1390 if (!EQ (value
, Qunbound
))
1393 xsignal1 (Qvoid_variable
, symbol
);
1396 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1397 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1398 The default value is seen in buffers that do not have their own values
1399 for this variable. */)
1400 (Lisp_Object symbol
, Lisp_Object value
)
1402 struct Lisp_Symbol
*sym
;
1404 CHECK_SYMBOL (symbol
);
1405 if (SYMBOL_CONSTANT_P (symbol
))
1407 if (NILP (Fkeywordp (symbol
))
1408 || !EQ (value
, Fdefault_value (symbol
)))
1409 xsignal1 (Qsetting_constant
, symbol
);
1411 /* Allow setting keywords to their own value. */
1414 sym
= XSYMBOL (symbol
);
1417 switch (sym
->redirect
)
1419 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1420 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1421 case SYMBOL_LOCALIZED
:
1423 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1425 /* Store new value into the DEFAULT-VALUE slot. */
1426 XSETCDR (blv
->defcell
, value
);
1428 /* If the default binding is now loaded, set the REALVALUE slot too. */
1429 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1430 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1433 case SYMBOL_FORWARDED
:
1435 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1437 /* Handle variables like case-fold-search that have special slots
1439 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1440 if (BUFFER_OBJFWDP (valcontents
))
1442 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1443 int idx
= PER_BUFFER_IDX (offset
);
1445 set_per_buffer_default (offset
, value
);
1447 /* If this variable is not always local in all buffers,
1448 set it in the buffers that don't nominally have a local value. */
1454 if (!PER_BUFFER_VALUE_P (b
, idx
))
1455 set_per_buffer_value (b
, offset
, value
);
1460 return Fset (symbol
, value
);
1462 default: emacs_abort ();
1466 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1467 doc
: /* Set the default value of variable VAR to VALUE.
1468 VAR, the variable name, is literal (not evaluated);
1469 VALUE is an expression: it is evaluated and its value returned.
1470 The default value of a variable is seen in buffers
1471 that do not have their own values for the variable.
1473 More generally, you can use multiple variables and values, as in
1474 (setq-default VAR VALUE VAR VALUE...)
1475 This sets each VAR's default value to the corresponding VALUE.
1476 The VALUE for the Nth VAR can refer to the new default values
1478 usage: (setq-default [VAR VALUE]...) */)
1481 Lisp_Object args_left
, symbol
, val
;
1482 struct gcpro gcpro1
;
1484 args_left
= val
= args
;
1487 while (CONSP (args_left
))
1489 val
= eval_sub (Fcar (XCDR (args_left
)));
1490 symbol
= XCAR (args_left
);
1491 Fset_default (symbol
, val
);
1492 args_left
= Fcdr (XCDR (args_left
));
1499 /* Lisp functions for creating and removing buffer-local variables. */
1504 union Lisp_Fwd
*fwd
;
1507 static struct Lisp_Buffer_Local_Value
*
1508 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1509 union Lisp_Val_Fwd valcontents
)
1511 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1515 XSETSYMBOL (symbol
, sym
);
1516 tem
= Fcons (symbol
, (forwarded
1517 ? do_symval_forwarding (valcontents
.fwd
)
1518 : valcontents
.value
));
1520 /* Buffer_Local_Values cannot have as realval a buffer-local
1521 or keyboard-local forwarding. */
1522 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1523 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1524 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1525 set_blv_where (blv
, Qnil
);
1526 blv
->frame_local
= 0;
1527 blv
->local_if_set
= 0;
1528 set_blv_defcell (blv
, tem
);
1529 set_blv_valcell (blv
, tem
);
1530 set_blv_found (blv
, 0);
1534 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1535 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1536 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1537 At any time, the value for the current buffer is in effect,
1538 unless the variable has never been set in this buffer,
1539 in which case the default value is in effect.
1540 Note that binding the variable with `let', or setting it while
1541 a `let'-style binding made in this buffer is in effect,
1542 does not make the variable buffer-local. Return VARIABLE.
1544 In most cases it is better to use `make-local-variable',
1545 which makes a variable local in just one buffer.
1547 The function `default-value' gets the default value and `set-default' sets it. */)
1548 (register Lisp_Object variable
)
1550 struct Lisp_Symbol
*sym
;
1551 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1552 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1553 bool forwarded
IF_LINT (= 0);
1555 CHECK_SYMBOL (variable
);
1556 sym
= XSYMBOL (variable
);
1559 switch (sym
->redirect
)
1561 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1562 case SYMBOL_PLAINVAL
:
1563 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1564 if (EQ (valcontents
.value
, Qunbound
))
1565 valcontents
.value
= Qnil
;
1567 case SYMBOL_LOCALIZED
:
1568 blv
= SYMBOL_BLV (sym
);
1569 if (blv
->frame_local
)
1570 error ("Symbol %s may not be buffer-local",
1571 SDATA (SYMBOL_NAME (variable
)));
1573 case SYMBOL_FORWARDED
:
1574 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1575 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1576 error ("Symbol %s may not be buffer-local",
1577 SDATA (SYMBOL_NAME (variable
)));
1578 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1581 default: emacs_abort ();
1585 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1589 blv
= make_blv (sym
, forwarded
, valcontents
);
1590 sym
->redirect
= SYMBOL_LOCALIZED
;
1591 SET_SYMBOL_BLV (sym
, blv
);
1594 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1595 if (let_shadows_global_binding_p (symbol
))
1596 message ("Making %s buffer-local while let-bound!",
1597 SDATA (SYMBOL_NAME (variable
)));
1601 blv
->local_if_set
= 1;
1605 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1606 1, 1, "vMake Local Variable: ",
1607 doc
: /* Make VARIABLE have a separate value in the current buffer.
1608 Other buffers will continue to share a common default value.
1609 \(The buffer-local value of VARIABLE starts out as the same value
1610 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1613 If the variable is already arranged to become local when set,
1614 this function causes a local value to exist for this buffer,
1615 just as setting the variable would do.
1617 This function returns VARIABLE, and therefore
1618 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1621 See also `make-variable-buffer-local'.
1623 Do not use `make-local-variable' to make a hook variable buffer-local.
1624 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1625 (Lisp_Object variable
)
1628 bool forwarded
IF_LINT (= 0);
1629 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1630 struct Lisp_Symbol
*sym
;
1631 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1633 CHECK_SYMBOL (variable
);
1634 sym
= XSYMBOL (variable
);
1637 switch (sym
->redirect
)
1639 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1640 case SYMBOL_PLAINVAL
:
1641 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1642 case SYMBOL_LOCALIZED
:
1643 blv
= SYMBOL_BLV (sym
);
1644 if (blv
->frame_local
)
1645 error ("Symbol %s may not be buffer-local",
1646 SDATA (SYMBOL_NAME (variable
)));
1648 case SYMBOL_FORWARDED
:
1649 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1650 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1651 error ("Symbol %s may not be buffer-local",
1652 SDATA (SYMBOL_NAME (variable
)));
1654 default: emacs_abort ();
1658 error ("Symbol %s may not be buffer-local",
1659 SDATA (SYMBOL_NAME (variable
)));
1661 if (blv
? blv
->local_if_set
1662 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1664 tem
= Fboundp (variable
);
1665 /* Make sure the symbol has a local value in this particular buffer,
1666 by setting it to the same value it already has. */
1667 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1672 blv
= make_blv (sym
, forwarded
, valcontents
);
1673 sym
->redirect
= SYMBOL_LOCALIZED
;
1674 SET_SYMBOL_BLV (sym
, blv
);
1677 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1678 if (let_shadows_global_binding_p (symbol
))
1679 message ("Making %s local to %s while let-bound!",
1680 SDATA (SYMBOL_NAME (variable
)),
1681 SDATA (BVAR (current_buffer
, name
)));
1685 /* Make sure this buffer has its own value of symbol. */
1686 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1687 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1690 if (let_shadows_buffer_binding_p (sym
))
1691 message ("Making %s buffer-local while locally let-bound!",
1692 SDATA (SYMBOL_NAME (variable
)));
1694 /* Swap out any local binding for some other buffer, and make
1695 sure the current value is permanently recorded, if it's the
1697 find_symbol_value (variable
);
1699 bset_local_var_alist
1701 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1702 BVAR (current_buffer
, local_var_alist
)));
1704 /* Make sure symbol does not think it is set up for this buffer;
1705 force it to look once again for this buffer's value. */
1706 if (current_buffer
== XBUFFER (blv
->where
))
1707 set_blv_where (blv
, Qnil
);
1708 set_blv_found (blv
, 0);
1711 /* If the symbol forwards into a C variable, then load the binding
1712 for this buffer now. If C code modifies the variable before we
1713 load the binding in, then that new value will clobber the default
1714 binding the next time we unload it. */
1716 swap_in_symval_forwarding (sym
, blv
);
1721 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1722 1, 1, "vKill Local Variable: ",
1723 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1724 From now on the default value will apply in this buffer. Return VARIABLE. */)
1725 (register Lisp_Object variable
)
1727 register Lisp_Object tem
;
1728 struct Lisp_Buffer_Local_Value
*blv
;
1729 struct Lisp_Symbol
*sym
;
1731 CHECK_SYMBOL (variable
);
1732 sym
= XSYMBOL (variable
);
1735 switch (sym
->redirect
)
1737 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1738 case SYMBOL_PLAINVAL
: return variable
;
1739 case SYMBOL_FORWARDED
:
1741 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1742 if (BUFFER_OBJFWDP (valcontents
))
1744 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1745 int idx
= PER_BUFFER_IDX (offset
);
1749 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1750 set_per_buffer_value (current_buffer
, offset
,
1751 per_buffer_default (offset
));
1756 case SYMBOL_LOCALIZED
:
1757 blv
= SYMBOL_BLV (sym
);
1758 if (blv
->frame_local
)
1761 default: emacs_abort ();
1764 /* Get rid of this buffer's alist element, if any. */
1765 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1766 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1768 bset_local_var_alist
1770 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1772 /* If the symbol is set up with the current buffer's binding
1773 loaded, recompute its value. We have to do it now, or else
1774 forwarded objects won't work right. */
1776 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1777 if (EQ (buf
, blv
->where
))
1779 set_blv_where (blv
, Qnil
);
1781 find_symbol_value (variable
);
1788 /* Lisp functions for creating and removing buffer-local variables. */
1790 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1791 when/if this is removed. */
1793 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1794 1, 1, "vMake Variable Frame Local: ",
1795 doc
: /* Enable VARIABLE to have frame-local bindings.
1796 This does not create any frame-local bindings for VARIABLE,
1797 it just makes them possible.
1799 A frame-local binding is actually a frame parameter value.
1800 If a frame F has a value for the frame parameter named VARIABLE,
1801 that also acts as a frame-local binding for VARIABLE in F--
1802 provided this function has been called to enable VARIABLE
1803 to have frame-local bindings at all.
1805 The only way to create a frame-local binding for VARIABLE in a frame
1806 is to set the VARIABLE frame parameter of that frame. See
1807 `modify-frame-parameters' for how to set frame parameters.
1809 Note that since Emacs 23.1, variables cannot be both buffer-local and
1810 frame-local any more (buffer-local bindings used to take precedence over
1811 frame-local bindings). */)
1812 (Lisp_Object variable
)
1815 union Lisp_Val_Fwd valcontents
;
1816 struct Lisp_Symbol
*sym
;
1817 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1819 CHECK_SYMBOL (variable
);
1820 sym
= XSYMBOL (variable
);
1823 switch (sym
->redirect
)
1825 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1826 case SYMBOL_PLAINVAL
:
1827 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1828 if (EQ (valcontents
.value
, Qunbound
))
1829 valcontents
.value
= Qnil
;
1831 case SYMBOL_LOCALIZED
:
1832 if (SYMBOL_BLV (sym
)->frame_local
)
1835 error ("Symbol %s may not be frame-local",
1836 SDATA (SYMBOL_NAME (variable
)));
1837 case SYMBOL_FORWARDED
:
1838 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1839 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1840 error ("Symbol %s may not be frame-local",
1841 SDATA (SYMBOL_NAME (variable
)));
1843 default: emacs_abort ();
1847 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1849 blv
= make_blv (sym
, forwarded
, valcontents
);
1850 blv
->frame_local
= 1;
1851 sym
->redirect
= SYMBOL_LOCALIZED
;
1852 SET_SYMBOL_BLV (sym
, blv
);
1855 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1856 if (let_shadows_global_binding_p (symbol
))
1857 message ("Making %s frame-local while let-bound!",
1858 SDATA (SYMBOL_NAME (variable
)));
1863 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1865 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1866 BUFFER defaults to the current buffer. */)
1867 (register Lisp_Object variable
, Lisp_Object buffer
)
1869 register struct buffer
*buf
;
1870 struct Lisp_Symbol
*sym
;
1873 buf
= current_buffer
;
1876 CHECK_BUFFER (buffer
);
1877 buf
= XBUFFER (buffer
);
1880 CHECK_SYMBOL (variable
);
1881 sym
= XSYMBOL (variable
);
1884 switch (sym
->redirect
)
1886 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1887 case SYMBOL_PLAINVAL
: return Qnil
;
1888 case SYMBOL_LOCALIZED
:
1890 Lisp_Object tail
, elt
, tmp
;
1891 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1892 XSETBUFFER (tmp
, buf
);
1893 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1895 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1896 return blv_found (blv
) ? Qt
: Qnil
;
1898 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1901 if (EQ (variable
, XCAR (elt
)))
1903 eassert (!blv
->frame_local
);
1909 case SYMBOL_FORWARDED
:
1911 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1912 if (BUFFER_OBJFWDP (valcontents
))
1914 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1915 int idx
= PER_BUFFER_IDX (offset
);
1916 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1921 default: emacs_abort ();
1925 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1927 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1928 BUFFER defaults to the current buffer.
1930 More precisely, return non-nil if either VARIABLE already has a local
1931 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1932 `make-variable-buffer-local'). */)
1933 (register Lisp_Object variable
, Lisp_Object buffer
)
1935 struct Lisp_Symbol
*sym
;
1937 CHECK_SYMBOL (variable
);
1938 sym
= XSYMBOL (variable
);
1941 switch (sym
->redirect
)
1943 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1944 case SYMBOL_PLAINVAL
: return Qnil
;
1945 case SYMBOL_LOCALIZED
:
1947 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1948 if (blv
->local_if_set
)
1950 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1951 return Flocal_variable_p (variable
, buffer
);
1953 case SYMBOL_FORWARDED
:
1954 /* All BUFFER_OBJFWD slots become local if they are set. */
1955 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1956 default: emacs_abort ();
1960 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1962 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1963 If the current binding is buffer-local, the value is the current buffer.
1964 If the current binding is frame-local, the value is the selected frame.
1965 If the current binding is global (the default), the value is nil. */)
1966 (register Lisp_Object variable
)
1968 struct Lisp_Symbol
*sym
;
1970 CHECK_SYMBOL (variable
);
1971 sym
= XSYMBOL (variable
);
1973 /* Make sure the current binding is actually swapped in. */
1974 find_symbol_value (variable
);
1977 switch (sym
->redirect
)
1979 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1980 case SYMBOL_PLAINVAL
: return Qnil
;
1981 case SYMBOL_FORWARDED
:
1983 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1984 if (KBOARD_OBJFWDP (valcontents
))
1985 return Fframe_terminal (Fselected_frame ());
1986 else if (!BUFFER_OBJFWDP (valcontents
))
1990 case SYMBOL_LOCALIZED
:
1991 /* For a local variable, record both the symbol and which
1992 buffer's or frame's value we are saving. */
1993 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1994 return Fcurrent_buffer ();
1995 else if (sym
->redirect
== SYMBOL_LOCALIZED
1996 && blv_found (SYMBOL_BLV (sym
)))
1997 return SYMBOL_BLV (sym
)->where
;
2000 default: emacs_abort ();
2004 /* This code is disabled now that we use the selected frame to return
2005 keyboard-local-values. */
2007 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2009 DEFUN ("terminal-local-value", Fterminal_local_value
,
2010 Sterminal_local_value
, 2, 2, 0,
2011 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2012 If SYMBOL is not a terminal-local variable, then return its normal
2013 value, like `symbol-value'.
2015 TERMINAL may be a terminal object, a frame, or nil (meaning the
2016 selected frame's terminal device). */)
2017 (Lisp_Object symbol
, Lisp_Object terminal
)
2020 struct terminal
*t
= get_terminal (terminal
, 1);
2021 push_kboard (t
->kboard
);
2022 result
= Fsymbol_value (symbol
);
2027 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2028 Sset_terminal_local_value
, 3, 3, 0,
2029 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2030 If VARIABLE is not a terminal-local variable, then set its normal
2031 binding, like `set'.
2033 TERMINAL may be a terminal object, a frame, or nil (meaning the
2034 selected frame's terminal device). */)
2035 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2038 struct terminal
*t
= get_terminal (terminal
, 1);
2039 push_kboard (d
->kboard
);
2040 result
= Fset (symbol
, value
);
2046 /* Find the function at the end of a chain of symbol function indirections. */
2048 /* If OBJECT is a symbol, find the end of its function chain and
2049 return the value found there. If OBJECT is not a symbol, just
2050 return it. If there is a cycle in the function chain, signal a
2051 cyclic-function-indirection error.
2053 This is like Findirect_function, except that it doesn't signal an
2054 error if the chain ends up unbound. */
2056 indirect_function (register Lisp_Object object
)
2058 Lisp_Object tortoise
, hare
;
2060 hare
= tortoise
= object
;
2064 if (!SYMBOLP (hare
) || NILP (hare
))
2066 hare
= XSYMBOL (hare
)->function
;
2067 if (!SYMBOLP (hare
) || NILP (hare
))
2069 hare
= XSYMBOL (hare
)->function
;
2071 tortoise
= XSYMBOL (tortoise
)->function
;
2073 if (EQ (hare
, tortoise
))
2074 xsignal1 (Qcyclic_function_indirection
, object
);
2080 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2081 doc
: /* Return the function at the end of OBJECT's function chain.
2082 If OBJECT is not a symbol, just return it. Otherwise, follow all
2083 function indirections to find the final function binding and return it.
2084 If the final symbol in the chain is unbound, signal a void-function error.
2085 Optional arg NOERROR non-nil means to return nil instead of signaling.
2086 Signal a cyclic-function-indirection error if there is a loop in the
2087 function chain of symbols. */)
2088 (register Lisp_Object object
, Lisp_Object noerror
)
2092 /* Optimize for no indirection. */
2094 if (SYMBOLP (result
) && !NILP (result
)
2095 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2096 result
= indirect_function (result
);
2101 xsignal1 (Qvoid_function
, object
);
2106 /* Extract and set vector and string elements. */
2108 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2109 doc
: /* Return the element of ARRAY at index IDX.
2110 ARRAY may be a vector, a string, a char-table, a bool-vector,
2111 or a byte-code object. IDX starts at 0. */)
2112 (register Lisp_Object array
, Lisp_Object idx
)
2114 register EMACS_INT idxval
;
2117 idxval
= XINT (idx
);
2118 if (STRINGP (array
))
2121 ptrdiff_t idxval_byte
;
2123 if (idxval
< 0 || idxval
>= SCHARS (array
))
2124 args_out_of_range (array
, idx
);
2125 if (! STRING_MULTIBYTE (array
))
2126 return make_number ((unsigned char) SREF (array
, idxval
));
2127 idxval_byte
= string_char_to_byte (array
, idxval
);
2129 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2130 return make_number (c
);
2132 else if (BOOL_VECTOR_P (array
))
2136 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2137 args_out_of_range (array
, idx
);
2139 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2140 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2142 else if (CHAR_TABLE_P (array
))
2144 CHECK_CHARACTER (idx
);
2145 return CHAR_TABLE_REF (array
, idxval
);
2150 if (VECTORP (array
))
2151 size
= ASIZE (array
);
2152 else if (COMPILEDP (array
))
2153 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2155 wrong_type_argument (Qarrayp
, array
);
2157 if (idxval
< 0 || idxval
>= size
)
2158 args_out_of_range (array
, idx
);
2159 return AREF (array
, idxval
);
2163 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2164 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2165 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2166 bool-vector. IDX starts at 0. */)
2167 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2169 register EMACS_INT idxval
;
2172 idxval
= XINT (idx
);
2173 CHECK_ARRAY (array
, Qarrayp
);
2174 CHECK_IMPURE (array
);
2176 if (VECTORP (array
))
2178 if (idxval
< 0 || idxval
>= ASIZE (array
))
2179 args_out_of_range (array
, idx
);
2180 ASET (array
, idxval
, newelt
);
2182 else if (BOOL_VECTOR_P (array
))
2186 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2187 args_out_of_range (array
, idx
);
2189 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2191 if (! NILP (newelt
))
2192 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2194 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2195 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2197 else if (CHAR_TABLE_P (array
))
2199 CHECK_CHARACTER (idx
);
2200 CHAR_TABLE_SET (array
, idxval
, newelt
);
2206 if (idxval
< 0 || idxval
>= SCHARS (array
))
2207 args_out_of_range (array
, idx
);
2208 CHECK_CHARACTER (newelt
);
2209 c
= XFASTINT (newelt
);
2211 if (STRING_MULTIBYTE (array
))
2213 ptrdiff_t idxval_byte
, nbytes
;
2214 int prev_bytes
, new_bytes
;
2215 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2217 nbytes
= SBYTES (array
);
2218 idxval_byte
= string_char_to_byte (array
, idxval
);
2219 p1
= SDATA (array
) + idxval_byte
;
2220 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2221 new_bytes
= CHAR_STRING (c
, p0
);
2222 if (prev_bytes
!= new_bytes
)
2224 /* We must relocate the string data. */
2225 ptrdiff_t nchars
= SCHARS (array
);
2227 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2229 memcpy (str
, SDATA (array
), nbytes
);
2230 allocate_string_data (XSTRING (array
), nchars
,
2231 nbytes
+ new_bytes
- prev_bytes
);
2232 memcpy (SDATA (array
), str
, idxval_byte
);
2233 p1
= SDATA (array
) + idxval_byte
;
2234 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2235 nbytes
- (idxval_byte
+ prev_bytes
));
2237 clear_string_char_byte_cache ();
2244 if (! SINGLE_BYTE_CHAR_P (c
))
2248 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2249 if (SREF (array
, i
) >= 0x80)
2250 args_out_of_range (array
, newelt
);
2251 /* ARRAY is an ASCII string. Convert it to a multibyte
2252 string, and try `aset' again. */
2253 STRING_SET_MULTIBYTE (array
);
2254 return Faset (array
, idx
, newelt
);
2256 SSET (array
, idxval
, c
);
2263 /* Arithmetic functions */
2265 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2268 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2270 double f1
= 0, f2
= 0;
2273 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2274 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2276 if (FLOATP (num1
) || FLOATP (num2
))
2279 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2280 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2286 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2291 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2296 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2301 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2306 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2311 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2320 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2321 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2322 (register Lisp_Object num1
, Lisp_Object num2
)
2324 return arithcompare (num1
, num2
, equal
);
2327 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2328 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2329 (register Lisp_Object num1
, Lisp_Object num2
)
2331 return arithcompare (num1
, num2
, less
);
2334 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2335 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2336 (register Lisp_Object num1
, Lisp_Object num2
)
2338 return arithcompare (num1
, num2
, grtr
);
2341 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2342 doc
: /* Return t if first arg is less than or equal to second arg.
2343 Both must be numbers or markers. */)
2344 (register Lisp_Object num1
, Lisp_Object num2
)
2346 return arithcompare (num1
, num2
, less_or_equal
);
2349 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2350 doc
: /* Return t if first arg is greater than or equal to second arg.
2351 Both must be numbers or markers. */)
2352 (register Lisp_Object num1
, Lisp_Object num2
)
2354 return arithcompare (num1
, num2
, grtr_or_equal
);
2357 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2358 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2359 (register Lisp_Object num1
, Lisp_Object num2
)
2361 return arithcompare (num1
, num2
, notequal
);
2364 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2365 doc
: /* Return t if NUMBER is zero. */)
2366 (register Lisp_Object number
)
2368 CHECK_NUMBER_OR_FLOAT (number
);
2370 if (FLOATP (number
))
2372 if (XFLOAT_DATA (number
) == 0.0)
2382 /* Convert the cons-of-integers, integer, or float value C to an
2383 unsigned value with maximum value MAX. Signal an error if C does not
2384 have a valid format or is out of range. */
2386 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2389 uintmax_t val
IF_LINT (= 0);
2392 valid
= 0 <= XINT (c
);
2395 else if (FLOATP (c
))
2397 double d
= XFLOAT_DATA (c
);
2399 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2405 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2407 uintmax_t top
= XFASTINT (XCAR (c
));
2408 Lisp_Object rest
= XCDR (c
);
2409 if (top
<= UINTMAX_MAX
>> 24 >> 16
2411 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2412 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2414 uintmax_t mid
= XFASTINT (XCAR (rest
));
2415 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2418 else if (top
<= UINTMAX_MAX
>> 16)
2422 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2424 val
= top
<< 16 | XFASTINT (rest
);
2430 if (! (valid
&& val
<= max
))
2431 error ("Not an in-range integer, float, or cons of integers");
2435 /* Convert the cons-of-integers, integer, or float value C to a signed
2436 value with extrema MIN and MAX. Signal an error if C does not have
2437 a valid format or is out of range. */
2439 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2442 intmax_t val
IF_LINT (= 0);
2448 else if (FLOATP (c
))
2450 double d
= XFLOAT_DATA (c
);
2452 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2458 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2460 intmax_t top
= XINT (XCAR (c
));
2461 Lisp_Object rest
= XCDR (c
);
2462 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2464 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2465 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2467 intmax_t mid
= XFASTINT (XCAR (rest
));
2468 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2471 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2475 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2477 val
= top
<< 16 | XFASTINT (rest
);
2483 if (! (valid
&& min
<= val
&& val
<= max
))
2484 error ("Not an in-range integer, float, or cons of integers");
2488 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2489 doc
: /* Return the decimal representation of NUMBER as a string.
2490 Uses a minus sign if negative.
2491 NUMBER may be an integer or a floating point number. */)
2492 (Lisp_Object number
)
2494 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2497 CHECK_NUMBER_OR_FLOAT (number
);
2499 if (FLOATP (number
))
2500 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2502 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2504 return make_unibyte_string (buffer
, len
);
2507 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2508 doc
: /* Parse STRING as a decimal number and return the number.
2509 This parses both integers and floating point numbers.
2510 It ignores leading spaces and tabs, and all trailing chars.
2512 If BASE, interpret STRING as a number in that base. If BASE isn't
2513 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2514 If the base used is not 10, STRING is always parsed as integer. */)
2515 (register Lisp_Object string
, Lisp_Object base
)
2521 CHECK_STRING (string
);
2527 CHECK_NUMBER (base
);
2528 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2529 xsignal1 (Qargs_out_of_range
, base
);
2533 p
= SSDATA (string
);
2534 while (*p
== ' ' || *p
== '\t')
2537 val
= string_to_number (p
, b
, 1);
2538 return NILP (val
) ? make_number (0) : val
;
2554 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2555 ptrdiff_t, Lisp_Object
*);
2557 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2560 ptrdiff_t argnum
, ok_args
;
2561 EMACS_INT accum
= 0;
2562 EMACS_INT next
, ok_accum
;
2583 for (argnum
= 0; argnum
< nargs
; argnum
++)
2591 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2593 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2596 return float_arith_driver (ok_accum
, ok_args
, code
,
2599 next
= XINT (args
[argnum
]);
2603 if (INT_ADD_OVERFLOW (accum
, next
))
2611 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2616 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2619 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2621 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2623 accum
= ab
& INTMASK
;
2634 xsignal0 (Qarith_error
);
2648 if (!argnum
|| next
> accum
)
2652 if (!argnum
|| next
< accum
)
2658 XSETINT (val
, accum
);
2663 #define isnan(x) ((x) != (x))
2666 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2667 ptrdiff_t nargs
, Lisp_Object
*args
)
2669 register Lisp_Object val
;
2672 for (; argnum
< nargs
; argnum
++)
2674 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2675 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2679 next
= XFLOAT_DATA (val
);
2683 args
[argnum
] = val
; /* runs into a compiler bug. */
2684 next
= XINT (args
[argnum
]);
2692 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2702 if (! IEEE_FLOATING_POINT
&& next
== 0)
2703 xsignal0 (Qarith_error
);
2710 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2712 if (!argnum
|| isnan (next
) || next
> accum
)
2716 if (!argnum
|| isnan (next
) || next
< accum
)
2722 return make_float (accum
);
2726 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2727 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2728 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2729 (ptrdiff_t nargs
, Lisp_Object
*args
)
2731 return arith_driver (Aadd
, nargs
, args
);
2734 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2735 doc
: /* Negate number or subtract numbers or markers and return the result.
2736 With one arg, negates it. With more than one arg,
2737 subtracts all but the first from the first.
2738 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2739 (ptrdiff_t nargs
, Lisp_Object
*args
)
2741 return arith_driver (Asub
, nargs
, args
);
2744 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2745 doc
: /* Return product of any number of arguments, which are numbers or markers.
2746 usage: (* &rest NUMBERS-OR-MARKERS) */)
2747 (ptrdiff_t nargs
, Lisp_Object
*args
)
2749 return arith_driver (Amult
, nargs
, args
);
2752 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2753 doc
: /* Return first argument divided by all the remaining arguments.
2754 The arguments must be numbers or markers.
2755 usage: (/ DIVIDEND &rest DIVISORS) */)
2756 (ptrdiff_t nargs
, Lisp_Object
*args
)
2759 for (argnum
= 2; argnum
< nargs
; argnum
++)
2760 if (FLOATP (args
[argnum
]))
2761 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2762 return arith_driver (Adiv
, nargs
, args
);
2765 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2766 doc
: /* Return remainder of X divided by Y.
2767 Both must be integers or markers. */)
2768 (register Lisp_Object x
, Lisp_Object y
)
2772 CHECK_NUMBER_COERCE_MARKER (x
);
2773 CHECK_NUMBER_COERCE_MARKER (y
);
2776 xsignal0 (Qarith_error
);
2778 XSETINT (val
, XINT (x
) % XINT (y
));
2782 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2783 doc
: /* Return X modulo Y.
2784 The result falls between zero (inclusive) and Y (exclusive).
2785 Both X and Y must be numbers or markers. */)
2786 (register Lisp_Object x
, Lisp_Object y
)
2791 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2792 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2794 if (FLOATP (x
) || FLOATP (y
))
2795 return fmod_float (x
, y
);
2801 xsignal0 (Qarith_error
);
2805 /* If the "remainder" comes out with the wrong sign, fix it. */
2806 if (i2
< 0 ? i1
> 0 : i1
< 0)
2813 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2814 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2815 The value is always a number; markers are converted to numbers.
2816 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2817 (ptrdiff_t nargs
, Lisp_Object
*args
)
2819 return arith_driver (Amax
, nargs
, args
);
2822 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2823 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2824 The value is always a number; markers are converted to numbers.
2825 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2826 (ptrdiff_t nargs
, Lisp_Object
*args
)
2828 return arith_driver (Amin
, nargs
, args
);
2831 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2832 doc
: /* Return bitwise-and of all the arguments.
2833 Arguments may be integers, or markers converted to integers.
2834 usage: (logand &rest INTS-OR-MARKERS) */)
2835 (ptrdiff_t nargs
, Lisp_Object
*args
)
2837 return arith_driver (Alogand
, nargs
, args
);
2840 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2841 doc
: /* Return bitwise-or of all the arguments.
2842 Arguments may be integers, or markers converted to integers.
2843 usage: (logior &rest INTS-OR-MARKERS) */)
2844 (ptrdiff_t nargs
, Lisp_Object
*args
)
2846 return arith_driver (Alogior
, nargs
, args
);
2849 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2850 doc
: /* Return bitwise-exclusive-or of all the arguments.
2851 Arguments may be integers, or markers converted to integers.
2852 usage: (logxor &rest INTS-OR-MARKERS) */)
2853 (ptrdiff_t nargs
, Lisp_Object
*args
)
2855 return arith_driver (Alogxor
, nargs
, args
);
2858 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2859 doc
: /* Return VALUE with its bits shifted left by COUNT.
2860 If COUNT is negative, shifting is actually to the right.
2861 In this case, the sign bit is duplicated. */)
2862 (register Lisp_Object value
, Lisp_Object count
)
2864 register Lisp_Object val
;
2866 CHECK_NUMBER (value
);
2867 CHECK_NUMBER (count
);
2869 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2871 else if (XINT (count
) > 0)
2872 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2873 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2874 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2876 XSETINT (val
, XINT (value
) >> -XINT (count
));
2880 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2881 doc
: /* Return VALUE with its bits shifted left by COUNT.
2882 If COUNT is negative, shifting is actually to the right.
2883 In this case, zeros are shifted in on the left. */)
2884 (register Lisp_Object value
, Lisp_Object count
)
2886 register Lisp_Object val
;
2888 CHECK_NUMBER (value
);
2889 CHECK_NUMBER (count
);
2891 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2893 else if (XINT (count
) > 0)
2894 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2895 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2898 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2902 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2903 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2904 Markers are converted to integers. */)
2905 (register Lisp_Object number
)
2907 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2909 if (FLOATP (number
))
2910 return (make_float (1.0 + XFLOAT_DATA (number
)));
2912 XSETINT (number
, XINT (number
) + 1);
2916 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2917 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2918 Markers are converted to integers. */)
2919 (register Lisp_Object number
)
2921 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2923 if (FLOATP (number
))
2924 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2926 XSETINT (number
, XINT (number
) - 1);
2930 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2931 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2932 (register Lisp_Object number
)
2934 CHECK_NUMBER (number
);
2935 XSETINT (number
, ~XINT (number
));
2939 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2940 doc
: /* Return the byteorder for the machine.
2941 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2942 lowercase l) for small endian machines. */)
2945 unsigned i
= 0x04030201;
2946 int order
= *(char *)&i
== 1 ? 108 : 66;
2948 return make_number (order
);
2956 Lisp_Object error_tail
, arith_tail
;
2958 DEFSYM (Qquote
, "quote");
2959 DEFSYM (Qlambda
, "lambda");
2960 DEFSYM (Qsubr
, "subr");
2961 DEFSYM (Qerror_conditions
, "error-conditions");
2962 DEFSYM (Qerror_message
, "error-message");
2963 DEFSYM (Qtop_level
, "top-level");
2965 DEFSYM (Qerror
, "error");
2966 DEFSYM (Quser_error
, "user-error");
2967 DEFSYM (Qquit
, "quit");
2968 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2969 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2970 DEFSYM (Qvoid_function
, "void-function");
2971 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2972 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2973 DEFSYM (Qvoid_variable
, "void-variable");
2974 DEFSYM (Qsetting_constant
, "setting-constant");
2975 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2977 DEFSYM (Qinvalid_function
, "invalid-function");
2978 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2979 DEFSYM (Qno_catch
, "no-catch");
2980 DEFSYM (Qend_of_file
, "end-of-file");
2981 DEFSYM (Qarith_error
, "arith-error");
2982 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2983 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2984 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2985 DEFSYM (Qtext_read_only
, "text-read-only");
2986 DEFSYM (Qmark_inactive
, "mark-inactive");
2988 DEFSYM (Qlistp
, "listp");
2989 DEFSYM (Qconsp
, "consp");
2990 DEFSYM (Qsymbolp
, "symbolp");
2991 DEFSYM (Qkeywordp
, "keywordp");
2992 DEFSYM (Qintegerp
, "integerp");
2993 DEFSYM (Qnatnump
, "natnump");
2994 DEFSYM (Qwholenump
, "wholenump");
2995 DEFSYM (Qstringp
, "stringp");
2996 DEFSYM (Qarrayp
, "arrayp");
2997 DEFSYM (Qsequencep
, "sequencep");
2998 DEFSYM (Qbufferp
, "bufferp");
2999 DEFSYM (Qvectorp
, "vectorp");
3000 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3001 DEFSYM (Qmarkerp
, "markerp");
3002 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3003 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3004 DEFSYM (Qboundp
, "boundp");
3005 DEFSYM (Qfboundp
, "fboundp");
3007 DEFSYM (Qfloatp
, "floatp");
3008 DEFSYM (Qnumberp
, "numberp");
3009 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3011 DEFSYM (Qchar_table_p
, "char-table-p");
3012 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3014 DEFSYM (Qsubrp
, "subrp");
3015 DEFSYM (Qunevalled
, "unevalled");
3016 DEFSYM (Qmany
, "many");
3018 DEFSYM (Qcdr
, "cdr");
3020 /* Handle automatic advice activation. */
3021 DEFSYM (Qad_advice_info
, "ad-advice-info");
3022 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3024 error_tail
= pure_cons (Qerror
, Qnil
);
3026 /* ERROR is used as a signaler for random errors for which nothing else is
3029 Fput (Qerror
, Qerror_conditions
,
3031 Fput (Qerror
, Qerror_message
,
3032 build_pure_c_string ("error"));
3034 #define PUT_ERROR(sym, tail, msg) \
3035 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3036 Fput (sym, Qerror_message, build_pure_c_string (msg))
3038 PUT_ERROR (Qquit
, Qnil
, "Quit");
3040 PUT_ERROR (Quser_error
, error_tail
, "");
3041 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3042 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3043 PUT_ERROR (Qvoid_function
, error_tail
,
3044 "Symbol's function definition is void");
3045 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3046 "Symbol's chain of function indirections contains a loop");
3047 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3048 "Symbol's chain of variable indirections contains a loop");
3049 DEFSYM (Qcircular_list
, "circular-list");
3050 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3051 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3052 PUT_ERROR (Qsetting_constant
, error_tail
,
3053 "Attempt to set a constant symbol");
3054 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3055 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3056 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3057 "Wrong number of arguments");
3058 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3059 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3061 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3062 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3063 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3065 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3066 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3067 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3068 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3069 "Text is read-only");
3071 DEFSYM (Qrange_error
, "range-error");
3072 DEFSYM (Qdomain_error
, "domain-error");
3073 DEFSYM (Qsingularity_error
, "singularity-error");
3074 DEFSYM (Qoverflow_error
, "overflow-error");
3075 DEFSYM (Qunderflow_error
, "underflow-error");
3077 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3079 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3081 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3082 "Arithmetic singularity error");
3084 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3085 "Arithmetic overflow error");
3086 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3087 "Arithmetic underflow error");
3091 staticpro (&Qunbound
);
3093 /* Types that type-of returns. */
3094 DEFSYM (Qinteger
, "integer");
3095 DEFSYM (Qsymbol
, "symbol");
3096 DEFSYM (Qstring
, "string");
3097 DEFSYM (Qcons
, "cons");
3098 DEFSYM (Qmarker
, "marker");
3099 DEFSYM (Qoverlay
, "overlay");
3100 DEFSYM (Qfloat
, "float");
3101 DEFSYM (Qwindow_configuration
, "window-configuration");
3102 DEFSYM (Qprocess
, "process");
3103 DEFSYM (Qwindow
, "window");
3104 DEFSYM (Qcompiled_function
, "compiled-function");
3105 DEFSYM (Qbuffer
, "buffer");
3106 DEFSYM (Qframe
, "frame");
3107 DEFSYM (Qvector
, "vector");
3108 DEFSYM (Qchar_table
, "char-table");
3109 DEFSYM (Qbool_vector
, "bool-vector");
3110 DEFSYM (Qhash_table
, "hash-table");
3111 DEFSYM (Qmisc
, "misc");
3113 DEFSYM (Qdefun
, "defun");
3115 DEFSYM (Qfont_spec
, "font-spec");
3116 DEFSYM (Qfont_entity
, "font-entity");
3117 DEFSYM (Qfont_object
, "font-object");
3119 DEFSYM (Qinteractive_form
, "interactive-form");
3120 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3122 defsubr (&Sindirect_variable
);
3123 defsubr (&Sinteractive_form
);
3126 defsubr (&Stype_of
);
3131 defsubr (&Sintegerp
);
3132 defsubr (&Sinteger_or_marker_p
);
3133 defsubr (&Snumberp
);
3134 defsubr (&Snumber_or_marker_p
);
3136 defsubr (&Snatnump
);
3137 defsubr (&Ssymbolp
);
3138 defsubr (&Skeywordp
);
3139 defsubr (&Sstringp
);
3140 defsubr (&Smultibyte_string_p
);
3141 defsubr (&Svectorp
);
3142 defsubr (&Schar_table_p
);
3143 defsubr (&Svector_or_char_table_p
);
3144 defsubr (&Sbool_vector_p
);
3146 defsubr (&Ssequencep
);
3147 defsubr (&Sbufferp
);
3148 defsubr (&Smarkerp
);
3150 defsubr (&Sbyte_code_function_p
);
3151 defsubr (&Schar_or_string_p
);
3154 defsubr (&Scar_safe
);
3155 defsubr (&Scdr_safe
);
3158 defsubr (&Ssymbol_function
);
3159 defsubr (&Sindirect_function
);
3160 defsubr (&Ssymbol_plist
);
3161 defsubr (&Ssymbol_name
);
3162 defsubr (&Smakunbound
);
3163 defsubr (&Sfmakunbound
);
3165 defsubr (&Sfboundp
);
3167 defsubr (&Sdefalias
);
3168 defsubr (&Ssetplist
);
3169 defsubr (&Ssymbol_value
);
3171 defsubr (&Sdefault_boundp
);
3172 defsubr (&Sdefault_value
);
3173 defsubr (&Sset_default
);
3174 defsubr (&Ssetq_default
);
3175 defsubr (&Smake_variable_buffer_local
);
3176 defsubr (&Smake_local_variable
);
3177 defsubr (&Skill_local_variable
);
3178 defsubr (&Smake_variable_frame_local
);
3179 defsubr (&Slocal_variable_p
);
3180 defsubr (&Slocal_variable_if_set_p
);
3181 defsubr (&Svariable_binding_locus
);
3182 #if 0 /* XXX Remove this. --lorentey */
3183 defsubr (&Sterminal_local_value
);
3184 defsubr (&Sset_terminal_local_value
);
3188 defsubr (&Snumber_to_string
);
3189 defsubr (&Sstring_to_number
);
3190 defsubr (&Seqlsign
);
3213 defsubr (&Sbyteorder
);
3214 defsubr (&Ssubr_arity
);
3215 defsubr (&Ssubr_name
);
3217 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3219 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3220 doc
: /* The largest value that is representable in a Lisp integer. */);
3221 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3222 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3224 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3225 doc
: /* The smallest value that is representable in a Lisp integer. */);
3226 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3227 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;