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 Lisp_Object value
= default_value (symbol
);
1388 if (!EQ (value
, Qunbound
))
1391 xsignal1 (Qvoid_variable
, symbol
);
1394 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1395 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1396 The default value is seen in buffers that do not have their own values
1397 for this variable. */)
1398 (Lisp_Object symbol
, Lisp_Object value
)
1400 struct Lisp_Symbol
*sym
;
1402 CHECK_SYMBOL (symbol
);
1403 if (SYMBOL_CONSTANT_P (symbol
))
1405 if (NILP (Fkeywordp (symbol
))
1406 || !EQ (value
, Fdefault_value (symbol
)))
1407 xsignal1 (Qsetting_constant
, symbol
);
1409 /* Allow setting keywords to their own value. */
1412 sym
= XSYMBOL (symbol
);
1415 switch (sym
->redirect
)
1417 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1418 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1419 case SYMBOL_LOCALIZED
:
1421 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1423 /* Store new value into the DEFAULT-VALUE slot. */
1424 XSETCDR (blv
->defcell
, value
);
1426 /* If the default binding is now loaded, set the REALVALUE slot too. */
1427 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1428 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1431 case SYMBOL_FORWARDED
:
1433 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1435 /* Handle variables like case-fold-search that have special slots
1437 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1438 if (BUFFER_OBJFWDP (valcontents
))
1440 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1441 int idx
= PER_BUFFER_IDX (offset
);
1443 set_per_buffer_default (offset
, value
);
1445 /* If this variable is not always local in all buffers,
1446 set it in the buffers that don't nominally have a local value. */
1452 if (!PER_BUFFER_VALUE_P (b
, idx
))
1453 set_per_buffer_value (b
, offset
, value
);
1458 return Fset (symbol
, value
);
1460 default: emacs_abort ();
1464 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1465 doc
: /* Set the default value of variable VAR to VALUE.
1466 VAR, the variable name, is literal (not evaluated);
1467 VALUE is an expression: it is evaluated and its value returned.
1468 The default value of a variable is seen in buffers
1469 that do not have their own values for the variable.
1471 More generally, you can use multiple variables and values, as in
1472 (setq-default VAR VALUE VAR VALUE...)
1473 This sets each VAR's default value to the corresponding VALUE.
1474 The VALUE for the Nth VAR can refer to the new default values
1476 usage: (setq-default [VAR VALUE]...) */)
1479 Lisp_Object args_left
, symbol
, val
;
1480 struct gcpro gcpro1
;
1482 args_left
= val
= args
;
1485 while (CONSP (args_left
))
1487 val
= eval_sub (Fcar (XCDR (args_left
)));
1488 symbol
= XCAR (args_left
);
1489 Fset_default (symbol
, val
);
1490 args_left
= Fcdr (XCDR (args_left
));
1497 /* Lisp functions for creating and removing buffer-local variables. */
1502 union Lisp_Fwd
*fwd
;
1505 static struct Lisp_Buffer_Local_Value
*
1506 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1507 union Lisp_Val_Fwd valcontents
)
1509 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1513 XSETSYMBOL (symbol
, sym
);
1514 tem
= Fcons (symbol
, (forwarded
1515 ? do_symval_forwarding (valcontents
.fwd
)
1516 : valcontents
.value
));
1518 /* Buffer_Local_Values cannot have as realval a buffer-local
1519 or keyboard-local forwarding. */
1520 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1521 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1522 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1523 set_blv_where (blv
, Qnil
);
1524 blv
->frame_local
= 0;
1525 blv
->local_if_set
= 0;
1526 set_blv_defcell (blv
, tem
);
1527 set_blv_valcell (blv
, tem
);
1528 set_blv_found (blv
, 0);
1532 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1533 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1534 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1535 At any time, the value for the current buffer is in effect,
1536 unless the variable has never been set in this buffer,
1537 in which case the default value is in effect.
1538 Note that binding the variable with `let', or setting it while
1539 a `let'-style binding made in this buffer is in effect,
1540 does not make the variable buffer-local. Return VARIABLE.
1542 In most cases it is better to use `make-local-variable',
1543 which makes a variable local in just one buffer.
1545 The function `default-value' gets the default value and `set-default' sets it. */)
1546 (register Lisp_Object variable
)
1548 struct Lisp_Symbol
*sym
;
1549 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1550 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1551 bool forwarded
IF_LINT (= 0);
1553 CHECK_SYMBOL (variable
);
1554 sym
= XSYMBOL (variable
);
1557 switch (sym
->redirect
)
1559 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1560 case SYMBOL_PLAINVAL
:
1561 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1562 if (EQ (valcontents
.value
, Qunbound
))
1563 valcontents
.value
= Qnil
;
1565 case SYMBOL_LOCALIZED
:
1566 blv
= SYMBOL_BLV (sym
);
1567 if (blv
->frame_local
)
1568 error ("Symbol %s may not be buffer-local",
1569 SDATA (SYMBOL_NAME (variable
)));
1571 case SYMBOL_FORWARDED
:
1572 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1573 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1574 error ("Symbol %s may not be buffer-local",
1575 SDATA (SYMBOL_NAME (variable
)));
1576 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1579 default: emacs_abort ();
1583 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1587 blv
= make_blv (sym
, forwarded
, valcontents
);
1588 sym
->redirect
= SYMBOL_LOCALIZED
;
1589 SET_SYMBOL_BLV (sym
, blv
);
1592 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1593 if (let_shadows_global_binding_p (symbol
))
1594 message ("Making %s buffer-local while let-bound!",
1595 SDATA (SYMBOL_NAME (variable
)));
1599 blv
->local_if_set
= 1;
1603 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1604 1, 1, "vMake Local Variable: ",
1605 doc
: /* Make VARIABLE have a separate value in the current buffer.
1606 Other buffers will continue to share a common default value.
1607 \(The buffer-local value of VARIABLE starts out as the same value
1608 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1611 If the variable is already arranged to become local when set,
1612 this function causes a local value to exist for this buffer,
1613 just as setting the variable would do.
1615 This function returns VARIABLE, and therefore
1616 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1619 See also `make-variable-buffer-local'.
1621 Do not use `make-local-variable' to make a hook variable buffer-local.
1622 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1623 (Lisp_Object variable
)
1626 bool forwarded
IF_LINT (= 0);
1627 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1628 struct Lisp_Symbol
*sym
;
1629 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1631 CHECK_SYMBOL (variable
);
1632 sym
= XSYMBOL (variable
);
1635 switch (sym
->redirect
)
1637 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1638 case SYMBOL_PLAINVAL
:
1639 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1640 case SYMBOL_LOCALIZED
:
1641 blv
= SYMBOL_BLV (sym
);
1642 if (blv
->frame_local
)
1643 error ("Symbol %s may not be buffer-local",
1644 SDATA (SYMBOL_NAME (variable
)));
1646 case SYMBOL_FORWARDED
:
1647 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1648 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1649 error ("Symbol %s may not be buffer-local",
1650 SDATA (SYMBOL_NAME (variable
)));
1652 default: emacs_abort ();
1656 error ("Symbol %s may not be buffer-local",
1657 SDATA (SYMBOL_NAME (variable
)));
1659 if (blv
? blv
->local_if_set
1660 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1662 tem
= Fboundp (variable
);
1663 /* Make sure the symbol has a local value in this particular buffer,
1664 by setting it to the same value it already has. */
1665 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1670 blv
= make_blv (sym
, forwarded
, valcontents
);
1671 sym
->redirect
= SYMBOL_LOCALIZED
;
1672 SET_SYMBOL_BLV (sym
, blv
);
1675 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1676 if (let_shadows_global_binding_p (symbol
))
1677 message ("Making %s local to %s while let-bound!",
1678 SDATA (SYMBOL_NAME (variable
)),
1679 SDATA (BVAR (current_buffer
, name
)));
1683 /* Make sure this buffer has its own value of symbol. */
1684 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1685 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1688 if (let_shadows_buffer_binding_p (sym
))
1689 message ("Making %s buffer-local while locally let-bound!",
1690 SDATA (SYMBOL_NAME (variable
)));
1692 /* Swap out any local binding for some other buffer, and make
1693 sure the current value is permanently recorded, if it's the
1695 find_symbol_value (variable
);
1697 bset_local_var_alist
1699 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1700 BVAR (current_buffer
, local_var_alist
)));
1702 /* Make sure symbol does not think it is set up for this buffer;
1703 force it to look once again for this buffer's value. */
1704 if (current_buffer
== XBUFFER (blv
->where
))
1705 set_blv_where (blv
, Qnil
);
1706 set_blv_found (blv
, 0);
1709 /* If the symbol forwards into a C variable, then load the binding
1710 for this buffer now. If C code modifies the variable before we
1711 load the binding in, then that new value will clobber the default
1712 binding the next time we unload it. */
1714 swap_in_symval_forwarding (sym
, blv
);
1719 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1720 1, 1, "vKill Local Variable: ",
1721 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1722 From now on the default value will apply in this buffer. Return VARIABLE. */)
1723 (register Lisp_Object variable
)
1725 register Lisp_Object tem
;
1726 struct Lisp_Buffer_Local_Value
*blv
;
1727 struct Lisp_Symbol
*sym
;
1729 CHECK_SYMBOL (variable
);
1730 sym
= XSYMBOL (variable
);
1733 switch (sym
->redirect
)
1735 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1736 case SYMBOL_PLAINVAL
: return variable
;
1737 case SYMBOL_FORWARDED
:
1739 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1740 if (BUFFER_OBJFWDP (valcontents
))
1742 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1743 int idx
= PER_BUFFER_IDX (offset
);
1747 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1748 set_per_buffer_value (current_buffer
, offset
,
1749 per_buffer_default (offset
));
1754 case SYMBOL_LOCALIZED
:
1755 blv
= SYMBOL_BLV (sym
);
1756 if (blv
->frame_local
)
1759 default: emacs_abort ();
1762 /* Get rid of this buffer's alist element, if any. */
1763 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1764 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1766 bset_local_var_alist
1768 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1770 /* If the symbol is set up with the current buffer's binding
1771 loaded, recompute its value. We have to do it now, or else
1772 forwarded objects won't work right. */
1774 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1775 if (EQ (buf
, blv
->where
))
1777 set_blv_where (blv
, Qnil
);
1779 find_symbol_value (variable
);
1786 /* Lisp functions for creating and removing buffer-local variables. */
1788 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1789 when/if this is removed. */
1791 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1792 1, 1, "vMake Variable Frame Local: ",
1793 doc
: /* Enable VARIABLE to have frame-local bindings.
1794 This does not create any frame-local bindings for VARIABLE,
1795 it just makes them possible.
1797 A frame-local binding is actually a frame parameter value.
1798 If a frame F has a value for the frame parameter named VARIABLE,
1799 that also acts as a frame-local binding for VARIABLE in F--
1800 provided this function has been called to enable VARIABLE
1801 to have frame-local bindings at all.
1803 The only way to create a frame-local binding for VARIABLE in a frame
1804 is to set the VARIABLE frame parameter of that frame. See
1805 `modify-frame-parameters' for how to set frame parameters.
1807 Note that since Emacs 23.1, variables cannot be both buffer-local and
1808 frame-local any more (buffer-local bindings used to take precedence over
1809 frame-local bindings). */)
1810 (Lisp_Object variable
)
1813 union Lisp_Val_Fwd valcontents
;
1814 struct Lisp_Symbol
*sym
;
1815 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1817 CHECK_SYMBOL (variable
);
1818 sym
= XSYMBOL (variable
);
1821 switch (sym
->redirect
)
1823 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1824 case SYMBOL_PLAINVAL
:
1825 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1826 if (EQ (valcontents
.value
, Qunbound
))
1827 valcontents
.value
= Qnil
;
1829 case SYMBOL_LOCALIZED
:
1830 if (SYMBOL_BLV (sym
)->frame_local
)
1833 error ("Symbol %s may not be frame-local",
1834 SDATA (SYMBOL_NAME (variable
)));
1835 case SYMBOL_FORWARDED
:
1836 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1837 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1838 error ("Symbol %s may not be frame-local",
1839 SDATA (SYMBOL_NAME (variable
)));
1841 default: emacs_abort ();
1845 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1847 blv
= make_blv (sym
, forwarded
, valcontents
);
1848 blv
->frame_local
= 1;
1849 sym
->redirect
= SYMBOL_LOCALIZED
;
1850 SET_SYMBOL_BLV (sym
, blv
);
1853 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1854 if (let_shadows_global_binding_p (symbol
))
1855 message ("Making %s frame-local while let-bound!",
1856 SDATA (SYMBOL_NAME (variable
)));
1861 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1863 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1864 BUFFER defaults to the current buffer. */)
1865 (register Lisp_Object variable
, Lisp_Object buffer
)
1867 register struct buffer
*buf
;
1868 struct Lisp_Symbol
*sym
;
1871 buf
= current_buffer
;
1874 CHECK_BUFFER (buffer
);
1875 buf
= XBUFFER (buffer
);
1878 CHECK_SYMBOL (variable
);
1879 sym
= XSYMBOL (variable
);
1882 switch (sym
->redirect
)
1884 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1885 case SYMBOL_PLAINVAL
: return Qnil
;
1886 case SYMBOL_LOCALIZED
:
1888 Lisp_Object tail
, elt
, tmp
;
1889 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1890 XSETBUFFER (tmp
, buf
);
1891 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1893 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1894 return blv_found (blv
) ? Qt
: Qnil
;
1896 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1899 if (EQ (variable
, XCAR (elt
)))
1901 eassert (!blv
->frame_local
);
1907 case SYMBOL_FORWARDED
:
1909 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1910 if (BUFFER_OBJFWDP (valcontents
))
1912 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1913 int idx
= PER_BUFFER_IDX (offset
);
1914 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1919 default: emacs_abort ();
1923 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1925 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1926 BUFFER defaults to the current buffer.
1928 More precisely, return non-nil if either VARIABLE already has a local
1929 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1930 `make-variable-buffer-local'). */)
1931 (register Lisp_Object variable
, Lisp_Object buffer
)
1933 struct Lisp_Symbol
*sym
;
1935 CHECK_SYMBOL (variable
);
1936 sym
= XSYMBOL (variable
);
1939 switch (sym
->redirect
)
1941 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1942 case SYMBOL_PLAINVAL
: return Qnil
;
1943 case SYMBOL_LOCALIZED
:
1945 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1946 if (blv
->local_if_set
)
1948 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1949 return Flocal_variable_p (variable
, buffer
);
1951 case SYMBOL_FORWARDED
:
1952 /* All BUFFER_OBJFWD slots become local if they are set. */
1953 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1954 default: emacs_abort ();
1958 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1960 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1961 If the current binding is buffer-local, the value is the current buffer.
1962 If the current binding is frame-local, the value is the selected frame.
1963 If the current binding is global (the default), the value is nil. */)
1964 (register Lisp_Object variable
)
1966 struct Lisp_Symbol
*sym
;
1968 CHECK_SYMBOL (variable
);
1969 sym
= XSYMBOL (variable
);
1971 /* Make sure the current binding is actually swapped in. */
1972 find_symbol_value (variable
);
1975 switch (sym
->redirect
)
1977 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1978 case SYMBOL_PLAINVAL
: return Qnil
;
1979 case SYMBOL_FORWARDED
:
1981 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1982 if (KBOARD_OBJFWDP (valcontents
))
1983 return Fframe_terminal (Fselected_frame ());
1984 else if (!BUFFER_OBJFWDP (valcontents
))
1988 case SYMBOL_LOCALIZED
:
1989 /* For a local variable, record both the symbol and which
1990 buffer's or frame's value we are saving. */
1991 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1992 return Fcurrent_buffer ();
1993 else if (sym
->redirect
== SYMBOL_LOCALIZED
1994 && blv_found (SYMBOL_BLV (sym
)))
1995 return SYMBOL_BLV (sym
)->where
;
1998 default: emacs_abort ();
2002 /* This code is disabled now that we use the selected frame to return
2003 keyboard-local-values. */
2005 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2007 DEFUN ("terminal-local-value", Fterminal_local_value
,
2008 Sterminal_local_value
, 2, 2, 0,
2009 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2010 If SYMBOL is not a terminal-local variable, then return its normal
2011 value, like `symbol-value'.
2013 TERMINAL may be a terminal object, a frame, or nil (meaning the
2014 selected frame's terminal device). */)
2015 (Lisp_Object symbol
, Lisp_Object terminal
)
2018 struct terminal
*t
= get_terminal (terminal
, 1);
2019 push_kboard (t
->kboard
);
2020 result
= Fsymbol_value (symbol
);
2025 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2026 Sset_terminal_local_value
, 3, 3, 0,
2027 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2028 If VARIABLE is not a terminal-local variable, then set its normal
2029 binding, like `set'.
2031 TERMINAL may be a terminal object, a frame, or nil (meaning the
2032 selected frame's terminal device). */)
2033 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2036 struct terminal
*t
= get_terminal (terminal
, 1);
2037 push_kboard (d
->kboard
);
2038 result
= Fset (symbol
, value
);
2044 /* Find the function at the end of a chain of symbol function indirections. */
2046 /* If OBJECT is a symbol, find the end of its function chain and
2047 return the value found there. If OBJECT is not a symbol, just
2048 return it. If there is a cycle in the function chain, signal a
2049 cyclic-function-indirection error.
2051 This is like Findirect_function, except that it doesn't signal an
2052 error if the chain ends up unbound. */
2054 indirect_function (register Lisp_Object object
)
2056 Lisp_Object tortoise
, hare
;
2058 hare
= tortoise
= object
;
2062 if (!SYMBOLP (hare
) || NILP (hare
))
2064 hare
= XSYMBOL (hare
)->function
;
2065 if (!SYMBOLP (hare
) || NILP (hare
))
2067 hare
= XSYMBOL (hare
)->function
;
2069 tortoise
= XSYMBOL (tortoise
)->function
;
2071 if (EQ (hare
, tortoise
))
2072 xsignal1 (Qcyclic_function_indirection
, object
);
2078 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2079 doc
: /* Return the function at the end of OBJECT's function chain.
2080 If OBJECT is not a symbol, just return it. Otherwise, follow all
2081 function indirections to find the final function binding and return it.
2082 If the final symbol in the chain is unbound, signal a void-function error.
2083 Optional arg NOERROR non-nil means to return nil instead of signaling.
2084 Signal a cyclic-function-indirection error if there is a loop in the
2085 function chain of symbols. */)
2086 (register Lisp_Object object
, Lisp_Object noerror
)
2090 /* Optimize for no indirection. */
2092 if (SYMBOLP (result
) && !NILP (result
)
2093 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2094 result
= indirect_function (result
);
2099 xsignal1 (Qvoid_function
, object
);
2104 /* Extract and set vector and string elements. */
2106 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2107 doc
: /* Return the element of ARRAY at index IDX.
2108 ARRAY may be a vector, a string, a char-table, a bool-vector,
2109 or a byte-code object. IDX starts at 0. */)
2110 (register Lisp_Object array
, Lisp_Object idx
)
2112 register EMACS_INT idxval
;
2115 idxval
= XINT (idx
);
2116 if (STRINGP (array
))
2119 ptrdiff_t idxval_byte
;
2121 if (idxval
< 0 || idxval
>= SCHARS (array
))
2122 args_out_of_range (array
, idx
);
2123 if (! STRING_MULTIBYTE (array
))
2124 return make_number ((unsigned char) SREF (array
, idxval
));
2125 idxval_byte
= string_char_to_byte (array
, idxval
);
2127 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2128 return make_number (c
);
2130 else if (BOOL_VECTOR_P (array
))
2134 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2135 args_out_of_range (array
, idx
);
2137 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2138 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2140 else if (CHAR_TABLE_P (array
))
2142 CHECK_CHARACTER (idx
);
2143 return CHAR_TABLE_REF (array
, idxval
);
2148 if (VECTORP (array
))
2149 size
= ASIZE (array
);
2150 else if (COMPILEDP (array
))
2151 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2153 wrong_type_argument (Qarrayp
, array
);
2155 if (idxval
< 0 || idxval
>= size
)
2156 args_out_of_range (array
, idx
);
2157 return AREF (array
, idxval
);
2161 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2162 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2163 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2164 bool-vector. IDX starts at 0. */)
2165 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2167 register EMACS_INT idxval
;
2170 idxval
= XINT (idx
);
2171 CHECK_ARRAY (array
, Qarrayp
);
2172 CHECK_IMPURE (array
);
2174 if (VECTORP (array
))
2176 if (idxval
< 0 || idxval
>= ASIZE (array
))
2177 args_out_of_range (array
, idx
);
2178 ASET (array
, idxval
, newelt
);
2180 else if (BOOL_VECTOR_P (array
))
2184 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2185 args_out_of_range (array
, idx
);
2187 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2189 if (! NILP (newelt
))
2190 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2192 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2193 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2195 else if (CHAR_TABLE_P (array
))
2197 CHECK_CHARACTER (idx
);
2198 CHAR_TABLE_SET (array
, idxval
, newelt
);
2204 if (idxval
< 0 || idxval
>= SCHARS (array
))
2205 args_out_of_range (array
, idx
);
2206 CHECK_CHARACTER (newelt
);
2207 c
= XFASTINT (newelt
);
2209 if (STRING_MULTIBYTE (array
))
2211 ptrdiff_t idxval_byte
, nbytes
;
2212 int prev_bytes
, new_bytes
;
2213 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2215 nbytes
= SBYTES (array
);
2216 idxval_byte
= string_char_to_byte (array
, idxval
);
2217 p1
= SDATA (array
) + idxval_byte
;
2218 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2219 new_bytes
= CHAR_STRING (c
, p0
);
2220 if (prev_bytes
!= new_bytes
)
2222 /* We must relocate the string data. */
2223 ptrdiff_t nchars
= SCHARS (array
);
2225 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2227 memcpy (str
, SDATA (array
), nbytes
);
2228 allocate_string_data (XSTRING (array
), nchars
,
2229 nbytes
+ new_bytes
- prev_bytes
);
2230 memcpy (SDATA (array
), str
, idxval_byte
);
2231 p1
= SDATA (array
) + idxval_byte
;
2232 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2233 nbytes
- (idxval_byte
+ prev_bytes
));
2235 clear_string_char_byte_cache ();
2242 if (! SINGLE_BYTE_CHAR_P (c
))
2246 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2247 if (SREF (array
, i
) >= 0x80)
2248 args_out_of_range (array
, newelt
);
2249 /* ARRAY is an ASCII string. Convert it to a multibyte
2250 string, and try `aset' again. */
2251 STRING_SET_MULTIBYTE (array
);
2252 return Faset (array
, idx
, newelt
);
2254 SSET (array
, idxval
, c
);
2261 /* Arithmetic functions */
2263 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2266 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2268 double f1
= 0, f2
= 0;
2271 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2272 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2274 if (FLOATP (num1
) || FLOATP (num2
))
2277 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2278 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2284 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2289 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2294 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2299 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2304 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2309 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2318 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2319 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2320 (register Lisp_Object num1
, Lisp_Object num2
)
2322 return arithcompare (num1
, num2
, equal
);
2325 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2326 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2327 (register Lisp_Object num1
, Lisp_Object num2
)
2329 return arithcompare (num1
, num2
, less
);
2332 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2333 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2334 (register Lisp_Object num1
, Lisp_Object num2
)
2336 return arithcompare (num1
, num2
, grtr
);
2339 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2340 doc
: /* Return t if first arg is less than or equal to second arg.
2341 Both must be numbers or markers. */)
2342 (register Lisp_Object num1
, Lisp_Object num2
)
2344 return arithcompare (num1
, num2
, less_or_equal
);
2347 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2348 doc
: /* Return t if first arg is greater than or equal to second arg.
2349 Both must be numbers or markers. */)
2350 (register Lisp_Object num1
, Lisp_Object num2
)
2352 return arithcompare (num1
, num2
, grtr_or_equal
);
2355 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2356 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2357 (register Lisp_Object num1
, Lisp_Object num2
)
2359 return arithcompare (num1
, num2
, notequal
);
2362 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2363 doc
: /* Return t if NUMBER is zero. */)
2364 (register Lisp_Object number
)
2366 CHECK_NUMBER_OR_FLOAT (number
);
2368 if (FLOATP (number
))
2370 if (XFLOAT_DATA (number
) == 0.0)
2380 /* Convert the cons-of-integers, integer, or float value C to an
2381 unsigned value with maximum value MAX. Signal an error if C does not
2382 have a valid format or is out of range. */
2384 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2387 uintmax_t val
IF_LINT (= 0);
2390 valid
= 0 <= XINT (c
);
2393 else if (FLOATP (c
))
2395 double d
= XFLOAT_DATA (c
);
2397 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2403 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2405 uintmax_t top
= XFASTINT (XCAR (c
));
2406 Lisp_Object rest
= XCDR (c
);
2407 if (top
<= UINTMAX_MAX
>> 24 >> 16
2409 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2410 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2412 uintmax_t mid
= XFASTINT (XCAR (rest
));
2413 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2416 else if (top
<= UINTMAX_MAX
>> 16)
2420 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2422 val
= top
<< 16 | XFASTINT (rest
);
2428 if (! (valid
&& val
<= max
))
2429 error ("Not an in-range integer, float, or cons of integers");
2433 /* Convert the cons-of-integers, integer, or float value C to a signed
2434 value with extrema MIN and MAX. Signal an error if C does not have
2435 a valid format or is out of range. */
2437 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2440 intmax_t val
IF_LINT (= 0);
2446 else if (FLOATP (c
))
2448 double d
= XFLOAT_DATA (c
);
2450 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2456 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2458 intmax_t top
= XINT (XCAR (c
));
2459 Lisp_Object rest
= XCDR (c
);
2460 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2462 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2463 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2465 intmax_t mid
= XFASTINT (XCAR (rest
));
2466 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2469 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2473 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2475 val
= top
<< 16 | XFASTINT (rest
);
2481 if (! (valid
&& min
<= val
&& val
<= max
))
2482 error ("Not an in-range integer, float, or cons of integers");
2486 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2487 doc
: /* Return the decimal representation of NUMBER as a string.
2488 Uses a minus sign if negative.
2489 NUMBER may be an integer or a floating point number. */)
2490 (Lisp_Object number
)
2492 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2495 CHECK_NUMBER_OR_FLOAT (number
);
2497 if (FLOATP (number
))
2498 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2500 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2502 return make_unibyte_string (buffer
, len
);
2505 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2506 doc
: /* Parse STRING as a decimal number and return the number.
2507 This parses both integers and floating point numbers.
2508 It ignores leading spaces and tabs, and all trailing chars.
2510 If BASE, interpret STRING as a number in that base. If BASE isn't
2511 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2512 If the base used is not 10, STRING is always parsed as integer. */)
2513 (register Lisp_Object string
, Lisp_Object base
)
2519 CHECK_STRING (string
);
2525 CHECK_NUMBER (base
);
2526 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2527 xsignal1 (Qargs_out_of_range
, base
);
2531 p
= SSDATA (string
);
2532 while (*p
== ' ' || *p
== '\t')
2535 val
= string_to_number (p
, b
, 1);
2536 return NILP (val
) ? make_number (0) : val
;
2552 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2553 ptrdiff_t, Lisp_Object
*);
2555 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2558 ptrdiff_t argnum
, ok_args
;
2559 EMACS_INT accum
= 0;
2560 EMACS_INT next
, ok_accum
;
2581 for (argnum
= 0; argnum
< nargs
; argnum
++)
2589 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2591 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2594 return float_arith_driver (ok_accum
, ok_args
, code
,
2597 next
= XINT (args
[argnum
]);
2601 if (INT_ADD_OVERFLOW (accum
, next
))
2609 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2614 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2617 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2619 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2621 accum
= ab
& INTMASK
;
2632 xsignal0 (Qarith_error
);
2646 if (!argnum
|| next
> accum
)
2650 if (!argnum
|| next
< accum
)
2656 XSETINT (val
, accum
);
2661 #define isnan(x) ((x) != (x))
2664 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2665 ptrdiff_t nargs
, Lisp_Object
*args
)
2667 register Lisp_Object val
;
2670 for (; argnum
< nargs
; argnum
++)
2672 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2673 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2677 next
= XFLOAT_DATA (val
);
2681 args
[argnum
] = val
; /* runs into a compiler bug. */
2682 next
= XINT (args
[argnum
]);
2690 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2700 if (! IEEE_FLOATING_POINT
&& next
== 0)
2701 xsignal0 (Qarith_error
);
2708 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2710 if (!argnum
|| isnan (next
) || next
> accum
)
2714 if (!argnum
|| isnan (next
) || next
< accum
)
2720 return make_float (accum
);
2724 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2725 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2726 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2727 (ptrdiff_t nargs
, Lisp_Object
*args
)
2729 return arith_driver (Aadd
, nargs
, args
);
2732 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2733 doc
: /* Negate number or subtract numbers or markers and return the result.
2734 With one arg, negates it. With more than one arg,
2735 subtracts all but the first from the first.
2736 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2737 (ptrdiff_t nargs
, Lisp_Object
*args
)
2739 return arith_driver (Asub
, nargs
, args
);
2742 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2743 doc
: /* Return product of any number of arguments, which are numbers or markers.
2744 usage: (* &rest NUMBERS-OR-MARKERS) */)
2745 (ptrdiff_t nargs
, Lisp_Object
*args
)
2747 return arith_driver (Amult
, nargs
, args
);
2750 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2751 doc
: /* Return first argument divided by all the remaining arguments.
2752 The arguments must be numbers or markers.
2753 usage: (/ DIVIDEND &rest DIVISORS) */)
2754 (ptrdiff_t nargs
, Lisp_Object
*args
)
2757 for (argnum
= 2; argnum
< nargs
; argnum
++)
2758 if (FLOATP (args
[argnum
]))
2759 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2760 return arith_driver (Adiv
, nargs
, args
);
2763 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2764 doc
: /* Return remainder of X divided by Y.
2765 Both must be integers or markers. */)
2766 (register Lisp_Object x
, Lisp_Object y
)
2770 CHECK_NUMBER_COERCE_MARKER (x
);
2771 CHECK_NUMBER_COERCE_MARKER (y
);
2774 xsignal0 (Qarith_error
);
2776 XSETINT (val
, XINT (x
) % XINT (y
));
2780 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2781 doc
: /* Return X modulo Y.
2782 The result falls between zero (inclusive) and Y (exclusive).
2783 Both X and Y must be numbers or markers. */)
2784 (register Lisp_Object x
, Lisp_Object y
)
2789 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2790 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2792 if (FLOATP (x
) || FLOATP (y
))
2793 return fmod_float (x
, y
);
2799 xsignal0 (Qarith_error
);
2803 /* If the "remainder" comes out with the wrong sign, fix it. */
2804 if (i2
< 0 ? i1
> 0 : i1
< 0)
2811 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2812 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2813 The value is always a number; markers are converted to numbers.
2814 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2815 (ptrdiff_t nargs
, Lisp_Object
*args
)
2817 return arith_driver (Amax
, nargs
, args
);
2820 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2821 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2822 The value is always a number; markers are converted to numbers.
2823 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2824 (ptrdiff_t nargs
, Lisp_Object
*args
)
2826 return arith_driver (Amin
, nargs
, args
);
2829 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2830 doc
: /* Return bitwise-and of all the arguments.
2831 Arguments may be integers, or markers converted to integers.
2832 usage: (logand &rest INTS-OR-MARKERS) */)
2833 (ptrdiff_t nargs
, Lisp_Object
*args
)
2835 return arith_driver (Alogand
, nargs
, args
);
2838 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2839 doc
: /* Return bitwise-or of all the arguments.
2840 Arguments may be integers, or markers converted to integers.
2841 usage: (logior &rest INTS-OR-MARKERS) */)
2842 (ptrdiff_t nargs
, Lisp_Object
*args
)
2844 return arith_driver (Alogior
, nargs
, args
);
2847 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2848 doc
: /* Return bitwise-exclusive-or of all the arguments.
2849 Arguments may be integers, or markers converted to integers.
2850 usage: (logxor &rest INTS-OR-MARKERS) */)
2851 (ptrdiff_t nargs
, Lisp_Object
*args
)
2853 return arith_driver (Alogxor
, nargs
, args
);
2856 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2857 doc
: /* Return VALUE with its bits shifted left by COUNT.
2858 If COUNT is negative, shifting is actually to the right.
2859 In this case, the sign bit is duplicated. */)
2860 (register Lisp_Object value
, Lisp_Object count
)
2862 register Lisp_Object val
;
2864 CHECK_NUMBER (value
);
2865 CHECK_NUMBER (count
);
2867 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2869 else if (XINT (count
) > 0)
2870 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2871 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2872 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2874 XSETINT (val
, XINT (value
) >> -XINT (count
));
2878 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2879 doc
: /* Return VALUE with its bits shifted left by COUNT.
2880 If COUNT is negative, shifting is actually to the right.
2881 In this case, zeros are shifted in on the left. */)
2882 (register Lisp_Object value
, Lisp_Object count
)
2884 register Lisp_Object val
;
2886 CHECK_NUMBER (value
);
2887 CHECK_NUMBER (count
);
2889 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2891 else if (XINT (count
) > 0)
2892 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2893 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2896 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2900 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2901 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2902 Markers are converted to integers. */)
2903 (register Lisp_Object number
)
2905 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2907 if (FLOATP (number
))
2908 return (make_float (1.0 + XFLOAT_DATA (number
)));
2910 XSETINT (number
, XINT (number
) + 1);
2914 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2915 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2916 Markers are converted to integers. */)
2917 (register Lisp_Object number
)
2919 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2921 if (FLOATP (number
))
2922 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2924 XSETINT (number
, XINT (number
) - 1);
2928 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2929 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2930 (register Lisp_Object number
)
2932 CHECK_NUMBER (number
);
2933 XSETINT (number
, ~XINT (number
));
2937 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2938 doc
: /* Return the byteorder for the machine.
2939 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2940 lowercase l) for small endian machines. */)
2943 unsigned i
= 0x04030201;
2944 int order
= *(char *)&i
== 1 ? 108 : 66;
2946 return make_number (order
);
2954 Lisp_Object error_tail
, arith_tail
;
2956 DEFSYM (Qquote
, "quote");
2957 DEFSYM (Qlambda
, "lambda");
2958 DEFSYM (Qsubr
, "subr");
2959 DEFSYM (Qerror_conditions
, "error-conditions");
2960 DEFSYM (Qerror_message
, "error-message");
2961 DEFSYM (Qtop_level
, "top-level");
2963 DEFSYM (Qerror
, "error");
2964 DEFSYM (Quser_error
, "user-error");
2965 DEFSYM (Qquit
, "quit");
2966 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2967 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2968 DEFSYM (Qvoid_function
, "void-function");
2969 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2970 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2971 DEFSYM (Qvoid_variable
, "void-variable");
2972 DEFSYM (Qsetting_constant
, "setting-constant");
2973 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2975 DEFSYM (Qinvalid_function
, "invalid-function");
2976 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2977 DEFSYM (Qno_catch
, "no-catch");
2978 DEFSYM (Qend_of_file
, "end-of-file");
2979 DEFSYM (Qarith_error
, "arith-error");
2980 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2981 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2982 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2983 DEFSYM (Qtext_read_only
, "text-read-only");
2984 DEFSYM (Qmark_inactive
, "mark-inactive");
2986 DEFSYM (Qlistp
, "listp");
2987 DEFSYM (Qconsp
, "consp");
2988 DEFSYM (Qsymbolp
, "symbolp");
2989 DEFSYM (Qkeywordp
, "keywordp");
2990 DEFSYM (Qintegerp
, "integerp");
2991 DEFSYM (Qnatnump
, "natnump");
2992 DEFSYM (Qwholenump
, "wholenump");
2993 DEFSYM (Qstringp
, "stringp");
2994 DEFSYM (Qarrayp
, "arrayp");
2995 DEFSYM (Qsequencep
, "sequencep");
2996 DEFSYM (Qbufferp
, "bufferp");
2997 DEFSYM (Qvectorp
, "vectorp");
2998 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2999 DEFSYM (Qmarkerp
, "markerp");
3000 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3001 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3002 DEFSYM (Qboundp
, "boundp");
3003 DEFSYM (Qfboundp
, "fboundp");
3005 DEFSYM (Qfloatp
, "floatp");
3006 DEFSYM (Qnumberp
, "numberp");
3007 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3009 DEFSYM (Qchar_table_p
, "char-table-p");
3010 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3012 DEFSYM (Qsubrp
, "subrp");
3013 DEFSYM (Qunevalled
, "unevalled");
3014 DEFSYM (Qmany
, "many");
3016 DEFSYM (Qcdr
, "cdr");
3018 /* Handle automatic advice activation. */
3019 DEFSYM (Qad_advice_info
, "ad-advice-info");
3020 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3022 error_tail
= pure_cons (Qerror
, Qnil
);
3024 /* ERROR is used as a signaler for random errors for which nothing else is
3027 Fput (Qerror
, Qerror_conditions
,
3029 Fput (Qerror
, Qerror_message
,
3030 build_pure_c_string ("error"));
3032 #define PUT_ERROR(sym, tail, msg) \
3033 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3034 Fput (sym, Qerror_message, build_pure_c_string (msg))
3036 PUT_ERROR (Qquit
, Qnil
, "Quit");
3038 PUT_ERROR (Quser_error
, error_tail
, "");
3039 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3040 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3041 PUT_ERROR (Qvoid_function
, error_tail
,
3042 "Symbol's function definition is void");
3043 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3044 "Symbol's chain of function indirections contains a loop");
3045 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3046 "Symbol's chain of variable indirections contains a loop");
3047 DEFSYM (Qcircular_list
, "circular-list");
3048 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3049 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3050 PUT_ERROR (Qsetting_constant
, error_tail
,
3051 "Attempt to set a constant symbol");
3052 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3053 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3054 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3055 "Wrong number of arguments");
3056 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3057 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3059 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3060 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3061 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3063 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3064 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3065 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3066 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3067 "Text is read-only");
3069 DEFSYM (Qrange_error
, "range-error");
3070 DEFSYM (Qdomain_error
, "domain-error");
3071 DEFSYM (Qsingularity_error
, "singularity-error");
3072 DEFSYM (Qoverflow_error
, "overflow-error");
3073 DEFSYM (Qunderflow_error
, "underflow-error");
3075 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3077 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3079 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3080 "Arithmetic singularity error");
3082 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3083 "Arithmetic overflow error");
3084 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3085 "Arithmetic underflow error");
3089 staticpro (&Qunbound
);
3091 /* Types that type-of returns. */
3092 DEFSYM (Qinteger
, "integer");
3093 DEFSYM (Qsymbol
, "symbol");
3094 DEFSYM (Qstring
, "string");
3095 DEFSYM (Qcons
, "cons");
3096 DEFSYM (Qmarker
, "marker");
3097 DEFSYM (Qoverlay
, "overlay");
3098 DEFSYM (Qfloat
, "float");
3099 DEFSYM (Qwindow_configuration
, "window-configuration");
3100 DEFSYM (Qprocess
, "process");
3101 DEFSYM (Qwindow
, "window");
3102 DEFSYM (Qcompiled_function
, "compiled-function");
3103 DEFSYM (Qbuffer
, "buffer");
3104 DEFSYM (Qframe
, "frame");
3105 DEFSYM (Qvector
, "vector");
3106 DEFSYM (Qchar_table
, "char-table");
3107 DEFSYM (Qbool_vector
, "bool-vector");
3108 DEFSYM (Qhash_table
, "hash-table");
3109 DEFSYM (Qmisc
, "misc");
3111 DEFSYM (Qdefun
, "defun");
3113 DEFSYM (Qfont_spec
, "font-spec");
3114 DEFSYM (Qfont_entity
, "font-entity");
3115 DEFSYM (Qfont_object
, "font-object");
3117 DEFSYM (Qinteractive_form
, "interactive-form");
3118 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3120 defsubr (&Sindirect_variable
);
3121 defsubr (&Sinteractive_form
);
3124 defsubr (&Stype_of
);
3129 defsubr (&Sintegerp
);
3130 defsubr (&Sinteger_or_marker_p
);
3131 defsubr (&Snumberp
);
3132 defsubr (&Snumber_or_marker_p
);
3134 defsubr (&Snatnump
);
3135 defsubr (&Ssymbolp
);
3136 defsubr (&Skeywordp
);
3137 defsubr (&Sstringp
);
3138 defsubr (&Smultibyte_string_p
);
3139 defsubr (&Svectorp
);
3140 defsubr (&Schar_table_p
);
3141 defsubr (&Svector_or_char_table_p
);
3142 defsubr (&Sbool_vector_p
);
3144 defsubr (&Ssequencep
);
3145 defsubr (&Sbufferp
);
3146 defsubr (&Smarkerp
);
3148 defsubr (&Sbyte_code_function_p
);
3149 defsubr (&Schar_or_string_p
);
3152 defsubr (&Scar_safe
);
3153 defsubr (&Scdr_safe
);
3156 defsubr (&Ssymbol_function
);
3157 defsubr (&Sindirect_function
);
3158 defsubr (&Ssymbol_plist
);
3159 defsubr (&Ssymbol_name
);
3160 defsubr (&Smakunbound
);
3161 defsubr (&Sfmakunbound
);
3163 defsubr (&Sfboundp
);
3165 defsubr (&Sdefalias
);
3166 defsubr (&Ssetplist
);
3167 defsubr (&Ssymbol_value
);
3169 defsubr (&Sdefault_boundp
);
3170 defsubr (&Sdefault_value
);
3171 defsubr (&Sset_default
);
3172 defsubr (&Ssetq_default
);
3173 defsubr (&Smake_variable_buffer_local
);
3174 defsubr (&Smake_local_variable
);
3175 defsubr (&Skill_local_variable
);
3176 defsubr (&Smake_variable_frame_local
);
3177 defsubr (&Slocal_variable_p
);
3178 defsubr (&Slocal_variable_if_set_p
);
3179 defsubr (&Svariable_binding_locus
);
3180 #if 0 /* XXX Remove this. --lorentey */
3181 defsubr (&Sterminal_local_value
);
3182 defsubr (&Sset_terminal_local_value
);
3186 defsubr (&Snumber_to_string
);
3187 defsubr (&Sstring_to_number
);
3188 defsubr (&Seqlsign
);
3211 defsubr (&Sbyteorder
);
3212 defsubr (&Ssubr_arity
);
3213 defsubr (&Ssubr_name
);
3215 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3217 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3218 doc
: /* The largest value that is representable in a Lisp integer. */);
3219 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3220 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3222 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3223 doc
: /* The smallest value that is representable in a Lisp integer. */);
3224 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3225 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;