1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 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 (at
10 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/>. */
25 #include <count-one-bits.h>
26 #include <count-trailing-zeros.h>
31 #include "character.h"
37 static void swap_in_symval_forwarding (struct Lisp_Symbol
*,
38 struct Lisp_Buffer_Local_Value
*);
41 BOOLFWDP (union Lisp_Fwd
*a
)
43 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
46 INTFWDP (union Lisp_Fwd
*a
)
48 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
51 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
53 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
56 OBJFWDP (union Lisp_Fwd
*a
)
58 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
61 static struct Lisp_Boolfwd
*
62 XBOOLFWD (union Lisp_Fwd
*a
)
64 eassert (BOOLFWDP (a
));
67 static struct Lisp_Kboard_Objfwd
*
68 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
70 eassert (KBOARD_OBJFWDP (a
));
71 return &a
->u_kboard_objfwd
;
73 static struct Lisp_Intfwd
*
74 XINTFWD (union Lisp_Fwd
*a
)
76 eassert (INTFWDP (a
));
79 static struct Lisp_Objfwd
*
80 XOBJFWD (union Lisp_Fwd
*a
)
82 eassert (OBJFWDP (a
));
87 CHECK_SUBR (Lisp_Object x
)
89 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
93 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
95 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
100 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
102 return XCDR (blv
->valcell
);
106 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
108 XSETCDR (blv
->valcell
, val
);
112 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
118 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
124 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
129 static _Noreturn
void
130 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
132 Lisp_Object size1
= make_number (bool_vector_size (a1
));
133 Lisp_Object size2
= make_number (bool_vector_size (a2
));
135 xsignal2 (Qwrong_length_argument
, size1
, size2
);
137 xsignal3 (Qwrong_length_argument
, size1
, size2
,
138 make_number (bool_vector_size (a3
)));
142 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
144 /* If VALUE is not even a valid Lisp object, we'd want to abort here
145 where we can get a backtrace showing where it came from. We used
146 to try and do that by checking the tagbits, but nowadays all
147 tagbits are potentially valid. */
148 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
151 xsignal2 (Qwrong_type_argument
, predicate
, value
);
155 pure_write_error (Lisp_Object obj
)
157 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
161 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
163 xsignal2 (Qargs_out_of_range
, a1
, a2
);
167 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
169 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
173 /* Data type predicates. */
175 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
176 doc
: /* Return t if the two args are the same Lisp object. */
178 (Lisp_Object obj1
, Lisp_Object obj2
)
185 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
186 doc
: /* Return t if OBJECT is nil, and return nil otherwise. */
195 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
196 doc
: /* Return a symbol representing the type of OBJECT.
197 The symbol returned names the object's basic type;
198 for example, (type-of 1) returns `integer'. */)
201 switch (XTYPE (object
))
216 switch (XMISCTYPE (object
))
218 case Lisp_Misc_Marker
:
220 case Lisp_Misc_Overlay
:
222 case Lisp_Misc_Float
:
224 case Lisp_Misc_Finalizer
:
227 case Lisp_Misc_User_Ptr
:
234 case Lisp_Vectorlike
:
235 if (WINDOW_CONFIGURATIONP (object
))
236 return Qwindow_configuration
;
237 if (PROCESSP (object
))
239 if (WINDOWP (object
))
243 if (COMPILEDP (object
))
244 return Qcompiled_function
;
245 if (BUFFERP (object
))
247 if (CHAR_TABLE_P (object
))
249 if (BOOL_VECTOR_P (object
))
253 if (HASH_TABLE_P (object
))
255 if (FONT_SPEC_P (object
))
257 if (FONT_ENTITY_P (object
))
259 if (FONT_OBJECT_P (object
))
261 if (THREADP (object
))
265 if (CONDVARP (object
))
266 return Qcondition_variable
;
277 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
278 doc
: /* Return t if OBJECT is a cons cell. */
287 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
288 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */
297 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
298 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
299 Otherwise, return nil. */
303 if (CONSP (object
) || NILP (object
))
308 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
309 doc
: /* Return t if OBJECT is not a list. Lists include nil. */
313 if (CONSP (object
) || NILP (object
))
318 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
319 doc
: /* Return t if OBJECT is a symbol. */
323 if (SYMBOLP (object
))
328 /* Define this in C to avoid unnecessarily consing up the symbol
330 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
331 doc
: /* Return t if OBJECT is a keyword.
332 This means that it is a symbol with a print name beginning with `:'
333 interned in the initial obarray. */)
337 && SREF (SYMBOL_NAME (object
), 0) == ':'
338 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
343 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
344 doc
: /* Return t if OBJECT is a vector. */)
347 if (VECTORP (object
))
352 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
353 doc
: /* Return t if OBJECT is a string. */
357 if (STRINGP (object
))
362 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
364 doc
: /* Return t if OBJECT is a multibyte string.
365 Return nil if OBJECT is either a unibyte string, or not a string. */)
368 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
373 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
374 doc
: /* Return t if OBJECT is a char-table. */)
377 if (CHAR_TABLE_P (object
))
382 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
383 Svector_or_char_table_p
, 1, 1, 0,
384 doc
: /* Return t if OBJECT is a char-table or vector. */)
387 if (VECTORP (object
) || CHAR_TABLE_P (object
))
392 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
393 doc
: /* Return t if OBJECT is a bool-vector. */)
396 if (BOOL_VECTOR_P (object
))
401 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
402 doc
: /* Return t if OBJECT is an array (string or vector). */)
410 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
411 doc
: /* Return t if OBJECT is a sequence (list or array). */)
412 (register Lisp_Object object
)
414 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
419 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
420 doc
: /* Return t if OBJECT is an editor buffer. */)
423 if (BUFFERP (object
))
428 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
429 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
432 if (MARKERP (object
))
438 DEFUN ("user-ptrp", Fuser_ptrp
, Suser_ptrp
, 1, 1, 0,
439 doc
: /* Return t if OBJECT is a module user pointer. */)
442 if (USER_PTRP (object
))
448 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is a built-in function. */)
457 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
459 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
462 if (COMPILEDP (object
))
467 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
468 doc
: /* Return t if OBJECT is a character or a string. */
470 (register Lisp_Object object
)
472 if (CHARACTERP (object
) || STRINGP (object
))
477 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
478 doc
: /* Return t if OBJECT is an integer. */
482 if (INTEGERP (object
))
487 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
488 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
489 (register Lisp_Object object
)
491 if (MARKERP (object
) || INTEGERP (object
))
496 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
497 doc
: /* Return t if OBJECT is a nonnegative integer. */
501 if (NATNUMP (object
))
506 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
507 doc
: /* Return t if OBJECT is a number (floating point or integer). */
511 if (NUMBERP (object
))
517 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
518 Snumber_or_marker_p
, 1, 1, 0,
519 doc
: /* Return t if OBJECT is a number or a marker. */)
522 if (NUMBERP (object
) || MARKERP (object
))
527 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
528 doc
: /* Return t if OBJECT is a floating point number. */
537 DEFUN ("threadp", Fthreadp
, Sthreadp
, 1, 1, 0,
538 doc
: /* Return t if OBJECT is a thread. */)
541 if (THREADP (object
))
546 DEFUN ("mutexp", Fmutexp
, Smutexp
, 1, 1, 0,
547 doc
: /* Return t if OBJECT is a mutex. */)
555 DEFUN ("condition-variable-p", Fcondition_variable_p
, Scondition_variable_p
,
557 doc
: /* Return t if OBJECT is a condition variable. */)
560 if (CONDVARP (object
))
565 /* Extract and set components of lists. */
567 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
568 doc
: /* Return the car of LIST. If arg is nil, return nil.
569 Error if arg is not nil and not a cons cell. See also `car-safe'.
571 See Info node `(elisp)Cons Cells' for a discussion of related basic
572 Lisp concepts such as car, cdr, cons cell and list. */)
573 (register Lisp_Object list
)
578 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
579 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
582 return CAR_SAFE (object
);
585 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
586 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
587 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
589 See Info node `(elisp)Cons Cells' for a discussion of related basic
590 Lisp concepts such as cdr, car, cons cell and list. */)
591 (register Lisp_Object list
)
596 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
597 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
600 return CDR_SAFE (object
);
603 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
604 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
605 (register Lisp_Object cell
, Lisp_Object newcar
)
608 CHECK_IMPURE (cell
, XCONS (cell
));
609 XSETCAR (cell
, newcar
);
613 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
614 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
615 (register Lisp_Object cell
, Lisp_Object newcdr
)
618 CHECK_IMPURE (cell
, XCONS (cell
));
619 XSETCDR (cell
, newcdr
);
623 /* Extract and set components of symbols. */
625 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
626 doc
: /* Return t if SYMBOL's value is not void.
627 Note that if `lexical-binding' is in effect, this refers to the
628 global value outside of any lexical scope. */)
629 (register Lisp_Object symbol
)
631 Lisp_Object valcontents
;
632 struct Lisp_Symbol
*sym
;
633 CHECK_SYMBOL (symbol
);
634 sym
= XSYMBOL (symbol
);
637 switch (sym
->redirect
)
639 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
640 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
641 case SYMBOL_LOCALIZED
:
643 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
645 /* In set_internal, we un-forward vars when their value is
650 swap_in_symval_forwarding (sym
, blv
);
651 valcontents
= blv_value (blv
);
655 case SYMBOL_FORWARDED
:
656 /* In set_internal, we un-forward vars when their value is
659 default: emacs_abort ();
662 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
665 /* FIXME: It has been previously suggested to make this function an
666 alias for symbol-function, but upon discussion at Bug#23957,
667 there is a risk breaking backward compatibility, as some users of
668 fboundp may expect `t' in particular, rather than any true
669 value. An alias is still welcome so long as the compatibility
670 issues are addressed. */
671 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
672 doc
: /* Return t if SYMBOL's function definition is not void. */)
673 (register Lisp_Object symbol
)
675 CHECK_SYMBOL (symbol
);
676 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
679 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
680 doc
: /* Make SYMBOL's value be void.
682 (register Lisp_Object symbol
)
684 CHECK_SYMBOL (symbol
);
685 if (SYMBOL_CONSTANT_P (symbol
))
686 xsignal1 (Qsetting_constant
, symbol
);
687 Fset (symbol
, Qunbound
);
691 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
692 doc
: /* Make SYMBOL's function definition be nil.
694 (register Lisp_Object symbol
)
696 CHECK_SYMBOL (symbol
);
697 if (NILP (symbol
) || EQ (symbol
, Qt
))
698 xsignal1 (Qsetting_constant
, symbol
);
699 set_symbol_function (symbol
, Qnil
);
703 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
704 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
705 (register Lisp_Object symbol
)
707 CHECK_SYMBOL (symbol
);
708 return XSYMBOL (symbol
)->function
;
711 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
712 doc
: /* Return SYMBOL's property list. */)
713 (register Lisp_Object symbol
)
715 CHECK_SYMBOL (symbol
);
716 return XSYMBOL (symbol
)->plist
;
719 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
720 doc
: /* Return SYMBOL's name, a string. */)
721 (register Lisp_Object symbol
)
723 register Lisp_Object name
;
725 CHECK_SYMBOL (symbol
);
726 name
= SYMBOL_NAME (symbol
);
730 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
731 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
732 (register Lisp_Object symbol
, Lisp_Object definition
)
734 register Lisp_Object function
;
735 CHECK_SYMBOL (symbol
);
737 function
= XSYMBOL (symbol
)->function
;
739 if (!NILP (Vautoload_queue
) && !NILP (function
))
740 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
742 if (AUTOLOADP (function
))
743 Fput (symbol
, Qautoload
, XCDR (function
));
745 /* Convert to eassert or remove after GC bug is found. In the
746 meantime, check unconditionally, at a slight perf hit. */
747 if (! valid_lisp_object_p (definition
))
750 set_symbol_function (symbol
, definition
);
755 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
756 doc
: /* Set SYMBOL's function definition to DEFINITION.
757 Associates the function with the current load file, if any.
758 The optional third argument DOCSTRING specifies the documentation string
759 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
760 determined by DEFINITION.
762 Internally, this normally uses `fset', but if SYMBOL has a
763 `defalias-fset-function' property, the associated value is used instead.
765 The return value is undefined. */)
766 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
768 CHECK_SYMBOL (symbol
);
769 if (!NILP (Vpurify_flag
)
770 /* If `definition' is a keymap, immutable (and copying) is wrong. */
771 && !KEYMAPP (definition
))
772 definition
= Fpurecopy (definition
);
775 bool autoload
= AUTOLOADP (definition
);
776 if (NILP (Vpurify_flag
) || !autoload
)
777 { /* Only add autoload entries after dumping, because the ones before are
778 not useful and else we get loads of them from the loaddefs.el. */
780 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
781 /* Remember that the function was already an autoload. */
782 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
783 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
787 { /* Handle automatic advice activation. */
788 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
790 call2 (hook
, symbol
, definition
);
792 Ffset (symbol
, definition
);
795 if (!NILP (docstring
))
796 Fput (symbol
, Qfunction_documentation
, docstring
);
797 /* We used to return `definition', but now that `defun' and `defmacro' expand
798 to a call to `defalias', we return `symbol' for backward compatibility
803 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
804 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
805 (register Lisp_Object symbol
, Lisp_Object newplist
)
807 CHECK_SYMBOL (symbol
);
808 set_symbol_plist (symbol
, newplist
);
812 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
813 doc
: /* Return minimum and maximum number of args allowed for SUBR.
814 SUBR must be a built-in function.
815 The returned value is a pair (MIN . MAX). MIN is the minimum number
816 of args. MAX is the maximum number or the symbol `many', for a
817 function with `&rest' args, or `unevalled' for a special form. */)
820 short minargs
, maxargs
;
822 minargs
= XSUBR (subr
)->min_args
;
823 maxargs
= XSUBR (subr
)->max_args
;
824 return Fcons (make_number (minargs
),
825 maxargs
== MANY
? Qmany
826 : maxargs
== UNEVALLED
? Qunevalled
827 : make_number (maxargs
));
830 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
831 doc
: /* Return name of subroutine SUBR.
832 SUBR must be a built-in function. */)
837 name
= XSUBR (subr
)->symbol_name
;
838 return build_string (name
);
841 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
842 doc
: /* Return the interactive form of CMD or nil if none.
843 If CMD is not a command, the return value is nil.
844 Value, if non-nil, is a list (interactive SPEC). */)
847 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
852 /* Use an `interactive-form' property if present, analogous to the
853 function-documentation property. */
855 while (SYMBOLP (fun
))
857 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
861 fun
= Fsymbol_function (fun
);
866 const char *spec
= XSUBR (fun
)->intspec
;
868 return list2 (Qinteractive
,
869 (*spec
!= '(') ? build_string (spec
) :
870 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
872 else if (COMPILEDP (fun
))
874 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
875 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
877 else if (AUTOLOADP (fun
))
878 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
879 else if (CONSP (fun
))
881 Lisp_Object funcar
= XCAR (fun
);
882 if (EQ (funcar
, Qclosure
))
883 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
884 else if (EQ (funcar
, Qlambda
))
885 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
891 /***********************************************************************
892 Getting and Setting Values of Symbols
893 ***********************************************************************/
895 /* Return the symbol holding SYMBOL's value. Signal
896 `cyclic-variable-indirection' if SYMBOL's chain of variable
897 indirections contains a loop. */
900 indirect_variable (struct Lisp_Symbol
*symbol
)
902 struct Lisp_Symbol
*tortoise
, *hare
;
904 hare
= tortoise
= symbol
;
906 while (hare
->redirect
== SYMBOL_VARALIAS
)
908 hare
= SYMBOL_ALIAS (hare
);
909 if (hare
->redirect
!= SYMBOL_VARALIAS
)
912 hare
= SYMBOL_ALIAS (hare
);
913 tortoise
= SYMBOL_ALIAS (tortoise
);
915 if (hare
== tortoise
)
918 XSETSYMBOL (tem
, symbol
);
919 xsignal1 (Qcyclic_variable_indirection
, tem
);
927 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
928 doc
: /* Return the variable at the end of OBJECT's variable chain.
929 If OBJECT is a symbol, follow its variable indirections (if any), and
930 return the variable at the end of the chain of aliases. See Info node
931 `(elisp)Variable Aliases'.
933 If OBJECT is not a symbol, just return it. If there is a loop in the
934 chain of aliases, signal a `cyclic-variable-indirection' error. */)
937 if (SYMBOLP (object
))
939 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
940 XSETSYMBOL (object
, sym
);
946 /* Given the raw contents of a symbol value cell,
947 return the Lisp value of the symbol.
948 This does not handle buffer-local variables; use
949 swap_in_symval_forwarding for that. */
952 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
954 register Lisp_Object val
;
955 switch (XFWDTYPE (valcontents
))
958 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
962 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
965 return *XOBJFWD (valcontents
)->objvar
;
967 case Lisp_Fwd_Buffer_Obj
:
968 return per_buffer_value (current_buffer
,
969 XBUFFER_OBJFWD (valcontents
)->offset
);
971 case Lisp_Fwd_Kboard_Obj
:
972 /* We used to simply use current_kboard here, but from Lisp
973 code, its value is often unexpected. It seems nicer to
974 allow constructions like this to work as intuitively expected:
976 (with-selected-frame frame
977 (define-key local-function-map "\eOP" [f1]))
979 On the other hand, this affects the semantics of
980 last-command and real-last-command, and people may rely on
981 that. I took a quick look at the Lisp codebase, and I
982 don't think anything will break. --lorentey */
983 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
984 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
985 default: emacs_abort ();
989 /* Used to signal a user-friendly error when symbol WRONG is
990 not a member of CHOICE, which should be a list of symbols. */
993 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
995 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
996 Lisp_Object obj
, *args
;
997 AUTO_STRING (one_of
, "One of ");
998 AUTO_STRING (comma
, ", ");
999 AUTO_STRING (or, " or ");
1000 AUTO_STRING (should_be_specified
, " should be specified");
1003 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
1007 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
1009 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
1010 args
[i
++] = (NILP (XCDR (obj
)) ? should_be_specified
1011 : NILP (XCDR (XCDR (obj
))) ? or : comma
);
1014 obj
= Fconcat (i
, args
);
1016 xsignal2 (Qerror
, obj
, wrong
);
1019 /* Used to signal a user-friendly error if WRONG is not a number or
1020 integer/floating-point number outsize of inclusive MIN..MAX range. */
1023 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
1025 AUTO_STRING (value_should_be_from
, "Value should be from ");
1026 AUTO_STRING (to
, " to ");
1028 CALLN (Fconcat
, value_should_be_from
, Fnumber_to_string (min
),
1029 to
, Fnumber_to_string (max
)),
1033 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1034 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1035 buffer-independent contents of the value cell: forwarded just one
1036 step past the buffer-localness.
1038 BUF non-zero means set the value in buffer BUF instead of the
1039 current buffer. This only plays a role for per-buffer variables. */
1042 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
1044 switch (XFWDTYPE (valcontents
))
1047 CHECK_NUMBER (newval
);
1048 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1052 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1056 *XOBJFWD (valcontents
)->objvar
= newval
;
1058 /* If this variable is a default for something stored
1059 in the buffer itself, such as default-fill-column,
1060 find the buffers that don't have local values for it
1062 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1063 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1065 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1066 - (char *) &buffer_defaults
);
1067 int idx
= PER_BUFFER_IDX (offset
);
1069 Lisp_Object tail
, buf
;
1074 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1076 struct buffer
*b
= XBUFFER (buf
);
1078 if (! PER_BUFFER_VALUE_P (b
, idx
))
1079 set_per_buffer_value (b
, offset
, newval
);
1084 case Lisp_Fwd_Buffer_Obj
:
1086 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1087 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1091 if (SYMBOLP (predicate
))
1095 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1097 if (NILP (Fmemq (newval
, prop
)))
1098 wrong_choice (prop
, newval
);
1100 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1102 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1104 if (!NUMBERP (newval
)
1105 || !NILP (arithcompare (newval
, min
, ARITH_LESS
))
1106 || !NILP (arithcompare (newval
, max
, ARITH_GRTR
)))
1107 wrong_range (min
, max
, newval
);
1109 else if (FUNCTIONP (predicate
))
1111 if (NILP (call1 (predicate
, newval
)))
1112 wrong_type_argument (predicate
, newval
);
1117 buf
= current_buffer
;
1118 set_per_buffer_value (buf
, offset
, newval
);
1122 case Lisp_Fwd_Kboard_Obj
:
1124 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1125 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1126 *(Lisp_Object
*) p
= newval
;
1131 emacs_abort (); /* goto def; */
1135 /* Set up SYMBOL to refer to its global binding. This makes it safe
1136 to alter the status of other bindings. BEWARE: this may be called
1137 during the mark phase of GC, where we assume that Lisp_Object slots
1138 of BLV are marked after this function has changed them. */
1141 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1143 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1145 /* Unload the previously loaded binding. */
1147 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1149 /* Select the global binding in the symbol. */
1150 set_blv_valcell (blv
, blv
->defcell
);
1152 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1154 /* Indicate that the global binding is set up now. */
1155 set_blv_where (blv
, Qnil
);
1156 set_blv_found (blv
, 0);
1159 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1160 VALCONTENTS is the contents of its value cell,
1161 which points to a struct Lisp_Buffer_Local_Value.
1163 Return the value forwarded one step past the buffer-local stage.
1164 This could be another forwarding pointer. */
1167 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1169 register Lisp_Object tem1
;
1171 eassert (blv
== SYMBOL_BLV (symbol
));
1176 || (blv
->frame_local
1177 ? !EQ (selected_frame
, tem1
)
1178 : current_buffer
!= XBUFFER (tem1
)))
1181 /* Unload the previously loaded binding. */
1182 tem1
= blv
->valcell
;
1184 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1185 /* Choose the new binding. */
1188 XSETSYMBOL (var
, symbol
);
1189 if (blv
->frame_local
)
1191 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1192 set_blv_where (blv
, selected_frame
);
1196 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1197 set_blv_where (blv
, Fcurrent_buffer ());
1200 if (!(blv
->found
= !NILP (tem1
)))
1201 tem1
= blv
->defcell
;
1203 /* Load the new binding. */
1204 set_blv_valcell (blv
, tem1
);
1206 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1210 /* Find the value of a symbol, returning Qunbound if it's not bound.
1211 This is helpful for code which just wants to get a variable's value
1212 if it has one, without signaling an error.
1213 Note that it must not be possible to quit
1214 within this function. Great care is required for this. */
1217 find_symbol_value (Lisp_Object symbol
)
1219 struct Lisp_Symbol
*sym
;
1221 CHECK_SYMBOL (symbol
);
1222 sym
= XSYMBOL (symbol
);
1225 switch (sym
->redirect
)
1227 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1228 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1229 case SYMBOL_LOCALIZED
:
1231 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1232 swap_in_symval_forwarding (sym
, blv
);
1233 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1236 case SYMBOL_FORWARDED
:
1237 return do_symval_forwarding (SYMBOL_FWD (sym
));
1238 default: emacs_abort ();
1242 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1243 doc
: /* Return SYMBOL's value. Error if that is void.
1244 Note that if `lexical-binding' is in effect, this returns the
1245 global value outside of any lexical scope. */)
1246 (Lisp_Object symbol
)
1250 val
= find_symbol_value (symbol
);
1251 if (!EQ (val
, Qunbound
))
1254 xsignal1 (Qvoid_variable
, symbol
);
1257 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1258 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1259 (register Lisp_Object symbol
, Lisp_Object newval
)
1261 set_internal (symbol
, newval
, Qnil
, SET_INTERNAL_SET
);
1265 /* Store the value NEWVAL into SYMBOL.
1266 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1267 (nil stands for the current buffer/frame).
1269 If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to
1270 become local in every buffer where it is set, then we make it
1271 local. If BINDFLAG is SET_INTERNAL_BIND or SET_INTERNAL_UNBIND, we
1275 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1276 enum Set_Internal_Bind bindflag
)
1278 bool voide
= EQ (newval
, Qunbound
);
1279 struct Lisp_Symbol
*sym
;
1282 /* If restoring in a dead buffer, do nothing. */
1283 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1286 CHECK_SYMBOL (symbol
);
1287 sym
= XSYMBOL (symbol
);
1288 switch (sym
->trapped_write
)
1290 case SYMBOL_NOWRITE
:
1291 if (NILP (Fkeywordp (symbol
))
1292 || !EQ (newval
, Fsymbol_value (symbol
)))
1293 xsignal1 (Qsetting_constant
, symbol
);
1295 /* Allow setting keywords to their own value. */
1298 case SYMBOL_TRAPPED_WRITE
:
1299 notify_variable_watchers (symbol
, voide
? Qnil
: newval
,
1300 (bindflag
== SET_INTERNAL_BIND
? Qlet
:
1301 bindflag
== SET_INTERNAL_UNBIND
? Qunlet
:
1302 voide
? Qmakunbound
: Qset
),
1305 case SYMBOL_UNTRAPPED_WRITE
:
1308 default: emacs_abort ();
1312 switch (sym
->redirect
)
1314 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1315 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1316 case SYMBOL_LOCALIZED
:
1318 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1321 if (blv
->frame_local
)
1322 where
= selected_frame
;
1324 XSETBUFFER (where
, current_buffer
);
1326 /* If the current buffer is not the buffer whose binding is
1327 loaded, or if there may be frame-local bindings and the frame
1328 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1329 the default binding is loaded, the loaded binding may be the
1331 if (!EQ (blv
->where
, where
)
1332 /* Also unload a global binding (if the var is local_if_set). */
1333 || (EQ (blv
->valcell
, blv
->defcell
)))
1335 /* The currently loaded binding is not necessarily valid.
1336 We need to unload it, and choose a new binding. */
1338 /* Write out `realvalue' to the old loaded binding. */
1340 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1342 /* Find the new binding. */
1343 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1344 tem1
= assq_no_quit (symbol
,
1346 ? XFRAME (where
)->param_alist
1347 : BVAR (XBUFFER (where
), local_var_alist
)));
1348 set_blv_where (blv
, where
);
1353 /* This buffer still sees the default value. */
1355 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1356 or if this is `let' rather than `set',
1357 make CURRENT-ALIST-ELEMENT point to itself,
1358 indicating that we're seeing the default value.
1359 Likewise if the variable has been let-bound
1360 in the current buffer. */
1361 if (bindflag
|| !blv
->local_if_set
1362 || let_shadows_buffer_binding_p (sym
))
1365 tem1
= blv
->defcell
;
1367 /* If it's a local_if_set, being set not bound,
1368 and we're not within a let that was made for this buffer,
1369 create a new buffer-local binding for the variable.
1370 That means, give this buffer a new assoc for a local value
1371 and load that binding. */
1374 /* local_if_set is only supported for buffer-local
1375 bindings, not for frame-local bindings. */
1376 eassert (!blv
->frame_local
);
1377 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1378 bset_local_var_alist
1380 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1384 /* Record which binding is now loaded. */
1385 set_blv_valcell (blv
, tem1
);
1388 /* Store the new value in the cons cell. */
1389 set_blv_value (blv
, newval
);
1394 /* If storing void (making the symbol void), forward only through
1395 buffer-local indicator, not through Lisp_Objfwd, etc. */
1398 store_symval_forwarding (blv
->fwd
, newval
,
1400 ? XBUFFER (where
) : current_buffer
);
1404 case SYMBOL_FORWARDED
:
1407 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1408 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1409 if (BUFFER_OBJFWDP (innercontents
))
1411 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1412 int idx
= PER_BUFFER_IDX (offset
);
1415 && !let_shadows_buffer_binding_p (sym
))
1416 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1420 { /* If storing void (making the symbol void), forward only through
1421 buffer-local indicator, not through Lisp_Objfwd, etc. */
1422 sym
->redirect
= SYMBOL_PLAINVAL
;
1423 SET_SYMBOL_VAL (sym
, newval
);
1426 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1429 default: emacs_abort ();
1435 set_symbol_trapped_write (Lisp_Object symbol
, enum symbol_trapped_write trap
)
1437 struct Lisp_Symbol
* sym
= XSYMBOL (symbol
);
1438 if (sym
->trapped_write
== SYMBOL_NOWRITE
)
1439 xsignal1 (Qtrapping_constant
, symbol
);
1440 else if (sym
->redirect
== SYMBOL_LOCALIZED
1441 && SYMBOL_BLV (sym
)->frame_local
)
1442 xsignal1 (Qtrapping_frame_local
, symbol
);
1443 sym
->trapped_write
= trap
;
1447 restore_symbol_trapped_write (Lisp_Object symbol
)
1449 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1453 harmonize_variable_watchers (Lisp_Object alias
, Lisp_Object base_variable
)
1455 if (!EQ (base_variable
, alias
)
1456 && EQ (base_variable
, Findirect_variable (alias
)))
1457 set_symbol_trapped_write
1458 (alias
, XSYMBOL (base_variable
)->trapped_write
);
1461 DEFUN ("add-variable-watcher", Fadd_variable_watcher
, Sadd_variable_watcher
,
1463 doc
: /* Cause WATCH-FUNCTION to be called when SYMBOL is set.
1465 It will be called with 4 arguments: (SYMBOL NEWVAL OPERATION WHERE).
1466 SYMBOL is the variable being changed.
1467 NEWVAL is the value it will be changed to.
1468 OPERATION is a symbol representing the kind of change, one of: `set',
1469 `let', `unlet', `makunbound', and `defvaralias'.
1470 WHERE is a buffer if the buffer-local value of the variable being
1471 changed, nil otherwise.
1473 All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */)
1474 (Lisp_Object symbol
, Lisp_Object watch_function
)
1476 symbol
= Findirect_variable (symbol
);
1477 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1478 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1480 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1481 Lisp_Object member
= Fmember (watch_function
, watchers
);
1483 Fput (symbol
, Qwatchers
, Fcons (watch_function
, watchers
));
1487 DEFUN ("remove-variable-watcher", Fremove_variable_watcher
, Sremove_variable_watcher
,
1489 doc
: /* Undo the effect of `add-variable-watcher'.
1490 Remove WATCH-FUNCTION from the list of functions to be called when
1491 SYMBOL (or its aliases) are set. */)
1492 (Lisp_Object symbol
, Lisp_Object watch_function
)
1494 symbol
= Findirect_variable (symbol
);
1495 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1496 watchers
= Fdelete (watch_function
, watchers
);
1497 if (NILP (watchers
))
1499 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1500 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1502 Fput (symbol
, Qwatchers
, watchers
);
1506 DEFUN ("get-variable-watchers", Fget_variable_watchers
, Sget_variable_watchers
,
1508 doc
: /* Return a list of SYMBOL's active watchers. */)
1509 (Lisp_Object symbol
)
1511 return (SYMBOL_TRAPPED_WRITE_P (symbol
) == SYMBOL_TRAPPED_WRITE
)
1512 ? Fget (Findirect_variable (symbol
), Qwatchers
)
1517 notify_variable_watchers (Lisp_Object symbol
,
1519 Lisp_Object operation
,
1522 symbol
= Findirect_variable (symbol
);
1524 ptrdiff_t count
= SPECPDL_INDEX ();
1525 record_unwind_protect (restore_symbol_trapped_write
, symbol
);
1526 /* Avoid recursion. */
1527 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1530 && !EQ (operation
, Qset_default
) && !EQ (operation
, Qmakunbound
)
1531 && !NILP (Flocal_variable_if_set_p (symbol
, Fcurrent_buffer ())))
1533 XSETBUFFER (where
, current_buffer
);
1536 if (EQ (operation
, Qset_default
))
1539 for (Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1541 watchers
= XCDR (watchers
))
1543 Lisp_Object watcher
= XCAR (watchers
);
1544 /* Call subr directly to avoid gc. */
1545 if (SUBRP (watcher
))
1547 Lisp_Object args
[] = { symbol
, newval
, operation
, where
};
1548 funcall_subr (XSUBR (watcher
), ARRAYELTS (args
), args
);
1551 CALLN (Ffuncall
, watcher
, symbol
, newval
, operation
, where
);
1554 unbind_to (count
, Qnil
);
1558 /* Access or set a buffer-local symbol's default value. */
1560 /* Return the default value of SYMBOL, but don't check for voidness.
1561 Return Qunbound if it is void. */
1564 default_value (Lisp_Object symbol
)
1566 struct Lisp_Symbol
*sym
;
1568 CHECK_SYMBOL (symbol
);
1569 sym
= XSYMBOL (symbol
);
1572 switch (sym
->redirect
)
1574 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1575 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1576 case SYMBOL_LOCALIZED
:
1578 /* If var is set up for a buffer that lacks a local value for it,
1579 the current value is nominally the default value.
1580 But the `realvalue' slot may be more up to date, since
1581 ordinary setq stores just that slot. So use that. */
1582 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1583 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1584 return do_symval_forwarding (blv
->fwd
);
1586 return XCDR (blv
->defcell
);
1588 case SYMBOL_FORWARDED
:
1590 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1592 /* For a built-in buffer-local variable, get the default value
1593 rather than letting do_symval_forwarding get the current value. */
1594 if (BUFFER_OBJFWDP (valcontents
))
1596 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1597 if (PER_BUFFER_IDX (offset
) != 0)
1598 return per_buffer_default (offset
);
1601 /* For other variables, get the current value. */
1602 return do_symval_forwarding (valcontents
);
1604 default: emacs_abort ();
1608 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1609 doc
: /* Return t if SYMBOL has a non-void default value.
1610 This is the value that is seen in buffers that do not have their own values
1611 for this variable. */)
1612 (Lisp_Object symbol
)
1614 register Lisp_Object value
;
1616 value
= default_value (symbol
);
1617 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1620 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1621 doc
: /* Return SYMBOL's default value.
1622 This is the value that is seen in buffers that do not have their own values
1623 for this variable. The default value is meaningful for variables with
1624 local bindings in certain buffers. */)
1625 (Lisp_Object symbol
)
1627 Lisp_Object value
= default_value (symbol
);
1628 if (!EQ (value
, Qunbound
))
1631 xsignal1 (Qvoid_variable
, symbol
);
1634 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1635 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1636 The default value is seen in buffers that do not have their own values
1637 for this variable. */)
1638 (Lisp_Object symbol
, Lisp_Object value
)
1640 struct Lisp_Symbol
*sym
;
1642 CHECK_SYMBOL (symbol
);
1643 sym
= XSYMBOL (symbol
);
1644 switch (sym
->trapped_write
)
1646 case SYMBOL_NOWRITE
:
1647 if (NILP (Fkeywordp (symbol
))
1648 || !EQ (value
, Fsymbol_value (symbol
)))
1649 xsignal1 (Qsetting_constant
, symbol
);
1651 /* Allow setting keywords to their own value. */
1654 case SYMBOL_TRAPPED_WRITE
:
1655 /* Don't notify here if we're going to call Fset anyway. */
1656 if (sym
->redirect
!= SYMBOL_PLAINVAL
)
1657 notify_variable_watchers (symbol
, value
, Qset_default
, Qnil
);
1659 case SYMBOL_UNTRAPPED_WRITE
:
1662 default: emacs_abort ();
1666 switch (sym
->redirect
)
1668 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1669 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1670 case SYMBOL_LOCALIZED
:
1672 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1674 /* Store new value into the DEFAULT-VALUE slot. */
1675 XSETCDR (blv
->defcell
, value
);
1677 /* If the default binding is now loaded, set the REALVALUE slot too. */
1678 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1679 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1682 case SYMBOL_FORWARDED
:
1684 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1686 /* Handle variables like case-fold-search that have special slots
1688 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1689 if (BUFFER_OBJFWDP (valcontents
))
1691 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1692 int idx
= PER_BUFFER_IDX (offset
);
1694 set_per_buffer_default (offset
, value
);
1696 /* If this variable is not always local in all buffers,
1697 set it in the buffers that don't nominally have a local value. */
1703 if (!PER_BUFFER_VALUE_P (b
, idx
))
1704 set_per_buffer_value (b
, offset
, value
);
1709 return Fset (symbol
, value
);
1711 default: emacs_abort ();
1715 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1716 doc
: /* Set the default value of variable VAR to VALUE.
1717 VAR, the variable name, is literal (not evaluated);
1718 VALUE is an expression: it is evaluated and its value returned.
1719 The default value of a variable is seen in buffers
1720 that do not have their own values for the variable.
1722 More generally, you can use multiple variables and values, as in
1723 (setq-default VAR VALUE VAR VALUE...)
1724 This sets each VAR's default value to the corresponding VALUE.
1725 The VALUE for the Nth VAR can refer to the new default values
1727 usage: (setq-default [VAR VALUE]...) */)
1730 Lisp_Object args_left
, symbol
, val
;
1732 args_left
= val
= args
;
1734 while (CONSP (args_left
))
1736 val
= eval_sub (Fcar (XCDR (args_left
)));
1737 symbol
= XCAR (args_left
);
1738 Fset_default (symbol
, val
);
1739 args_left
= Fcdr (XCDR (args_left
));
1745 /* Lisp functions for creating and removing buffer-local variables. */
1750 union Lisp_Fwd
*fwd
;
1753 static struct Lisp_Buffer_Local_Value
*
1754 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1755 union Lisp_Val_Fwd valcontents
)
1757 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1761 XSETSYMBOL (symbol
, sym
);
1762 tem
= Fcons (symbol
, (forwarded
1763 ? do_symval_forwarding (valcontents
.fwd
)
1764 : valcontents
.value
));
1766 /* Buffer_Local_Values cannot have as realval a buffer-local
1767 or keyboard-local forwarding. */
1768 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1769 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1770 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1771 set_blv_where (blv
, Qnil
);
1772 blv
->frame_local
= 0;
1773 blv
->local_if_set
= 0;
1774 set_blv_defcell (blv
, tem
);
1775 set_blv_valcell (blv
, tem
);
1776 set_blv_found (blv
, 0);
1780 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1781 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1782 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1783 At any time, the value for the current buffer is in effect,
1784 unless the variable has never been set in this buffer,
1785 in which case the default value is in effect.
1786 Note that binding the variable with `let', or setting it while
1787 a `let'-style binding made in this buffer is in effect,
1788 does not make the variable buffer-local. Return VARIABLE.
1790 This globally affects all uses of this variable, so it belongs together with
1791 the variable declaration, rather than with its uses (if you just want to make
1792 a variable local to the current buffer for one particular use, use
1793 `make-local-variable'). Buffer-local bindings are normally cleared
1794 while setting up a new major mode, unless they have a `permanent-local'
1797 The function `default-value' gets the default value and `set-default' sets it. */)
1798 (register Lisp_Object variable
)
1800 struct Lisp_Symbol
*sym
;
1801 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1802 union Lisp_Val_Fwd valcontents
;
1805 CHECK_SYMBOL (variable
);
1806 sym
= XSYMBOL (variable
);
1809 switch (sym
->redirect
)
1811 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1812 case SYMBOL_PLAINVAL
:
1813 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1814 if (EQ (valcontents
.value
, Qunbound
))
1815 valcontents
.value
= Qnil
;
1817 case SYMBOL_LOCALIZED
:
1818 blv
= SYMBOL_BLV (sym
);
1819 if (blv
->frame_local
)
1820 error ("Symbol %s may not be buffer-local",
1821 SDATA (SYMBOL_NAME (variable
)));
1823 case SYMBOL_FORWARDED
:
1824 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1825 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1826 error ("Symbol %s may not be buffer-local",
1827 SDATA (SYMBOL_NAME (variable
)));
1828 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1831 default: emacs_abort ();
1834 if (SYMBOL_CONSTANT_P (variable
))
1835 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1839 blv
= make_blv (sym
, forwarded
, valcontents
);
1840 sym
->redirect
= SYMBOL_LOCALIZED
;
1841 SET_SYMBOL_BLV (sym
, blv
);
1844 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1845 if (let_shadows_global_binding_p (symbol
))
1847 AUTO_STRING (format
, "Making %s buffer-local while let-bound!");
1848 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1853 blv
->local_if_set
= 1;
1857 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1858 1, 1, "vMake Local Variable: ",
1859 doc
: /* Make VARIABLE have a separate value in the current buffer.
1860 Other buffers will continue to share a common default value.
1861 \(The buffer-local value of VARIABLE starts out as the same value
1862 VARIABLE previously had. If VARIABLE was void, it remains void.)
1865 If the variable is already arranged to become local when set,
1866 this function causes a local value to exist for this buffer,
1867 just as setting the variable would do.
1869 This function returns VARIABLE, and therefore
1870 (set (make-local-variable \\='VARIABLE) VALUE-EXP)
1873 See also `make-variable-buffer-local'.
1875 Do not use `make-local-variable' to make a hook variable buffer-local.
1876 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1877 (Lisp_Object variable
)
1881 union Lisp_Val_Fwd valcontents
;
1882 struct Lisp_Symbol
*sym
;
1883 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1885 CHECK_SYMBOL (variable
);
1886 sym
= XSYMBOL (variable
);
1889 switch (sym
->redirect
)
1891 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1892 case SYMBOL_PLAINVAL
:
1893 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1894 case SYMBOL_LOCALIZED
:
1895 blv
= SYMBOL_BLV (sym
);
1896 if (blv
->frame_local
)
1897 error ("Symbol %s may not be buffer-local",
1898 SDATA (SYMBOL_NAME (variable
)));
1900 case SYMBOL_FORWARDED
:
1901 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1902 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1903 error ("Symbol %s may not be buffer-local",
1904 SDATA (SYMBOL_NAME (variable
)));
1906 default: emacs_abort ();
1909 if (sym
->trapped_write
== SYMBOL_NOWRITE
)
1910 error ("Symbol %s may not be buffer-local",
1911 SDATA (SYMBOL_NAME (variable
)));
1913 if (blv
? blv
->local_if_set
1914 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1916 tem
= Fboundp (variable
);
1917 /* Make sure the symbol has a local value in this particular buffer,
1918 by setting it to the same value it already has. */
1919 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1924 blv
= make_blv (sym
, forwarded
, valcontents
);
1925 sym
->redirect
= SYMBOL_LOCALIZED
;
1926 SET_SYMBOL_BLV (sym
, blv
);
1929 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1930 if (let_shadows_global_binding_p (symbol
))
1932 AUTO_STRING (format
, "Making %s local to %s while let-bound!");
1933 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
),
1934 BVAR (current_buffer
, name
));
1939 /* Make sure this buffer has its own value of symbol. */
1940 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1941 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1944 if (let_shadows_buffer_binding_p (sym
))
1946 AUTO_STRING (format
,
1947 "Making %s buffer-local while locally let-bound!");
1948 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1951 /* Swap out any local binding for some other buffer, and make
1952 sure the current value is permanently recorded, if it's the
1954 find_symbol_value (variable
);
1956 bset_local_var_alist
1958 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1959 BVAR (current_buffer
, local_var_alist
)));
1961 /* Make sure symbol does not think it is set up for this buffer;
1962 force it to look once again for this buffer's value. */
1963 if (current_buffer
== XBUFFER (blv
->where
))
1964 set_blv_where (blv
, Qnil
);
1965 set_blv_found (blv
, 0);
1968 /* If the symbol forwards into a C variable, then load the binding
1969 for this buffer now. If C code modifies the variable before we
1970 load the binding in, then that new value will clobber the default
1971 binding the next time we unload it. */
1973 swap_in_symval_forwarding (sym
, blv
);
1978 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1979 1, 1, "vKill Local Variable: ",
1980 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1981 From now on the default value will apply in this buffer. Return VARIABLE. */)
1982 (register Lisp_Object variable
)
1984 register Lisp_Object tem
;
1985 struct Lisp_Buffer_Local_Value
*blv
;
1986 struct Lisp_Symbol
*sym
;
1988 CHECK_SYMBOL (variable
);
1989 sym
= XSYMBOL (variable
);
1992 switch (sym
->redirect
)
1994 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1995 case SYMBOL_PLAINVAL
: return variable
;
1996 case SYMBOL_FORWARDED
:
1998 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1999 if (BUFFER_OBJFWDP (valcontents
))
2001 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2002 int idx
= PER_BUFFER_IDX (offset
);
2006 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
2007 set_per_buffer_value (current_buffer
, offset
,
2008 per_buffer_default (offset
));
2013 case SYMBOL_LOCALIZED
:
2014 blv
= SYMBOL_BLV (sym
);
2015 if (blv
->frame_local
)
2018 default: emacs_abort ();
2021 if (sym
->trapped_write
== SYMBOL_TRAPPED_WRITE
)
2022 notify_variable_watchers (variable
, Qnil
, Qmakunbound
, Fcurrent_buffer ());
2024 /* Get rid of this buffer's alist element, if any. */
2025 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
2026 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
2028 bset_local_var_alist
2030 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
2032 /* If the symbol is set up with the current buffer's binding
2033 loaded, recompute its value. We have to do it now, or else
2034 forwarded objects won't work right. */
2036 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
2037 if (EQ (buf
, blv
->where
))
2039 set_blv_where (blv
, Qnil
);
2041 find_symbol_value (variable
);
2048 /* Lisp functions for creating and removing buffer-local variables. */
2050 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
2051 when/if this is removed. */
2053 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
2054 1, 1, "vMake Variable Frame Local: ",
2055 doc
: /* Enable VARIABLE to have frame-local bindings.
2056 This does not create any frame-local bindings for VARIABLE,
2057 it just makes them possible.
2059 A frame-local binding is actually a frame parameter value.
2060 If a frame F has a value for the frame parameter named VARIABLE,
2061 that also acts as a frame-local binding for VARIABLE in F--
2062 provided this function has been called to enable VARIABLE
2063 to have frame-local bindings at all.
2065 The only way to create a frame-local binding for VARIABLE in a frame
2066 is to set the VARIABLE frame parameter of that frame. See
2067 `modify-frame-parameters' for how to set frame parameters.
2069 Note that since Emacs 23.1, variables cannot be both buffer-local and
2070 frame-local any more (buffer-local bindings used to take precedence over
2071 frame-local bindings). */)
2072 (Lisp_Object variable
)
2075 union Lisp_Val_Fwd valcontents
;
2076 struct Lisp_Symbol
*sym
;
2077 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
2079 CHECK_SYMBOL (variable
);
2080 sym
= XSYMBOL (variable
);
2083 switch (sym
->redirect
)
2085 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2086 case SYMBOL_PLAINVAL
:
2087 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
2088 if (EQ (valcontents
.value
, Qunbound
))
2089 valcontents
.value
= Qnil
;
2091 case SYMBOL_LOCALIZED
:
2092 if (SYMBOL_BLV (sym
)->frame_local
)
2095 error ("Symbol %s may not be frame-local",
2096 SDATA (SYMBOL_NAME (variable
)));
2097 case SYMBOL_FORWARDED
:
2098 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
2099 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
2100 error ("Symbol %s may not be frame-local",
2101 SDATA (SYMBOL_NAME (variable
)));
2103 default: emacs_abort ();
2106 if (SYMBOL_TRAPPED_WRITE_P (variable
))
2107 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
2109 blv
= make_blv (sym
, forwarded
, valcontents
);
2110 blv
->frame_local
= 1;
2111 sym
->redirect
= SYMBOL_LOCALIZED
;
2112 SET_SYMBOL_BLV (sym
, blv
);
2115 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
2116 if (let_shadows_global_binding_p (symbol
))
2118 AUTO_STRING (format
, "Making %s frame-local while let-bound!");
2119 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
2125 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
2127 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
2128 BUFFER defaults to the current buffer. */)
2129 (Lisp_Object variable
, Lisp_Object buffer
)
2131 struct buffer
*buf
= decode_buffer (buffer
);
2132 struct Lisp_Symbol
*sym
;
2134 CHECK_SYMBOL (variable
);
2135 sym
= XSYMBOL (variable
);
2138 switch (sym
->redirect
)
2140 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2141 case SYMBOL_PLAINVAL
: return Qnil
;
2142 case SYMBOL_LOCALIZED
:
2144 Lisp_Object tail
, elt
, tmp
;
2145 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2146 XSETBUFFER (tmp
, buf
);
2147 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2149 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
2150 return blv_found (blv
) ? Qt
: Qnil
;
2152 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
2155 if (EQ (variable
, XCAR (elt
)))
2157 eassert (!blv
->frame_local
);
2163 case SYMBOL_FORWARDED
:
2165 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2166 if (BUFFER_OBJFWDP (valcontents
))
2168 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2169 int idx
= PER_BUFFER_IDX (offset
);
2170 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2175 default: emacs_abort ();
2179 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2181 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
2182 BUFFER defaults to the current buffer.
2184 More precisely, return non-nil if either VARIABLE already has a local
2185 value in BUFFER, or if VARIABLE is automatically buffer-local (see
2186 `make-variable-buffer-local'). */)
2187 (register Lisp_Object variable
, Lisp_Object buffer
)
2189 struct Lisp_Symbol
*sym
;
2191 CHECK_SYMBOL (variable
);
2192 sym
= XSYMBOL (variable
);
2195 switch (sym
->redirect
)
2197 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2198 case SYMBOL_PLAINVAL
: return Qnil
;
2199 case SYMBOL_LOCALIZED
:
2201 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2202 if (blv
->local_if_set
)
2204 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2205 return Flocal_variable_p (variable
, buffer
);
2207 case SYMBOL_FORWARDED
:
2208 /* All BUFFER_OBJFWD slots become local if they are set. */
2209 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2210 default: emacs_abort ();
2214 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2216 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2217 If the current binding is buffer-local, the value is the current buffer.
2218 If the current binding is frame-local, the value is the selected frame.
2219 If the current binding is global (the default), the value is nil. */)
2220 (register Lisp_Object variable
)
2222 struct Lisp_Symbol
*sym
;
2224 CHECK_SYMBOL (variable
);
2225 sym
= XSYMBOL (variable
);
2227 /* Make sure the current binding is actually swapped in. */
2228 find_symbol_value (variable
);
2231 switch (sym
->redirect
)
2233 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2234 case SYMBOL_PLAINVAL
: return Qnil
;
2235 case SYMBOL_FORWARDED
:
2237 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2238 if (KBOARD_OBJFWDP (valcontents
))
2239 return Fframe_terminal (selected_frame
);
2240 else if (!BUFFER_OBJFWDP (valcontents
))
2244 case SYMBOL_LOCALIZED
:
2245 /* For a local variable, record both the symbol and which
2246 buffer's or frame's value we are saving. */
2247 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2248 return Fcurrent_buffer ();
2249 else if (sym
->redirect
== SYMBOL_LOCALIZED
2250 && blv_found (SYMBOL_BLV (sym
)))
2251 return SYMBOL_BLV (sym
)->where
;
2254 default: emacs_abort ();
2258 /* This code is disabled now that we use the selected frame to return
2259 keyboard-local-values. */
2261 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2263 DEFUN ("terminal-local-value", Fterminal_local_value
,
2264 Sterminal_local_value
, 2, 2, 0,
2265 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2266 If SYMBOL is not a terminal-local variable, then return its normal
2267 value, like `symbol-value'.
2269 TERMINAL may be a terminal object, a frame, or nil (meaning the
2270 selected frame's terminal device). */)
2271 (Lisp_Object symbol
, Lisp_Object terminal
)
2274 struct terminal
*t
= get_terminal (terminal
, 1);
2275 push_kboard (t
->kboard
);
2276 result
= Fsymbol_value (symbol
);
2281 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2282 Sset_terminal_local_value
, 3, 3, 0,
2283 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2284 If VARIABLE is not a terminal-local variable, then set its normal
2285 binding, like `set'.
2287 TERMINAL may be a terminal object, a frame, or nil (meaning the
2288 selected frame's terminal device). */)
2289 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2292 struct terminal
*t
= get_terminal (terminal
, 1);
2293 push_kboard (d
->kboard
);
2294 result
= Fset (symbol
, value
);
2300 /* Find the function at the end of a chain of symbol function indirections. */
2302 /* If OBJECT is a symbol, find the end of its function chain and
2303 return the value found there. If OBJECT is not a symbol, just
2304 return it. If there is a cycle in the function chain, signal a
2305 cyclic-function-indirection error.
2307 This is like Findirect_function, except that it doesn't signal an
2308 error if the chain ends up unbound. */
2310 indirect_function (register Lisp_Object object
)
2312 Lisp_Object tortoise
, hare
;
2314 hare
= tortoise
= object
;
2318 if (!SYMBOLP (hare
) || NILP (hare
))
2320 hare
= XSYMBOL (hare
)->function
;
2321 if (!SYMBOLP (hare
) || NILP (hare
))
2323 hare
= XSYMBOL (hare
)->function
;
2325 tortoise
= XSYMBOL (tortoise
)->function
;
2327 if (EQ (hare
, tortoise
))
2328 xsignal1 (Qcyclic_function_indirection
, object
);
2334 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2335 doc
: /* Return the function at the end of OBJECT's function chain.
2336 If OBJECT is not a symbol, just return it. Otherwise, follow all
2337 function indirections to find the final function binding and return it.
2338 Signal a cyclic-function-indirection error if there is a loop in the
2339 function chain of symbols. */)
2340 (register Lisp_Object object
, Lisp_Object noerror
)
2344 /* Optimize for no indirection. */
2346 if (SYMBOLP (result
) && !NILP (result
)
2347 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2348 result
= indirect_function (result
);
2355 /* Extract and set vector and string elements. */
2357 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2358 doc
: /* Return the element of ARRAY at index IDX.
2359 ARRAY may be a vector, a string, a char-table, a bool-vector,
2360 or a byte-code object. IDX starts at 0. */)
2361 (register Lisp_Object array
, Lisp_Object idx
)
2363 register EMACS_INT idxval
;
2366 idxval
= XINT (idx
);
2367 if (STRINGP (array
))
2370 ptrdiff_t idxval_byte
;
2372 if (idxval
< 0 || idxval
>= SCHARS (array
))
2373 args_out_of_range (array
, idx
);
2374 if (! STRING_MULTIBYTE (array
))
2375 return make_number ((unsigned char) SREF (array
, idxval
));
2376 idxval_byte
= string_char_to_byte (array
, idxval
);
2378 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2379 return make_number (c
);
2381 else if (BOOL_VECTOR_P (array
))
2383 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2384 args_out_of_range (array
, idx
);
2385 return bool_vector_ref (array
, idxval
);
2387 else if (CHAR_TABLE_P (array
))
2389 CHECK_CHARACTER (idx
);
2390 return CHAR_TABLE_REF (array
, idxval
);
2395 if (VECTORP (array
))
2396 size
= ASIZE (array
);
2397 else if (COMPILEDP (array
))
2398 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2400 wrong_type_argument (Qarrayp
, array
);
2402 if (idxval
< 0 || idxval
>= size
)
2403 args_out_of_range (array
, idx
);
2404 return AREF (array
, idxval
);
2408 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2409 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2410 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2411 bool-vector. IDX starts at 0. */)
2412 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2414 register EMACS_INT idxval
;
2417 idxval
= XINT (idx
);
2418 CHECK_ARRAY (array
, Qarrayp
);
2420 if (VECTORP (array
))
2422 CHECK_IMPURE (array
, XVECTOR (array
));
2423 if (idxval
< 0 || idxval
>= ASIZE (array
))
2424 args_out_of_range (array
, idx
);
2425 ASET (array
, idxval
, newelt
);
2427 else if (BOOL_VECTOR_P (array
))
2429 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2430 args_out_of_range (array
, idx
);
2431 bool_vector_set (array
, idxval
, !NILP (newelt
));
2433 else if (CHAR_TABLE_P (array
))
2435 CHECK_CHARACTER (idx
);
2436 CHAR_TABLE_SET (array
, idxval
, newelt
);
2442 CHECK_IMPURE (array
, XSTRING (array
));
2443 if (idxval
< 0 || idxval
>= SCHARS (array
))
2444 args_out_of_range (array
, idx
);
2445 CHECK_CHARACTER (newelt
);
2446 c
= XFASTINT (newelt
);
2448 if (STRING_MULTIBYTE (array
))
2450 ptrdiff_t idxval_byte
, nbytes
;
2451 int prev_bytes
, new_bytes
;
2452 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2454 nbytes
= SBYTES (array
);
2455 idxval_byte
= string_char_to_byte (array
, idxval
);
2456 p1
= SDATA (array
) + idxval_byte
;
2457 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2458 new_bytes
= CHAR_STRING (c
, p0
);
2459 if (prev_bytes
!= new_bytes
)
2461 /* We must relocate the string data. */
2462 ptrdiff_t nchars
= SCHARS (array
);
2464 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2466 memcpy (str
, SDATA (array
), nbytes
);
2467 allocate_string_data (XSTRING (array
), nchars
,
2468 nbytes
+ new_bytes
- prev_bytes
);
2469 memcpy (SDATA (array
), str
, idxval_byte
);
2470 p1
= SDATA (array
) + idxval_byte
;
2471 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2472 nbytes
- (idxval_byte
+ prev_bytes
));
2474 clear_string_char_byte_cache ();
2481 if (! SINGLE_BYTE_CHAR_P (c
))
2485 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2486 if (SREF (array
, i
) >= 0x80)
2487 args_out_of_range (array
, newelt
);
2488 /* ARRAY is an ASCII string. Convert it to a multibyte
2489 string, and try `aset' again. */
2490 STRING_SET_MULTIBYTE (array
);
2491 return Faset (array
, idx
, newelt
);
2493 SSET (array
, idxval
, c
);
2500 /* Arithmetic functions */
2503 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2505 double f1
= 0, f2
= 0;
2508 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2509 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2511 if (FLOATP (num1
) || FLOATP (num2
))
2514 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2515 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2521 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2525 case ARITH_NOTEQUAL
:
2526 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2531 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2535 case ARITH_LESS_OR_EQUAL
:
2536 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2541 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2545 case ARITH_GRTR_OR_EQUAL
:
2546 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2556 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2557 enum Arith_Comparison comparison
)
2560 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2562 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2568 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2569 doc
: /* Return t if args, all numbers or markers, are equal.
2570 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2571 (ptrdiff_t nargs
, Lisp_Object
*args
)
2573 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2576 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2577 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2578 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2579 (ptrdiff_t nargs
, Lisp_Object
*args
)
2581 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2584 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2585 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2586 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2587 (ptrdiff_t nargs
, Lisp_Object
*args
)
2589 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2592 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2593 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2594 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2595 (ptrdiff_t nargs
, Lisp_Object
*args
)
2597 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2600 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2601 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2602 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2603 (ptrdiff_t nargs
, Lisp_Object
*args
)
2605 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2608 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2609 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2610 (register Lisp_Object num1
, Lisp_Object num2
)
2612 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2615 /* Convert the integer I to a cons-of-integers, where I is not in
2618 #define INTBIG_TO_LISP(i, extremum) \
2619 (eassert (FIXNUM_OVERFLOW_P (i)), \
2620 (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \
2621 && FIXNUM_OVERFLOW_P ((i) >> 16)) \
2622 ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \
2623 : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \
2624 && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \
2625 ? Fcons (make_number ((i) >> 16 >> 24), \
2626 Fcons (make_number ((i) >> 16 & 0xffffff), \
2627 make_number ((i) & 0xffff))) \
2631 intbig_to_lisp (intmax_t i
)
2633 return INTBIG_TO_LISP (i
, INTMAX_MIN
);
2637 uintbig_to_lisp (uintmax_t i
)
2639 return INTBIG_TO_LISP (i
, UINTMAX_MAX
);
2642 /* Convert the cons-of-integers, integer, or float value C to an
2643 unsigned value with maximum value MAX. Signal an error if C does not
2644 have a valid format or is out of range. */
2646 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2652 valid
= 0 <= XINT (c
);
2655 else if (FLOATP (c
))
2657 double d
= XFLOAT_DATA (c
);
2659 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2665 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2667 uintmax_t top
= XFASTINT (XCAR (c
));
2668 Lisp_Object rest
= XCDR (c
);
2669 if (top
<= UINTMAX_MAX
>> 24 >> 16
2671 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2672 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2674 uintmax_t mid
= XFASTINT (XCAR (rest
));
2675 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2678 else if (top
<= UINTMAX_MAX
>> 16)
2682 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2684 val
= top
<< 16 | XFASTINT (rest
);
2690 if (! (valid
&& val
<= max
))
2691 error ("Not an in-range integer, float, or cons of integers");
2695 /* Convert the cons-of-integers, integer, or float value C to a signed
2696 value with extrema MIN and MAX. Signal an error if C does not have
2697 a valid format or is out of range. */
2699 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2708 else if (FLOATP (c
))
2710 double d
= XFLOAT_DATA (c
);
2712 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2718 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2720 intmax_t top
= XINT (XCAR (c
));
2721 Lisp_Object rest
= XCDR (c
);
2722 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2724 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2725 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2727 intmax_t mid
= XFASTINT (XCAR (rest
));
2728 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2731 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2735 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2737 val
= top
<< 16 | XFASTINT (rest
);
2743 if (! (valid
&& min
<= val
&& val
<= max
))
2744 error ("Not an in-range integer, float, or cons of integers");
2748 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2749 doc
: /* Return the decimal representation of NUMBER as a string.
2750 Uses a minus sign if negative.
2751 NUMBER may be an integer or a floating point number. */)
2752 (Lisp_Object number
)
2754 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2757 CHECK_NUMBER_OR_FLOAT (number
);
2759 if (FLOATP (number
))
2760 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2762 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2764 return make_unibyte_string (buffer
, len
);
2767 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2768 doc
: /* Parse STRING as a decimal number and return the number.
2769 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2770 STRING cannot be parsed as an integer or floating point number.
2772 If BASE, interpret STRING as a number in that base. If BASE isn't
2773 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2774 If the base used is not 10, STRING is always parsed as an integer. */)
2775 (register Lisp_Object string
, Lisp_Object base
)
2781 CHECK_STRING (string
);
2787 CHECK_NUMBER (base
);
2788 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2789 xsignal1 (Qargs_out_of_range
, base
);
2793 p
= SSDATA (string
);
2794 while (*p
== ' ' || *p
== '\t')
2797 val
= string_to_number (p
, b
, 1);
2798 return NILP (val
) ? make_number (0) : val
;
2814 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2815 ptrdiff_t, Lisp_Object
*);
2817 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2820 ptrdiff_t argnum
, ok_args
;
2821 EMACS_INT accum
= 0;
2822 EMACS_INT next
, ok_accum
;
2844 for (argnum
= 0; argnum
< nargs
; argnum
++)
2852 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2854 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2857 return float_arith_driver (ok_accum
, ok_args
, code
,
2860 next
= XINT (args
[argnum
]);
2864 overflow
|= INT_ADD_WRAPV (accum
, next
, &accum
);
2868 accum
= nargs
== 1 ? - next
: next
;
2870 overflow
|= INT_SUBTRACT_WRAPV (accum
, next
, &accum
);
2873 overflow
|= INT_MULTIPLY_WRAPV (accum
, next
, &accum
);
2876 if (! (argnum
|| nargs
== 1))
2881 xsignal0 (Qarith_error
);
2882 if (INT_DIVIDE_OVERFLOW (accum
, next
))
2898 if (!argnum
|| next
> accum
)
2902 if (!argnum
|| next
< accum
)
2908 XSETINT (val
, accum
);
2913 #define isnan(x) ((x) != (x))
2916 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2917 ptrdiff_t nargs
, Lisp_Object
*args
)
2919 register Lisp_Object val
;
2922 for (; argnum
< nargs
; argnum
++)
2924 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2925 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2929 next
= XFLOAT_DATA (val
);
2933 args
[argnum
] = val
; /* runs into a compiler bug. */
2934 next
= XINT (args
[argnum
]);
2942 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2948 if (! (argnum
|| nargs
== 1))
2952 if (! IEEE_FLOATING_POINT
&& next
== 0)
2953 xsignal0 (Qarith_error
);
2960 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2962 if (!argnum
|| isnan (next
) || next
> accum
)
2966 if (!argnum
|| isnan (next
) || next
< accum
)
2972 return make_float (accum
);
2976 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2977 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2978 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2979 (ptrdiff_t nargs
, Lisp_Object
*args
)
2981 return arith_driver (Aadd
, nargs
, args
);
2984 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2985 doc
: /* Negate number or subtract numbers or markers and return the result.
2986 With one arg, negates it. With more than one arg,
2987 subtracts all but the first from the first.
2988 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2989 (ptrdiff_t nargs
, Lisp_Object
*args
)
2991 return arith_driver (Asub
, nargs
, args
);
2994 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2995 doc
: /* Return product of any number of arguments, which are numbers or markers.
2996 usage: (* &rest NUMBERS-OR-MARKERS) */)
2997 (ptrdiff_t nargs
, Lisp_Object
*args
)
2999 return arith_driver (Amult
, nargs
, args
);
3002 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
3003 doc
: /* Divide number by divisors and return the result.
3004 With two or more arguments, return first argument divided by the rest.
3005 With one argument, return 1 divided by the argument.
3006 The arguments must be numbers or markers.
3007 usage: (/ NUMBER &rest DIVISORS) */)
3008 (ptrdiff_t nargs
, Lisp_Object
*args
)
3011 for (argnum
= 2; argnum
< nargs
; argnum
++)
3012 if (FLOATP (args
[argnum
]))
3013 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
3014 return arith_driver (Adiv
, nargs
, args
);
3017 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
3018 doc
: /* Return remainder of X divided by Y.
3019 Both must be integers or markers. */)
3020 (register Lisp_Object x
, Lisp_Object y
)
3024 CHECK_NUMBER_COERCE_MARKER (x
);
3025 CHECK_NUMBER_COERCE_MARKER (y
);
3028 xsignal0 (Qarith_error
);
3030 XSETINT (val
, XINT (x
) % XINT (y
));
3034 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
3035 doc
: /* Return X modulo Y.
3036 The result falls between zero (inclusive) and Y (exclusive).
3037 Both X and Y must be numbers or markers. */)
3038 (register Lisp_Object x
, Lisp_Object y
)
3043 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
3044 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
3046 if (FLOATP (x
) || FLOATP (y
))
3047 return fmod_float (x
, y
);
3053 xsignal0 (Qarith_error
);
3057 /* If the "remainder" comes out with the wrong sign, fix it. */
3058 if (i2
< 0 ? i1
> 0 : i1
< 0)
3065 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
3066 doc
: /* Return largest of all the arguments (which must be numbers or markers).
3067 The value is always a number; markers are converted to numbers.
3068 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3069 (ptrdiff_t nargs
, Lisp_Object
*args
)
3071 return arith_driver (Amax
, nargs
, args
);
3074 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
3075 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
3076 The value is always a number; markers are converted to numbers.
3077 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3078 (ptrdiff_t nargs
, Lisp_Object
*args
)
3080 return arith_driver (Amin
, nargs
, args
);
3083 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
3084 doc
: /* Return bitwise-and of all the arguments.
3085 Arguments may be integers, or markers converted to integers.
3086 usage: (logand &rest INTS-OR-MARKERS) */)
3087 (ptrdiff_t nargs
, Lisp_Object
*args
)
3089 return arith_driver (Alogand
, nargs
, args
);
3092 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
3093 doc
: /* Return bitwise-or of all the arguments.
3094 Arguments may be integers, or markers converted to integers.
3095 usage: (logior &rest INTS-OR-MARKERS) */)
3096 (ptrdiff_t nargs
, Lisp_Object
*args
)
3098 return arith_driver (Alogior
, nargs
, args
);
3101 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
3102 doc
: /* Return bitwise-exclusive-or of all the arguments.
3103 Arguments may be integers, or markers converted to integers.
3104 usage: (logxor &rest INTS-OR-MARKERS) */)
3105 (ptrdiff_t nargs
, Lisp_Object
*args
)
3107 return arith_driver (Alogxor
, nargs
, args
);
3111 ash_lsh_impl (register Lisp_Object value
, Lisp_Object count
, bool lsh
)
3113 register Lisp_Object val
;
3115 CHECK_NUMBER (value
);
3116 CHECK_NUMBER (count
);
3118 if (XINT (count
) >= EMACS_INT_WIDTH
)
3120 else if (XINT (count
) > 0)
3121 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
3122 else if (XINT (count
) <= -EMACS_INT_WIDTH
)
3123 XSETINT (val
, lsh
? 0 : XINT (value
) < 0 ? -1 : 0);
3125 XSETINT (val
, lsh
? XUINT (value
) >> -XINT (count
) : \
3126 XINT (value
) >> -XINT (count
));
3130 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
3131 doc
: /* Return VALUE with its bits shifted left by COUNT.
3132 If COUNT is negative, shifting is actually to the right.
3133 In this case, the sign bit is duplicated. */)
3134 (register Lisp_Object value
, Lisp_Object count
)
3136 return ash_lsh_impl (value
, count
, false);
3139 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
3140 doc
: /* Return VALUE with its bits shifted left by COUNT.
3141 If COUNT is negative, shifting is actually to the right.
3142 In this case, zeros are shifted in on the left. */)
3143 (register Lisp_Object value
, Lisp_Object count
)
3145 return ash_lsh_impl (value
, count
, true);
3148 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3149 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3150 Markers are converted to integers. */)
3151 (register Lisp_Object number
)
3153 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3155 if (FLOATP (number
))
3156 return (make_float (1.0 + XFLOAT_DATA (number
)));
3158 XSETINT (number
, XINT (number
) + 1);
3162 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3163 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3164 Markers are converted to integers. */)
3165 (register Lisp_Object number
)
3167 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3169 if (FLOATP (number
))
3170 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3172 XSETINT (number
, XINT (number
) - 1);
3176 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3177 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3178 (register Lisp_Object number
)
3180 CHECK_NUMBER (number
);
3181 XSETINT (number
, ~XINT (number
));
3185 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3186 doc
: /* Return the byteorder for the machine.
3187 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3188 lowercase l) for small endian machines. */
3192 unsigned i
= 0x04030201;
3193 int order
= *(char *)&i
== 1 ? 108 : 66;
3195 return make_number (order
);
3198 /* Because we round up the bool vector allocate size to word_size
3199 units, we can safely read past the "end" of the vector in the
3200 operations below. These extra bits are always zero. */
3203 bool_vector_spare_mask (EMACS_INT nr_bits
)
3205 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
3208 /* Info about unsigned long long, falling back on unsigned long
3209 if unsigned long long is not available. */
3211 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH
3212 enum { ULL_WIDTH
= ULLONG_WIDTH
};
3213 # define ULL_MAX ULLONG_MAX
3215 enum { ULL_WIDTH
= ULONG_WIDTH
};
3216 # define ULL_MAX ULONG_MAX
3217 # define count_one_bits_ll count_one_bits_l
3218 # define count_trailing_zeros_ll count_trailing_zeros_l
3221 /* Shift VAL right by the width of an unsigned long long.
3222 ULL_WIDTH must be less than BITS_PER_BITS_WORD. */
3225 shift_right_ull (bits_word w
)
3227 /* Pacify bogus GCC warning about shift count exceeding type width. */
3228 int shift
= ULL_WIDTH
- BITS_PER_BITS_WORD
< 0 ? ULL_WIDTH
: 0;
3232 /* Return the number of 1 bits in W. */
3235 count_one_bits_word (bits_word w
)
3237 if (BITS_WORD_MAX
<= UINT_MAX
)
3238 return count_one_bits (w
);
3239 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3240 return count_one_bits_l (w
);
3243 int i
= 0, count
= 0;
3244 while (count
+= count_one_bits_ll (w
),
3245 (i
+= ULL_WIDTH
) < BITS_PER_BITS_WORD
)
3246 w
= shift_right_ull (w
);
3251 enum bool_vector_op
{ bool_vector_exclusive_or
,
3253 bool_vector_intersection
,
3254 bool_vector_set_difference
,
3255 bool_vector_subsetp
};
3258 bool_vector_binop_driver (Lisp_Object a
,
3261 enum bool_vector_op op
)
3264 bits_word
*adata
, *bdata
, *destdata
;
3268 CHECK_BOOL_VECTOR (a
);
3269 CHECK_BOOL_VECTOR (b
);
3271 nr_bits
= bool_vector_size (a
);
3272 if (bool_vector_size (b
) != nr_bits
)
3273 wrong_length_argument (a
, b
, dest
);
3275 nr_words
= bool_vector_words (nr_bits
);
3276 adata
= bool_vector_data (a
);
3277 bdata
= bool_vector_data (b
);
3281 dest
= make_uninit_bool_vector (nr_bits
);
3282 destdata
= bool_vector_data (dest
);
3286 CHECK_BOOL_VECTOR (dest
);
3287 destdata
= bool_vector_data (dest
);
3288 if (bool_vector_size (dest
) != nr_bits
)
3289 wrong_length_argument (a
, b
, dest
);
3293 case bool_vector_exclusive_or
:
3294 for (; i
< nr_words
; i
++)
3295 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3299 case bool_vector_subsetp
:
3300 for (; i
< nr_words
; i
++)
3301 if (adata
[i
] &~ bdata
[i
])
3305 case bool_vector_union
:
3306 for (; i
< nr_words
; i
++)
3307 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3311 case bool_vector_intersection
:
3312 for (; i
< nr_words
; i
++)
3313 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3317 case bool_vector_set_difference
:
3318 for (; i
< nr_words
; i
++)
3319 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3330 case bool_vector_exclusive_or
:
3331 for (; i
< nr_words
; i
++)
3332 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3335 case bool_vector_union
:
3336 for (; i
< nr_words
; i
++)
3337 destdata
[i
] = adata
[i
] | bdata
[i
];
3340 case bool_vector_intersection
:
3341 for (; i
< nr_words
; i
++)
3342 destdata
[i
] = adata
[i
] & bdata
[i
];
3345 case bool_vector_set_difference
:
3346 for (; i
< nr_words
; i
++)
3347 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3357 /* PRECONDITION must be true. Return VALUE. This odd construction
3358 works around a bogus GCC diagnostic "shift count >= width of type". */
3361 pre_value (bool precondition
, int value
)
3363 eassume (precondition
);
3364 return precondition
? value
: 0;
3367 /* Compute the number of trailing zero bits in val. If val is zero,
3368 return the number of bits in val. */
3370 count_trailing_zero_bits (bits_word val
)
3372 if (BITS_WORD_MAX
== UINT_MAX
)
3373 return count_trailing_zeros (val
);
3374 if (BITS_WORD_MAX
== ULONG_MAX
)
3375 return count_trailing_zeros_l (val
);
3376 if (BITS_WORD_MAX
== ULL_MAX
)
3377 return count_trailing_zeros_ll (val
);
3379 /* The rest of this code is for the unlikely platform where bits_word differs
3380 in width from unsigned int, unsigned long, and unsigned long long. */
3381 val
|= ~ BITS_WORD_MAX
;
3382 if (BITS_WORD_MAX
<= UINT_MAX
)
3383 return count_trailing_zeros (val
);
3384 if (BITS_WORD_MAX
<= ULONG_MAX
)
3385 return count_trailing_zeros_l (val
);
3390 count
< BITS_PER_BITS_WORD
- ULL_WIDTH
;
3394 return count
+ count_trailing_zeros_ll (val
);
3395 val
= shift_right_ull (val
);
3398 if (BITS_PER_BITS_WORD
% ULL_WIDTH
!= 0
3399 && BITS_WORD_MAX
== (bits_word
) -1)
3400 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3401 BITS_PER_BITS_WORD
% ULL_WIDTH
);
3402 return count
+ count_trailing_zeros_ll (val
);
3407 bits_word_to_host_endian (bits_word val
)
3409 #ifndef WORDS_BIGENDIAN
3412 if (BITS_WORD_MAX
>> 31 == 1)
3413 return bswap_32 (val
);
3414 # if HAVE_UNSIGNED_LONG_LONG
3415 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3416 return bswap_64 (val
);
3421 for (i
= 0; i
< sizeof val
; i
++)
3423 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3424 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3425 val
= val
>> 1 >> (CHAR_BIT
- 1);
3432 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3433 Sbool_vector_exclusive_or
, 2, 3, 0,
3434 doc
: /* Return A ^ B, bitwise exclusive or.
3435 If optional third argument C is given, store result into C.
3436 A, B, and C must be bool vectors of the same length.
3437 Return the destination vector if it changed or nil otherwise. */)
3438 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3440 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3443 DEFUN ("bool-vector-union", Fbool_vector_union
,
3444 Sbool_vector_union
, 2, 3, 0,
3445 doc
: /* Return A | B, bitwise or.
3446 If optional third argument C is given, store result into C.
3447 A, B, and C must be bool vectors of the same length.
3448 Return the destination vector if it changed or nil otherwise. */)
3449 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3451 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3454 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3455 Sbool_vector_intersection
, 2, 3, 0,
3456 doc
: /* Return A & B, bitwise and.
3457 If optional third argument C is given, store result into C.
3458 A, B, and C must be bool vectors of the same length.
3459 Return the destination vector if it changed or nil otherwise. */)
3460 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3462 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3465 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3466 Sbool_vector_set_difference
, 2, 3, 0,
3467 doc
: /* Return A &~ B, set difference.
3468 If optional third argument C is given, store result into C.
3469 A, B, and C must be bool vectors of the same length.
3470 Return the destination vector if it changed or nil otherwise. */)
3471 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3473 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3476 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3477 Sbool_vector_subsetp
, 2, 2, 0,
3478 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3479 A and B must be bool vectors of the same length. */)
3480 (Lisp_Object a
, Lisp_Object b
)
3482 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3485 DEFUN ("bool-vector-not", Fbool_vector_not
,
3486 Sbool_vector_not
, 1, 2, 0,
3487 doc
: /* Compute ~A, set complement.
3488 If optional second argument B is given, store result into B.
3489 A and B must be bool vectors of the same length.
3490 Return the destination vector. */)
3491 (Lisp_Object a
, Lisp_Object b
)
3494 bits_word
*bdata
, *adata
;
3497 CHECK_BOOL_VECTOR (a
);
3498 nr_bits
= bool_vector_size (a
);
3501 b
= make_uninit_bool_vector (nr_bits
);
3504 CHECK_BOOL_VECTOR (b
);
3505 if (bool_vector_size (b
) != nr_bits
)
3506 wrong_length_argument (a
, b
, Qnil
);
3509 bdata
= bool_vector_data (b
);
3510 adata
= bool_vector_data (a
);
3512 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3513 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3515 if (nr_bits
% BITS_PER_BITS_WORD
)
3517 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3519 mword
&= bool_vector_spare_mask (nr_bits
);
3520 bdata
[i
] = bits_word_to_host_endian (mword
);
3526 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3527 Sbool_vector_count_population
, 1, 1, 0,
3528 doc
: /* Count how many elements in A are t.
3529 A is a bool vector. To count A's nil elements, subtract the return
3530 value from A's length. */)
3536 ptrdiff_t i
, nwords
;
3538 CHECK_BOOL_VECTOR (a
);
3540 nr_bits
= bool_vector_size (a
);
3541 nwords
= bool_vector_words (nr_bits
);
3543 adata
= bool_vector_data (a
);
3545 for (i
= 0; i
< nwords
; i
++)
3546 count
+= count_one_bits_word (adata
[i
]);
3548 return make_number (count
);
3551 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3552 Sbool_vector_count_consecutive
, 3, 3, 0,
3553 doc
: /* Count how many consecutive elements in A equal B starting at I.
3554 A is a bool vector, B is t or nil, and I is an index into A. */)
3555 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3562 bits_word mword
; /* Machine word. */
3563 ptrdiff_t pos
, pos0
;
3566 CHECK_BOOL_VECTOR (a
);
3569 nr_bits
= bool_vector_size (a
);
3570 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3571 args_out_of_range (a
, i
);
3573 adata
= bool_vector_data (a
);
3574 nr_words
= bool_vector_words (nr_bits
);
3575 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3576 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3579 /* By XORing with twiddle, we transform the problem of "count
3580 consecutive equal values" into "count the zero bits". The latter
3581 operation usually has hardware support. */
3582 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3584 /* Scan the remainder of the mword at the current offset. */
3585 if (pos
< nr_words
&& offset
!= 0)
3587 mword
= bits_word_to_host_endian (adata
[pos
]);
3591 /* Do not count the pad bits. */
3592 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3594 count
= count_trailing_zero_bits (mword
);
3596 if (count
+ offset
< BITS_PER_BITS_WORD
)
3597 return make_number (count
);
3600 /* Scan whole words until we either reach the end of the vector or
3601 find an mword that doesn't completely match. twiddle is
3602 endian-independent. */
3604 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3606 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3610 /* If we stopped because of a mismatch, see how many bits match
3611 in the current mword. */
3612 mword
= bits_word_to_host_endian (adata
[pos
]);
3614 count
+= count_trailing_zero_bits (mword
);
3616 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3618 /* If we hit the end, we might have overshot our count. Reduce
3619 the total by the number of spare bits at the end of the
3621 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3624 return make_number (count
);
3631 Lisp_Object error_tail
, arith_tail
;
3633 DEFSYM (Qquote
, "quote");
3634 DEFSYM (Qlambda
, "lambda");
3635 DEFSYM (Qsubr
, "subr");
3636 DEFSYM (Qerror_conditions
, "error-conditions");
3637 DEFSYM (Qerror_message
, "error-message");
3638 DEFSYM (Qtop_level
, "top-level");
3640 DEFSYM (Qerror
, "error");
3641 DEFSYM (Quser_error
, "user-error");
3642 DEFSYM (Qquit
, "quit");
3643 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3644 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3645 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3646 DEFSYM (Qvoid_function
, "void-function");
3647 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3648 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3649 DEFSYM (Qvoid_variable
, "void-variable");
3650 DEFSYM (Qsetting_constant
, "setting-constant");
3651 DEFSYM (Qtrapping_constant
, "trapping-constant");
3652 DEFSYM (Qtrapping_frame_local
, "trapping-frame-local");
3653 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3655 DEFSYM (Qinvalid_function
, "invalid-function");
3656 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3657 DEFSYM (Qno_catch
, "no-catch");
3658 DEFSYM (Qend_of_file
, "end-of-file");
3659 DEFSYM (Qarith_error
, "arith-error");
3660 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3661 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3662 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3663 DEFSYM (Qtext_read_only
, "text-read-only");
3664 DEFSYM (Qmark_inactive
, "mark-inactive");
3666 DEFSYM (Qlistp
, "listp");
3667 DEFSYM (Qconsp
, "consp");
3668 DEFSYM (Qsymbolp
, "symbolp");
3669 DEFSYM (Qintegerp
, "integerp");
3670 DEFSYM (Qnatnump
, "natnump");
3671 DEFSYM (Qwholenump
, "wholenump");
3672 DEFSYM (Qstringp
, "stringp");
3673 DEFSYM (Qarrayp
, "arrayp");
3674 DEFSYM (Qsequencep
, "sequencep");
3675 DEFSYM (Qbufferp
, "bufferp");
3676 DEFSYM (Qvectorp
, "vectorp");
3677 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3678 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3679 DEFSYM (Qmarkerp
, "markerp");
3681 DEFSYM (Quser_ptrp
, "user-ptrp");
3683 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3684 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3685 DEFSYM (Qfboundp
, "fboundp");
3687 DEFSYM (Qfloatp
, "floatp");
3688 DEFSYM (Qnumberp
, "numberp");
3689 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3691 DEFSYM (Qchar_table_p
, "char-table-p");
3692 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3694 DEFSYM (Qsubrp
, "subrp");
3695 DEFSYM (Qunevalled
, "unevalled");
3696 DEFSYM (Qmany
, "many");
3698 DEFSYM (Qcdr
, "cdr");
3700 error_tail
= pure_cons (Qerror
, Qnil
);
3702 /* ERROR is used as a signaler for random errors for which nothing else is
3705 Fput (Qerror
, Qerror_conditions
,
3707 Fput (Qerror
, Qerror_message
,
3708 build_pure_c_string ("error"));
3710 #define PUT_ERROR(sym, tail, msg) \
3711 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3712 Fput (sym, Qerror_message, build_pure_c_string (msg))
3714 PUT_ERROR (Qquit
, Qnil
, "Quit");
3716 PUT_ERROR (Quser_error
, error_tail
, "");
3717 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3718 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3719 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3720 PUT_ERROR (Qvoid_function
, error_tail
,
3721 "Symbol's function definition is void");
3722 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3723 "Symbol's chain of function indirections contains a loop");
3724 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3725 "Symbol's chain of variable indirections contains a loop");
3726 DEFSYM (Qcircular_list
, "circular-list");
3727 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3728 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3729 PUT_ERROR (Qsetting_constant
, error_tail
,
3730 "Attempt to set a constant symbol");
3731 PUT_ERROR (Qtrapping_constant
, error_tail
,
3732 "Attempt to trap writes to a constant symbol");
3733 PUT_ERROR (Qtrapping_frame_local
, error_tail
,
3734 "Attempt to trap writes to a frame local variable");
3735 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3736 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3737 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3738 "Wrong number of arguments");
3739 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3740 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3742 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3743 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3744 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3746 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3747 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3748 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3749 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3750 "Text is read-only");
3752 DEFSYM (Qrange_error
, "range-error");
3753 DEFSYM (Qdomain_error
, "domain-error");
3754 DEFSYM (Qsingularity_error
, "singularity-error");
3755 DEFSYM (Qoverflow_error
, "overflow-error");
3756 DEFSYM (Qunderflow_error
, "underflow-error");
3758 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3760 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3762 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3763 "Arithmetic singularity error");
3765 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3766 "Arithmetic overflow error");
3767 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3768 "Arithmetic underflow error");
3770 /* Types that type-of returns. */
3771 DEFSYM (Qinteger
, "integer");
3772 DEFSYM (Qsymbol
, "symbol");
3773 DEFSYM (Qstring
, "string");
3774 DEFSYM (Qcons
, "cons");
3775 DEFSYM (Qmarker
, "marker");
3776 DEFSYM (Qoverlay
, "overlay");
3777 DEFSYM (Qfinalizer
, "finalizer");
3779 DEFSYM (Quser_ptr
, "user-ptr");
3781 DEFSYM (Qfloat
, "float");
3782 DEFSYM (Qwindow_configuration
, "window-configuration");
3783 DEFSYM (Qprocess
, "process");
3784 DEFSYM (Qwindow
, "window");
3785 DEFSYM (Qcompiled_function
, "compiled-function");
3786 DEFSYM (Qbuffer
, "buffer");
3787 DEFSYM (Qframe
, "frame");
3788 DEFSYM (Qvector
, "vector");
3789 DEFSYM (Qchar_table
, "char-table");
3790 DEFSYM (Qbool_vector
, "bool-vector");
3791 DEFSYM (Qhash_table
, "hash-table");
3792 DEFSYM (Qthread
, "thread");
3793 DEFSYM (Qmutex
, "mutex");
3794 DEFSYM (Qcondition_variable
, "condition-variable");
3796 DEFSYM (Qdefun
, "defun");
3798 DEFSYM (Qfont_spec
, "font-spec");
3799 DEFSYM (Qfont_entity
, "font-entity");
3800 DEFSYM (Qfont_object
, "font-object");
3802 DEFSYM (Qinteractive_form
, "interactive-form");
3803 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3805 defsubr (&Sindirect_variable
);
3806 defsubr (&Sinteractive_form
);
3809 defsubr (&Stype_of
);
3814 defsubr (&Sintegerp
);
3815 defsubr (&Sinteger_or_marker_p
);
3816 defsubr (&Snumberp
);
3817 defsubr (&Snumber_or_marker_p
);
3819 defsubr (&Snatnump
);
3820 defsubr (&Ssymbolp
);
3821 defsubr (&Skeywordp
);
3822 defsubr (&Sstringp
);
3823 defsubr (&Smultibyte_string_p
);
3824 defsubr (&Svectorp
);
3825 defsubr (&Schar_table_p
);
3826 defsubr (&Svector_or_char_table_p
);
3827 defsubr (&Sbool_vector_p
);
3829 defsubr (&Ssequencep
);
3830 defsubr (&Sbufferp
);
3831 defsubr (&Smarkerp
);
3833 defsubr (&Sbyte_code_function_p
);
3834 defsubr (&Schar_or_string_p
);
3835 defsubr (&Sthreadp
);
3837 defsubr (&Scondition_variable_p
);
3840 defsubr (&Scar_safe
);
3841 defsubr (&Scdr_safe
);
3844 defsubr (&Ssymbol_function
);
3845 defsubr (&Sindirect_function
);
3846 defsubr (&Ssymbol_plist
);
3847 defsubr (&Ssymbol_name
);
3848 defsubr (&Smakunbound
);
3849 defsubr (&Sfmakunbound
);
3851 defsubr (&Sfboundp
);
3853 defsubr (&Sdefalias
);
3854 defsubr (&Ssetplist
);
3855 defsubr (&Ssymbol_value
);
3857 defsubr (&Sdefault_boundp
);
3858 defsubr (&Sdefault_value
);
3859 defsubr (&Sset_default
);
3860 defsubr (&Ssetq_default
);
3861 defsubr (&Smake_variable_buffer_local
);
3862 defsubr (&Smake_local_variable
);
3863 defsubr (&Skill_local_variable
);
3864 defsubr (&Smake_variable_frame_local
);
3865 defsubr (&Slocal_variable_p
);
3866 defsubr (&Slocal_variable_if_set_p
);
3867 defsubr (&Svariable_binding_locus
);
3868 #if 0 /* XXX Remove this. --lorentey */
3869 defsubr (&Sterminal_local_value
);
3870 defsubr (&Sset_terminal_local_value
);
3874 defsubr (&Snumber_to_string
);
3875 defsubr (&Sstring_to_number
);
3876 defsubr (&Seqlsign
);
3898 defsubr (&Sbyteorder
);
3899 defsubr (&Ssubr_arity
);
3900 defsubr (&Ssubr_name
);
3902 defsubr (&Suser_ptrp
);
3905 defsubr (&Sbool_vector_exclusive_or
);
3906 defsubr (&Sbool_vector_union
);
3907 defsubr (&Sbool_vector_intersection
);
3908 defsubr (&Sbool_vector_set_difference
);
3909 defsubr (&Sbool_vector_not
);
3910 defsubr (&Sbool_vector_subsetp
);
3911 defsubr (&Sbool_vector_count_consecutive
);
3912 defsubr (&Sbool_vector_count_population
);
3914 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3916 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3917 doc
: /* The largest value that is representable in a Lisp integer. */);
3918 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3919 make_symbol_constant (intern_c_string ("most-positive-fixnum"));
3921 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3922 doc
: /* The smallest value that is representable in a Lisp integer. */);
3923 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3924 make_symbol_constant (intern_c_string ("most-negative-fixnum"));
3926 DEFSYM (Qwatchers
, "watchers");
3927 DEFSYM (Qmakunbound
, "makunbound");
3928 DEFSYM (Qunlet
, "unlet");
3929 DEFSYM (Qset
, "set");
3930 DEFSYM (Qset_default
, "set-default");
3931 defsubr (&Sadd_variable_watcher
);
3932 defsubr (&Sremove_variable_watcher
);
3933 defsubr (&Sget_variable_watchers
);